00001
00002
00003
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
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
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);}
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;
00052 #if vax
00053 { register short s;
00054 s=u.sval.low;
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
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 \
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
00105
00106
00107
00108
00109
00110
00111
00112 {
00113 vpush(a); vpush(d);
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)
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)
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;
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;
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
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);
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
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(f);
00296 #endif
00297 return(cd);}
00298
00299
00300
00301
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= (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
00355 bumpcix(i,i+1);
00356 classtab[i+1]=classtab[i];
00357 temp=intval(classtab[i].def->c.cls.cix);
00358 classtab[i].def->c.cls.cix=makeint(temp+1); }
00359 bumpcix(supercix,newcix);
00360
00361 if (newcix<nextcix) recixobj(newcix);
00362
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
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) {
00398 class->c.vcls.elmtype=makeint(tag);
00399 class->c.vcls.size=makeint(-1);}
00400 pointer_update(name->c.sym.speval,class);
00401
00402 name->c.sym.vtype=V_GLOBAL;
00403 enterclass(class);
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)
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)
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(f);
00517 #endif
00518 clo->c.clo.env0=e0;
00519 clo->c.clo.env1=e1;
00520 clo->c.clo.env2=e2;
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
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
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
00605
00606
00607 pointer defun(ctx,name,mod,f)
00608 register context *ctx;
00609 char *name;
00610 pointer mod;
00611 pointer (*f)();
00612 { register pointer sym,pkg;
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 pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_FUNCTION));
00625 #ifdef DEFUN_DEBUG
00626 printf( "0x%lx\n", sym->c.sym.spefunc->c.code.entry );
00627 #endif
00628 return(sym);}
00629
00630 pointer defunpkg(ctx,name,mod,f,pkg)
00631 register context *ctx;
00632 char *name;
00633 pointer mod,pkg;
00634 pointer (*f)();
00635 { pointer sym;
00636 sym=intern(ctx,name,strlen(name),pkg);
00637 pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_FUNCTION));
00638 return(sym);}
00639
00640 pointer defmacro(ctx,name,mod,f)
00641 register context *ctx;
00642 char *name;
00643 pointer mod;
00644 pointer (*f)();
00645 { register pointer sym,pkg;
00646 pkg=Spevalof(PACKAGE);
00647 sym=intern(ctx,name,strlen(name),pkg);
00648 pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_MACRO));
00649 return(sym);}
00650
00651 #if Solaris2 || PTHREAD
00652 int next_special_index=3;
00653 static mutex_t spex_lock;
00654
00655 int special_index()
00656 { int x;
00657
00658 if (next_special_index==3) mutex_init(&spex_lock,USYNC_THREAD,NULL);
00659 mutex_lock(&spex_lock);
00660 x= next_special_index++;
00661 mutex_unlock(&spex_lock);
00662 if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=512"); }
00663 return(x);}
00664 #else
00665 int next_special_index=3;
00666
00667 int special_index()
00668 { int x;
00669
00670 x= next_special_index++;
00671 if (x>=MAX_SPECIALS) { error(E_USER,(pointer)"too many special variables >=512"); }
00672
00673 return(x);}
00674 #endif
00675
00676 pointer defspecial(ctx,name,mod,f)
00677 register context *ctx;
00678 char *name;
00679 pointer mod;
00680 pointer (*f)();
00681 { register pointer sym,pkg;
00682 pkg=Spevalof(PACKAGE);
00683 sym=intern(ctx,name,strlen(name),pkg);
00684 pointer_update(sym->c.sym.spefunc,makecode(mod,f,SUBR_SPECIAL));
00685 return(sym);}
00686
00687 pointer defconst(ctx,name,val,pkg)
00688 register context *ctx;
00689 char *name;
00690 pointer val,pkg;
00691 { register pointer sym;
00692 vpush(val);
00693 sym=intern(ctx,name,strlen(name),pkg);
00694 sym->c.sym.vtype=V_CONSTANT;
00695 pointer_update(sym->c.sym.speval,vpop());
00696 return(sym);}
00697
00698 pointer defvar(ctx,name,val,pkg)
00699 register context *ctx;
00700 char *name;
00701 pointer val,pkg;
00702 { register pointer sym;
00703 int x;
00704 vpush(val);
00705 sym=intern(ctx,name,strlen(name),pkg);
00706 sym->c.sym.vtype=V_GLOBAL;
00707 pointer_update(sym->c.sym.speval,vpop());
00708 return(sym);}
00709
00710 pointer deflocal(ctx,name,val,pkg)
00711 register context *ctx;
00712 char *name;
00713 pointer val,pkg;
00714 { register pointer sym;
00715 int x;
00716 vpush(val);
00717 sym=intern(ctx,name,strlen(name),pkg);
00718 x=special_index();
00719 sym->c.sym.vtype=makeint(x);
00720
00721
00722
00723 pointer_update(ctx->specials->c.vec.v[x],vpop());
00724 pointer_update(sym->c.sym.speval,val);
00725 return(sym);}
00726
00727 pointer defkeyword(ctx,name)
00728 register context *ctx;
00729 char *name;
00730 { register pointer sym;
00731 sym=intern(ctx,name,strlen(name),keywordpkg);
00732 return(sym);}
00733
00734
00735
00736
00737
00738 extern pointer putprop();
00739
00740 pointer compfun(ctx,sym,mod,entry,doc)
00741 register context *ctx;
00742 register pointer sym,mod,doc;
00743 pointer (*entry)();
00744 { pointer_update(sym->c.sym.spefunc,makecode(mod,entry,SUBR_FUNCTION));
00745 if (doc!=NIL) putprop(ctx,sym,doc,K_FUNCTION_DOCUMENTATION);
00746 return(sym);}
00747
00748 pointer compmacro(ctx,sym,mod,entry,doc)
00749 register context *ctx;
00750 register pointer sym,mod,doc;
00751 pointer (* entry)();
00752 { pointer_update(sym->c.sym.spefunc,makecode(mod,entry,SUBR_MACRO));
00753 if (doc!=NIL) putprop(ctx,sym, doc, K_FUNCTION_DOCUMENTATION);
00754 return(sym);}
00755
00756
00757
00758
00759
00760 struct blockframe *makeblock(ctx,kind,name,jbuf,link)
00761 register context *ctx;
00762 pointer kind,name;
00763 jmp_buf *jbuf;
00764 struct blockframe *link;
00765 { register struct blockframe *blk=ctx->blkfp;
00766 *(ctx->vsp)=(pointer)ctx->blkfp; blk=(struct blockframe *)(ctx->vsp);
00767 (ctx->vsp) += wordsizeof(struct blockframe);
00768 blk->lexklink=link;
00769 blk->dynklink=ctx->blkfp;
00770 blk->kind=kind;
00771 blk->name=name;
00772 blk->jbp=jbuf;
00773 ctx->blkfp=blk;
00774 return(blk);}
00775
00776 struct fletframe *makeflet(ctx,nm,def,scp,link)
00777 register context *ctx;
00778 pointer nm,def;
00779 struct fletframe *scp,*link;
00780 { register struct fletframe *ffp=(struct fletframe *)(ctx->vsp);
00781 register pointer p;
00782 int i;
00783 for (i=0; i<sizeof(struct fletframe)/sizeof(pointer); i++)
00784 vpush(makeint(0));
00785 ffp->name=nm;
00786 p=cons(ctx,makeint(hide_ptr((pointer)scp)),def);
00787 p=cons(ctx,makeint(hide_ptr((pointer)(ctx->bindfp))),p);
00788 p=cons(ctx,nm,p);
00789 ffp->fclosure=cons(ctx,LAMCLOSURE,p);
00790 ffp->scope=scp;
00791 ffp->lexlink=link; ffp->dynlink=ctx->fletfp;
00792 ctx->fletfp=ffp;
00793 return(ffp);}
00794
00795 void mkcatchframe(ctx,lab,jbuf)
00796 context *ctx;
00797 pointer lab;
00798 jmp_buf *jbuf;
00799 { struct catchframe *cfp;
00800 cfp=(struct catchframe *)ctx->vsp;
00801 cfp->nextcatch=ctx->catchfp;
00802 cfp->cf=ctx->callfp;
00803 cfp->bf=ctx->bindfp;
00804
00805 cfp->jbp=(jmp_buf *)jbuf;
00806 cfp->label=lab;
00807 cfp->ff=ctx->fletfp;
00808 ctx->vsp += (sizeof(struct catchframe)/sizeof(pointer));
00809 ctx->catchfp=cfp;}
00810
00811
00812
00813
00814 extern context *mainctx;
00815
00816 void allocate_stack(ctx,n)
00817 context *ctx;
00818 register int n;
00819 { register int i;
00820 if (ctx->stack) cfree(ctx->stack);
00821 n=max(1024,n);
00822 #if 0
00823 i=(int)malloc((n+1)*sizeof(pointer));
00824 ctx->stack=(pointer *)i;
00825 #else
00826 ctx->stack=(pointer *)malloc((n+1)*sizeof(pointer));
00827 #endif
00828 ctx->stacklimit= &ctx->stack[n-100];
00829 #if STACK_DEBUG
00830 printf( "allocate_stack: 0x%lx -- 0x%lx\n", ctx->stack, ctx->stacklimit );
00831 #endif
00832 }
00833
00834 context *makelispcontext(bs_size)
00835 int bs_size;
00836 { pointer *stk, specialtab;
00837 context *cntx;
00838 int i;
00839
00840 cntx=(context *)malloc(sizeof(context));
00841 if (bs_size<4096) bs_size=4096;
00842 stk=(pointer *)malloc(sizeof(pointer) * bs_size);
00843 cntx->stack=stk;
00844 cntx->vsp=stk;
00845 cntx->stacklimit = stk+bs_size-64;
00846 #if STACK_DEBUG
00847 printf( "makelispcontext: stack: 0x%lx -- 0x%lx\n", cntx->stack, cntx->stacklimit );
00848 #endif
00849 cntx->callfp=NULL;
00850 cntx->catchfp=NULL;
00851 cntx->bindfp=NULL;
00852 cntx->sbindfp=NULL;
00853 cntx->blkfp=NULL;
00854 cntx->protfp=NULL;
00855 cntx->fletfp=NULL;
00856 cntx->newfletfp=NULL;
00857 cntx->lastalloc=NULL;
00858 cntx->errhandler=NULL;
00859 cntx->alloc_big_count=0;
00860 cntx->alloc_small_count=0;
00861 cntx->special_bind_count=0;
00862 cntx->threadobj=NIL;
00863 #ifdef RGC
00864 stk = (pointer *)malloc(sizeof(pointer) * bs_size * 2);
00865 cntx->gcstack = stk;
00866 cntx->gsp = stk;
00867 cntx->gcstacklimit = stk+bs_size*2-64;
00868 #ifdef __GC_ALLOC_DRIVEN
00869 cntx->my_gc_pri = 2;
00870 #endif
00871 #endif
00872 cntx->slashflag=0;
00873 cntx->intsig=0;
00874 #ifdef __RETURN_BARRIER
00875 cntx->rbar.pointer = NULL;
00876 mutex_init(&cntx->rbar.lock, NULL);
00877 #endif
00878
00879
00880 if (C_VECTOR) {
00881 specialtab=makevector(C_VECTOR,MAX_SPECIALS);
00882
00883 for (i=0; i<MAX_SPECIALS; i++)
00884 specialtab->c.vec.v[i]=mainctx->specials->c.vec.v[i];
00885 cntx->specials=specialtab;}
00886
00887 { register int i;
00888 register struct methdef *mc;
00889 mc=(struct methdef *)malloc(sizeof(struct methdef)*MAXMETHCACHE);
00890 for (i=0; i<MAXMETHCACHE; i++) {
00891 mc[i].selector=mc[i].class=mc[i].ownerclass=mc[i].method=NULL;}
00892 cntx->methcache=mc;
00893 cntx->thr_buddy=(struct buddyfree *)
00894 malloc(sizeof(struct buddyfree) * (MAXTHRBUDDY+1));
00895 for (i=0; i<MAXTHRBUDDY; i++) {
00896 cntx->thr_buddy[i].bp=0;
00897 cntx->thr_buddy[i].count=0;}
00898 cntx->thr_buddy[MAXTHRBUDDY].bp= (bpointer)-1;
00899 }
00900 return(cntx);}
00901
00902 void deletecontext(id,ctx)
00903 register context *ctx;
00904 { if (id<MAXTHREAD) euscontexts[id]=NULL;
00905 cfree(ctx->stack);
00906 cfree(ctx);}
00907
00908 #if THREADED
00909 pointer makethreadport(ctx)
00910 context *ctx;
00911 { sema_t *sem;
00912 pointer s;
00913 pointer thrport;
00914 thrport=allocobj(THREAD, threadport, threadcp.cix);
00915
00916 thrport->c.thrp.plist=NIL;
00917 thrport->c.thrp.requester=makeint(0);
00918 vpush(thrport);
00919
00920
00921 s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
00922 sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
00923 thrport->c.thrp.reqsem=s;
00924
00925 s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
00926 sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
00927 thrport->c.thrp.runsem=s;
00928
00929 s=makevector(C_INTVECTOR, (sizeof(sema_t)+3)/sizeof(long));
00930 sema_init((sema_t *)s->c.ivec.iv, 0, USYNC_THREAD, 0);
00931 thrport->c.thrp.donesem=s;
00932
00933
00934
00935
00936
00937 thrport->c.thrp.contex=makeint((eusinteger_t)ctx>>2);
00938 thrport->c.thrp.func=NIL;
00939 thrport->c.thrp.args=NIL;
00940 thrport->c.thrp.result=NIL;
00941 thrport->c.thrp.idle=NIL;
00942 thrport->c.thrp.wait=NIL;
00943 ctx->threadobj=thrport;
00944 ctx->lastalloc=thrport;
00945 vpop();
00946 return(thrport);}
00947 #endif
00948