eus.h
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* eus.h        Etl, Umezono, Sakura-mura Lisp
00003 /*      @(#)$Id$
00004 /*      Copyright(c)1988, Toshihiro Matsui, Electrotechnical Laboratory,
00005 /*      all rights reserved, all wrongs left.
00006 /*      created on:     1986-May
00007 /*      needed to be included by all euslisp kernel (.c) files and
00008 /*      user functions compiled by euscomp.
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)   /*impossible pointer object*/
00092 #define UNBOUND ((pointer)0L)
00093 
00094 /* dynamic value type */
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 /* function types*/
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 /* stack frame types (lots more)*/
00107 #define BLOCKFRAME      ((pointer)((0<<2)+2)) // makeint(0)
00108 #define TAGBODYFRAME    ((pointer)((1<<2)+2)) // makeint(1)
00109 
00110 /*vector element types*/
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 /* machine architecture dependent constants*/
00121 /* MASK & long removes the MSB (sign bit) */
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 /* configuration constants                                      */
00133 /****************************************************************/
00134 
00135 #define DEFAULTCHUNKINDEX       16      /*fib2(12)=754*/
00136 #define MAXBUDDY        40      /*fib(30) is big enough*/
00137         /*MAXBUDDY must be smaller than 2^bix, where bix is 6bit, 
00138          63 at most.
00139          fib(29) nealy equals to 2.4M,
00140          fib(30) to 4M words*/
00141 #define MAXTHRBUDDY     6       /*small free cells cached thread-locally*/
00142 #define MAXSTACK        8388608 /* patched: default stack size 16bit -> 23bit, can be expanded by sys:newstack*/
00143 #define SYMBOLHASH      60      /*initial obvector size in package*/
00144 #define MAXCLASS        4096    /* by M.Inaba from 64 */
00145 #define KEYWORDPARAMETERLIMIT 128       /* patched: default keyword size 32->128 */
00146 #define ARRAYRANKLIMIT  7       /*minimal requirement for CommonLisp*/
00147 #define MAXTHREAD       64      /*maximum number of threads*/
00148 #define MAX_SPECIALS    512     /*maximum number of special variables*/
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 /* type definitions:
00158         bix is buddy index,
00159         and cix is class index, which is sometimes refered as cid */
00160 
00161 typedef unsigned char byte;
00162 typedef unsigned short word;    /*seldom used*/
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;      /* GC mark*/
00176   unsigned b:1;         /* buddy: indicates the side in which its buddy should be found */
00177   unsigned m:1;         /* memory: records b or m of parent cell when it's split*/
00178   unsigned smark:1;     /* shared mark*/
00179   unsigned pmark:1;     /* print mark*/
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;               /*5 bits are enough*/
00187 #endif
00188   short    cix;};       /*8 bits may be enough*/
00189 
00190 /****************************************************************/
00191 /* struct definition for lisp object cell
00192 /****************************************************************/
00193 struct cons {
00194     pointer car,        /*cons is made of a car and a cdr*/
00195             cdr;};      /*what a familiar structure!*/
00196 
00197 struct propertied_object {
00198     pointer plist;};
00199 
00200 struct symbol {
00201     pointer plist,      /*inherited from prop_obj*/
00202             speval,
00203             vtype,      /*const,var,special*/
00204             spefunc,
00205             pname,
00206             homepkg;};
00207 
00208 struct string {         /*resembles with vector*/
00209     pointer length;     /*boxed*/
00210     byte chars[1];};    /*long word aligned*/
00211 
00212 struct foreign {
00213     pointer length;
00214     byte *chars; };
00215 
00216 struct package {
00217     pointer plist;
00218     pointer names;      /*package name at car, nicknames in cdr*/
00219     pointer use;        /*spreaded use-package list*/
00220     pointer symvector;  /*hashed obvector*/
00221     pointer symcount;   /*number of interned symbols in this package*/
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;   /*function,macro,special*/
00232     pointer entry;      /*offset from beginning of codevector*/
00233 #if ARM
00234     pointer entry2;     /* some archtecture did not set code on 4 byte alignment */
00235 #endif
00236     };
00237 
00238 struct fcode {          /*foreign function code*/
00239     pointer codevec;
00240     pointer quotevec;
00241     pointer subrtype;
00242     pointer entry;
00243   pointer entry2;    /* kanehiro's patch 2000.12.13 */
00244     pointer paramtypes;
00245     pointer resulttype;};
00246 
00247 struct ldmodule {       /*foreign language object module*/
00248     pointer codevec;
00249     pointer quotevec;
00250     pointer subrtype;   /*function,macro,special*/
00251     pointer entry;
00252 #if ARM
00253     pointer entry2;     /* some archtecture did not set code on 4 byte alignment */
00254 #endif
00255     pointer symtab;
00256     pointer objname;
00257     pointer handle;};   /* dl's handle */
00258 
00259 struct closure {
00260     pointer codevec;
00261     pointer quotevec;
00262     pointer subrtype;   /*function,macro,special*/
00263     pointer entry;      /*offset from beginning of codevector*/
00264 #if ARM
00265     pointer entry2;     /* some archtecture did not set code on 4 byte alignment */
00266 #endif
00267     pointer env0;       /*upper closure link*/
00268     pointer *env1;      /*argument pointer:     argv*/
00269     pointer *env2;};    /*local variable frame: local*/
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 {         /*used for reading labeled forms: #n#,#n=*/
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 /* structs for object oriented programming */
00318 struct object {
00319   pointer iv[2];};      /*instance variables*/
00320 
00321 struct _class {
00322   pointer plist;
00323   pointer name;         /*class name symbol*/
00324   pointer super;        /*super class*/
00325   pointer cix;
00326   pointer vars;         /*var names including inherited ones*/
00327   pointer types;
00328   pointer forwards;
00329   pointer methods;      /*method list*/
00330   };
00331 
00332 struct vecclass {       /*vector class*/
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 /* extended numbers */
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;}; /*bignum vector*/
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 /*    struct { signed sival:30; unsigned tag:2;} tval; */
00434     } numunion;
00435 
00436 /* buddy cell */
00437 struct bcell {
00438     struct cellheader h;
00439     union {
00440       struct bcell *nextbcell;
00441       struct cell  *c[2];} b;} /* bcell */;
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 /* stack frames and context
00471 /****************************************************************/
00472 struct callframe {
00473   struct  callframe *vlink;
00474   pointer form;
00475   };
00476 
00477 struct bindframe {      /*to achieve lexical binding in the interpreter*/
00478   struct  bindframe *dynblink, *lexblink;       /*links to upper level*/
00479   pointer sym;          /*symbol*/
00480   pointer val;};        /*bound value*/
00481 
00482 struct specialbindframe {       /*special value binding frame*/
00483   struct  specialbindframe *sblink;
00484   pointer sym;          /*pointer to the symbol word(dynval or dynfunc)*/
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;        /*bind frame save*/
00497   struct  callframe *cf;        /*call frame save*/
00498   struct  fletframe *ff;
00499   jmp_buf *jbp;
00500   };
00501 
00502 struct protectframe {
00503   struct protectframe *protlink;
00504   pointer cleaner;      /*cleanup form closure*/
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 /*must be power to 2*/
00515 
00516 struct methdef {
00517   pointer selector,class,ownerclass,method;
00518   } /*methcache[MAXMETHCACHE]*/; 
00519 
00520 /* thread context */
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;  /* some extra words are needed? */
00547 #else
00548         long    extra[10];      /* 32 long words */
00549 #endif
00550 #ifdef __GC_ALLOC_DRIVEN
00551     int my_gc_pri;
00552 #endif
00553         }
00554         context;
00555 
00556 /****************************************************************
00557 /* memory and class management structures
00558 /****************************************************************/
00559 extern long buddysize[MAXBUDDY+1];
00560 
00561 extern struct buddyfree {
00562   int count;    /*number of free cells*/
00563   bpointer bp;}  buddy[MAXBUDDY+1];
00564 
00565 struct class_desc {     /* per- class descripter */
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"    /* thread definition by APT */
00576 #endif
00577 
00578 
00579 /****************************************************************/
00580 /* global variables for eus
00581 /*      date:   1986-Apr
00582 /*      1987-Apr
00583 /****************************************************************/
00584 /* process id and program name*/
00585 extern eusinteger_t mypid;
00586 extern char *progname;
00587 
00588 /* heap management */
00589 /* every free cell is linked to the buddybase structure*/
00590 extern struct buddyfree buddy[MAXBUDDY+1];
00591 extern struct chunk *chunklist;
00592 extern char *maxmemory;
00593 extern long freeheap, totalheap;        /*size of heap left and allocated*/
00594 
00595 /* memory management timers for performance evaluation */
00596 extern long gccount,marktime,sweeptime;
00597 extern long alloccount[MAXBUDDY];
00598 
00599 /* System internal objects are connected to sysobj list
00600 /* to protect from garbage-collection */
00601 extern pointer sysobj;
00602 extern pointer lastalloc;
00603 
00604 /* thread euscontexts */
00605 extern context *euscontexts[MAXTHREAD];
00606 
00607 /****************************************************************/
00608 /* system defined (built-in) class index
00609 /*      modified to accept  dynamic type extension (1987-Jan)
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 /*cixpair modulecp; */
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 /*extended numbers*/
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 /*symbol management*/
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 /* SELF is already used on SunOS 4.1.x. */
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 /*memory management parameters*/
00668 extern pointer GCMERGE,GCMARGIN;
00669 
00670 /* keywords */
00671 extern pointer K_IN,K_OUT,K_IO; /*direction keyword*/
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 /*class management*/
00678 extern struct class_desc classtab[MAXCLASS];
00679 extern int nextcix;
00680 
00681 /*class cells*/
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 /*class names*/
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 /*toplevel & evaluation control*/
00700 extern int intsig; /*0:no signal, 1-32:pending, -1:in progress*/
00701 extern int intcode;
00702 extern int ehbypass;
00703 
00704 /*reader variables*/
00705 extern pointer charmacro[256];
00706 extern pointer sharpmacro[256];
00707 extern int export_all;
00708 
00709 /****************************************************************/
00710 /* macro definition for euslisp
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 // #define isint(p) (((eusinteger_t)(p) & 3)==2) // org
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 // #define makeint(v) ((pointer)((((eusinteger_t)(v))<<2)+2)) // org
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 // #define intval(p) (((eusinteger_t)(p))>>2) // org
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 /*#if GCC
00814 #define makeflt(f) (nu.fval=(f), (pointer)((nu.ival & (~2)) | 1)) 
00815 #define makeflt(f) (nu.fval=(f),nu.tval.tag=1,(pointer)(nu.ival))
00816 #endif */
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 /*predicates to test object type*/
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 /* extended numbers */
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 /* bignum */
00882 #define bigsize(x) vecsize((x)->c.bgnm.bv)
00883 #define bigvec(x) (x)->c.bgnm.bv->c.ivec.iv
00884 
00885 /*stack*/
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 /* error code definition
00912 /*      1986-Jun-17
00913 /****************************************************************/
00914 
00915 enum errorcode {
00916 /* first 10 codes are fatal errors */
00917   E_NORMAL,             /*0*/
00918   E_STACKOVER,          /*stack overflow*/
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 /* followings are not fatal errors */
00935   E_SETCONST,           /*11 attempt to set to constant*/
00936   E_UNBOUND,
00937   E_UNDEF,
00938   E_MISMATCHARG,
00939   E_ILLFUNC,
00940   E_ILLCH,
00941   E_READ,
00942   E_WRITE,
00943   E_LONGSTRING,         /*19: string too long*/
00944   E_NOSYMBOL,           /*20: symbol expected*/
00945   E_NOLIST,             /*list expected*/
00946   E_LAMBDA,             /*illegal lambda form*/
00947   E_PARAMETER,          /*illegal lambda parameter syntax*/  
00948   E_NOCATCHER,          /*no catch block */
00949   E_NOBLOCK,            /*no block to return*/
00950   E_STREAM,             /*stream expected*/
00951   E_IODIRECTION,        /*io stream direction keyword*/
00952   E_NOINT,              /*integer value expected*/
00953   E_NOSTRING,           /*string expected*/
00954   E_OPENFILE,           /*30: error in open*/
00955   E_EOF,                /*EOF encountered*/
00956   E_NONUMBER,           /*number expected*/
00957   E_CLASSOVER,          /*class table overflow*/
00958   E_NOCLASS,            /*class expected*/
00959   E_NOVECTOR,           /*vector expected*/
00960   E_VECSIZE,            /*error of vector size*/
00961   E_DUPOBJVAR,          /*duplicated object variable name*/
00962   E_INSTANTIATE,        /*38: cannot make an instance*/
00963   E_ARRAYINDEX,
00964   E_NOMETHOD,           /*40*/
00965   E_CIRCULAR,
00966   E_SHARPMACRO,         /*unknown sharp macro*/
00967   E_ALIST,              /*list expected for an element of an alist*/
00968   E_NOMACRO,            /*macro expected*/
00969   E_NOPACKAGE,          /*no such package */
00970   E_PKGNAME,            /*the package already exists*/
00971   E_NOOBJ,              /*invalid form*/
00972   E_NOOBJVAR,           /*48: not an object variable*/
00973   E_NOSEQ,              /*sequence(list,string,vector) expected*/
00974   E_STARTEND,           /*illegal subsequence index*/
00975   E_NOSUPER,            /*no superclass*/
00976   E_FORMATSTRING,       /*invalid format string character*/
00977   E_FLOATVECTOR,        /*float vector expected*/
00978   E_CHARRANGE,          /*0..255*/
00979   E_VECINDEX,           /*vector index mismatch*/
00980   E_NOOBJECT,           /*other than numbers expected*/
00981   E_TYPEMISMATCH,       /*the: type mismatch*/
00982   E_DECLARE,            /*illegal declaration*/
00983   E_DECLFORM,           /*invalid declaration form*/
00984   E_NOVARIABLE,         /*constant is used in let or lambda*/
00985   E_ROTAXIS,            /*illegal rotation axis spec*/
00986   E_MULTIDECL,
00987   E_READLABEL,          /*illegal #n= or #n# label*/
00988   E_READFVECTOR,        /*error of #f( expression*/
00989   E_READOBJECT,         /*error in #V or #J format*/
00990   E_SOCKET,             /*error of socket address*/
00991   E_NOARRAY,            /*array expected*/
00992   E_ARRAYDIMENSION,     /*array dimension mismatch*/
00993   E_KEYPARAM,           /*keyword parameter expected*/
00994   E_NOKEYPARAM,         /*no such keyword*/
00995   E_NOINTVECTOR,        /*integer vector expected*/
00996   E_SEQINDEX,           /*sequence index out of range*/
00997   E_BITVECTOR,          /*not a bit vector*/
00998   E_EXTSYMBOL,          /*no such external symbol*/
00999   E_SYMBOLCONFLICT,     /*symbol conflict in a package*/
01000 
01001 /* the following error is added by APT */
01002     E_USER,
01003 
01004 /*  E_END must locate at the end of the error list */
01005     E_END
01006   };
01007 
01008 /* function prototypes */
01009 
01010 #ifdef __cplusplus
01011 extern "C" {
01012 #endif
01013 /*eval*/
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 /*allocater*/
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 /*boxing,unboxing*/
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 /*io*/
01095 extern pointer reader(context *, pointer, pointer);
01096 extern pointer prinx(context *, pointer, pointer);
01097 
01098 /*for compiled code*/
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 /* mutex locks*/
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 


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