00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012 #if (alpha || IRIX6 || x86_64)
00013 #define WORD_SIZE 64
00014 #else
00015 #define WORD_SIZE 32
00016 #endif
00017
00018 #if (WORD_SIZE == 64)
00019 typedef long eusinteger_t;
00020 typedef double eusfloat_t;
00021 #define WORDSHIFT 3
00022 #else
00023 typedef int eusinteger_t;
00024 typedef float eusfloat_t;
00025 #define WORDSHIFT 2
00026 #endif
00027 #define wordsizeof(type) (sizeof(type)>>WORDSHIFT)
00028
00029 #if GCC || Solaris2 || IRIX || Linux || IRIX6
00030 #define USE_STDARG
00031 #include <stdlib.h>
00032 #include <string.h>
00033 #include <unistd.h>
00034 #include <ctype.h>
00035 #endif
00036
00037 #if alpha
00038 #include <stdlib.h>
00039 #include <unistd.h>
00040 #include <values.h>
00041 #define USE_STDARG
00042 #endif
00043
00044 #ifdef Darwin
00045 #define cfree free
00046 #endif
00047
00048 #ifdef USE_STDARG
00049 #include <stdarg.h>
00050 #else
00051 #include <varargs.h>
00052 #endif
00053
00054 #if Cygwin
00055 #define T LISPT
00056 #define READ LISPREAD
00057 #define cfree free
00058 #endif
00059
00060 #if vxworks
00061 #include <vxWorks.h>
00062 #include <stdioLib.h>
00063 #define errno errnoGet()
00064 #else
00065 #include <stdio.h>
00066 #ifndef __cplusplus
00067 #define min(x,y) ((x<y)?x:y)
00068 #define max(x,y) ((x<y)?y:x)
00069 #endif
00070 #endif
00071
00072 #if (WORD_SIZE == 64)
00073 extern eusinteger_t setjmp_val;
00074 #define eussetjmp(buf) (_setjmp(buf)?setjmp_val:(eusinteger_t)0)
00075 #define euslongjmp(buf,val) (setjmp_val=(eusinteger_t)(val),_longjmp(buf,1))
00076 #else
00077 #if (Solaris2 || vxworks)
00078 #define eussetjmp(buf) (eusinteger_t)setjmp(buf)
00079 #define euslongjmp(buf,val) longjmp(buf,(int)(val))
00080 #include <synch.h>
00081 #else
00082 #define eussetjmp(buf) (eusinteger_t)_setjmp(buf)
00083 #define euslongjmp(buf,val) _longjmp(buf,(int)(val))
00084 #endif
00085 #endif
00086
00087 #include <setjmp.h>
00088 #include <string.h>
00089
00090 #define ERR (-1)
00091 #define STOPPER ((pointer)0L)
00092 #define UNBOUND ((pointer)0L)
00093
00094
00095 #define V_CONSTANT ((pointer)((0<<2)+2)) // makeint(0)
00096 #define V_VARIABLE ((pointer)((1<<2)+2)) // makeint(1)
00097 #define V_GLOBAL ((pointer)((2<<2)+2)) // makeint(2)
00098 #define V_SPECIAL ((pointer)((3<<2)+2)) // makeint(3)
00099
00100
00101 #define SUBR_FUNCTION ((pointer)((0<<2)+2)) // makeint(0)
00102 #define SUBR_MACRO ((pointer)((1<<2)+2)) // makeint(1)
00103 #define SUBR_SPECIAL ((pointer)((2<<2)+2)) // makeint(2)
00104 #define SUBR_ENTRY ((pointer)((3<<2)+2)) // makeint(3)
00105
00106
00107 #define BLOCKFRAME ((pointer)((0<<2)+2)) // makeint(0)
00108 #define TAGBODYFRAME ((pointer)((1<<2)+2)) // makeint(1)
00109
00110
00111 #define ELM_FIXED 0
00112 #define ELM_BIT 1
00113 #define ELM_CHAR 2
00114 #define ELM_BYTE 3
00115 #define ELM_INT 4
00116 #define ELM_FLOAT 5
00117 #define ELM_FOREIGN 6
00118 #define ELM_POINTER 7
00119
00120
00121
00122
00123 #if (WORD_SIZE == 64)
00124 #define MASK 0x7fffffffffffffff
00125 #define MSB 0x8000000000000000
00126 #else
00127 #define MASK 0x7fffffff
00128 #define MSB 0x80000000
00129 #endif
00130
00131
00132
00133
00134
00135 #define DEFAULTCHUNKINDEX 16
00136 #define MAXBUDDY 40
00137
00138
00139
00140
00141 #define MAXTHRBUDDY 6
00142 #define MAXSTACK 8388608
00143 #define SYMBOLHASH 60
00144 #define MAXCLASS 4096
00145 #define KEYWORDPARAMETERLIMIT 128
00146 #define ARRAYRANKLIMIT 7
00147 #define MAXTHREAD 64
00148 #define MAX_SPECIALS 512
00149 #if (WORD_SIZE == 64)
00150 #define MAXPOSFIXNUM (0x1fffffffffffffff)
00151 #define MINNEGFIXNUM (0xe000000000000000)
00152 #else
00153 #define MAXPOSFIXNUM (0x1fffffff)
00154 #define MINNEGFIXNUM (0xe0000000)
00155 #endif
00156
00157
00158
00159
00160
00161 typedef unsigned char byte;
00162 typedef unsigned short word;
00163 typedef struct cell *pointer;
00164
00165 #ifdef RGC
00166 #include "external_markbits.h"
00167 #include "time.h"
00168 #include "collector.h"
00169 #else
00170 #define GC_POINT
00171 #define GC_REGION(cmp_statement) cmp_statement
00172 #endif
00173
00174 struct cellheader {
00175 unsigned mark:1;
00176 unsigned b:1;
00177 unsigned m:1;
00178 unsigned smark:1;
00179 unsigned pmark:1;
00180 unsigned elmtype:3;
00181 unsigned nodispose:1;
00182 #ifdef RGC
00183 unsigned bix:7;
00184 #else
00185 unsigned extra:1;
00186 unsigned bix:6;
00187 #endif
00188 short cix;};
00189
00190
00191
00192
00193 struct cons {
00194 pointer car,
00195 cdr;};
00196
00197 struct propertied_object {
00198 pointer plist;};
00199
00200 struct symbol {
00201 pointer plist,
00202 speval,
00203 vtype,
00204 spefunc,
00205 pname,
00206 homepkg;};
00207
00208 struct string {
00209 pointer length;
00210 byte chars[1];};
00211
00212 struct foreign {
00213 pointer length;
00214 byte *chars; };
00215
00216 struct package {
00217 pointer plist;
00218 pointer names;
00219 pointer use;
00220 pointer symvector;
00221 pointer symcount;
00222 pointer intsymvector;
00223 pointer intsymcount;
00224 pointer shadows;
00225 pointer used_by;
00226 };
00227
00228 struct code {
00229 pointer codevec;
00230 pointer quotevec;
00231 pointer subrtype;
00232 pointer entry;
00233 #if ARM
00234 pointer entry2;
00235 #endif
00236 };
00237
00238 struct fcode {
00239 pointer codevec;
00240 pointer quotevec;
00241 pointer subrtype;
00242 pointer entry;
00243 pointer entry2;
00244 pointer paramtypes;
00245 pointer resulttype;};
00246
00247 struct ldmodule {
00248 pointer codevec;
00249 pointer quotevec;
00250 pointer subrtype;
00251 pointer entry;
00252 #if ARM
00253 pointer entry2;
00254 #endif
00255 pointer symtab;
00256 pointer objname;
00257 pointer handle;};
00258
00259 struct closure {
00260 pointer codevec;
00261 pointer quotevec;
00262 pointer subrtype;
00263 pointer entry;
00264 #if ARM
00265 pointer entry2;
00266 #endif
00267 pointer env0;
00268 pointer *env1;
00269 pointer *env2;};
00270
00271 struct stream {
00272 pointer plist;
00273 pointer direction;
00274 pointer buffer;
00275 pointer count;
00276 pointer tail;};
00277
00278 struct filestream {
00279 pointer plist;
00280 pointer direction;
00281 pointer buffer;
00282 pointer count;
00283 pointer tail;
00284 pointer fd;
00285 pointer fname;};
00286
00287 struct iostream {
00288 pointer plist;
00289 pointer in,out;};
00290
00291 struct labref {
00292 pointer label;
00293 pointer value;
00294 pointer unsolved;
00295 pointer next; };
00296
00297 struct vector {
00298 pointer size;
00299 pointer v[1];};
00300
00301 struct intvector {
00302 pointer length;
00303 eusinteger_t iv[1];};
00304
00305 struct floatvector {
00306 pointer length;
00307 eusfloat_t fv[1];};
00308
00309 struct arrayheader {
00310 pointer plist;
00311 pointer entity,
00312 rank,
00313 fillpointer,
00314 offset,
00315 dim[ARRAYRANKLIMIT];};
00316
00317
00318 struct object {
00319 pointer iv[2];};
00320
00321 struct _class {
00322 pointer plist;
00323 pointer name;
00324 pointer super;
00325 pointer cix;
00326 pointer vars;
00327 pointer types;
00328 pointer forwards;
00329 pointer methods;
00330 };
00331
00332 struct vecclass {
00333 pointer plist;
00334 pointer name;
00335 pointer super;
00336 pointer cix;
00337 pointer vars;
00338 pointer types;
00339 pointer forwards;
00340 pointer methods;
00341 pointer elmtype;
00342 pointer size;};
00343
00344 struct readtable {
00345 pointer plist;
00346 pointer syntax;
00347 pointer macro;
00348 pointer dispatch;
00349 pointer readcase;};
00350
00351 struct threadport {
00352 pointer plist;
00353 pointer id;
00354 pointer requester;
00355 pointer reqsem;
00356 pointer runsem;
00357 pointer donesem;
00358 pointer func;
00359 pointer args;
00360 pointer result;
00361 pointer contex;
00362 pointer idle;
00363 pointer wait;};
00364
00365
00366 struct ratio {
00367 pointer numerator;
00368 pointer denominator;};
00369
00370 struct complex {
00371 pointer real;
00372 pointer imaginary;};
00373
00374 struct bignum {
00375 pointer size;
00376 pointer bv;};
00377
00378
00379 typedef
00380 struct cell {
00381 #if vax || sun4 || news || mips || i386 || i486 || i586 || alpha || x86_64 || ARM
00382 unsigned mark:1;
00383 unsigned b:1;
00384 unsigned m:1;
00385 unsigned smark:1;
00386 unsigned pmark:1;
00387 unsigned elmtype:3;
00388 unsigned nodispose:1;
00389 #ifdef RGC
00390 unsigned bix:7;
00391 #else
00392 unsigned extra:1;
00393 unsigned bix:6;
00394 #endif
00395 #endif
00396 short cix;
00397 union cellunion {
00398 struct cons cons;
00399 struct symbol sym;
00400 struct string str;
00401 struct foreign foreign;
00402 struct package pkg;
00403 struct stream stream;
00404 struct filestream fstream;
00405 struct iostream iostream;
00406 struct code code;
00407 struct fcode fcode;
00408 struct ldmodule ldmod;
00409 struct closure clo;
00410 struct labref lab;
00411 struct arrayheader ary;
00412 struct vector vec;
00413 struct floatvector fvec;
00414 struct intvector ivec;
00415 struct object obj;
00416 struct _class cls;
00417 struct vecclass vcls;
00418 struct readtable rdtab;
00419 struct threadport thrp;
00420 struct ratio ratio;
00421 struct complex cmplx;
00422 struct bignum bgnm;
00423 } c;
00424 } cell;
00425
00426 typedef
00427 union numunion {
00428 eusfloat_t fval;
00429 eusinteger_t ival;
00430 #if vax
00431 struct {short low,high;} sval;
00432 #endif
00433
00434 } numunion;
00435
00436
00437 struct bcell {
00438 struct cellheader h;
00439 union {
00440 struct bcell *nextbcell;
00441 struct cell *c[2];} b;} ;
00442
00443 typedef struct bcell *bpointer;
00444
00445 struct chunk {
00446 struct chunk *nextchunk;
00447 int chunkbix;
00448 struct bcell rootcell;};
00449
00450 typedef struct {
00451 short cix;
00452 short sub;} cixpair;
00453
00454 enum ch_type {
00455 ch_illegal,
00456 ch_white,
00457 ch_comment,
00458 ch_macro,
00459 ch_constituent,
00460 ch_sglescape,
00461 ch_multiescape,
00462 ch_termmacro,
00463 ch_nontermacro};
00464
00465 enum ch_attr {
00466 alphabetic,package_marker,illegal,alphadigit};
00467
00468
00469
00470
00471
00472 struct callframe {
00473 struct callframe *vlink;
00474 pointer form;
00475 };
00476
00477 struct bindframe {
00478 struct bindframe *dynblink, *lexblink;
00479 pointer sym;
00480 pointer val;};
00481
00482 struct specialbindframe {
00483 struct specialbindframe *sblink;
00484 pointer sym;
00485 pointer oldval;};
00486
00487 struct blockframe {
00488 pointer kind;
00489 struct blockframe *dynklink,*lexklink;
00490 pointer name;
00491 jmp_buf *jbp;};
00492
00493 struct catchframe {
00494 struct catchframe *nextcatch;
00495 pointer label;
00496 struct bindframe *bf;
00497 struct callframe *cf;
00498 struct fletframe *ff;
00499 jmp_buf *jbp;
00500 };
00501
00502 struct protectframe {
00503 struct protectframe *protlink;
00504 pointer cleaner;
00505 };
00506
00507 struct fletframe {
00508 pointer name;
00509 pointer fclosure;
00510 struct fletframe *scope;
00511 struct fletframe *lexlink;
00512 struct fletframe *dynlink;};
00513
00514 #define MAXMETHCACHE 256
00515
00516 struct methdef {
00517 pointer selector,class,ownerclass,method;
00518 } ;
00519
00520
00521
00522 typedef struct {
00523 pointer *stack, *vsp,*stacklimit;
00524 #ifdef RGC
00525 pointer *gcstack, *gsp, *gcstacklimit;
00526 #endif
00527 struct callframe *callfp;
00528 struct catchframe *catchfp;
00529 struct bindframe *bindfp;
00530 struct specialbindframe *sbindfp;
00531 struct blockframe *blkfp;
00532 struct protectframe *protfp;
00533 struct fletframe *fletfp, *newfletfp;
00534 pointer lastalloc;
00535 pointer errhandler;
00536 pointer threadobj;
00537 struct methdef *methcache;
00538 struct buddyfree *thr_buddy;
00539 int alloc_big_count;
00540 int alloc_small_count;
00541 int special_bind_count;
00542 int slashflag;
00543 pointer specials;
00544 int intsig;
00545 #ifdef __RETURN_BARRIER
00546 rbar_t rbar;
00547 #else
00548 long extra[10];
00549 #endif
00550 #ifdef __GC_ALLOC_DRIVEN
00551 int my_gc_pri;
00552 #endif
00553 }
00554 context;
00555
00556
00557
00558
00559 extern long buddysize[MAXBUDDY+1];
00560
00561 extern struct buddyfree {
00562 int count;
00563 bpointer bp;} buddy[MAXBUDDY+1];
00564
00565 struct class_desc {
00566 short cix;
00567 short subcix;
00568 pointer def; };
00569
00570 struct built_in_cid {
00571 pointer cls;
00572 cixpair *cp; };
00573
00574 #if THREADED
00575 #include "eus_thr.h"
00576 #endif
00577
00578
00579
00580
00581
00582
00583
00584
00585 extern eusinteger_t mypid;
00586 extern char *progname;
00587
00588
00589
00590 extern struct buddyfree buddy[MAXBUDDY+1];
00591 extern struct chunk *chunklist;
00592 extern char *maxmemory;
00593 extern long freeheap, totalheap;
00594
00595
00596 extern long gccount,marktime,sweeptime;
00597 extern long alloccount[MAXBUDDY];
00598
00599
00600
00601 extern pointer sysobj;
00602 extern pointer lastalloc;
00603
00604
00605 extern context *euscontexts[MAXTHREAD];
00606
00607
00608
00609
00610
00611
00612 extern cixpair objectcp;
00613 extern cixpair conscp;
00614 extern cixpair propobjcp;
00615 extern cixpair lockablecp;
00616 extern cixpair symbolcp;
00617 extern cixpair packagecp;
00618 extern cixpair streamcp;
00619 extern cixpair filestreamcp;
00620 extern cixpair iostreamcp;
00621 extern cixpair metaclasscp;
00622 extern cixpair vecclasscp;
00623 extern cixpair codecp;
00624 extern cixpair fcodecp;
00625
00626 extern cixpair ldmodulecp;
00627 extern cixpair closurecp;
00628 extern cixpair labrefcp;
00629 extern cixpair threadcp;
00630 extern cixpair arraycp;
00631 extern cixpair readtablecp;
00632 extern cixpair vectorcp;
00633 extern cixpair fltvectorcp;
00634 extern cixpair intvectorcp;
00635 extern cixpair stringcp;
00636 extern cixpair bitvectorcp;
00637
00638 extern cixpair extnumcp;
00639 extern cixpair ratiocp;
00640 extern cixpair complexcp;
00641 extern cixpair bignumcp;
00642
00643 extern struct built_in_cid builtinclass[64];
00644 extern int nextbclass;
00645
00646
00647
00648 extern pointer pkglist,lisppkg,keywordpkg,userpkg,syspkg,unixpkg,xpkg;
00649 extern pointer NIL,PACKAGE,T,QUOTE;
00650 extern pointer FUNCTION;
00651 extern pointer QDECLARE,QSPECIAL;
00652 #if SunOS4_1
00653 extern pointer QSELF;
00654 #else
00655 extern pointer SELF;
00656 #endif
00657 extern pointer CLASS;
00658 extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
00659 extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
00660 extern pointer TOPLEVEL,QEVALHOOK,ERRHANDLER;
00661 extern pointer QGCHOOK, QEXITHOOK;
00662 extern pointer QUNBOUND,QDEBUG;
00663 extern pointer QTHREADS;
00664 extern pointer QEQ,QEQUAL,QNOT;
00665 extern pointer QAND, QOR, QNOT;
00666
00667
00668 extern pointer GCMERGE,GCMARGIN;
00669
00670
00671 extern pointer K_IN,K_OUT,K_IO;
00672 extern pointer K_FLUSH,K_FILL,K_FILE,K_STRING;
00673 extern pointer K_NOMETHOD,K_BIT,K_BYTE,K_CHAR,K_SHORT,K_LONG,K_INTEGER,K_POINTER;
00674 extern pointer K_FLOAT32,K_FLOAT,K_DOUBLE,K_FOREIGN, K_FOREIGN_STRING;
00675 extern pointer K_DOWNCASE,K_UPCASE, K_PRESERVE, K_INVERT, K_CAPITALIZE;
00676
00677
00678 extern struct class_desc classtab[MAXCLASS];
00679 extern int nextcix;
00680
00681
00682 extern pointer C_CONS, C_OBJECT, C_SYMBOL, C_PACKAGE;
00683 extern pointer C_STREAM, C_FILESTREAM, C_IOSTREAM, C_CODE, C_FCODE;
00684 extern pointer C_LDMOD;
00685 extern pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_LABREF;
00686 extern pointer C_THREAD;
00687 extern pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
00688 extern pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
00689 extern pointer C_EXTNUM, C_RATIO, C_COMPLEX, C_BIGNUM;
00690
00691
00692 extern pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL,
00693 CODE, FCODE,LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF;
00694 extern pointer THREAD;
00695 extern pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE;
00696 extern pointer FOREIGNCODE,ARRAY,BITVECTOR;
00697 extern pointer EXTNUM, RATIO, COMPLEX, BIGNUM;
00698
00699
00700 extern int intsig;
00701 extern int intcode;
00702 extern int ehbypass;
00703
00704
00705 extern pointer charmacro[256];
00706 extern pointer sharpmacro[256];
00707 extern int export_all;
00708
00709
00710
00711
00712
00713 #ifdef RGC
00714 #define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error(E_DUMMY5,(pointer)(err)))
00715 #define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error(E_DUMMY5,(pointer)(err)))
00716 #define alloc rgc_alloc
00717 #else
00718 #define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error(E_DUMMY3,(pointer)(err)))
00719 #define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error(E_DUMMY3,(pointer)(err)))
00720 #define alloc gc_alloc
00721 #endif
00722 #define ccar(p) ((p)->c.cons.car)
00723 #define ccdr(p) ((p)->c.cons.cdr)
00724 #define cixof(p) ((p)->cix)
00725 #define classof(p) (classtab[(p)->cix].def)
00726 #define subcixof(p) (classtab[(p)->cix].subcix)
00727 #define speval(p) ((p)->c.sym.speval)
00728 #define spevalof(p,x) (ctx->specials->c.vec.v[x])
00729 #define Spevalof(p) (ctx->specials->c.vec.v[intval((p)->c.sym.vtype)])
00730 #define SPEVALOF(p) (((p)->c.sym.vtype>=V_SPECIAL)? \
00731 ctx->specials->c.vec.v[intval((p)->c.sym.vtype)]: \
00732 (p)->c.sym.speval)
00733 #define superof(p) ((p)->c.cls.super)
00734
00735 #if sun3 || apollo || (system5 && !alpha && !mips) || sanyo || vxworks || NEXT
00736 #define makepointer(bp) ((pointer)((eusinteger_t)(bp) | 2))
00737 #define isint(p) (!((eusinteger_t)(p) & 3))
00738 #define isflt(p) (((eusinteger_t)(p) & 3)==1)
00739 #define isnum(p) (((eusinteger_t)(p) & 2)==0)
00740 #define ispointer(p) ((eusinteger_t)(p) & 2)
00741 #define makeint(v) ((pointer)(((eusinteger_t)v)<<2))
00742 #define bpointerof(p) ((bpointer)((eusinteger_t)(p)-2))
00743 #endif
00744
00745 #if vax || sun4 || news || mips || i386 || i486 || i586 || alpha || x86_64 || ARM
00746
00747 #define makepointer(bp) ((pointer)((eusinteger_t)(bp)))
00748
00749 #define isint(p) ( (((eusinteger_t)(p)&3)==2) || (((eusinteger_t)(p)&0x3)==0x3) )
00750 #define isflt(p) (((eusinteger_t)(p) & 3)==1)
00751 #define isnum(p) (((eusinteger_t)(p) & 3))
00752 #define ispointer(p) (!((eusinteger_t)(p) & 3))
00753
00754 #ifdef __cplusplus
00755 extern "C" {
00756 #endif
00757 extern pointer makeint(eusinteger_t v);
00758 #ifdef __cplusplus
00759 }
00760 #endif
00761
00762 #define bpointerof(p) ((bpointer)((eusinteger_t)(p)))
00763 #ifdef RGC
00764 #define nextbuddy(p) ((bpointer)((eusinteger_t)(p)+(buddysize[(p->h.bix)&TAGMASK]*sizeof(pointer))))
00765 #else
00766 #define nextbuddy(p) ((bpointer)((eusinteger_t)(p)+(buddysize[p->h.bix]*sizeof(pointer))))
00767 #endif
00768 #ifndef __USE_MARK_BITMAP
00769 #define marked(p) (p->h.mark)
00770 #define markon(p) p->h.mark=1
00771 #define markoff(p) p->h.mark=0
00772 #endif
00773 #endif
00774
00775
00776 #ifdef __cplusplus
00777 extern "C" {
00778 #endif
00779 extern eusinteger_t intval(pointer p);
00780 #ifdef __cplusplus
00781 }
00782 #endif
00783 #define ckintval(p) ((isint(p)|| \
00784 (isbignum(p)&& \
00785 ((vecsize((p)->c.bgnm.bv)==1)|| \
00786 ((vecsize((p)->c.bgnm.bv)==2)&&((p)->c.bgnm.bv->c.ivec.iv[1]<2))))) \
00787 ?intval(p):(eusinteger_t)error(E_NOINT))
00788 #define bigintval(x) (isint(x)?intval(x):\
00789 (isbignum(x)?\
00790 ((vecsize((x)->c.bgnm.bv)>=2)?\
00791 (((x)->c.bgnm.bv->c.ivec.iv[1]<<(WORD_SIZE-1)) | ((x)->c.bgnm.bv->c.ivec.iv[0])): \
00792 ((x)->c.bgnm.bv->c.ivec.iv[0])):\
00793 (eusinteger_t)error(E_NOINT)) )
00794 #define mkbigint(y) \
00795 (pointer)((((y)^((y)>>1))&(eusinteger_t)3<<(WORD_SIZE-3))?makebig1(y):makeint(y))
00796
00797 #define elmtypeof(p) (bpointerof(p)->h.elmtype)
00798 #ifdef RGC
00799 #define bixof(p) (bpointerof(p)->h.bix & TAGMASK)
00800 #else
00801 #define bixof(p) (bpointerof(p)->h.bix)
00802 #endif
00803
00804 #if sun3 || sun4 || system5 || apollo || news || sanyo || vxworks || mips || NEXT || i386 || i486 || i586 || x86_64 || ARM
00805 #if x86_64
00806 #define fltval(p) (nu.ival=((eusinteger_t)(p) & ~3L), nu.fval)
00807 #define makeflt(f) (nu.fval=(eusfloat_t)(f), (pointer)((nu.ival & ~3L) | 1L))
00808 #else
00809 #define fltval(p) (nu.ival=((eusinteger_t)(p) & ~3), nu.fval)
00810 #define makeflt(f) (nu.fval=(eusfloat_t)(f), (pointer)((nu.ival & ~3) | 1))
00811 #endif
00812
00813
00814
00815
00816
00817
00818 #define ckfltval(p) (isflt(p)?fltval(p):\
00819 (isint(p)?intval(p):\
00820 (pisbignum(p)?big_to_float(p):\
00821 (pisratio(p)?ratio2flt(p):\
00822 (eusinteger_t)error(E_NONUMBER)))))
00823 #endif
00824
00825
00826 #define pislist(p) (p->cix<=conscp.sub)
00827 #define piscons(p) (p->cix<=conscp.sub)
00828 #define pispropobj(p) (propobjcp.cix<=(p)->cix && (p)->cix<=propobjcp.sub)
00829 #define ispropobj(p) (ispointer(p) && pispropobj(p))
00830 #define pissymbol(p) (symbolcp.cix<=(p)->cix && (p)->cix<=symbolcp.sub)
00831 #define issymbol(p) (ispointer(p) && pissymbol(p))
00832 #define pisstring(p) (stringcp.cix<=(p)->cix && (p)->cix<=stringcp.sub)
00833 #define isstring(p) (ispointer(p) && pisstring(p))
00834 #define islist(p) (ispointer(p) && pislist(p))
00835 #define iscons(p) (ispointer(p) && piscons(p))
00836 #define piscode(p) (codecp.cix<=(p)->cix && (p)->cix<=codecp.sub)
00837 #define iscode(p) (ispointer(p) && piscode(p))
00838 #define pisfcode(p) (fcodecp.cix<=(p)->cix && (p)->cix<=fcodecp.sub)
00839 #define isfcode(p) (ispointer(p) && pisfcode(p))
00840 #define pisldmod(p) (ldmodulecp.cix<=(p)->cix && (p)->cix<=ldmodulecp.sub)
00841 #define isldmod(p) (ispointer(p) && pisldmod(p))
00842 #define pisstream(p) (streamcp.cix<=(p)->cix && (p)->cix<=streamcp.sub)
00843 #define isstream(p) (ispointer(p) && pisstream(p))
00844 #define pisfilestream(p) (filestreamcp.cix<=(p)->cix && (p)->cix<=filestreamcp.sub)
00845 #define isfilestream(p) (ispointer(p) && pisfilestream(p))
00846 #define pisiostream(p) (iostreamcp.cix<=(p)->cix && (p)->cix<=iostreamcp.sub)
00847 #define isiostream(p) (ispointer(p) && pisiostream(p))
00848 #define pisreadtable(p) (readtablecp.cix<=((p)->cix) && ((p)->cix)<=readtablecp.sub)
00849 #define isreadtable(p) (ispointer(p) && pisreadtable(p))
00850 #define pisarray(p) (arraycp.cix<=((p)->cix) && ((p)->cix)<=arraycp.sub)
00851 #define isarray(p) (ispointer(p) && pisarray(p))
00852 #define pisvector(p) (elmtypeof(p))
00853 #define isvector(p) (ispointer(p) && pisvector(p))
00854 #define isfltvector(p) (ispointer(p) && (elmtypeof(p)==ELM_FLOAT))
00855 #define isptrvector(p) (ispointer(p) && (elmtypeof(p)==ELM_POINTER))
00856 #define isintvector(p) (ispointer(p) && (elmtypeof(p)==ELM_INT))
00857 #define pisclass(p) (metaclasscp.cix<=(p)->cix && (p)->cix<=metaclasscp.sub)
00858 #define isclass(p) (ispointer(p) && pisclass(p))
00859 #define pisvecclass(p) (vecclasscp.cix<=(p)->cix && (p)->cix<=vecclasscp.sub)
00860 #define isvecclass(p) (ispointer(p) && pisvecclass(p))
00861 #define pispackage(p) (packagecp.cix<=(p)->cix && (p)->cix<=packagecp.sub)
00862 #define ispackage(p) (ispointer(p) && pispackage(p))
00863 #define pisclosure(p) (closurecp.cix<=(p)->cix && (p)->cix<=closurecp.sub)
00864 #define isclosure(p) (ispointer(p) && pisclosure(p))
00865 #define pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub)
00866 #define islabref(p) (ispointer(p) && pislabref(p))
00867
00868 #define pisextnum(p) (extnumcp.cix<=(p)->cix && (p)->cix<=extnumcp.sub)
00869 #define isextnum(p) (ispointer(p) && pisextnum(p))
00870 #define pisratio(p) (ratiocp.cix<=(p)->cix && (p)->cix<=ratiocp.sub)
00871 #define isratio(p) (ispointer(p) && pisratio(p))
00872 #define piscomplex(p) (complexcp.cix<=(p)->cix && (p)->cix<=complexcp.sub)
00873 #define iscomplex(p) (ispointer(p) && piscomplex(p))
00874 #define pisbignum(p) (bignumcp.cix<=(p)->cix && (p)->cix<=bignumcp.sub)
00875 #define isbignum(p) (ispointer(p) && pisbignum(p))
00876
00877 #define strlength(p) ((int)intval((p)->c.str.length))
00878 #define vecsize(p) ((int)intval((p)->c.vec.size))
00879 #define objsize(p) ((int)vecsize(classof(p)->c.cls.vars))
00880
00881
00882 #define bigsize(x) vecsize((x)->c.bgnm.bv)
00883 #define bigvec(x) (x)->c.bgnm.bv->c.ivec.iv
00884
00885
00886 #define current_ctx (euscontexts[thr_self()])
00887 #ifdef STACK_DEBUG
00888 #define vpush(v) (*ctx->vsp++=p_print((pointer)(v),ctx))
00889 #define vpop() (printf("vpop:[0x%lx]=0x%lx\n",ctx->vsp-1,(ctx->vsp)[-1]),*(--(ctx->vsp)))
00890 #else
00891 #define vpush(v) (*ctx->vsp++=((pointer)v))
00892 #define vpop() (*(--(ctx->vsp)))
00893 #endif
00894 #define ckpush(v) (ctx->vsp<ctx->stacklimit?vpush(v):(pointer)error(E_STACKOVER))
00895
00896 #define ckarg(req) if (n!=(req)) error(E_MISMATCHARG)
00897 #define ckarg2(req1,req2) if ((n<(req1))||((req2)<n)) error(E_MISMATCHARG)
00898
00899 #define breakck if (ctx->intsig>0) sigbreak()
00900 #define stackck if (ctx->vsp>ctx->stacklimit) error(E_STACKOVER)
00901 #define debug (speval(QDEBUG)!=NIL)
00902
00903 #ifndef RGC
00904 #define pointer_update(l,r) { (l)=(r); }
00905 #define take_care(p)
00906
00907 #endif
00908
00909
00910
00911
00912
00913
00914
00915 enum errorcode {
00916
00917 E_NORMAL,
00918 E_STACKOVER,
00919 E_ALLOCATION,
00920 #ifdef RGC
00921 E_GCSTACKOVER,
00922 E_PSTACKOVER,
00923 #else
00924 E_DUMMY3,
00925 E_DUMMY4,
00926 #endif
00927 E_DUMMY5,
00928 E_DUMMY6,
00929 E_DUMMY7,
00930 E_DUMMY8,
00931 E_DUMMY9,
00932 E_DUMMY10,
00933 #define E_FATAL 10
00934
00935 E_SETCONST,
00936 E_UNBOUND,
00937 E_UNDEF,
00938 E_MISMATCHARG,
00939 E_ILLFUNC,
00940 E_ILLCH,
00941 E_READ,
00942 E_WRITE,
00943 E_LONGSTRING,
00944 E_NOSYMBOL,
00945 E_NOLIST,
00946 E_LAMBDA,
00947 E_PARAMETER,
00948 E_NOCATCHER,
00949 E_NOBLOCK,
00950 E_STREAM,
00951 E_IODIRECTION,
00952 E_NOINT,
00953 E_NOSTRING,
00954 E_OPENFILE,
00955 E_EOF,
00956 E_NONUMBER,
00957 E_CLASSOVER,
00958 E_NOCLASS,
00959 E_NOVECTOR,
00960 E_VECSIZE,
00961 E_DUPOBJVAR,
00962 E_INSTANTIATE,
00963 E_ARRAYINDEX,
00964 E_NOMETHOD,
00965 E_CIRCULAR,
00966 E_SHARPMACRO,
00967 E_ALIST,
00968 E_NOMACRO,
00969 E_NOPACKAGE,
00970 E_PKGNAME,
00971 E_NOOBJ,
00972 E_NOOBJVAR,
00973 E_NOSEQ,
00974 E_STARTEND,
00975 E_NOSUPER,
00976 E_FORMATSTRING,
00977 E_FLOATVECTOR,
00978 E_CHARRANGE,
00979 E_VECINDEX,
00980 E_NOOBJECT,
00981 E_TYPEMISMATCH,
00982 E_DECLARE,
00983 E_DECLFORM,
00984 E_NOVARIABLE,
00985 E_ROTAXIS,
00986 E_MULTIDECL,
00987 E_READLABEL,
00988 E_READFVECTOR,
00989 E_READOBJECT,
00990 E_SOCKET,
00991 E_NOARRAY,
00992 E_ARRAYDIMENSION,
00993 E_KEYPARAM,
00994 E_NOKEYPARAM,
00995 E_NOINTVECTOR,
00996 E_SEQINDEX,
00997 E_BITVECTOR,
00998 E_EXTSYMBOL,
00999 E_SYMBOLCONFLICT,
01000
01001
01002 E_USER,
01003
01004
01005 E_END
01006 };
01007
01008
01009
01010 #ifdef __cplusplus
01011 extern "C" {
01012 #endif
01013
01014 #if alpha || IRIX6 || Solaris2 || Linux || Cygwin
01015 #include "eus_proto.h"
01016 #else
01017 extern pointer eval(context *, pointer);
01018 extern pointer eval2(context *, pointer, pointer);
01019 extern pointer ufuncall(context *, pointer, pointer, pointer,
01020 struct bindframe *, int);
01021 extern pointer funlambda(context *, pointer, pointer, pointer, pointer *,
01022 struct bindframe *, int);
01023 extern pointer funcode(context *, pointer, pointer, int);
01024 extern pointer progn(context *, pointer);
01025 extern pointer csend(context *, ...);
01026 extern pointer getval(context *, pointer);
01027 extern pointer setval(context *, pointer, pointer);
01028 extern pointer getfunc(context *, pointer);
01029 extern struct bindframe *declare(context *, pointer, struct bindframe *);
01030 extern struct bindframe *vbind(context *, pointer, pointer,
01031 struct bindframe *, struct bindframe*);
01032 extern struct bindframe *fastbind(context *, pointer, pointer,
01033 struct bindframe *);
01034 extern void bindspecial(context *, pointer, pointer);
01035 extern void unbindspecial(context *, struct specialbindframe *);
01036 extern struct bindframe *bindkeyparams(context *, pointer, pointer *,
01037 int, struct bindframe *, struct bindframe *);
01038
01039 extern pointer Getstring();
01040 extern pointer findpkg();
01041 extern pointer memq();
01042
01043
01044 extern pointer alloc(int, int, int, int);
01045 extern pointer makebuffer(int);
01046 extern pointer makevector(pointer, int);
01047 extern pointer makeclass(context *, pointer, pointer, pointer,pointer, pointer,
01048 int, pointer);
01049 extern pointer makecode(pointer, pointer(*)(), pointer);
01050 extern pointer makematrix(context *, int, int);
01051 extern pointer makeobject(pointer);
01052 extern pointer rawcons(context *, pointer, pointer);
01053 extern pointer cons(context *, pointer, pointer);
01054 extern pointer makestring(char *, int);
01055 extern pointer findsymbol(unsigned char *, int, pointer, int *);
01056 extern pointer makesymbol(context *, char *, int, pointer);
01057 extern pointer intern(context *, char *, int, pointer);
01058 extern pointer makepkg(context *, pointer, pointer, pointer);
01059 extern pointer mkstream(context *, pointer, pointer);
01060 extern pointer mkfilestream(context *, pointer,pointer,int,pointer);
01061 extern pointer mkiostream(context *, pointer,pointer);
01062 extern pointer makemodule(context *, int);
01063 extern pointer makebig1(long);
01064 extern pointer eusfloat_to_big(float);
01065 extern eusfloat_t big_to_float(pointer);
01066 extern pointer defun(context *, char *, pointer, pointer(*)());
01067 extern pointer defmacro(context *, char *, pointer, pointer(*)());
01068 extern pointer defspecial(context *, char *, pointer, pointer(*)());
01069 extern pointer defunpkg(context *, char *, pointer, pointer(*)(),pointer);
01070 extern void addcmethod(context *, pointer, pointer (*)(),
01071 pointer, pointer, pointer);
01072 extern pointer defkeyword(context *, char *);
01073 extern pointer defvar(context *, char *, pointer, pointer);
01074 extern pointer deflocal(context *, char *, pointer, pointer);
01075 extern pointer defconst(context *, char *, pointer, pointer);
01076 extern pointer stacknlist(context *, int);
01077 #endif
01078
01079 #if THREADED
01080 extern pointer makethreadport(context *);
01081 #endif
01082
01083
01084 #if vax
01085 extern float fltval(),ckfltval(),bit_to_float();
01086 extern pointer makeflt();
01087 #else
01088 #ifndef makeflt
01089 extern pointer makeflt();
01090 #endif
01091 #endif
01092
01093 #if !alpha && !IRIX6
01094
01095 extern pointer reader(context *, pointer, pointer);
01096 extern pointer prinx(context *, pointer, pointer);
01097
01098
01099 extern pointer makeclosure(pointer,pointer,pointer(*)(),pointer, pointer*, pointer*);
01100 extern pointer fcall();
01101 extern pointer xcar(pointer), xcdr(pointer), xcadr(pointer);
01102 extern pointer *ovafptr(pointer,pointer);
01103 #endif
01104
01105
01106 #if Solaris2 || SunOS4_1
01107 extern mutex_t mark_lock;
01108 extern char *mark_locking;
01109 extern int mark_lock_thread;
01110 extern mutex_t p_mark_lock;
01111 extern rwlock_t gc_lock;
01112
01113 extern mutex_t alloc_lock;
01114 extern mutex_t free_thread_lock;
01115 extern mutex_t qthread_lock;
01116 extern mutex_t qsort_lock;
01117 extern sema_t free_thread_sem;
01118 #endif
01119 #ifdef __cplusplus
01120 }
01121 #endif
01122
01123 extern eusinteger_t hide_ptr (pointer p);
01124