makes.new.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* make eulisp objects 
00003 /*      Copyright Toshihiro MATSUI, ETL, 1987
00004 /****************************************************************/
00005 static char *rcsid="@(#)$Id$";
00006 
00007 #if Solaris2
00008 #include <errno.h>
00009 #include <synch.h>
00010 #include <thread.h>
00011 #endif
00012 
00013 #include "eus.h"
00014 
00015 #if 0 /* move to eus.h */
00016 #define nextbuddy(p) ((bpointer)((eusinteger_t)p+(buddysize[p->h.bix]*sizeof(pointer))))
00017 #endif
00018 
00019 extern pointer LAMCLOSURE, K_FUNCTION_DOCUMENTATION;
00020 
00021 /****************************************************************/
00022 /* boxing and unboxing
00023 /****************************************************************/
00024 #if vax
00025 float ckfltval(p)
00026 register int p;
00027 { numunion nu;
00028   if (isflt(p)) {
00029     nu.ival = p & 0xfffffffc;
00030 #if vax
00031     { register short s;
00032       s=nu.sval.low; nu.sval.low=nu.sval.high; nu.sval.high=s;}
00033 #endif
00034     return(nu.fval);}
00035   else if (isint(p)) { nu.fval=intval(p); return(nu.fval);} /*coerce to float*/
00036   else error(E_NONUMBER);}
00037 
00038 float fltval(p)
00039 int p;
00040 { numunion nu;
00041   nu.ival= p & 0xfffffffc;
00042 #if vax
00043   { register short s;
00044     s=nu.sval.low; nu.sval.low=nu.sval.high; nu.sval.high=s;}
00045 #endif
00046   return(nu.fval);}
00047 
00048 pointer makeflt(d)
00049 double d;
00050 { numunion u;
00051   u.fval=d;     /*double to short float*/
00052 #if vax
00053   { register short s;
00054     s=u.sval.low;               /*swap upper and lower short*/
00055     u.sval.low=u.sval.high;
00056     u.sval.high=s;}
00057 #endif
00058   return((pointer)((u.ival & 0xfffffffc) | 1));}
00059 #endif
00060   
00061 pointer Getstring(s)
00062 register pointer s;
00063 { if (issymbol(s)) s=s->c.sym.pname;
00064   if (!isstring(s)) error(E_NOSTRING);
00065   return(s);}
00066 
00067 byte *get_string(s)
00068 register pointer s;
00069 { if (isstring(s)) return(s->c.str.chars);
00070   if (issymbol(s)) return(s->c.sym.pname->c.str.chars);
00071   else error(E_NOSTRING);}
00072 
00073 /****************************************************************/
00074 /* cons & list
00075 /****************************************************************/
00076 
00077 #define allocobj(class,builtin,cid)  \
00078  ((class)? \
00079     alloc(vecsize(speval(class)->c.cls.vars), ELM_FIXED, \
00080           intval(speval(class)->c.cls.cix), \
00081           wordsizeof(struct builtin)): \
00082     alloc(wordsizeof(struct builtin), ELM_FIXED, cid, \
00083           wordsizeof(struct builtin)))
00084 
00085 pointer rawcons(ctx,a,d)
00086 register context *ctx;
00087 register pointer a,d;
00088 { register pointer c;
00089   vpush(a); vpush(d);
00090   c = alloc(wordsizeof(struct cons), ELM_FIXED, conscp.cix,
00091             wordsizeof(struct cons));
00092   c->c.cons.cdr=vpop();
00093   c->c.cons.car=vpop();
00094   return(c);}
00095 
00096 pointer cons(ctx,a,d)
00097 register context *ctx;
00098 register pointer a,d;
00099 {
00100   register pointer c;
00101   register bpointer b;
00102   /*
00103   if ((speval(QCONS)==C_CONS) && (b=buddy[1].bp)) {
00104     b->h.elmtype=ELM_FIXED;
00105     buddy[1].bp=b->b.nextbcell;
00106     freeheap -= 3;
00107     alloccount[1]++;
00108     c=makepointer(b);
00109     cixof(c)=conscp.cix;}
00110   else*/
00111    { 
00112     vpush(a); vpush(d); /*protect args from garbage collection*/
00113     c=alloc(vecsize(speval(QCONS)->c.cls.vars), ELM_FIXED, 
00114             intval(speval(QCONS)->c.cls.cix), 
00115             wordsizeof(struct cons)); 
00116     ctx->vsp-=2;  } 
00117   c->c.cons.car=a; c->c.cons.cdr=d;
00118   return(c);}
00119 
00120 pointer stackrawlist(ctx,n)     /*make a list out of elements pushed on vstack*/
00121 register context *ctx;
00122 register int n;
00123 { register pointer r=NIL, *fsp=ctx->vsp;
00124   while (n-->0) r=rawcons(ctx,*--fsp,r);
00125   ctx->vsp=fsp;
00126   return(r);}
00127 
00128 pointer stacknlist(ctx,n)       /*make a list out of elements pushed on vstack*/
00129 register context *ctx;
00130 register int n;
00131 { register pointer r=NIL, *fsp=ctx->vsp;
00132   while (n-->0) r=cons(ctx,*--fsp,r);
00133   ctx->vsp=fsp;
00134   return(r);}
00135 
00136 pointer makebuffer(size)
00137 register int size;
00138 { register pointer p;
00139   p = alloc((size+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR, stringcp.cix, (size+2*sizeof(eusinteger_t))>>WORDSHIFT);
00140   p->c.str.length=makeint(size);
00141   return(p);}
00142 
00143 pointer makestring(s,l)
00144 register char *s;
00145 register int l;
00146 { register pointer p;
00147   p=alloc((l+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR, stringcp.cix, (l+2*sizeof(eusinteger_t))>>WORDSHIFT );
00148   p->c.str.length=makeint(l);
00149   p->c.ivec.iv[l/sizeof(long)]=0;       /*terminator*/
00150   memcpy((void *)p->c.str.chars, (void *)s, l);
00151   return(p);}
00152 
00153 pointer make_foreign_string(eusinteger_t addr, int size)
00154 { register pointer p;
00155   p=alloc(2, ELM_FOREIGN, stringcp.cix, 2);
00156   p->c.str.length=makeint(size);
00157   p->c.ivec.iv[0]=addr;
00158   return(p);}
00159 
00160 pointer makesymbol(ctx,str,leng,home)
00161 register context *ctx;
00162 char *str;
00163 int leng;
00164 pointer home;
00165 { register pointer sym;
00166   int cid;
00167   vpush(makestring(str,leng));
00168   sym=allocobj(SYMBOL,symbol,symbolcp.cix);
00169   sym->c.sym.speval=sym->c.sym.spefunc=UNBOUND;
00170   sym->c.sym.vtype=V_VARIABLE;
00171   sym->c.sym.homepkg=home;
00172   sym->c.sym.plist=NIL;
00173   sym->c.sym.pname=vpop();
00174   return(sym);}
00175 
00176 pointer searchpkg(token,leng)
00177 byte *token;
00178 int leng;
00179 { pointer pkg,pkgs,names;
00180   pkgs=pkglist;
00181   while (pkgs && islist(pkgs)) {
00182     pkg=ccar(pkgs); pkgs=ccdr(pkgs);
00183     names=pkg->c.pkg.names;
00184     while (islist(names)) 
00185       if (strlength(ccar(names))==leng && 
00186           !memcmp((char *)ccar(names)->c.str.chars, (char *)token, leng)) return(pkg);
00187       else names=ccdr(names);}
00188   return(NULL);}
00189 
00190 pointer findpkg(pkgname)
00191 register pointer pkgname;       /*string or symbol*/
00192 { register pointer pkg,pkgs,names;
00193   if (ispackage(pkgname)) return(pkgname);
00194   pkgname=Getstring(pkgname);
00195   return(searchpkg(pkgname->c.str.chars,strlength(pkgname)));} 
00196 
00197 pointer makepkg(ctx,namestr,nicks,uses)
00198 register context *ctx;
00199 register pointer namestr,nicks,uses;
00200 { register pointer pkg,symvec,pkgs,names,p;
00201   register int i;
00202   /*check pkg name collision*/
00203   namestr=Getstring(namestr);
00204   if (findpkg(namestr)) error(E_PKGNAME,namestr);
00205   vpush(namestr); vpush(nicks); vpush(uses);
00206   i=0;
00207   while (islist(nicks)) {
00208     if (findpkg(ccar(nicks))) error(E_PKGNAME,ccar(nicks));
00209     vpush(Getstring(ccar(nicks))); i++;
00210     nicks=ccdr(nicks);}
00211   nicks=stackrawlist(ctx,i);    /*list up package nicknames*/
00212   i=0;
00213   while (islist(uses)) {
00214     if (p=findpkg(ccar(uses))) { vpush(p); i++; uses=ccdr(uses);}
00215     else error(E_PKGNAME,ccar(uses));}
00216   uses=stackrawlist(ctx,i);
00217   pkg=allocobj(PKGCLASS,package, packagecp.cix);
00218   pkg->c.pkg.names=pkg->c.pkg.symvector=pkg->c.pkg.intsymvector=NULL;
00219   pkg->c.pkg.symcount=pkg->c.pkg.intsymcount=makeint(0);
00220   pkg->c.pkg.use=uses;
00221   pkg->c.pkg.plist=NIL;
00222   pkg->c.pkg.shadows=NIL;
00223   pkg->c.pkg.used_by=NIL;
00224   vpush(pkg);
00225   pkg->c.pkg.names=rawcons(ctx,namestr,nicks);
00226   symvec=makevector(C_VECTOR,SYMBOLHASH);
00227   for (i=0; i<SYMBOLHASH; i++) symvec->c.vec.v[i]=makeint(0);
00228   pkg->c.pkg.symvector=symvec;
00229   symvec=makevector(C_VECTOR,SYMBOLHASH);
00230   for (i=0; i<SYMBOLHASH; i++) symvec->c.vec.v[i]=makeint(0);
00231   pkg->c.pkg.intsymvector=symvec;
00232   pkglist=rawcons(ctx,pkg,pkglist);
00233   ctx->lastalloc=pkg;
00234   ctx->vsp -= 4;
00235   return(pkg);}
00236 
00237 pointer mkstream(ctx,dir,string)
00238 register context *ctx;
00239 pointer dir,string;
00240 { register pointer s;
00241   vpush(string);
00242   s=allocobj(STREAM, stream, streamcp.cix);
00243   s->c.stream.direction=dir;
00244   s->c.stream.count=s->c.stream.tail=makeint(0);
00245   s->c.stream.buffer=vpop();
00246   s->c.stream.plist=NIL;
00247   return(s);}
00248 
00249 pointer mkfilestream(ctx,dir,string,fno,fname)
00250 register context *ctx;
00251 pointer dir,string,fname;
00252 int fno;
00253 { register pointer s;
00254   if (dir!=K_IN && dir!=K_OUT) error(E_IODIRECTION);
00255   vpush(string); vpush(fname);
00256   s=allocobj(FILESTREAM, filestream, filestreamcp.cix);
00257   s->c.fstream.direction=dir;
00258   s->c.fstream.count=s->c.fstream.tail=makeint(0);
00259   s->c.fstream.fname=vpop();
00260   s->c.fstream.buffer=vpop();
00261   s->c.fstream.fd=makeint(fno);
00262   s->c.fstream.plist=NIL;
00263   return(s);}
00264 
00265 pointer mkiostream(ctx,in,out)
00266 register context *ctx;
00267 register pointer in,out;
00268 { register pointer ios;
00269   if (!isstream(in) || !isstream(out)) error(E_STREAM);
00270   vpush(in); vpush(out);
00271   ios=allocobj(IOSTREAM, iostream, iostreamcp.cix);
00272   ios->c.iostream.out=out;
00273   ios->c.iostream.in=in;
00274   ios->c.iostream.plist=NIL;
00275   ctx->vsp -= 2;
00276   return(ios);}
00277 
00278 pointer makecode(mod,f,ftype)
00279 register pointer mod,ftype;
00280 pointer (*f)();
00281 /*actually, f is a pointer to a function returning a pointer*/
00282 { register pointer cd;
00283   eusinteger_t fentaddr;
00284   cd=allocobj(CODE, code, codecp.cix);
00285   cd->c.code.codevec=mod->c.code.codevec;
00286   cd->c.code.quotevec=mod->c.code.quotevec;
00287   cd->c.code.subrtype=ftype;
00288   fentaddr= (eusinteger_t)f>>2;
00289   cd->c.code.entry=makeint(fentaddr);
00290   return(cd);}
00291 
00292 
00293 /*
00294 /*      for DEFCLASS and INSTANTIATE
00295 */
00296 
00297 bumpcix(m,n)
00298 int m,n;
00299 { pointer super;
00300   if (classtab[m].subcix<n) {
00301     classtab[m].subcix=n;
00302     super=classtab[m].def->c.cls.super;
00303     if (isclass(super)) bumpcix(intval(super->c.cls.cix),n);}}
00304 
00305 recixobj(newcix)
00306 register int newcix;
00307 { register struct chunk *cp;
00308   register bpointer p,tail;
00309   register int s;
00310 #if defined(BIX_DEBUG) || defined(DEBUG_COUNT)
00311   static int count = 0;
00312 
00313   count++;
00314 #endif
00315 
00316   for (cp=chunklist; cp!=0; cp=cp->nextchunk) {
00317     s=buddysize[cp->chunkbix];
00318     p= &cp->rootcell;
00319     tail=(bpointer)((eusinteger_t)p+(s<<WORDSHIFT));
00320     while (p<tail) {
00321       if (p->h.cix>=newcix) p->h.cix++;
00322 #ifdef BIX_DEBUG
00323       printf( "recixobj:%d:p=0x%lx, bix = %d\n",
00324              count, p, p->h.bix );
00325 #endif
00326       p=nextbuddy(p);}
00327     }  }
00328 
00329 resetcix(class,p)
00330 pointer class;
00331 cixpair *p;
00332 { if (class) {
00333     p->cix=intval(class->c.cls.cix);
00334     p->sub=classtab[p->cix].subcix;} }
00335 
00336 enterclass(classobj)
00337 pointer classobj;
00338 { pointer super;
00339   register int i,newcix,temp,supercix;
00340 
00341   if (nextcix>=MAXCLASS) error(E_CLASSOVER);
00342   super= /*spevalof*/ (classobj->c.cls.super);
00343   if (isclass(super)) {
00344     supercix=intval(super->c.cls.cix);
00345     newcix=classtab[supercix].subcix+1;
00346     for (i=nextcix-1; i>=newcix; i--) {
00347       /*reconfigure class hierarchy*/
00348       bumpcix(i,i+1);
00349       classtab[i+1]=classtab[i];        /*bump classtab entry*/
00350       temp=intval(classtab[i].def->c.cls.cix);
00351       classtab[i].def->c.cls.cix=makeint(temp+1); }
00352     bumpcix(supercix,newcix);
00353     /*scan chunks and bumps object's cix which is greater than newcix*/
00354     if (newcix<nextcix)  recixobj(newcix);
00355     /*reset system defined class's cix*/
00356     for (i=0; i<nextbclass; i++)
00357       resetcix(builtinclass[i].cls, builtinclass[i].cp);
00358      }
00359   else newcix=nextcix;
00360   classobj->c.cls.cix=makeint(newcix);
00361   classtab[newcix].def=classobj;
00362   classtab[newcix].subcix=newcix; 
00363   nextcix++; }
00364 
00365 pointer makeclass(ctx,name,superobj,vars,types,forwards,tag,metaclass)
00366 register context *ctx;
00367 pointer name,superobj,vars,types,metaclass,forwards;
00368 int tag;
00369 { pointer class;
00370   extern pointer makeobject();
00371 
00372   /* make metaclass cell */
00373   vpush(vars); vpush(types);
00374   if (metaclass && isclass(metaclass)) class=makeobject(metaclass);
00375   else {
00376     if (tag==0)
00377       class=allocobj(METACLASS, _class, metaclasscp.cix);
00378     else 
00379       class=allocobj(VECCLASS, vecclass, vecclasscp.cix);} 
00380   class->c.cls.name=name;
00381   class->c.cls.super=superobj;
00382   class->c.cls.methods=NIL;
00383   class->c.cls.vars=vars;
00384   class->c.cls.types=types;
00385   class->c.cls.forwards=forwards;
00386   class->c.cls.plist=NIL;
00387   if (tag) {    /*vector type class*/
00388     class->c.vcls.elmtype=makeint(tag);
00389     class->c.vcls.size=makeint(-1);}
00390   name->c.sym.speval=class;
00391 /*  name->c.sym.vtype=V_SPECIAL;  */
00392   name->c.sym.vtype=V_GLOBAL; 
00393   enterclass(class);    /*determine cix and fill it in the cix slot*/
00394   vpop(); vpop();
00395   return(class);  }
00396 
00397 pointer makeobject(class)
00398 register pointer class;
00399 { register pointer obj,*v;
00400   register int size;
00401   size=vecsize(class->c.cls.vars);
00402   obj=alloc(size, ELM_FIXED, intval(class->c.cls.cix), size);
00403   v=obj->c.obj.iv;
00404   while (size>0) v[--size]=NIL;
00405   return(obj);}
00406 
00407 pointer makevector(vclass,size)
00408 register pointer vclass;
00409 register int size;
00410 { register pointer v,init,*vv;
00411   register int n,etype;
00412 
00413   etype=intval(vclass->c.vcls.elmtype);
00414   switch(etype) {
00415     case ELM_BIT: n=(size+WORD_SIZE-1)/WORD_SIZE; init=0; break;
00416     case ELM_CHAR:
00417     case ELM_BYTE: n=(size+sizeof(eusinteger_t))/sizeof(eusinteger_t); init=0; break;
00418     case ELM_FLOAT: n=size; init=(pointer)0; break;
00419     case ELM_INT: n=size; init=0; break;
00420     case ELM_FOREIGN: n=1; init=0; break;
00421     default: n=size; init=NIL;}
00422   v=alloc(n+1,etype, intval(vclass->c.vcls.cix),n+1);
00423   v->c.vec.size=makeint(size);
00424   vv=v->c.vec.v;
00425   while (--n>=0) vv[n]=init;
00426   return(v);}
00427 
00428 pointer makefvector(s)
00429 register int s;
00430 { register pointer v;
00431   register bpointer b;
00432   v=alloc(s+1,ELM_FLOAT, fltvectorcp.cix,s+1);
00433   v->c.vec.size=makeint(s);
00434   return(v);}
00435 
00436 pointer defvector(ctx,name,super,elm,size)      /*define vector class*/
00437 register context *ctx;
00438 char *name;
00439 pointer super;
00440 int elm,size;
00441 { pointer classsym,class,varvector,typevector,forwardvector;
00442   int i;
00443   classsym=intern(ctx,name,strlen(name),lisppkg);
00444   varvector=makevector(C_VECTOR,1);
00445   vpush(varvector);
00446   typevector=makevector(C_VECTOR,1);
00447   typevector->c.vec.v[0]=QINTEGER;
00448   vpush(typevector);
00449   forwardvector=makevector(C_VECTOR,1);
00450   forwardvector->c.vec.v[0]=NIL;
00451   vpush(forwardvector);
00452   varvector->c.vec.v[0]=intern(ctx,"LENGTH",6,lisppkg);
00453   class=makeclass(ctx,classsym,super,varvector,typevector,forwardvector,elm,0); 
00454   ctx->vsp -= 3;
00455   return(classsym);}
00456 
00457 pointer makematrix(ctx,row,column)
00458 register context *ctx;
00459 int row,column;
00460 { register pointer v,m;
00461   register int i;
00462   v=makefvector(row*column);
00463   vpush(v);
00464   m=allocobj(ARRAY, arrayheader, arraycp.cix);
00465   m->c.ary.entity=v;
00466   m->c.ary.fillpointer=NIL;
00467   m->c.ary.rank=makeint(2);
00468   m->c.ary.offset=makeint(0);
00469   m->c.ary.dim[0]=makeint(row);
00470   m->c.ary.dim[1]=makeint(column);
00471   m->c.ary.plist=NIL;
00472   for (i=2; i<ARRAYRANKLIMIT; i++) m->c.ary.dim[i]=NIL;
00473   vpop();
00474   return(m);}
00475 
00476 pointer makemodule(ctx,size)    /*size in bytes*/
00477 register context *ctx;
00478 int size;
00479 { register pointer mod,cvec;
00480   cvec=makebuffer(size);
00481   elmtypeof(cvec)=ELM_BYTE;
00482   vpush(cvec);
00483   mod=allocobj(LDMODULE, ldmodule, ldmodulecp.cix);
00484   mod->c.ldmod.codevec=vpop();
00485   mod->c.ldmod.quotevec=NIL;
00486   mod->c.ldmod.entry=NIL;
00487   mod->c.ldmod.subrtype=NIL;
00488   mod->c.ldmod.symtab=NIL;
00489   mod->c.ldmod.objname=NIL;
00490   mod->c.ldmod.handle=NIL;
00491   return(mod);}
00492 
00493 pointer makeclosure(code,quote,f,e0,e1,e2)
00494 pointer code,quote,e0,*e1,*e2;
00495 pointer (*f)();
00496 { register pointer clo;
00497   clo=allocobj(CLOSURE, closure, closurecp.cix);
00498   clo->c.clo.codevec=code;
00499   clo->c.clo.quotevec=quote;
00500   clo->c.clo.subrtype=SUBR_FUNCTION;
00501   clo->c.clo.entry=makeint((eusinteger_t)f>>2);
00502   clo->c.clo.env0=e0;
00503   clo->c.clo.env1=e1; /*makeint((int)e1>>2);*/
00504   clo->c.clo.env2=e2; /*makeint((int)e2>>2);*/
00505   return(clo);}
00506 
00507 pointer makereadtable(ctx)
00508 register context *ctx;
00509 { pointer rdtable,rdsyntax,rdmacro,rddispatch;
00510   vpush((rdsyntax=makebuffer(256)));
00511   vpush((rdmacro=makevector(C_VECTOR,256)));
00512   rddispatch=makevector(C_VECTOR,256);
00513   rdtable=allocobj(READTABLE, readtable, readtablecp.cix);
00514   vpush(rdtable);
00515   rdtable->c.rdtab.dispatch=rddispatch;
00516   rdtable->c.rdtab.macro=rdmacro;
00517   rdtable->c.rdtab.syntax=rdsyntax;
00518   rdtable->c.rdtab.plist=NIL;
00519   ctx->vsp -= 3;
00520   return(rdtable);}
00521 
00522 pointer makelabref(n,v,nxt)
00523 pointer n,v,nxt;
00524 { pointer l;
00525   l=alloc(wordsizeof(struct labref), ELM_FIXED, labrefcp.cix,
00526           wordsizeof(struct labref));
00527   l->c.lab.label=n;
00528   l->c.lab.value=v;
00529   l->c.lab.next=nxt;
00530   l->c.lab.unsolved=NIL;
00531   return(l);}  
00532 
00533 /****************************************************************
00534 /* extended numbers
00535 /****************************************************************/
00536 pointer makeratio(num, denom)
00537 int num, denom;
00538 { pointer r;
00539   r=allocobj(RATIO, ratio, ratiocp.cix);
00540   r->c.ratio.numerator=makeint(num);
00541   r->c.ratio.denominator=makeint(denom);
00542   /*  printf("ratio cid= %d  r=0x%x\n", ratiocp.cix, r); */
00543   return(r);}
00544 
00545 pointer makebig(n)
00546 int n;
00547 { register context *ctx=euscontexts[thr_self()];
00548   register pointer p,v;
00549   v=makevector(C_INTVECTOR, n);
00550   vpush(v);
00551   p=allocobj(BIGNUM, bignum, bignumcp.cix);
00552   p->c.bgnm.size=makeint(n);
00553   p->c.bgnm.bv=v;
00554   vpop();
00555   return(p);}
00556 
00557 pointer makebig1(x)
00558 long x;
00559 { register context *ctx=euscontexts[thr_self()];
00560   register pointer p,v;
00561 
00562   v=makevector(C_INTVECTOR, 1);
00563   vpush(v);
00564   p=allocobj(BIGNUM, bignum, bignumcp.cix);
00565   p->c.bgnm.size=makeint(1);
00566   p->c.bgnm.bv=v;
00567   v->c.ivec.iv[0]=x;
00568   vpop();
00569   return(p);}
00570 
00571 pointer makebig2(hi,lo)
00572 long hi, lo;
00573 { register context *ctx=euscontexts[thr_self()];
00574   register pointer p,v;
00575 
00576   v=makevector(C_INTVECTOR, 2);
00577   vpush(v);
00578   p=allocobj(BIGNUM, bignum, bignumcp.cix);
00579   p->c.bgnm.size=makeint(2);
00580   p->c.bgnm.bv=v;
00581   v->c.ivec.iv[0]=lo;
00582   v->c.ivec.iv[1]=hi;
00583   vpop();
00584   return(p);}
00585 
00586 
00587 /****************************************************************/
00588 /* defines
00589 /****************************************************************/
00590 
00591 pointer defun(ctx,name,mod,f)
00592 register context *ctx;
00593 char *name;
00594 pointer mod;
00595 pointer (*f)();
00596 { register pointer sym,pkg;
00597 #if defined(DEFUN_DEBUG) || defined(DEBUG_COUNT)
00598   static int count=0;
00599 
00600   count++;
00601 #endif
00602 #ifdef DEFUN_DEBUG
00603   printf( "defun:%d:%s:", count, name );
00604 #endif
00605 
00606   pkg=Spevalof(PACKAGE);
00607   sym=intern(ctx,name,strlen(name),pkg);
00608   sym->c.sym.spefunc=makecode(mod,f,SUBR_FUNCTION);
00609 #ifdef DEFUN_DEBUG
00610   printf( "0x%lx\n", sym->c.sym.spefunc->c.code.entry );
00611 #endif
00612   return(sym);}
00613 
00614 pointer defunpkg(ctx,name,mod,f,pkg)
00615 register context *ctx;
00616 char *name;
00617 pointer mod,pkg;
00618 pointer (*f)();
00619 { pointer sym;
00620   sym=intern(ctx,name,strlen(name),pkg);
00621   sym->c.sym.spefunc=makecode(mod,f,SUBR_FUNCTION);
00622   return(sym);}
00623 
00624 pointer defmacro(ctx,name,mod,f)
00625 register context *ctx;
00626 char *name;
00627 pointer mod;
00628 pointer (*f)();
00629 { register pointer sym,pkg;
00630   pkg=Spevalof(PACKAGE);
00631   sym=intern(ctx,name,strlen(name),pkg);
00632   sym->c.sym.spefunc=makecode(mod,f,SUBR_MACRO);
00633   return(sym);}
00634 
00635 #if Solaris2
00636 int next_special_index=3;
00637 static mutex_t spex_lock;
00638 
00639 int special_index()
00640 { int x;
00641 
00642   if (next_special_index==3) mutex_init(&spex_lock,USYNC_THREAD,NULL);
00643   mutex_lock(&spex_lock);
00644   x= next_special_index++;
00645   mutex_unlock(&spex_lock);
00646   if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=256"); }
00647   return(x);}
00648 #else
00649 int next_special_index=3;
00650 
00651 int special_index()
00652 { int x;
00653 
00654   x= next_special_index++;
00655   if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=256"); }
00656 
00657   return(x);}
00658 #endif
00659 
00660 pointer defspecial(ctx,name,mod,f)      /*define special form*/
00661 register context *ctx;
00662 char *name;
00663 pointer mod;
00664 pointer (*f)();
00665 { register pointer sym,pkg;
00666   pkg=Spevalof(PACKAGE);
00667   sym=intern(ctx,name,strlen(name),pkg);
00668   sym->c.sym.spefunc=makecode(mod,f,SUBR_SPECIAL);
00669   return(sym);}
00670 
00671 pointer defconst(ctx,name,val,pkg)
00672 register context *ctx;
00673 char *name;
00674 pointer val,pkg;
00675 { register pointer sym;
00676   vpush(val);
00677   sym=intern(ctx,name,strlen(name),pkg);
00678   sym->c.sym.vtype=V_CONSTANT;
00679   sym->c.sym.speval=vpop();
00680   return(sym);}
00681 
00682 pointer defvar(ctx,name,val,pkg)
00683 register context *ctx;
00684 char *name;
00685 pointer val,pkg;
00686 { register pointer sym;
00687   int x;
00688   vpush(val);
00689   sym=intern(ctx,name,strlen(name),pkg);
00690   sym->c.sym.vtype=V_GLOBAL;
00691   sym->c.sym.speval=vpop();
00692   return(sym);}
00693 
00694 pointer deflocal(ctx,name,val,pkg)
00695 register context *ctx;
00696 char *name;
00697 pointer val,pkg;
00698 { register pointer sym;
00699   int x;
00700   vpush(val);
00701   sym=intern(ctx,name,strlen(name),pkg);
00702   x=special_index();
00703   sym->c.sym.vtype=makeint(x);
00704   /*sym->c.sym.speval=vpop();*/
00705   /* put the same value in the global symbol-value
00706         and in the thread's special binding table */
00707   ctx->specials->c.vec.v[x]=vpop();
00708   sym->c.sym.speval=val;
00709   return(sym);}
00710 
00711 pointer defkeyword(ctx,name)
00712 register context *ctx;
00713 char *name;
00714 { register pointer sym;
00715   sym=intern(ctx,name,strlen(name),keywordpkg);
00716   return(sym);}
00717 
00718 /* 
00719 /* for making compiled function/macro 
00720 */
00721 
00722 extern pointer putprop();
00723 
00724 pointer compfun(ctx,sym,mod,entry,doc)
00725 register context *ctx;
00726 register pointer sym,mod,doc;
00727 pointer (*entry)();
00728 { sym->c.sym.spefunc=makecode(mod,entry,SUBR_FUNCTION);
00729   if (doc!=NIL) putprop(ctx,sym,doc,K_FUNCTION_DOCUMENTATION); 
00730   return(sym);}
00731 
00732 pointer compmacro(ctx,sym,mod,entry,doc)
00733 register context *ctx;
00734 register pointer sym,mod,doc;
00735 pointer (* entry)();
00736 { sym->c.sym.spefunc=makecode(mod,entry,SUBR_MACRO);
00737   if (doc!=NIL) putprop(ctx,sym, doc, K_FUNCTION_DOCUMENTATION); 
00738   return(sym);}
00739 
00740 /****************************************************************/
00741 /* stack frames
00742 /****************************************************************/
00743 
00744 struct blockframe *makeblock(ctx,kind,name,jbuf,link)
00745 register context *ctx;
00746 pointer kind,name;
00747 jmp_buf *jbuf;
00748 struct blockframe *link;
00749 { register struct blockframe *blk=ctx->blkfp;
00750   *(ctx->vsp)=(pointer)ctx->blkfp; blk=(struct blockframe *)(ctx->vsp);
00751   (ctx->vsp) += wordsizeof(struct blockframe);
00752   blk->lexklink=link;
00753   blk->dynklink=ctx->blkfp;
00754   blk->kind=kind;
00755   blk->name=name;
00756   blk->jbp=jbuf;
00757   ctx->blkfp=blk;
00758   return(blk);}
00759 
00760 struct fletframe *makeflet(ctx,nm,def,scp,link)
00761 register context *ctx;
00762 pointer nm,def;
00763 struct fletframe *scp,*link;
00764 { register struct fletframe *ffp=(struct fletframe *)(ctx->vsp);
00765   register pointer p;
00766   int i;
00767   for (i=0; i<sizeof(struct fletframe)/sizeof(pointer); i++)
00768     vpush(makeint(0));
00769   ffp->name=nm;
00770   p=cons(ctx,makeint(scp),def);
00771   p=cons(ctx,makeint(ctx->bindfp),p);
00772   p=cons(ctx,nm,p);
00773   ffp->fclosure=cons(ctx,LAMCLOSURE,p);
00774   ffp->scope=scp;
00775   ffp->lexlink=link; ffp->dynlink=ctx->fletfp;  /*dynlink is not used*/
00776   ctx->fletfp=ffp;
00777   return(ffp);}
00778 
00779 void mkcatchframe(ctx,lab,jbuf)
00780 context *ctx;
00781 pointer lab;
00782 jmp_buf jbuf;
00783 { struct catchframe *cfp;
00784   cfp=(struct catchframe *)ctx->vsp;
00785   cfp->nextcatch=ctx->catchfp;
00786   cfp->cf=ctx->callfp;
00787   cfp->bf=ctx->bindfp;
00788 /*  cfp->blkf=blkfp; */
00789   cfp->jbp=(jmp_buf *)jbuf;
00790   cfp->label=lab;
00791   cfp->ff=ctx->fletfp;
00792   ctx->vsp += (sizeof(struct catchframe)/sizeof(pointer));
00793   ctx->catchfp=cfp;}
00794 
00795 /****************************************************************/
00796 /* new thread context 
00797 /****************************************************************/
00798 extern context *mainctx;
00799 
00800 allocate_stack(ctx,n)
00801 context *ctx;
00802 register int n;
00803 { register int i;
00804   if (ctx->stack) cfree(ctx->stack);
00805   n=max(1024,n);
00806 #if 0 /* ???? */
00807   i=(int)malloc((n+1)*sizeof(pointer));
00808   if (i==NULL) error(E_STACKOVER);
00809   ctx->stack=(pointer *)i;
00810 #else
00811   ctx->stack=(pointer *)malloc((n+1)*sizeof(pointer));
00812   if (i==NULL) error(E_STACKOVER);
00813 #endif
00814   ctx->stacklimit= &ctx->stack[n-100]; 
00815 #if STACK_DEBUG
00816   printf( "allocate_stack: 0x%lx -- 0x%lx\n", ctx->stack, ctx->stacklimit );
00817 #endif
00818  }
00819 
00820 context *makelispcontext(bs_size)
00821 int bs_size;
00822 { pointer *stk, specialtab;
00823   context *cntx;
00824   int i;
00825   struct buddy_free *thrbuddy;
00826 
00827   cntx=(context *)malloc(sizeof(context));
00828   if (cntx==NULL) error(E_ALLOCATION);
00829   if (bs_size<4096) bs_size=4096;
00830   stk=(pointer *)malloc(sizeof(pointer) * bs_size);
00831   if (stk==NULL) error(E_ALLOCATION); 
00832   cntx->stack=stk;
00833   cntx->vsp=stk;
00834   cntx->stacklimit = stk+bs_size-64;
00835 #if STACK_DEBUG
00836   printf( "makelispcontext: stack: 0x%lx -- 0x%lx\n", cntx->stack, cntx->stacklimit );
00837 #endif
00838   cntx->callfp=NULL;
00839   cntx->catchfp=NULL;
00840   cntx->bindfp=NULL;
00841   cntx->sbindfp=NULL;
00842   cntx->blkfp=NULL;
00843   cntx->protfp=NULL;
00844   cntx->fletfp=NULL;
00845   cntx->newfletfp=NULL;
00846   cntx->lastalloc=NULL;
00847   cntx->errhandler=NULL;
00848   cntx->alloc_big_count=0;
00849   cntx->alloc_small_count=0;
00850   cntx->special_bind_count=0;
00851   cntx->threadobj=NIL;
00852   cntx->intsig=0;
00853 
00854  /* create a special variable table for this thread and link to specials slot*/
00855   if (C_VECTOR) {
00856     specialtab=makevector(C_VECTOR,MAX_SPECIALS);
00857     /* copy initial values of special variables from the main context*/
00858     for (i=0; i<MAX_SPECIALS; i++)
00859         specialtab->c.vec.v[i]=mainctx->specials->c.vec.v[i];
00860     cntx->specials=specialtab;}
00861 
00862   { register int i;
00863     register struct methdef *mc;
00864     mc=(struct methdef *)malloc(sizeof(struct methdef)*MAXMETHCACHE);
00865     if (mc==NULL) error(E_ALLOCATION);
00866     for (i=0; i<MAXMETHCACHE; i++) {
00867       mc[i].selector=mc[i].class=mc[i].ownerclass=mc[i].method=NULL;} 
00868     cntx->methcache=mc;
00869     thrbuddy=(struct buddyfree  *)
00870                         malloc(sizeof(struct buddyfree) * (MAXTHRBUDDY+1));
00871     if (thrbuddy==NULL) error(E_ALLOCATION);
00872     cntx->thr_buddy=thrbuddy;
00873     for (i=0; i<MAXTHRBUDDY; i++) {
00874       cntx->thr_buddy[i].bp=0;
00875       cntx->thr_buddy[i].count=0;}
00876     cntx->thr_buddy[MAXTHRBUDDY].bp= (bpointer)-1;
00877     }
00878   return(cntx);}
00879 
00880 void deletecontext(id,ctx)
00881 register context *ctx;
00882 { if (id<MAXTHREAD) euscontexts[id]=NULL;
00883   cfree(ctx->stack);
00884   cfree(ctx);}
00885 
00886 #if THREADED
00887 pointer makethreadport(ctx)
00888 context *ctx;
00889 { sema_t *sem;
00890   pointer s;
00891   pointer thrport;
00892   thrport=allocobj(THREAD, threadport, threadcp.cix);
00893 
00894   thrport->c.thrp.plist=NIL;
00895   thrport->c.thrp.requester=makeint(0);
00896   vpush(thrport);
00897 
00898   /* make three semaphores; reqsem, runsem, donesem */
00899   s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
00900   sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
00901   thrport->c.thrp.reqsem=s;
00902 
00903   s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
00904   sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
00905   thrport->c.thrp.runsem=s;
00906 
00907   s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
00908   sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
00909   thrport->c.thrp.donesem=s;
00910 
00911   sema_init(sem, 0, USYNC_THREAD, 0);
00912   thrport->c.thrp.donesem=makeint(sem); */
00913 
00914   thrport->c.thrp.contex=makeint((eusinteger_t)ctx>>2);
00915   thrport->c.thrp.func=NIL;
00916   thrport->c.thrp.args=NIL;
00917   thrport->c.thrp.result=NIL;
00918   thrport->c.thrp.idle=NIL;
00919   thrport->c.thrp.wait=NIL;
00920   ctx->threadobj=thrport;
00921   ctx->lastalloc=thrport;
00922   vpop();
00923   return(thrport);}
00924 #endif
00925 


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Sep 3 2015 10:36:20