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


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 18:05:53