eus.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* eus.c:
00003 /*      Toplevel, exception(error, signal) handler and initializers
00004 /*      Copyright(c)1988, Toshihiro MATSUI, Electrotechnical Laboratory
00005 /*      1986 April:     created 
00006 /*      1994 June:      multi thread
00007 /*      1996 January:   handles SIGSEGV, SIGBUS
00008 /****************************************************************/
00009 static char *rcsid="@(#) $Id$";
00010 
00011 #include "eus.h"
00012 
00013 #include <signal.h>
00014 #include <dlfcn.h>
00015 #include <fcntl.h>
00016 
00017 #if Solaris2
00018 #include <synch.h>
00019 #include <thread.h>
00020 #elif SunOS4_1
00021 #include <lwp/stackdep.h>
00022 #endif
00023 
00024 #if !THREADED
00025 unsigned int thr_self() { return(1);}
00026 #endif
00027 
00028 
00029 #if Linux && !OLD_LINUX && !Darwin
00030 #include <malloc.h> // define mallopt, M_MMAP_MAX
00031 #endif
00032 #if Darwin
00033 int _end;
00034 #endif
00035 
00036 /*variables*/
00037 /* process id and program name*/
00038 eusinteger_t mypid;
00039 char *progname;
00040 #if (WORD_SIZE == 64)
00041 eusinteger_t setjmp_val;
00042 #endif
00043 
00044 /* heap management */
00045 /* every free cell is linked to this structure*/
00046 struct buddyfree  buddy[MAXBUDDY+1];
00047 extern pointer *gcstack, *gcsp, *gcsplimit;
00048 #define DEFAULT_MAX_GCSTACK 16384
00049 
00050 
00051 /* System internal objects are connected to sysobj list
00052 /* to protect from being garbage-collected */
00053 
00054 pointer sysobj;
00055 
00056 /* context */
00057 context *mainctx;
00058 pointer mainport;
00059 #if Solaris2
00060   thread_t maintid;
00061 #endif
00062 
00063 
00064 /****************************************************************/
00065 /* system defined (built-in) class index
00066 /*      modified to accept  dynamic type extension (1987-Jan)
00067 /****************************************************************/
00068 
00069 cixpair objectcp;
00070 cixpair conscp;
00071 cixpair propobjcp;
00072 cixpair symbolcp;
00073 cixpair packagecp;
00074 cixpair streamcp;
00075 cixpair filestreamcp;
00076 cixpair iostreamcp;
00077 cixpair metaclasscp;
00078 cixpair vecclasscp;
00079 cixpair codecp;
00080 cixpair fcodecp;
00081 /*cixpair modulecp; */
00082 cixpair ldmodulecp;
00083 cixpair closurecp;
00084 cixpair labrefcp;
00085 cixpair threadcp;
00086 cixpair arraycp;
00087 cixpair readtablecp;
00088 cixpair vectorcp;
00089 cixpair fltvectorcp;
00090 cixpair intvectorcp;
00091 cixpair stringcp;
00092 cixpair bitvectorcp;
00093 /* extended numbers */
00094 cixpair extnumcp;
00095 cixpair ratiocp;
00096 cixpair complexcp;
00097 cixpair bignumcp;
00098 
00099 
00100 struct built_in_cid  builtinclass[64];
00101 int nextbclass;
00102 
00103 long buddysize[MAXBUDDY+1];
00104 struct buddyfree buddy[MAXBUDDY+1];
00105 context *euscontexts[MAXTHREAD];
00106 
00107 
00108 /*symbol management*/
00109 pointer pkglist,lisppkg,keywordpkg,userpkg,syspkg,unixpkg,xpkg;
00110 pointer NIL,PACKAGE,T,QUOTE;
00111 pointer FUNCTION;
00112 pointer QDECLARE,QSPECIAL;
00113 #if SunOS4_1 /* SELF is already used on SunOS 4.1.x. */
00114 pointer QSELF;
00115 #else
00116 pointer SELF;
00117 #endif
00118 pointer CLASS;
00119 pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
00120 pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
00121 pointer TOPLEVEL,QEVALHOOK,ERRHANDLER,FATALERROR;
00122 pointer QGCHOOK, QEXITHOOK;
00123 pointer QUNBOUND,QDEBUG;
00124 pointer QTHREADS;       /* system:*threads* */
00125 pointer QPARAGC;
00126 pointer QVERSION;
00127 pointer QEQ,QEQUAL,QNOT, QAND, QOR;
00128 
00129 /* keywords */
00130 pointer K_IN,K_OUT,K_IO;        /*direction keyword*/
00131 pointer K_FLUSH,K_FILL,K_FILE,K_STRING;
00132 pointer K_NOMETHOD,K_BIT,K_BYTE,K_CHAR,K_SHORT,K_LONG,K_INTEGER,K_POINTER;
00133 pointer K_FLOAT32,K_FLOAT,K_DOUBLE,K_FOREIGN, K_FOREIGN_STRING;
00134 pointer K_DOWNCASE,K_UPCASE, K_PRESERVE, K_INVERT, K_CAPITALIZE;
00135 pointer K_DISPOSE;
00136 
00137 /*class management*/
00138 struct class_desc  classtab[MAXCLASS];
00139 int nextcix;
00140 
00141 /*class cells*/
00142 pointer C_CONS, C_OBJECT, C_SYMBOL, C_PACKAGE;
00143 pointer C_STREAM, C_FILESTREAM, C_IOSTREAM, C_CODE, C_FCODE, C_LDMOD;
00144 pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_LABREF;
00145 pointer C_THREAD;
00146 pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
00147 pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
00148 pointer C_EXTNUM, C_RATIO, C_BIGNUM, C_COMPLEX;
00149 
00150 /*class names*/
00151 pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL, 
00152         CODE,FCODE, LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF;
00153 pointer THREAD;
00154 pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE;
00155 pointer FOREIGNCODE,ARRAY,BITVECTOR;
00156 pointer EXTNUM, RATIO, COMPLEX, BIGNUM;
00157 
00158 /*toplevel & evaluation control*/
00159 int intsig,intcode;
00160 int ehbypass;
00161 
00162 /*reader variables*/
00163 pointer charmacro[256];
00164 pointer sharpmacro[256];
00165 
00166 extern pointer defvector();
00167 static pointer reploop(context *, char *);
00168 
00169 pointer ALLOWOTHERKEYS,K_ALLOWOTHERKEYS;
00170 pointer OPTIONAL,REST,KEY,AUX,MACRO,LAMBDA,LAMCLOSURE,COMCLOSURE;
00171 pointer PRCIRCLE,PROBJECT,PRSTRUCTURE,PRCASE,PRLENGTH,PRLEVEL;
00172 pointer RANDSTATE,FEATURES,READBASE,PRINTBASE,QREADTABLE,QTERMIO;
00173 pointer GCMERGE,GCMARGIN, QLDENT;
00174 pointer K_PRIN1;
00175 pointer K_FUNCTION_DOCUMENTATION, K_VARIABLE_DOCUMENTATION,
00176         K_CLASS_DOCUMENTATION, K_METHOD_DOCUMENTATION, K_CLASS;
00177 pointer QLOADED_MODULES;
00178 pointer MAXCALLSTACKDEPTH;
00179 
00180 static pointer PROPOBJ,C_PROPOBJ;
00181 
00182 pointer eussigvec[NSIG];
00183 
00184 pointer sysmod;
00185 jmp_buf topjbuf;
00186 
00187 /****************************************************************/
00188 /* error handler
00189 */
00190 
00191 char *errmsg[100]={
00192         "",                             /*0*/
00193         "stack overflow",               /*1 errcode=1..10 are fatal errors*/
00194         "allocation",                   /*2*/
00195         "",                             /*3*/
00196         "",                             /*4*/
00197         "",                             /*5*/
00198         "",                             /*6*/
00199         "",                             /*7*/
00200         "",                             /*8*/
00201         "",                             /*9*/
00202         "",                             /*10    end of fatal error*/
00203         "attempt to set to constant",   /*11 E_SETCONST */
00204         "unbound variable",             /*12 E_UNBOUND  */
00205         "undefined function",           /*13 E_UNDEF    */
00206         "mismatch argument",            /*14 E_MISMATCHARG */
00207         "illegal function",             /*15 E_ILLFUNC */
00208         "illegal character",            /*16 E_ILLCH */
00209         "illegal delimiter",            /*17 E_READ */
00210         "write?",                       /*18 E_WRITE*/
00211         "too long string",              /*19 E_LONGSTRING */
00212         "symbol expected",
00213         "list expected",
00214         "illegal lambda form",
00215         "illegal lambda parameter syntax",
00216         "no catcher found",
00217         "no such block",
00218         "stream expected",
00219         "illegal stream direction keyword",
00220         "integer expected",
00221         "string expected",
00222         "error in open file",
00223         "EOF hit",
00224         "number expected",
00225         "class table overflow",
00226         "class expected",
00227         "vector expected",
00228         "array size must be positive",
00229         "duplicated object variable name",
00230         "cannot make instance",
00231         "array index out of range",             /*  E_ARRAYINDEX */
00232         "cannot find method",
00233         "circular list",
00234         "unknown sharp macro",
00235         "list expected for an element of an alist",
00236         "macro expected",
00237         "no such package",
00238         "package name",
00239         "invalid lisp object form",
00240         "no such object variable",
00241         "sequence expected",
00242         "illegal start/end index",
00243         "no super class",
00244         "invalid format string",
00245         "float vector expected",
00246         "char code out of range",
00247         "vector dimension mismatch",
00248         "object expected",
00249         "type mismatch",
00250         "declaration is not allowed here",
00251         "illegal declaration form",
00252         "cannot be used for a variable",
00253         "illegal rotation axis",
00254         "multiple variable declaration",
00255         "illegal #n= or #n= label",
00256         "illegal #f( expression",
00257         "illegal #v or #j expression", 
00258         "invalid socket address",
00259         "array expected",
00260         "array dimension mismatch",
00261         "keyword expected for arguments",
00262         "no such keyword",
00263         "integer vector expected",
00264         "sequence index out of range",
00265         "not a bit vector",
00266         "no such external symbol",
00267         "symbol conflict",
00268         "",
00269         "E_END",
00270         };
00271 
00272 static pointer brkloop();
00273 
00274 void unwind(ctx,p)
00275 register context *ctx;
00276 register pointer *p;
00277 { pointer cleanup;
00278   while (ctx->protfp>=(struct protectframe *)p) {       /*clean-up unwind-protect form*/
00279     cleanup=ctx->protfp->cleaner;
00280     ctx->protfp=ctx->protfp->protlink;
00281         /*first, update protfp to avoid endless 
00282           evaluation of cleanup form because of an error*/
00283     ufuncall(ctx,cleanup,cleanup,NULL,NULL,0);}
00284         /*an error may occur if catch, throw or return-from or access to
00285           special variables are taken in clean up forms*/
00286         /*unwind specially bound variables*/
00287   unbindspecial(ctx,(struct specialbindframe *)p);
00288   /*unwind block frames*/
00289   while (ctx->blkfp>(struct blockframe *)p) ctx->blkfp=ctx->blkfp->dynklink;
00290   /*unwind catch frames*/
00291   while (ctx->catchfp>(struct catchframe *)p) ctx->catchfp=ctx->catchfp->nextcatch;
00292   /*unwind flet frames*/
00293   while (ctx->fletfp>(struct fletframe *)p) ctx->fletfp=ctx->fletfp->dynlink;
00294   }
00295 
00296 #ifdef USE_STDARG
00297 pointer error(enum errorcode ec, ...)
00298 #else
00299 pointer error(va_alist)
00300 va_dcl
00301 #endif
00302 { 
00303   va_list args;
00304   pointer errhandler;
00305   register char *errstr;
00306   register int argc;
00307   register context *ctx;
00308   register struct callframe *vf;
00309   pointer msg;
00310   int i, n;
00311 
00312 #ifdef USE_STDARG
00313   va_start(args,ec);
00314 #else
00315   enum errorcode ec;
00316 
00317   va_start(args);
00318   ec = va_arg(args, enum errorcode);
00319 #endif
00320 
00321   ctx=euscontexts[thr_self()];
00322 
00323   /* print call stack */
00324   n=intval(Spevalof(MAXCALLSTACKDEPTH));
00325   if (n > 0) {
00326     fprintf( stderr, "Call Stack (max depth: %d):\n", n );
00327     vf=(struct callframe *)(ctx->callfp);
00328     for (i = 0; vf->vlink != NULL && i < n; ++i, vf = vf->vlink) {
00329       fprintf( stderr, "  %d: at ", i );
00330       prinx(ctx, vf->form, ERROUT);
00331       flushstream(ERROUT);
00332       fprintf( stderr, "\n" ); }
00333     if (vf->vlink != NULL) {
00334       fprintf (stderr, "  And more...\n"); }}
00335 
00336   /* error(errstr) must be error(E_USER,errstr) */
00337   if ((int)ec < E_END) errstr=errmsg[(int)ec];
00338   else {
00339       fprintf( stderr, "Internal warning: error: ec will be string.(%lx)\n",
00340               (long)ec );
00341       errstr=(char *)ec;
00342   }
00343 
00344   /*fatal error?  allocation failed or stack overflow? */
00345   if ((unsigned int)ec<=E_FATAL) {
00346     fprintf(stderr,"%s fatal error: th=%d %s\n",progname,thr_self(),errstr);
00347     if (speval(FATALERROR) != NIL) {
00348         fprintf(stderr, "exiting\n"); exit(ec);}
00349     else throw(ctx,makeint(0),NIL);}
00350 
00351   /* get extra message */
00352     switch((unsigned int)ec) {
00353       case E_UNBOUND: case E_UNDEF: case E_NOCLASS: case E_PKGNAME:
00354       case E_NOOBJ: case E_NOOBJVAR: case E_NOPACKAGE: case E_NOMETHOD:
00355       case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER:
00356       case E_NOVARIABLE: case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
00357       case E_USER:
00358         msg = va_arg(args,pointer);     break;
00359     }
00360 
00361   /* call user's error handler function */
00362   errhandler=ctx->errhandler;
00363   if (errhandler==NIL || errhandler==NULL)  errhandler=Spevalof(ERRHANDLER);
00364   Spevalof(QEVALHOOK)=NIL;      /* reset eval hook */
00365   if (errhandler!=NIL) {
00366     vpush(makeint((unsigned int)ec));
00367     vpush(makestring(errstr,strlen(errstr)));
00368     if (ctx->callfp) vpush(ctx->callfp->form); else vpush(NIL);
00369     switch((unsigned int)ec) {
00370       case E_UNBOUND: case E_UNDEF: case E_NOCLASS: case E_PKGNAME:
00371       case E_NOOBJ: case E_NOOBJVAR: case E_NOPACKAGE: case E_NOMETHOD:
00372       case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER:
00373       case E_NOVARIABLE: case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
00374         vpush(msg); argc=4; break;
00375       case E_USER:
00376         vpush(makestring((char*)msg,strlen((char*)msg))); argc=4; break;
00377     default: argc=3; break;}
00378     ufuncall(ctx,errhandler,errhandler,(pointer)(ctx->vsp-argc),ctx->bindfp,argc);
00379     ctx->vsp-=argc;
00380     }
00381 
00382   /*default error handler*/
00383   flushstream(ERROUT);
00384   fprintf(stderr,"%s: ERROR th=%d %s ",progname,thr_self(),errstr);
00385   switch((int)ec) {
00386       case E_UNBOUND: case E_UNDEF: case E_NOCLASS: case E_PKGNAME:
00387       case E_NOOBJ: case E_NOOBJVAR: case E_NOPACKAGE: case E_NOMETHOD:
00388       case E_NOKEYPARAM: case E_READLABEL: case E_ILLCH: case E_NOCATCHER:
00389       case E_NOVARIABLE: case E_EXTSYMBOL: case E_SYMBOLCONFLICT:
00390         prinx(ctx,msg,ERROUT); flushstream(ERROUT); break;
00391     }
00392   if( ec == E_USER ) {
00393       fprintf( stderr,"%p",msg ); flushstream(ERROUT); }
00394   else if (ispointer(msg)) {prinx(ctx,msg,ERROUT); flushstream(ERROUT); }
00395   if (ctx->callfp) {
00396     fprintf(stderr," in ");
00397     prinx(ctx,ctx->callfp->form,ERROUT);
00398     flushstream(ERROUT);}
00399   /*enter break loop*/
00400   brkloop(ctx,"E: ");
00401   throw(ctx,makeint(0),T);      /*throw to toplevel*/
00402   }
00403 
00404 #ifdef USE_STDARG
00405 pointer basicclass(char *name, ...)
00406 #else
00407 pointer basicclass(va_alist)
00408 va_dcl
00409 #endif
00410 {
00411   va_list ap;
00412   byte *vname;
00413   pointer super;
00414   cixpair *cixp;
00415   pointer classsym,class,varvector,superv,typevector,forwardvector;
00416   int n,i,svcount;
00417   context *ctx=mainctx;
00418 
00419 #ifdef USE_STDARG
00420   va_start(ap, name);
00421 #else
00422   char *name;
00423 
00424   va_start(ap);  
00425   name=va_arg(ap,byte *);
00426 #endif
00427   super=va_arg(ap,pointer);
00428   cixp=va_arg(ap,cixpair *); n=va_arg(ap,int);
00429   
00430   /*class name symbols are defined in lisp package*/
00431   classsym=intern(ctx,(char *)name,strlen(name),lisppkg);
00432   export(classsym,lisppkg);
00433   /* printf("name=%s NIL=%x super=%x\n",name,NIL,super); */
00434   if (super!=NIL) {
00435     superv= super->c.cls.vars;
00436     svcount=vecsize(superv);}
00437   else svcount=0;
00438   /* printf("name=%s super's_vcount=%d own_vcount=%d\n", name, svcount, n);*/
00439   varvector=makevector(C_VECTOR,svcount+n);  vpush(varvector);
00440   typevector=makevector(C_VECTOR,svcount+n);  vpush(typevector);
00441   forwardvector=makevector(C_VECTOR,svcount+n);  vpush(forwardvector);
00442   for (i=0; i<svcount; i++) {
00443     varvector->c.vec.v[i]=superv->c.vec.v[i];
00444     typevector->c.vec.v[i]=super->c.cls.types->c.vec.v[i];
00445     forwardvector->c.vec.v[i]=super->c.cls.forwards->c.vec.v[i];}
00446   for (i=0; i<n; i++) {
00447     vname=va_arg(ap,byte *);
00448     varvector->c.vec.v[i+svcount]=intern(ctx,(char *)vname,strlen((char *)vname),lisppkg);
00449     export(varvector->c.vec.v[i+svcount], lisppkg);  
00450     typevector->c.vec.v[i+svcount]=T;
00451     forwardvector->c.vec.v[i+svcount]=NIL;}
00452   class=makeclass(ctx,classsym,super,varvector,typevector,forwardvector,ELM_FIXED,0);
00453   builtinclass[nextbclass].cls=class;
00454   builtinclass[nextbclass].cp=cixp;
00455   nextbclass++;
00456   cixp->cix=intval(class->c.cls.cix);
00457   cixp->sub=classtab[cixp->cix].subcix;
00458   ctx->vsp-=3;
00459   va_end(ap);
00460   return(classsym);}
00461 
00462 
00463 /****************************************************************/
00464 /* initialization
00465 /****************************************************************/
00466 static void initmemory()
00467 { register int i;
00468   buddysize[0]=3; buddy[0].count=0; buddy[0].bp=0;
00469   buddysize[1]=3; buddy[1].count=0; buddy[1].bp=0;
00470   for (i=2; i<MAXBUDDY; i++) {
00471     buddy[i].count=0;
00472     buddysize[i]=buddysize[i-2]+buddysize[i-1]; /*fibonacci*/
00473     buddy[i].bp=0;}             /*no cells are connected*/
00474   buddy[MAXBUDDY].bp=(bpointer)(-1);    /*sentinel for alloc*/
00475 #if (WORD_SIZE == 64)
00476   buddysize[MAXBUDDY]= 0x7fffffffffffffff;      /*cell size limit*/
00477 #else
00478   buddysize[MAXBUDDY]= 0x7fffffff;      /*cell size limit*/
00479 #endif
00480 
00481   /*allocate enough memory for initialization*/
00482   newchunk(20);
00483   newchunk(18);
00484   gcstack=(pointer *)malloc(DEFAULT_MAX_GCSTACK * sizeof(pointer));
00485   gcsp=gcstack;
00486   gcsplimit= &gcstack[DEFAULT_MAX_GCSTACK -10];
00487   }
00488 
00489 #ifdef RGC
00490 void initmemory_rgc()
00491 { register int i;
00492   buddysize[0]=3; buddy[0].count=0; buddy[0].bp=0;
00493   buddysize[1]=3; buddy[1].count=0; buddy[1].bp=0;
00494   for (i=2; i<MAXBUDDY; i++) {
00495     buddy[i].count=0;
00496     buddysize[i]=buddysize[i-2]+buddysize[i-1]; /*fibonacci*/
00497     buddy[i].bp=0;}             /*no cells are connected*/
00498   buddy[MAXBUDDY].bp=(bpointer)(-1);    /*sentinel for alloc*/
00499 #if (WORD_SIZE == 64)
00500   buddysize[MAXBUDDY]= 0x7fffffffffffffff;      /*cell size limit*/
00501 #else
00502   buddysize[MAXBUDDY]= 0x7fffffff;      /*cell size limit*/
00503 #endif
00504 
00505   {
00506     unsigned int tmp;
00507     tmp = allocate_heap();
00508     fprintf(stderr, "allocate_heap: %d bytes\n", tmp*4);
00509   }
00510 
00511   gcstack=(pointer *)malloc(DEFAULT_MAX_GCSTACK * sizeof(pointer));
00512   gcsp=gcstack;
00513   gcsplimit= &gcstack[DEFAULT_MAX_GCSTACK -10];
00514 
00515 }
00516 #endif
00517 
00518 static void initclassid()
00519 { 
00520   /* built-in class id's*/
00521   nextcix=0;
00522   objectcp.cix=0; objectcp.sub=0;
00523   conscp.cix=1; conscp.sub=1;
00524   propobjcp.cix=2; propobjcp.sub=12;
00525     symbolcp.cix=3; symbolcp.sub=3;
00526     packagecp.cix=4; packagecp.sub=4;
00527     streamcp.cix=5; streamcp.sub=6;
00528       filestreamcp.cix=6; filestreamcp.sub=6;
00529     iostreamcp.cix=7; iostreamcp.sub=7;
00530     metaclasscp.cix=8; metaclasscp.sub=9;
00531       vecclasscp.cix=9; vecclasscp.sub=9;
00532     readtablecp.cix=10; readtablecp.sub=10;
00533     arraycp.cix=11; arraycp.sub=11;
00534     threadcp.cix=12; threadcp.sub=12;
00535 
00536   codecp.cix=13; codecp.sub=16;
00537     fcodecp.cix=14; fcodecp.sub=14;
00538     closurecp.cix=15; closurecp.sub=15;
00539     ldmodulecp.cix=16; ldmodulecp.sub=16;
00540 
00541   labrefcp.cix=17; labrefcp.sub=17;
00542 
00543   vectorcp.cix=18; vectorcp.sub=21;
00544   fltvectorcp.cix=19; fltvectorcp.sub=19;
00545   intvectorcp.cix=20; intvectorcp.sub=20;
00546   stringcp.cix=21; stringcp.sub=21;
00547 }
00548 
00549 static void initpackage()
00550 { register int i;
00551   register context *ctx=mainctx;
00552 
00553   /* GENESIS: First, VECTOR must exist!*/
00554   C_VECTOR=alloc(wordsizeof(struct vecclass),ELM_FIXED,vecclasscp.cix,
00555                  wordsizeof(struct vecclass));
00556   for (i=0; i<(wordsizeof(struct vecclass)); i++) C_VECTOR->c.obj.iv[i]=NULL;
00557   C_VECTOR->c.vcls.cix=makeint(vectorcp.cix);
00558   C_VECTOR->c.vcls.elmtype=makeint(ELM_POINTER);
00559 
00560   /*Then, NIL can be created*/
00561   lisppkg=makepkg(ctx,makestring("LISP",4),makeint(0),makeint(0));
00562   lisppkg->c.pkg.use=makeint(0);        /*prevent islist checking*/
00563   NIL=defconst(ctx,"NIL",NIL,lisppkg);
00564   NIL->c.sym.speval=NIL;
00565   NIL->c.sym.plist=NIL;
00566   sysobj=NIL;
00567   pkglist->c.cons.cdr=NIL;
00568   lisppkg->c.pkg.use=NIL;
00569   lisppkg->c.pkg.names->c.cons.cdr=NIL;
00570   lisppkg->c.pkg.plist=NIL;
00571   lisppkg->c.pkg.shadows=NIL;
00572   lisppkg->c.pkg.used_by=NIL;
00573   NIL->c.sym.homepkg=lisppkg;
00574 
00575   /*default packages*/
00576   keywordpkg=makepkg(ctx,makestring("KEYWORD",7),NIL,NIL);
00577   userpkg=   makepkg(ctx,makestring("USER",4),NIL,rawcons(ctx,lisppkg,NIL));
00578   syspkg=    makepkg(ctx,makestring("SYSTEM",6),NIL,rawcons(ctx,lisppkg,NIL));
00579   unixpkg=   makepkg(ctx,makestring("UNIX",4),NIL,rawcons(ctx,lisppkg,NIL));
00580   xpkg=      makepkg(ctx,makestring("X",1),NIL,rawcons(ctx,lisppkg,NIL));
00581   }
00582 
00583 static void initsymbols()
00584 { register int i;
00585   numunion nu;
00586   register context *ctx=mainctx;
00587 
00588   export_all=0;
00589 
00590   /* symbols */
00591   /* Be careful to define symbol pnames in upcase */
00592   T=defconst(ctx,"T",T,lisppkg);
00593   T->c.sym.speval=T;
00594   PACKAGE=deflocal(ctx,"*PACKAGE*",lisppkg,lisppkg);
00595   OPTIONAL=intern(ctx,"&OPTIONAL",9,lisppkg);
00596   REST=intern(ctx,"&REST",5,lisppkg);
00597   KEY=intern(ctx,"&KEY",4,lisppkg);
00598   AUX=intern(ctx,"&AUX",4,lisppkg);
00599   ALLOWOTHERKEYS=intern(ctx,"&ALLOW-OTHER-KEYS",17,lisppkg);
00600   LAMBDA=intern(ctx,"LAMBDA",6,lisppkg);
00601   MACRO=intern(ctx,"MACRO",5,lisppkg);
00602   FUNCTION=intern(ctx,"FUNCTION",8,lisppkg);
00603   LAMCLOSURE=intern(ctx,"LAMBDA-CLOSURE",14,lisppkg);
00604   COMCLOSURE=intern(ctx,"COMPILED-CLOSURE",16,lisppkg);
00605   QDECLARE=intern(ctx,"DECLARE",7,lisppkg);
00606   QSPECIAL=intern(ctx,"SPECIAL",7,lisppkg);
00607 #if SunOS4_1 /* SELF is already used on SunOS 4.1.x. */
00608   QSELF=intern(ctx,"SELF",4,lisppkg);
00609 #else
00610   SELF=intern(ctx,"SELF",4,lisppkg);
00611 #endif
00612   CLASS=intern(ctx,"CLASS",5,lisppkg);
00613   K_NOMETHOD=defkeyword(ctx,"NOMETHOD");
00614   K_IN=defkeyword(ctx,"INPUT");
00615   K_OUT=defkeyword(ctx,"OUTPUT");
00616   K_IO=defkeyword(ctx,"IO");
00617   K_FLUSH=defkeyword(ctx,"FLUSH");
00618   K_FILL=defkeyword(ctx,"FILL");
00619   K_FILE=defkeyword(ctx,"FILE"); 
00620   K_STRING=defkeyword(ctx,"STRING"); 
00621 /*  K_MSGQ=defkeyword(ctx,"MSGQ"); */
00622   K_DOWNCASE=defkeyword(ctx,"DOWNCASE");
00623   K_UPCASE=defkeyword(ctx,"UPCASE");
00624   K_PRESERVE=defkeyword(ctx,"PRESERVE");
00625   K_INVERT=defkeyword(ctx,"INVERT");
00626   K_CAPITALIZE=defkeyword(ctx,"CAPITALIZE");
00627   K_BIT=defkeyword(ctx,"BIT");
00628   K_CHAR=defkeyword(ctx,"CHAR");
00629   K_BYTE=defkeyword(ctx,"BYTE");
00630   K_SHORT=defkeyword(ctx,"SHORT");
00631   K_LONG=defkeyword(ctx,"LONG");
00632   K_INTEGER=defkeyword(ctx,"INTEGER");
00633   K_POINTER=defkeyword(ctx,"POINTER");
00634   K_FLOAT32=defkeyword(ctx,"FLOAT32");  
00635   K_FLOAT=defkeyword(ctx,"FLOAT");
00636   K_DOUBLE=defkeyword(ctx,"DOUBLE");
00637   K_FOREIGN=defkeyword(ctx,"FOREIGN");
00638   K_FOREIGN_STRING=defkeyword(ctx,"FOREIGN-STRING");
00639   K_ALLOWOTHERKEYS=defkeyword(ctx,"ALLOW-OTHER-KEYS");
00640   K_PRIN1=defkeyword(ctx,"PRIN1");
00641   K_CLASS=defkeyword(ctx,"CLASS");
00642   K_FUNCTION_DOCUMENTATION=defkeyword(ctx,"FUNCTION-DOCUMENTATION");
00643   K_CLASS_DOCUMENTATION=defkeyword(ctx,"CLASS-DOCUMENTATION");
00644   K_VARIABLE_DOCUMENTATION=defkeyword(ctx,"VARIABLE-DOCUMENTATION");
00645   K_METHOD_DOCUMENTATION=defkeyword(ctx,"METHOD-DOCUMENTATION");
00646   K_DISPOSE=defkeyword(ctx,"DISPOSE");
00647   QINTEGER=intern(ctx,"INTEGER",7,lisppkg);
00648   QFLOAT=intern(ctx,"FLOAT",5,lisppkg);
00649   QFIXNUM=intern(ctx,"FIXNUM",6,lisppkg);
00650   QNUMBER=intern(ctx,"NUMBER",6,lisppkg);
00651   QDEBUG=defvar(ctx,"*DEBUG*",NIL,lisppkg);
00652 /*  speval(QDEBUG)=NIL; */
00653   PRCASE=deflocal(ctx,"*PRINT-CASE*",K_DOWNCASE,lisppkg);
00654   PRCIRCLE=deflocal(ctx,"*PRINT-CIRCLE*",NIL,lisppkg);
00655   PROBJECT=deflocal(ctx,"*PRINT-OBJECT*",NIL,lisppkg);
00656   PRSTRUCTURE=deflocal(ctx,"*PRINT-STRUCTURE*",NIL,lisppkg);
00657   PRLENGTH=deflocal(ctx,"*PRINT-LENGTH*",NIL,lisppkg);
00658   PRLEVEL=deflocal(ctx,"*PRINT-LEVEL*",NIL,lisppkg);
00659   QREADTABLE=deflocal(ctx,"*READTABLE*",NIL,lisppkg);
00660   TOPLEVEL=defvar(ctx,"*TOPLEVEL*",NIL,lisppkg);
00661   ERRHANDLER=deflocal(ctx,"*ERROR-HANDLER*",NIL,lisppkg);
00662   QEVALHOOK=deflocal(ctx,"*EVALHOOK*",NIL,lisppkg);
00663   QUNBOUND=intern(ctx,"*UNBOUND*",9,lisppkg);
00664   RANDSTATE=deflocal(ctx,"*RANDOM-STATE*",UNBOUND,lisppkg);
00665   FEATURES=defvar(ctx,"*FEATURES*",NIL,lisppkg);
00666   READBASE=deflocal(ctx,"*READ-BASE*",makeint(10),lisppkg);
00667   PRINTBASE=deflocal(ctx,"*PRINT-BASE*",makeint(10),lisppkg);
00668   MAXCALLSTACKDEPTH=deflocal(ctx, "*MAX-CALLSTACK-DEPTH*",makeint(20),lisppkg);
00669   /*initialize i/o stream*/
00670   STDIN=mkfilestream(ctx,K_IN,makebuffer(128),0,NIL);
00671   QSTDIN=deflocal(ctx,"*STANDARD-INPUT*",STDIN,lisppkg);
00672   STDOUT=mkfilestream(ctx,K_OUT,makebuffer(256),1,NIL);
00673   QSTDOUT=deflocal(ctx,"*STANDARD-OUTPUT*",STDOUT,lisppkg);
00674   ERROUT=mkfilestream(ctx,K_OUT,makebuffer(128),2,NIL);
00675   QERROUT=deflocal(ctx,"*ERROR-OUTPUT*",ERROUT,lisppkg);
00676   QTERMIO=deflocal(ctx,"*TERMINAL-IO*",NIL,lisppkg);
00677   GCMERGE=defvar(ctx,"*GC-MERGE*",makeflt(0.2),syspkg);
00678   GCMARGIN=defvar(ctx,"*GC-MARGIN*",makeflt(0.4),syspkg);
00679   QLDENT=defvar(ctx,"*LOAD-ENTRIES*", NIL, syspkg);
00680   QTHREADS=defvar(ctx, "*THREADS*", NIL, syspkg);
00681   QPARAGC=defvar(ctx, "*PARALLEL-GC*", NIL, syspkg);
00682   QGCHOOK=defvar(ctx,"*GC-HOOK*",NIL,syspkg);
00683   QEXITHOOK=defvar(ctx,"*EXIT-HOOK*",NIL,syspkg);
00684   FATALERROR=defvar(ctx,"*EXIT-ON-FATAL-ERROR*",NIL,lisppkg);
00685 
00686   /*init character macro table*/
00687   for (i=0; i<256; i++) charmacro[i]=sharpmacro[i]=NIL;
00688 
00689   /*init signal vector*/
00690   for (i=0; i<NSIG; i++) eussigvec[i]=NIL;
00691 }
00692 
00693 static void initclasses()
00694 { extern pointer oblabels[MAXTHREAD];   /*eusio.c*/
00695   register context *ctx=mainctx;
00696   int i;
00697 
00698   /* basic classes */
00699 /*0*/
00700   OBJECT=basicclass("OBJECT",NIL,&objectcp,0);
00701   C_OBJECT=speval(OBJECT);
00702 /*1*/
00703   QCONS=basicclass("CONS",C_OBJECT,&conscp,2,"CAR","CDR");
00704   C_CONS=speval(QCONS);
00705 /*2*/
00706   PROPOBJ=basicclass("PROPERTIED-OBJECT",C_OBJECT, &propobjcp,1,"PLIST");
00707   C_PROPOBJ=speval(PROPOBJ);
00708 /*3*/
00709   SYMBOL=basicclass("SYMBOL",C_PROPOBJ,&symbolcp,5,
00710                     "VALUE","VTYPE","FUNCTION","PNAME","HOMEPKG");
00711   C_SYMBOL=speval(SYMBOL);
00712 /*4*/
00713   PKGCLASS=basicclass("PACKAGE",C_PROPOBJ,&packagecp,
00714                       8,"NAMES","USE","SYMVECTOR","SYMCOUNT",
00715                         "INTSYMVECTOR", "INTSYMCOUNT", "SHADOWS", "USED-BY");
00716   C_PACKAGE=speval(PKGCLASS);
00717 /*5*/
00718   STREAM=basicclass("STREAM",C_PROPOBJ,&streamcp,
00719                     4,"DIRECTION","BUFFER","COUNT","TAIL");
00720   C_STREAM=speval(STREAM);
00721 /*6*/
00722   FILESTREAM=basicclass("FILE-STREAM",C_STREAM,&filestreamcp,2,"FD","FNAME");
00723   C_FILESTREAM=speval(FILESTREAM);
00724 /*7*/
00725   IOSTREAM=basicclass("IO-STREAM",C_PROPOBJ,&iostreamcp,2,"INSTREAM","OUTSTREAM");
00726   C_IOSTREAM=speval(IOSTREAM);
00727 /*8*/
00728   METACLASS=basicclass("METACLASS",C_PROPOBJ,&metaclasscp,
00729                         7,"NAME","SUPER","CIX","VARS","TYPES","FORWARDS","METHODS");
00730   C_METACLASS=speval(METACLASS);
00731 /*9*/
00732   VECCLASS=basicclass("VECTORCLASS",C_METACLASS,&vecclasscp,
00733                       2,"ELEMENT-TYPE","SIZE");
00734   C_VCLASS=speval(VECCLASS);
00735 /*10*/
00736   READTABLE=basicclass("READTABLE",C_PROPOBJ,&readtablecp,
00737                        4,"SYNTAX","MACRO","DISPATCH-MACRO","CASE");
00738   C_READTABLE=speval(READTABLE);
00739 /*11*/
00740   ARRAY=basicclass("ARRAY",C_PROPOBJ,&arraycp,
00741                      11,"ENTITY","RANK","FILL-POINTER","DISPLACED-INDEX-OFFSET",
00742                         "DIM0","DIM1","DIM2","DIM3","DIM4","DIM5","DIM6");
00743   C_ARRAY=speval(ARRAY);
00744 /*12 */
00745   THREAD=basicclass("THREAD", C_PROPOBJ, &threadcp,
00746                         10, "ID", "REQUESTER", "REQUEST-SEM", "DONE-SEM",
00747                            "FUNC", "ARGS", "RESULT", "CONTEXT",
00748                            "IDLE", "WAIT");
00749   C_THREAD=speval(THREAD);
00750 /*13*/
00751   CODE=basicclass("COMPILED-CODE",C_OBJECT,&codecp,4,"CODEVECTOR","QUOTEVECTOR",
00752                   "TYPE","ENTRY");
00753   C_CODE=speval(CODE);
00754 /*14*/
00755   FCODE=basicclass("FOREIGN-CODE",C_CODE,&fcodecp,3,"ENTRY2","PARAMTYPES","RESULTTYPE"); /* kanehiro's patch 2000.12.13 */
00756   C_FCODE=speval(FCODE);
00757 /*15*/
00758 #if (WORD_SIZE == 64)
00759   CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp,3,"ENV0","ENV1","ENV2");
00760 #else
00761   CLOSURE=basicclass("CLOSURE",C_CODE,&closurecp,2,"ENV1","ENV2");
00762 #endif
00763   C_CLOSURE=speval(CLOSURE);
00764 /* 16    ---new for Solaris */
00765   LDMODULE=basicclass("LOAD-MODULE",C_CODE, &ldmodulecp, 3,
00766                         "SYMBOL-TABLE","OBJECT-FILE", "HANDLE");
00767   C_LDMOD=speval(LDMODULE);
00768 /*17*/
00769   LABREF=basicclass("LABEL-REFERENCE",C_OBJECT,&labrefcp,4,
00770                     "LABEL","VALUE","UNSOLVED","NEXT");
00771   C_LABREF=speval(LABREF);
00772 /*18*/
00773   VECTOR=defvector(ctx,"VECTOR",C_OBJECT,ELM_POINTER, 0);   /* alpha */
00774   C_VECTOR=speval(VECTOR);
00775   builtinclass[nextbclass].cls=C_VECTOR;
00776   builtinclass[nextbclass++].cp= &vectorcp;
00777 
00778   FLTVECTOR=defvector(ctx,"FLOAT-VECTOR",C_VECTOR,ELM_FLOAT, 0); /* alpha */
00779   C_FLTVECTOR=speval(FLTVECTOR);
00780   builtinclass[nextbclass].cls=C_FLTVECTOR;
00781   builtinclass[nextbclass++].cp= &fltvectorcp;
00782 
00783   INTVECTOR=defvector(ctx,"INTEGER-VECTOR",C_VECTOR,ELM_INT, 0); /* alpha */
00784   C_INTVECTOR=speval(INTVECTOR);
00785   builtinclass[nextbclass].cls=C_INTVECTOR;
00786   builtinclass[nextbclass++].cp= &intvectorcp;
00787 
00788   STRING=defvector(ctx,"STRING",C_VECTOR,ELM_CHAR, 0); /* alpha */
00789   C_STRING=speval(STRING);
00790   builtinclass[nextbclass].cls=C_STRING;
00791   builtinclass[nextbclass++].cp= &stringcp;
00792 
00793   BITVECTOR=defvector(ctx,"BIT-VECTOR",C_VECTOR,ELM_BIT, 0); /* alpha */
00794   C_BITVECTOR=speval(BITVECTOR);
00795   builtinclass[nextbclass].cls=C_BITVECTOR;
00796   builtinclass[nextbclass++].cp= &bitvectorcp;
00797 
00798 /* extended numbers */
00799   EXTNUM=basicclass("EXTENDED-NUMBER",C_OBJECT,&extnumcp,0);
00800   C_EXTNUM=speval(EXTNUM);
00801   RATIO=basicclass("RATIO",C_EXTNUM, &ratiocp,2,"NUMERATOR","DENOMINATOR");
00802   C_RATIO=speval(RATIO);
00803   COMPLEX=basicclass("COMPLEX", C_EXTNUM, &complexcp, 2, "REAL", "IMAGINARY");
00804   C_COMPLEX=speval(COMPLEX);
00805   BIGNUM=basicclass("BIGNUM", C_EXTNUM, &bignumcp, 2, "SIZE", "BV");
00806   C_BIGNUM=speval(BIGNUM);
00807 
00808   for (i=0;i<MAXTHREAD;i++) {
00809     oblabels[i]=(pointer)makelabref(makeint(-1),UNBOUND,NIL);
00810     sysobj=cons(ctx,oblabels[i],sysobj);
00811   }
00812 }
00813 
00814 static void initfeatures()
00815 { register pointer p;
00816   register context *ctx=mainctx;
00817   extern char *makedate;
00818   extern char *gitrevision;
00819   extern char *compilehost;
00820 
00821   p=makestring(VERSION,strlen(VERSION));
00822   vpush(p);
00823   p=makestring(compilehost,strlen(compilehost));
00824   vpush(p);
00825   p=makestring(makedate,strlen(makedate));
00826   vpush(p);
00827   p=makestring(gitrevision,strlen(gitrevision));
00828   vpush(p);
00829   p=stacknlist(ctx,4);
00830   QVERSION=defvar(ctx, "LISP-IMPLEMENTATION-VERSION", p,lisppkg);
00831 
00832   /*make features*/
00833 
00834   p=NIL;
00835 #if vax
00836   p=cons(ctx,intern(ctx,"VAX",3,keywordpkg),p);
00837 #endif
00838 #if sun
00839   p=cons(ctx,intern(ctx,"SUN",3,keywordpkg),p);
00840 #endif
00841 #if apollo
00842   p=cons(ctx,intern(ctx,"APOLLO",6,keywordpkg),p);
00843 #endif
00844 #if mips
00845   p=cons(ctx,intern(ctx,"MIPS",4,keywordpkg),p);
00846 #endif
00847 #if sun3
00848   p=cons(ctx,intern(ctx,"SUN3",4,keywordpkg),p);
00849 #endif
00850 #if sun4
00851   p=cons(ctx,intern(ctx,"SUN4",4,keywordpkg),p);
00852 #endif
00853 #if news
00854   p=cons(ctx,intern(ctx,"NEWS",4,keywordpkg),p);
00855 #endif
00856 #if sanyo
00857   p=cons(ctx,intern(ctx,"SANYO",5,keywordpkg),p);
00858 #endif
00859 #if bsd4_2
00860   p=cons(ctx,intern(ctx,"BSD4_2",6,keywordpkg),p);
00861 #endif
00862 #if SunOS4
00863   p=cons(ctx,intern(ctx,"SUNOS4",6,keywordpkg),p);
00864 #endif
00865 #if SunOS4_1
00866   p=cons(ctx,intern(ctx,"SUNOS4.1",8,keywordpkg),p);
00867 #endif
00868 #if system5
00869   p=cons(ctx,intern(ctx,"SYSTEM5",7,keywordpkg),p);
00870 #endif
00871 #if coff
00872   p=cons(ctx,intern(ctx,"COFF",4,keywordpkg),p);
00873 #endif
00874 #if Solaris2
00875   p=cons(ctx,intern(ctx,"SOLARIS2",8,keywordpkg),p);
00876 #endif
00877 #if GCC
00878   p=cons(ctx,intern(ctx,"GCC",3,keywordpkg),p);
00879 #endif
00880 #if GCC3
00881   p=cons(ctx,intern(ctx,"GCC3",4,keywordpkg),p);
00882 #endif
00883 #if i386
00884   p=cons(ctx,intern(ctx,"I386",4,keywordpkg),p);
00885 #endif
00886 #if Linux
00887   p=cons(ctx,intern(ctx,"LINUX",5,keywordpkg),p);
00888 #endif
00889 #if Linux_ppc
00890   p=cons(ctx,intern(ctx,"PPC",3,keywordpkg),p);
00891 #endif
00892 #if USE_MULTI_LIB
00893   p=cons(ctx,intern(ctx,"IA32",4,keywordpkg),p);
00894 #endif
00895 #if ELF
00896   p=cons(ctx,intern(ctx,"ELF",3,keywordpkg),p);
00897 #endif
00898 #if IRIX
00899   p=cons(ctx,intern(ctx,"IRIX",4,keywordpkg),p);
00900 #endif
00901 #if IRIX6
00902   p=cons(ctx,intern(ctx,"IRIX6",5,keywordpkg),p);
00903 #endif
00904 #if alpha
00905   p=cons(ctx,intern(ctx,"ALPHA",5,keywordpkg),p);
00906 #endif
00907 #if Cygwin
00908   p=cons(ctx,intern(ctx,"CYGWIN",6,keywordpkg),p);
00909 #endif
00910 #if Darwin
00911   p=cons(ctx,intern(ctx,"DARWIN",6,keywordpkg),p);
00912 #endif
00913 #if THREADED
00914   p=cons(ctx,intern(ctx,"THREAD",6,keywordpkg),p);
00915 #endif
00916 #if PTHREAD
00917   p=cons(ctx,intern(ctx,"PTHREAD",7,keywordpkg),p);
00918 #endif
00919 #if X_V11R6_1
00920   p=cons(ctx,intern(ctx,"X11R6.1",7,keywordpkg),p);
00921 #endif
00922 #if RGC
00923   p=cons(ctx,intern(ctx,"RGC",3,keywordpkg),p);
00924 #endif
00925 #if SH4
00926   p=cons(ctx,intern(ctx,"SH4",3,keywordpkg),p);
00927 #endif
00928 #if x86_64
00929   p=cons(ctx,intern(ctx,"X86_64",6,keywordpkg),p);
00930 #endif
00931 #if ARM
00932   p=cons(ctx,intern(ctx,"ARM",3,keywordpkg),p);
00933 #endif
00934 #if aarch64
00935   p=cons(ctx,intern(ctx,"AARCH64",7,keywordpkg),p);
00936 #endif
00937 
00938   defvar(ctx,"*FEATURES*",p,lisppkg);
00939 
00940   /*system function module*/
00941   sysmod=makemodule(ctx,0);
00942   sysmod->c.ldmod.codevec=makeint(0);
00943   sysmod->c.ldmod.handle=makeint((eusinteger_t)dlopen(0, RTLD_LAZY)>>2);
00944   sysobj=cons(ctx,sysmod, sysobj);
00945   }
00946 
00947 /****************************************************************/
00948 /* signal handlers
00949 /****************************************************************/
00950 
00951 extern long gcing;
00952 #include <sys/wait.h>
00953 
00954 void eusint(s,code,x,addr)
00955 register int s;
00956 int code,x;
00957 eusinteger_t addr;
00958 { int stat;
00959   context *ctx;
00960 
00961   ctx = euscontexts[thr_self()];
00962   if (debug) {
00963     fprintf(stderr, ";; eusint: sig=%d, %d; thr=%d ctx=%p\n",
00964                 s,code,thr_self(), ctx);}
00965   if (ctx==NULL) ctx=mainctx;
00966   ctx->intsig=s;
00967   intcode=code;
00968   switch(s) {
00969   case SIGCHLD:
00970     wait(&stat);
00971     if (debug)
00972       fprintf(stderr,";; child proc terminated; wait=0x%x\n",stat);
00973     ctx->intsig=0;
00974     break;
00975   case SIGFPE:
00976     fprintf(stderr,";; floating exception\n");
00977     goto sigfatal;
00978     break;
00979   case SIGPIPE:
00980     fprintf(stderr,";; pipe broken %d %x %lx\n",code,x,(unsigned long)addr);
00981     throw(mainctx,makeint(0),NIL);      /*nonsense*/
00982     break;
00983   case SIGSEGV:
00984     fprintf(stderr,";; Segmentation Fault.\n");
00985     goto sigfatal;
00986   case SIGBUS:
00987     fprintf(stderr,";; Bus Error.\n");
00988 
00989     sigfatal:
00990 
00991     if (speval(FATALERROR) != NIL) exit(s);
00992     if (ctx->callfp) {
00993       fprintf(stderr,";; in ");
00994       prinx(ctx,ctx->callfp->form,ERROUT);
00995       flushstream(ERROUT);
00996       fprintf(stderr,"\n");}
00997     fprintf(stderr,";; You are still in a signal handler.\n;;Try reset or throw to upper level as soon as possible.\n");
00998     fprintf(stderr,";; code=%d x=%x addr=%lx\n",code,x,(unsigned long)addr);
00999     reploop(mainctx, "Fatal: ");
01000     fprintf(stderr,";; No, you cannot continue the previous evaluation.\n");
01001     /* goto sigfatal; */
01002     exit(s);
01003     break;
01004   }
01005 
01006 #if Solaris2 || system5
01007   signal(s,(void (*)())eusint); /*reinstall signal*/
01008 #endif
01009 
01010 #if THREADED
01011     if (isintvector(eussigvec[s])) {
01012 /*      if (s==SIGALRM && gcing) {intsig=0; return;} */
01013         /*ignore Alarm clock during gc*/
01014       sema_post((sema_t *)eussigvec[s]->c.ivec.iv);
01015       ctx->intsig=0;}
01016 #endif
01017   if (debug) { fprintf(stderr, ";; eusint exit: intsig=%d\n",ctx->intsig);}
01018 }
01019 
01020 static pointer brkloop(ctx, prompt)
01021 context *ctx;
01022 char *prompt;
01023 { jmp_buf brkjmp;
01024   pointer val;
01025   int i;
01026   mkcatchframe(ctx,T,&brkjmp);
01027   Spevalof(QSTDOUT)=STDOUT;
01028   Spevalof(QSTDIN)=STDIN;
01029   Spevalof(QERROUT)=ERROUT;
01030   if ((val=(pointer)eussetjmp(brkjmp))==0) val=reploop(ctx,prompt);
01031   else if ((eusinteger_t)val==1) val=makeint(0);        /*longjmp cannot return 0*/
01032   ctx->callfp=ctx->catchfp->cf;
01033   ctx->bindfp=ctx->catchfp->bf;
01034   ctx->vsp=(pointer *)ctx->catchfp;
01035   ctx->catchfp=(struct catchframe *)*(ctx->vsp);
01036   return(val);}
01037 
01038 void sigbreak()
01039 { pointer sighandler,*vspsave;
01040   context *ctx=euscontexts[thr_self()];
01041   int is;
01042 
01043   is=ctx->intsig;
01044   if (debug) printf("sigbreak: intsig=%d thr_self=%d\n", is, thr_self());
01045   sighandler=eussigvec[is];
01046   if (isintvector(sighandler)) return;
01047   vspsave=ctx->vsp;
01048   ctx->intsig=0;
01049   QEVALHOOK->c.sym.speval=NIL;
01050   if (sighandler!=NIL) {
01051     vpush(makeint(is)); vpush(makeint(intcode));
01052     ufuncall(ctx,sighandler,sighandler,(pointer)(ctx->vsp-2),ctx->bindfp,2);
01053     ctx->vsp=vspsave;  }
01054   else {
01055     fprintf(stderr,"signal=%d to thread %d, \n",is, thr_self());
01056     /*    brkloop(ctx,"B: "); */
01057     return; }}
01058   
01059 
01060 /****************************************************************/
01061 /* main and toplevel
01062 /****************************************************************/
01063 static pointer reploop(ctx,prompt)
01064 register context *ctx;
01065 char *prompt;
01066 { pointer p,q;
01067   int ttyp;
01068   ehbypass=0;
01069   ttyp=isatty(intval(STDIN->c.fstream.fd));
01070   do {
01071     if (ttyp) {
01072       p=Spevalof(PACKAGE);
01073       if (p!=userpkg) { /*print pkg name*/
01074         printf("%s:",ccar(p->c.pkg.names)->c.str.chars);}
01075       printf("%s",prompt);
01076       fflush(stdout);}
01077     p=reader(ctx,STDIN,NIL);
01078     if (p==(pointer)EOF) return(NIL);
01079     breakck;
01080     q=eval(ctx,p);
01081     if (q!=UNBOUND) { prinx(ctx,q,STDOUT); terpri(STDOUT);}}
01082   while (1);}
01083 
01084 static void toplevel(ctx,argc,argv)
01085 register context *ctx;
01086 int argc;
01087 char *argv[];
01088 { pointer argvp,topform;
01089   int i,j;
01090 
01091   /* reset stack pointer and frame pointers*/
01092   j=(int)eussetjmp(topjbuf);  
01093   ctx->vsp=ctx->stack;
01094   ctx->bindfp=NULL;
01095   ctx->sbindfp=NULL;
01096   ctx->callfp=NULL;
01097   ctx->blkfp=NULL;
01098   ctx->protfp=NULL;
01099   ctx->catchfp=NULL;
01100   ctx->fletfp=NULL;
01101   topform=speval(TOPLEVEL);
01102   if (topform!=NIL) {
01103     if (j==0) {
01104       for (i=0; i<argc; i++) vpush(makestring(argv[i],strlen(argv[i])));
01105       ufuncall(ctx,topform,topform,(pointer)(ctx->vsp-argc),0,argc);}
01106     else ufuncall(ctx,topform,topform,(pointer)(ctx->vsp),0,0);}
01107   else { /*TOPLEVEL not yet defined-- try built-in toplevel*/
01108     mkcatchframe(ctx,makeint(0),&topjbuf);
01109     fprintf(stderr, "entering reploop\n");
01110     reploop(ctx,": ");}
01111   }
01112 
01113 /* load initial configuration file from EUSDIR/eusrt0.l */
01114 static void configure_eus(ctx)
01115 register context *ctx;
01116 { pointer argv, p, in;
01117   int i,j;
01118   char *eusdir, *eusrt;
01119   char fname[1024];
01120   extern pointer SRCLOAD();
01121 
01122   /* reset stack pointer and frame pointers*/
01123   j=(int)eussetjmp(topjbuf);  
01124   eusdir=(char *)getenv("EUSDIR");
01125   if (eusdir==NULL) { 
01126     fprintf(stderr, "EUSDIR is not setenved, assuming /usr/local/eus\n");
01127     eusdir= "/usr/local/eus/"; }
01128   sprintf(fname,"%s/lib/eus.init.l", eusdir);
01129 
01130 #if !Solaris2 || GCC
01131   /* read the init-module list from "EUSDIR/lib/eus.init.l" */
01132   in=(pointer)openfile(ctx,fname,O_RDONLY,0,256);
01133   if (in==NULL) {
01134     fprintf(stderr,
01135          "$EUSDIR/lib/eus.init.l was not found\nfailed to initialize.\n"
01136          "Entering raweus.\n"
01137          "To exit, type (unix::exit)\n");
01138     return;}
01139   vpush(in);
01140   p=reader(ctx,in,NIL);
01141   vpop();
01142   closestream(in);
01143   /* prinx(ctx,p,STDOUT);  */
01144 #endif
01145 
01146   vpush(p);
01147   /*  prinx(ctx,p,STDOUT); terpri(STDOUT); */
01148   p=(pointer)list_module_initializers(ctx,p);
01149   vpop();
01150   speval(QLDENT)=p;
01151 
01152   eusrt=(char *)getenv("EUSRT");
01153   if (eusrt==NULL)  sprintf(fname,"%s/lib/eusrt.l", eusdir);
01154   else strcpy(fname, eusrt);
01155   if (isatty(0)!=0) {
01156     fprintf(stderr, "configuring by \"%s\"\n", fname); }
01157   mkcatchframe(ctx,makeint(0),&topjbuf);
01158   argv=makestring(fname, strlen(fname));
01159   vpush(argv);
01160   eusstart(ctx);
01161   SRCLOAD(ctx, 1, ctx->vsp-1);
01162   }
01163 
01164 
01165 int mainargc;
01166 char *mainargv[32];
01167 
01168 
01169 void mainthread(ctx)
01170 register context *ctx;
01171 { 
01172   euscontexts[thr_self()]=ctx;
01173 
01174   /*initialize system*/
01175 #ifndef RGC
01176   initmemory();
01177 #endif
01178   initclassid();
01179 
01180   {
01181     int i;
01182     pointer specialtab;
01183     specialtab=alloc(MAX_SPECIALS+1,ELM_POINTER,vectorcp.cix,MAX_SPECIALS+1);
01184     specialtab->c.vec.size=makeint(MAX_SPECIALS);
01185     for (i=0; i<MAX_SPECIALS; i++)     specialtab->c.vec.v[i]=NIL;
01186     ctx->specials=specialtab;    }
01187 
01188   initpackage();
01189   initsymbols();
01190   initclasses();
01191   initfeatures();
01192 
01193   ctx->threadobj=NIL;
01194 
01195 
01196   /* define built-in functions */
01197   lists(ctx,sysmod);    /*list functions and predicates*/
01198   predicates(ctx,sysmod); /*predicates*/
01199   sequence(ctx,sysmod); /*sequence functions*/
01200   specials(ctx,sysmod); /*control forms, special forms*/
01201   lispio(ctx,sysmod);   /*lisp i/o*/
01202   loadsave(ctx,sysmod); /*loader and saver*/
01203   leo(ctx,sysmod);      /*object oriented programming*/
01204   arith(ctx,sysmod);    /*arithmetic functions*/
01205   matrix(ctx,sysmod);   /*floatvector, matrix operation*/
01206   unixcall(ctx,sysmod); /*unix system binding*/
01207   foreign(ctx,sysmod);  /*foreign function interface*/
01208   vectorarray(ctx,sysmod);      /*vector and array functions*/
01209   charstring(ctx,sysmod);
01210 #if THREADED
01211   mthread(ctx,sysmod);
01212 #if Solaris2
01213   mainport=makethreadport(mainctx);
01214   speval(QTHREADS)=cons(ctx, mainport, speval(QTHREADS));
01215   mainport->c.thrp.id=makeint((int)maintid);
01216 #endif
01217 #endif
01218 
01219   initreader(ctx);
01220   sysfunc(ctx,sysmod);
01221 #ifdef RGC
01222   rgcfunc(ctx,sysmod);
01223 #endif
01224   eusioctl(ctx,sysmod);
01225   Spevalof(PACKAGE)=userpkg; 
01226 
01227   defvar(ctx,"*PROGRAM-NAME*",makestring(progname,strlen(progname)),lisppkg);
01228 
01229   /* exec_module_initializers(); */
01230   ctx->vsp=ctx->stack;
01231   configure_eus(ctx); 
01232 
01233   signal(SIGCHLD, (void (*)())eusint);
01234   signal(SIGFPE,  (void (*)())eusint);
01235   signal(SIGPIPE, (void (*)())eusint);
01236 #ifdef RGC
01237 //  signal(SIGSEGV, (void (*)())eusint); /* for debugging. R.Hanai */
01238 #else
01239   signal(SIGSEGV, (void (*)())eusint);
01240 #endif
01241   signal(SIGBUS,  (void (*)())eusint);
01242 
01243   toplevel(ctx,mainargc,mainargv);
01244 
01245   { pointer exithook=speval(QEXITHOOK);
01246     if (exithook != NIL) {
01247       ufuncall(ctx,exithook,exithook,(pointer)(ctx->vsp),0,0);}
01248     }
01249 
01250 #if THREADED
01251 #if SunOS4_1
01252   thr_exit(0);
01253 #else
01254   exit(0);
01255 #endif
01256 #endif
01257   }
01258 
01259 int main(argc,argv)
01260 int argc;
01261 char *argv[];
01262 { int i, stat=0;
01263   unsigned char *m;
01264 
01265 #ifdef Darwin
01266   _end = sbrk(0);
01267 #endif
01268 
01269   mypid=getpid();
01270   mainargc=argc;
01271   for (i=0; i<argc; i++) mainargv[i]=argv[i];
01272 
01273   tzset();
01274 
01275 #if Linux && !OLD_LINUX && !Darwin
01276   mallopt(M_MMAP_MAX,0);
01277 #endif
01278 
01279   /* following two lines are just to speed up frequent sbreak at the beginning
01280      of the execution. These lines may be deleted without any harm.*/
01281   m=(unsigned char *)malloc(4*1024*1024);
01282   cfree(m);
01283 
01284 #if vxworks
01285   progname=taskName(mypid);
01286 #else
01287   progname=argv[0];
01288 #endif
01289   /* get stack area and initialize stack/frame pointers */
01290   for (i=0; i<MAXTHREAD; i++) euscontexts[i]=0;
01291   mainctx=(context *)makelispcontext(MAXSTACK);
01292 #if THREADED
01293 #if Solaris2
01294   mutex_init(&mark_lock, USYNC_THREAD, 0);
01295   mutex_init(&p_mark_lock, USYNC_THREAD, 0);
01296   thr_create(0, 2*1024*1024,mainthread, mainctx, 0, &maintid);
01297   { sigset_t mainsig, omainsig;
01298     sigemptyset(&mainsig);
01299     sigaddset(&mainsig, SIGINT);
01300     /* printf("mainthread=%d\n", thr_self()); */         
01301     thr_sigsetmask(SIG_BLOCK, &mainsig, &omainsig);
01302     }
01303   thr_join(maintid, 0, (void *)&stat);
01304 #else
01305 #if SunOS4_1 || alpha || PTHREAD
01306   mthread_init( mainctx );
01307 #ifdef RGC
01308   init_rgc();
01309 #endif
01310 #endif
01311   mainthread(mainctx);
01312 #endif  /* Solaris2 */
01313 #else
01314   mainthread(mainctx);
01315 #endif
01316   
01317   { pointer exithook=speval(QEXITHOOK);
01318     if (exithook != NIL) {
01319       ufuncall(mainctx,exithook,exithook,(pointer)(mainctx->vsp),0,0);}
01320     }
01321 
01322   exit(stat);
01323   }
01324 
01325 #if (WORD_SIZE == 64)
01326 pointer makeint(eusinteger_t v) {
01327   if (v>(eusinteger_t)MAXPOSFIXNUM || v<(eusinteger_t)MINNEGFIXNUM) {
01328     if (v&0x7L) {
01329       return(mkbigint(v));
01330     }
01331     return ((pointer)(v|0x3L)); }
01332   else return((pointer)((v<<2)+2));
01333 }
01334 eusinteger_t intval(pointer p) {
01335   eusinteger_t i=(eusinteger_t)p;
01336   if (p==NULL) {
01337     fprintf(stderr,"p=null\n");
01338     raise(SIGSEGV);
01339     return 0;}
01340   else if ((i&0x3L)==0x3L) {
01341     return (i&~0x3L); }
01342   else if (isbignum(p)) {
01343     return (bigintval(p)); }
01344   else if ((i&0x7)==0x0L) {
01345     fprintf(stderr,";p=pointer?(%p)\n", p);
01346     return (i); }
01347   else return (((eusinteger_t)i)>>2);
01348 }
01349 #else
01350 pointer makeint(eusinteger_t v) {
01351   if (v>(int)MAXPOSFIXNUM || v<(int)MINNEGFIXNUM) {
01352     //    fprintf(stderr, "makeint(%x)\n", v);
01353     if (v&0x3) {
01354       //      fprintf(stderr, "v=%x(bignum)\n", v);
01355       return(mkbigint(v));
01356     }
01357     return ((pointer)(v|0x3)); }
01358   else return((pointer)((v<<2)+2));
01359 }
01360 eusinteger_t intval(pointer p) {
01361   eusinteger_t i=(eusinteger_t)p;
01362   if (p==NULL) {
01363     fprintf(stderr,"p=null\n");
01364     return 0;}
01365   else if ((i&0x3)==0x3) {
01366     return (i&~0x3); }
01367   else if (isbignum(p)) {
01368     return (bigintval(p)); }
01369   else if ((i&0x3)==0x0) {
01370     fprintf(stderr,";p=pointer?(%p)\n", p);
01371     return (i); }
01372   else return (((eusinteger_t)i)>>2);
01373 }
01374 #endif
01375 
01376 eusinteger_t hide_ptr (pointer p) { return (eusinteger_t)p; }


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