eus.h

Go to the documentation of this file.

/****************************************************************/
/* eus.h        Etl, Umezono, Sakura-mura Lisp
/*      @(#)$Id$
/*      Copyright(c)1988, Toshihiro Matsui, Electrotechnical Laboratory,
/*      all rights reserved, all wrongs left.
/*      created on:     1986-May
/*      needed to be included by all euslisp kernel (.c) files and
/*      user functions compiled by euscomp.
/****************************************************************/
 
 
#if (__SIZEOF_SIZE_T__ == 8) || (alpha || IRIX6 || x86_64 || aarch64 || ppc64le)
#define WORD_SIZE 64
#else
#define WORD_SIZE 32
#endif
 
#if (WORD_SIZE == 64)
typedef long eusinteger_t;
typedef unsigned long euspointer_t;
typedef double eusfloat_t;
#define WORDSHIFT 3
#else
typedef int eusinteger_t;
typedef unsigned int euspointer_t;
typedef float eusfloat_t;
#define WORDSHIFT 2
#endif
#define wordsizeof(type) (sizeof(type)>>WORDSHIFT)
 
#if GCC || Solaris2 || IRIX || Linux || IRIX6
#define USE_STDARG
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <ctype.h>
#endif
 
#if alpha
#include <stdlib.h>
#include <unistd.h>
#include <values.h>
#define USE_STDARG
#endif
 
#if defined(Darwin) || defined(Linux) || defined(Linux64)
#define cfree free
#endif
 
#ifdef USE_STDARG
#include <stdarg.h>
#else
#include <varargs.h>
#endif
 
#if Cygwin
#define T       LISPT
#define READ    LISPREAD
#define cfree   free
#endif
 
#if vxworks
#include <vxWorks.h>
#include <stdioLib.h>
#define errno errnoGet()
#else
#include <stdio.h>
#ifndef __cplusplus
#define min(x,y) ((x<y)?x:y)
#define max(x,y) ((x<y)?y:x)
#endif
#endif
 
#if (WORD_SIZE == 64)
extern euspointer_t setjmp_val;
#define eussetjmp(buf) (_setjmp(buf)?setjmp_val:(euspointer_t)0)
#define euslongjmp(buf,val) (setjmp_val=(euspointer_t)(val),_longjmp(buf,1))
#else
#if (Solaris2 || vxworks)
#define eussetjmp(buf) (eusinteger_t)setjmp(buf)
#define euslongjmp(buf,val) longjmp(buf,(int)(val))
#include <synch.h>
#else
#define eussetjmp(buf) (eusinteger_t)_setjmp(buf)
#define euslongjmp(buf,val) _longjmp(buf,(int)(val))
#endif
#endif
 
#include <setjmp.h>
#include <string.h>
 
#define ERR (-1)
#define STOPPER ((pointer)0L)   /*impossible pointer object*/
#define UNBOUND ((pointer)0L)
 
/* dynamic value type */
#define V_CONSTANT      ((pointer)((0<<2)+2)) // makeint(0)
#define V_VARIABLE      ((pointer)((1<<2)+2)) // makeint(1)
#define V_GLOBAL        ((pointer)((2<<2)+2)) // makeint(2)
#define V_SPECIAL       ((pointer)((3<<2)+2)) // makeint(3)
 
/* function types*/
#define SUBR_FUNCTION   ((pointer)((0<<2)+2)) // makeint(0)
#define SUBR_MACRO      ((pointer)((1<<2)+2)) // makeint(1)
#define SUBR_SPECIAL    ((pointer)((2<<2)+2)) // makeint(2)
#define SUBR_ENTRY      ((pointer)((3<<2)+2)) // makeint(3)
 
/* stack frame types (lots more)*/
#define BLOCKFRAME      ((pointer)((0<<2)+2)) // makeint(0)
#define TAGBODYFRAME    ((pointer)((1<<2)+2)) // makeint(1)
 
/*vector element types*/
#define ELM_FIXED       0
#define ELM_BIT         1
#define ELM_CHAR        2
#define ELM_BYTE        3
#define ELM_INT         4
#define ELM_FLOAT       5
#define ELM_FOREIGN     6
#define ELM_POINTER     7
 
/* machine architecture dependent constants*/
/* MASK & long removes the MSB (sign bit) */
 
#if (WORD_SIZE == 64)
#define MASK 0x7fffffffffffffff
#define MSB  0x8000000000000000
#else
#define MASK 0x7fffffff
#define MSB  0x80000000
#endif
 
/****************************************************************/
/* configuration constants                                      */
/****************************************************************/
 
#define DEFAULTCHUNKINDEX       16      /*fib2(12)=754*/
#define MAXBUDDY        40      /*fib(30) is big enough*/
        /*MAXBUDDY must be smaller than 2^bix, where bix is 6bit, 
         63 at most.
         fib(29) nealy equals to 2.4M,
         fib(30) to 4M words*/
#define MAXTHRBUDDY     6       /*small free cells cached thread-locally*/
#define MAXSTACK        8388608 /* patched: default stack size 16bit -> 23bit, can be expanded by sys:newstack*/
#define SYMBOLHASH      60      /*initial obvector size in package*/
#define MAXCLASS        4096    /* by M.Inaba from 64 */
#define KEYWORDPARAMETERLIMIT 128       /* patched: default keyword size 32->128 */
#define ARRAYRANKLIMIT  7       /*minimal requirement for CommonLisp*/
#define MAXTHREAD       64      /*maximum number of threads*/
#define MAX_SPECIALS    512     /*maximum number of special variables*/
#if (WORD_SIZE == 64)
#define MAXPOSFIXNUM (0x1fffffffffffffff)
#define MINNEGFIXNUM (0xe000000000000000)
#else
#define MAXPOSFIXNUM (0x1fffffff)
#define MINNEGFIXNUM (0xe0000000)
#endif
 
/* type definitions:
        bix is buddy index,
        and cix is class index, which is sometimes refered as cid */
 
typedef unsigned char byte;
typedef unsigned short word;    /*seldom used*/
typedef struct cell *pointer;
 
#ifdef RGC
#include "external_markbits.h"
#include "time.h"
#include "collector.h"
#else
#define GC_POINT
#define GC_REGION(cmp_statement) cmp_statement
#endif
 
struct cellheader {
  unsigned mark:1;      /* GC mark*/
  unsigned b:1;         /* buddy: indicates the side in which its buddy should be found */
  unsigned m:1;         /* memory: records b or m of parent cell when it's split*/
  unsigned smark:1;     /* shared mark*/
  unsigned pmark:1;     /* print mark*/
  unsigned elmtype:3;
  unsigned nodispose:1;
#ifdef RGC
  unsigned bix:7;
#else
  unsigned extra:1;
  unsigned bix:6;               /*5 bits are enough*/
#endif
  short    cix;};       /*8 bits may be enough*/
 
/****************************************************************/
/* struct definition for lisp object cell
/****************************************************************/
struct cons {
    pointer car,        /*cons is made of a car and a cdr*/
            cdr;};      /*what a familiar structure!*/
 
struct propertied_object {
    pointer plist;};
 
struct symbol {
    pointer plist,      /*inherited from prop_obj*/
            speval,
            vtype,      /*const,var,special*/
            spefunc,
            pname,
            homepkg;};
 
struct string {         /*resembles with vector*/
    pointer length;     /*boxed*/
    byte chars[1];};    /*long word aligned*/
 
struct foreign {
    pointer length;
    byte *chars; };
 
struct package {
    pointer plist;
    pointer names;      /*package name at car, nicknames in cdr*/
    pointer use;        /*spreaded use-package list*/
    pointer symvector;  /*hashed obvector*/
    pointer symcount;   /*number of interned symbols in this package*/
    pointer intsymvector;
    pointer intsymcount;
    pointer shadows;
    pointer used_by;
    };
 
struct code {
    pointer codevec;
    pointer quotevec;
    pointer subrtype;   /*function,macro,special*/
    pointer entry;      /*offset from beginning of codevector*/
#if ARM
    pointer entry2;     /* some archtecture did not set code on 4 byte alignment */
#endif
    };
 
struct fcode {          /*foreign function code*/
    pointer codevec;
    pointer quotevec;
    pointer subrtype;
    pointer entry;
  pointer entry2;    /* kanehiro's patch 2000.12.13 */
    pointer paramtypes;
    pointer resulttype;};
 
struct ldmodule {       /*foreign language object module*/
    pointer codevec;
    pointer quotevec;
    pointer subrtype;   /*function,macro,special*/
    pointer entry;
#if ARM
    pointer entry2;     /* some archtecture did not set code on 4 byte alignment */
#endif
    pointer symtab;
    pointer objname;
    pointer handle;};   /* dl's handle */
 
struct closure {
    pointer codevec;
    pointer quotevec;
    pointer subrtype;   /*function,macro,special*/
    pointer entry;      /*offset from beginning of codevector*/
#if ARM
    pointer entry2;     /* some archtecture did not set code on 4 byte alignment */
#endif
    pointer env0;       /*upper closure link*/
    pointer *env1;      /*argument pointer:     argv*/
    pointer *env2;};    /*local variable frame: local*/
 
struct stream {
    pointer plist;
    pointer direction;
    pointer buffer;
    pointer count;
    pointer tail;};
 
struct filestream {
    pointer plist;
    pointer direction;
    pointer buffer;
    pointer count;
    pointer tail;
    pointer fd;
    pointer fname;};
 
struct iostream {
    pointer plist;
    pointer in,out;};
 
struct labref {         /*used for reading labeled forms: #n#,#n=*/
    pointer label;
    pointer value;
    pointer unsolved;
    pointer next; };
 
struct vector {
    pointer size;
    pointer v[1];};
 
struct intvector {
    pointer length;
    eusinteger_t iv[1];};
 
struct floatvector {
    pointer length;
    eusfloat_t fv[1];};
 
struct arrayheader {
  pointer plist;
  pointer entity,
          rank,
          fillpointer,
          offset,
          dim[ARRAYRANKLIMIT];};
 
/* structs for object oriented programming */
struct object {
  pointer iv[2];};      /*instance variables*/
 
struct _class {
  pointer plist;
  pointer name;         /*class name symbol*/
  pointer super;        /*super class*/
  pointer cix;
  pointer vars;         /*var names including inherited ones*/
  pointer types;
  pointer forwards;
  pointer methods;      /*method list*/
  };
 
struct vecclass {       /*vector class*/
  pointer plist;
  pointer name;
  pointer super;
  pointer cix;
  pointer vars;
  pointer types;
  pointer forwards;
  pointer methods;
  pointer elmtype;
  pointer size;};
 
struct readtable {
  pointer plist;
  pointer syntax;
  pointer macro;
  pointer dispatch;
  pointer readcase;};
 
struct threadport {
  pointer plist;
  pointer id;
  pointer requester;
  pointer reqsem;
  pointer runsem;
  pointer donesem;
  pointer func;
  pointer args;
  pointer result;
  pointer contex;
  pointer idle;
  pointer wait;};
 
/* extended numbers */
struct ratio {
  pointer numerator;
  pointer denominator;};
 
struct complex {
  pointer real;
  pointer imaginary;};
 
struct bignum {
  pointer size;
  pointer bv;}; /*bignum vector*/
 
/****************************************************************/
typedef 
  struct cell {
#if vax || sun4 || news || mips || alpha || Linux
    unsigned mark:1;
    unsigned b:1;
    unsigned m:1;
    unsigned smark:1;
    unsigned pmark:1;
    unsigned elmtype:3;
    unsigned nodispose:1;
#ifdef RGC
    unsigned bix:7;
#else
    unsigned extra:1;
    unsigned bix:6;
#endif
#endif
    short cix;
    union cellunion {
      struct cons cons;
      struct symbol sym;
      struct string str;
      struct foreign foreign;
      struct package pkg;
      struct stream stream;
      struct filestream fstream;
      struct iostream iostream;
      struct code code;
      struct fcode fcode;
      struct ldmodule ldmod;
      struct closure clo;
      struct labref lab;
      struct arrayheader ary;
      struct vector vec;
      struct floatvector fvec;
      struct intvector ivec;
      struct object obj;
      struct _class cls;
      struct vecclass vcls;
      struct readtable rdtab;
      struct threadport thrp;
      struct ratio ratio;
      struct complex cmplx;
      struct bignum  bgnm;
      } c;
    } cell;
 
typedef 
  union numunion {
    eusfloat_t   fval;
    eusinteger_t ival;
#if vax
    struct {short low,high;} sval;
#endif
/*    struct { signed sival:30; unsigned tag:2;} tval; */
    } numunion;
 
/* buddy cell */
struct bcell {
    struct cellheader h;
    union {
      struct bcell *nextbcell;
      struct cell  *c[2];} b;} /* bcell */;
 
typedef struct bcell *bpointer;
 
struct chunk {
  struct chunk *nextchunk;
  int chunkbix;
  struct bcell rootcell;};
 
typedef struct {
        short cix;
        short sub;} cixpair;
 
enum ch_type {
        ch_illegal,
        ch_white,
        ch_comment,
        ch_macro,
        ch_constituent,
        ch_sglescape,
        ch_multiescape,
        ch_termmacro,
        ch_nontermacro};
 
enum ch_attr {
        alphabetic,package_marker,illegal,alphadigit};
 

/****************************************************************/
/* stack frames and context
/****************************************************************/
struct callframe {
  struct  callframe *vlink;
  pointer form;
  };
 
struct bindframe {      /*to achieve lexical binding in the interpreter*/
  struct  bindframe *dynblink, *lexblink;       /*links to upper level*/
  pointer sym;          /*symbol*/
  pointer val;};        /*bound value*/
 
struct specialbindframe {       /*special value binding frame*/
  struct  specialbindframe *sblink;
  pointer sym;          /*pointer to the symbol word(dynval or dynfunc)*/
  pointer oldval;};
 
struct blockframe {
  pointer kind;
  struct  blockframe *dynklink,*lexklink;
  pointer name;
  jmp_buf *jbp;};
 
struct catchframe {
  struct  catchframe *nextcatch;
  pointer label;
  struct  bindframe *bf;        /*bind frame save*/
  struct  callframe *cf;        /*call frame save*/
  struct  fletframe *ff;
  jmp_buf *jbp;
  };
 
struct protectframe {
  struct protectframe *protlink;
  pointer cleaner;      /*cleanup form closure*/
  };
 
struct  fletframe {
  pointer name;
  pointer fclosure;
  struct  fletframe *scope;
  struct  fletframe *lexlink;
  struct  fletframe *dynlink;};
 
#define MAXMETHCACHE 256 /*must be power to 2*/
 
struct methdef {
  pointer selector,class,ownerclass,method;
  } /*methcache[MAXMETHCACHE]*/; 
 
/* thread context */
 
typedef struct {
        pointer *stack, *vsp,*stacklimit;
#ifdef RGC
    pointer *gcstack, *gsp, *gcstacklimit;
#endif
        struct  callframe       *callfp;
        struct  catchframe      *catchfp;
        struct  bindframe       *bindfp;
        struct  specialbindframe *sbindfp;
        struct  blockframe      *blkfp;
        struct  protectframe    *protfp;
        struct  fletframe       *fletfp, *newfletfp;
        pointer lastalloc;
        pointer errhandler;
        pointer threadobj;
        struct  methdef         *methcache;
        struct  buddyfree       *thr_buddy;
        int     alloc_big_count;
        int     alloc_small_count;
        int     special_bind_count;
        int     slashflag;
        pointer specials;
        int     intsig;
#ifdef __RETURN_BARRIER
    rbar_t rbar;  /* some extra words are needed? */
#else
        long    extra[10];      /* 32 long words */
#endif
#ifdef __GC_ALLOC_DRIVEN
    int my_gc_pri;
#endif
        }
        context;
 
/****************************************************************
/* memory and class management structures
/****************************************************************/
extern long buddysize[MAXBUDDY+1];
 
extern struct buddyfree {
  int count;    /*number of free cells*/
  bpointer bp;}  buddy[MAXBUDDY+1];
 
struct class_desc {     /* per- class descripter */
  short cix;
  short subcix;
  pointer def; };
 
struct built_in_cid {
  pointer cls;
  cixpair *cp; };
 
#if THREADED
#include "eus_thr.h"    /* thread definition by APT */
#endif
 

/****************************************************************/
/* global variables for eus
/*      date:   1986-Apr
/*      1987-Apr
/****************************************************************/
/* process id and program name*/
extern eusinteger_t mypid;
extern char *progname;
 
/* heap management */
/* every free cell is linked to the buddybase structure*/
extern struct buddyfree buddy[MAXBUDDY+1];
extern struct chunk *chunklist;
extern char *maxmemory;
extern long freeheap, totalheap;        /*size of heap left and allocated*/
 
/* memory management timers for performance evaluation */
extern long gccount,marktime,sweeptime;
extern long alloccount[MAXBUDDY];
 
/* System internal objects are connected to sysobj list
/* to protect from garbage-collection */
extern pointer sysobj;
extern pointer lastalloc;
 
/* thread euscontexts */
extern context *euscontexts[MAXTHREAD];
 
/****************************************************************/
/* system defined (built-in) class index
/*      modified to accept  dynamic type extension (1987-Jan)
/****************************************************************/
 
extern cixpair objectcp;
extern cixpair conscp;
extern cixpair propobjcp;
extern cixpair lockablecp;
extern cixpair symbolcp;
extern cixpair packagecp;
extern cixpair streamcp;
extern cixpair filestreamcp;
extern cixpair iostreamcp;
extern cixpair metaclasscp;
extern cixpair vecclasscp;
extern cixpair codecp;
extern cixpair fcodecp;
/*cixpair modulecp; */
extern cixpair ldmodulecp;
extern cixpair closurecp;
extern cixpair labrefcp;
extern cixpair threadcp;
extern cixpair arraycp;
extern cixpair readtablecp;
extern cixpair vectorcp;
extern cixpair fltvectorcp;
extern cixpair intvectorcp;
extern cixpair stringcp;
extern cixpair bitvectorcp;
/*extended numbers*/
extern cixpair extnumcp;
extern cixpair ratiocp;
extern cixpair complexcp;
extern cixpair bignumcp;
 
extern struct built_in_cid  builtinclass[64];
extern int nextbclass;
 

/*symbol management*/
extern pointer pkglist,lisppkg,keywordpkg,userpkg,syspkg,unixpkg,xpkg;
extern pointer NIL,PACKAGE,T,QUOTE;
extern pointer FUNCTION;
extern pointer QDECLARE,QSPECIAL;
#if SunOS4_1 /* SELF is already used on SunOS 4.1.x. */
extern pointer QSELF;
#else
extern pointer SELF;
#endif
extern pointer CLASS;
extern pointer STDIN,STDOUT,ERROUT,QSTDIN,QSTDOUT,QERROUT;
extern pointer QINTEGER,QFIXNUM,QFLOAT,QNUMBER;
extern pointer TOPLEVEL,QEVALHOOK,ERRHANDLER;
extern pointer QGCHOOK, QEXITHOOK;
extern pointer QUNBOUND,QDEBUG;
extern pointer QTHREADS;
extern pointer QEQ,QEQUAL,QNOT;
extern pointer QAND, QOR, QNOT;
 
/*memory management parameters*/
extern pointer GCMERGE,GCMARGIN;
 
/* keywords */
extern pointer K_IN,K_OUT,K_IO; /*direction keyword*/
extern pointer K_FLUSH,K_FILL,K_FILE,K_STRING;
extern pointer K_NOMETHOD,K_BIT,K_BYTE,K_CHAR,K_SHORT,K_LONG,K_INTEGER,K_POINTER;
extern pointer K_FLOAT32,K_FLOAT,K_DOUBLE,K_FOREIGN, K_FOREIGN_STRING;
extern pointer K_DOWNCASE,K_UPCASE, K_PRESERVE, K_INVERT, K_CAPITALIZE;
 
/*class management*/
extern struct class_desc classtab[MAXCLASS];
extern int nextcix;
 
/*class cells*/
extern pointer C_CONS, C_OBJECT, C_SYMBOL, C_PACKAGE;
extern pointer C_STREAM, C_FILESTREAM, C_IOSTREAM, C_CODE, C_FCODE;
extern pointer C_LDMOD;
extern pointer C_VECTOR, C_METACLASS, C_CLOSURE, C_LABREF;
extern pointer C_THREAD;
extern pointer C_VCLASS, C_FLTVECTOR, C_INTVECTOR, C_STRING, C_BITVECTOR;
extern pointer C_FOREIGNCODE,C_ARRAY,C_READTABLE;
extern pointer C_EXTNUM, C_RATIO, C_COMPLEX, C_BIGNUM;
 
/*class names*/
extern pointer QCONS,STRING,STREAM,FILESTREAM,IOSTREAM,SYMBOL,  
        CODE, FCODE,LDMODULE, PKGCLASS,METACLASS,CLOSURE,LABREF;
extern pointer THREAD;
extern pointer VECTOR,VECCLASS,FLTVECTOR,INTVECTOR,OBJECT,READTABLE;
extern pointer FOREIGNCODE,ARRAY,BITVECTOR;
extern pointer EXTNUM, RATIO, COMPLEX, BIGNUM;
 
/*toplevel & evaluation control*/
extern int intsig; /*0:no signal, 1-32:pending, -1:in progress*/
extern int intcode;
extern int ehbypass;
 
/*reader variables*/
extern pointer charmacro[256];
extern pointer sharpmacro[256];
extern int export_all;

/****************************************************************/
/* macro definition for euslisp
/****************************************************************/
 
#ifdef RGC
#define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error(E_DUMMY5,(pointer)(err)))
#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error(E_DUMMY5,(pointer)(err)))
#define alloc rgc_alloc
#else
#define carof(p,err) (islist(p)?(p)->c.cons.car:(pointer)error(E_DUMMY3,(pointer)(err)))
#define cdrof(p,err) (islist(p)?(p)->c.cons.cdr:(pointer)error(E_DUMMY3,(pointer)(err)))
#define alloc gc_alloc
#endif
#define ccar(p) ((p)->c.cons.car)
#define ccdr(p) ((p)->c.cons.cdr)
#define cixof(p) ((p)->cix)
#define classof(p) (ispointer(p)?classtab[(p)->cix].def:(pointer)error(E_NOOBJECT))
#define subcixof(p) (classtab[(p)->cix].subcix)
#define speval(p) ((p)->c.sym.speval)
#define spevalof(p,x) (ctx->specials->c.vec.v[x])
#define Spevalof(p) (ctx->specials->c.vec.v[intval((p)->c.sym.vtype)])
#define SPEVALOF(p) (((p)->c.sym.vtype>=V_SPECIAL)? \
        ctx->specials->c.vec.v[intval((p)->c.sym.vtype)]: \
        (p)->c.sym.speval)
#define superof(p) ((p)->c.cls.super)
 
#if sun3 || apollo || (system5 && !alpha && !mips) || sanyo || vxworks || NEXT
#define makepointer(bp) ((pointer)((eusinteger_t)(bp) | 2))
#define isint(p) (!((eusinteger_t)(p) & 3))
#define isflt(p) (((eusinteger_t)(p) & 3)==1)
#define isnum(p) (((eusinteger_t)(p) & 2)==0)
#define numberp(p) (((isnum(p)) || (pisextnum(p)))) // predicates.c:NUMBERP
#define ispointer(p) ((eusinteger_t)(p) & 2)
#define makeint(v) ((pointer)(((eusinteger_t)v)<<2))
#define bpointerof(p) ((bpointer)((eusinteger_t)(p)-2))
#endif
 
#if vax || sun4 || news || mips || alpha || Linux
 
#define makepointer(bp) ((pointer)(bp))
// #define isint(p) (((euspointer_t)(p) & 3)==2) // org
#define isint(p)        ( (((euspointer_t)(p)&3)==2) || (((euspointer_t)(p)&0x3)==0x3) )
#define isflt(p) (((euspointer_t)(p) & 3)==1)
#define isnum(p) (((euspointer_t)(p) & 3))
#define numberp(p) (((isnum(p)) || (pisextnum(p)))) // predicates.c:NUMBERP
#define ispointer(p) (!((euspointer_t)(p) & 3))
// #define makeint(v) ((pointer)((((euspointer_t)(v))<<2)+2)) // org
#ifdef __cplusplus
extern "C" {
#endif
extern pointer makeint(eusinteger_t v);
#ifdef __cplusplus
}
#endif
 
#define bpointerof(p) ((bpointer)((euspointer_t)(p)))
#ifdef RGC
#define nextbuddy(p) ((bpointer)((euspointer_t)(p)+(buddysize[(p->h.bix)&TAGMASK]*sizeof(pointer))))
#else
#define nextbuddy(p) ((bpointer)((euspointer_t)(p)+(buddysize[p->h.bix]*sizeof(pointer))))
#endif
#ifndef __USE_MARK_BITMAP
#define marked(p)  (p->h.mark)
#define markon(p)  p->h.mark=1
#define markoff(p) p->h.mark=0
#endif
#endif
 
// #define intval(p) (((eusinteger_t)(p))>>2) // org
#ifdef __cplusplus
extern "C" {
#endif
extern eusinteger_t intval(pointer p);
#ifdef __cplusplus
}
#endif
#define ckintval(p) ((isint(p)||                                        \
                      (isbignum(p)&&                                    \
                       ((vecsize((p)->c.bgnm.bv)==1)||                  \
                        ((vecsize((p)->c.bgnm.bv)==2)&&((p)->c.bgnm.bv->c.ivec.iv[1]<2))))) \
                     ?intval(p):(eusinteger_t)error(E_NOINT))
#define bigintval(x) (isint(x)?intval(x):\
   (isbignum(x)?\
        ((vecsize((x)->c.bgnm.bv)>=2)?\
         (((x)->c.bgnm.bv->c.ivec.iv[1]<<(WORD_SIZE-1)) | ((x)->c.bgnm.bv->c.ivec.iv[0])): \
         ((x)->c.bgnm.bv->c.ivec.iv[0])):\
        (eusinteger_t)error(E_NOINT)) )
#define mkbigint(y) \
  (pointer)((((y)^((y)>>1))&(eusinteger_t)3<<(WORD_SIZE-3))?makebig1(y):makeint(y))
 
#define elmtypeof(p) (bpointerof(p)->h.elmtype)
#ifdef RGC
#define bixof(p) (bpointerof(p)->h.bix & TAGMASK)
#else
#define bixof(p) (bpointerof(p)->h.bix)
#endif
 
#if sun3 || sun4 || system5 || apollo || news || sanyo || vxworks || mips || NEXT || Linux
#if (WORD_SIZE == 64)
#define fltval(p) (nu.ival=((eusinteger_t)(p) & ~3L), nu.fval)
#define makeflt(f) (nu.fval=(eusfloat_t)(f), (pointer)((nu.ival & ~3L) | 1L))
#else
#define fltval(p) (nu.ival=((eusinteger_t)(p) & ~3), nu.fval)
#define makeflt(f) (nu.fval=(eusfloat_t)(f), (pointer)((nu.ival & ~3) | 1))
#endif
 
/*#if GCC
#define makeflt(f) (nu.fval=(f), (pointer)((nu.ival & (~2)) | 1)) 
#define makeflt(f) (nu.fval=(f),nu.tval.tag=1,(pointer)(nu.ival))
#endif */
 
#define ckfltval(p) (isflt(p)?fltval(p):\
        (isint(p)?intval(p):\
        (pisbignum(p)?big_to_float(p):\
        (pisratio(p)?ratio2flt(p):\
        (eusinteger_t)error(E_NONUMBER)))))
#endif
 
/*predicates to test object type*/
#define pislist(p)  (p->cix<=conscp.sub)
#define piscons(p)  (p->cix<=conscp.sub)
#define pispropobj(p) (propobjcp.cix<=(p)->cix && (p)->cix<=propobjcp.sub)
#define ispropobj(p) (ispointer(p) && pispropobj(p))
#define pissymbol(p) (symbolcp.cix<=(p)->cix && (p)->cix<=symbolcp.sub)
#define issymbol(p) (ispointer(p) && pissymbol(p))
#define pisstring(p)  (stringcp.cix<=(p)->cix && (p)->cix<=stringcp.sub)
#define isstring(p) (ispointer(p) && pisstring(p))
#define islist(p) (ispointer(p) && pislist(p))
#define iscons(p) (ispointer(p) && piscons(p))
#define piscode(p) (codecp.cix<=(p)->cix && (p)->cix<=codecp.sub)
#define iscode(p) (ispointer(p) && piscode(p))
#define pisfcode(p) (fcodecp.cix<=(p)->cix && (p)->cix<=fcodecp.sub)
#define isfcode(p) (ispointer(p) && pisfcode(p))
#define pisldmod(p) (ldmodulecp.cix<=(p)->cix && (p)->cix<=ldmodulecp.sub)
#define isldmod(p) (ispointer(p) && pisldmod(p))
#define pisstream(p) (streamcp.cix<=(p)->cix && (p)->cix<=streamcp.sub)
#define isstream(p) (ispointer(p) && pisstream(p))
#define pisfilestream(p) (filestreamcp.cix<=(p)->cix && (p)->cix<=filestreamcp.sub)
#define isfilestream(p) (ispointer(p) && pisfilestream(p))
#define pisiostream(p) (iostreamcp.cix<=(p)->cix && (p)->cix<=iostreamcp.sub)
#define isiostream(p) (ispointer(p) && pisiostream(p))
#define pisreadtable(p) (readtablecp.cix<=((p)->cix) && ((p)->cix)<=readtablecp.sub)
#define isreadtable(p) (ispointer(p) && pisreadtable(p))
#define pisarray(p) (arraycp.cix<=((p)->cix) && ((p)->cix)<=arraycp.sub)
#define isarray(p) (ispointer(p) && pisarray(p))
#define pisvector(p) (elmtypeof(p))
#define isvector(p) (ispointer(p) && pisvector(p))
#define isfltvector(p) (ispointer(p) && (elmtypeof(p)==ELM_FLOAT))
#define isptrvector(p) (ispointer(p) && (elmtypeof(p)==ELM_POINTER))
#define isintvector(p) (ispointer(p) && (elmtypeof(p)==ELM_INT))
#define pisclass(p) (metaclasscp.cix<=(p)->cix && (p)->cix<=metaclasscp.sub)
#define isclass(p) (ispointer(p) && pisclass(p))
#define pisvecclass(p) (vecclasscp.cix<=(p)->cix && (p)->cix<=vecclasscp.sub)
#define isvecclass(p) (ispointer(p) && pisvecclass(p))
#define pispackage(p) (packagecp.cix<=(p)->cix && (p)->cix<=packagecp.sub)
#define ispackage(p) (ispointer(p) && pispackage(p))
#define pisclosure(p) (closurecp.cix<=(p)->cix && (p)->cix<=closurecp.sub)
#define isclosure(p) (ispointer(p) && pisclosure(p))
#define pislabref(p) (labrefcp.cix<=(p)->cix && (p)->cix<=labrefcp.sub)
#define islabref(p) (ispointer(p) && pislabref(p))
/* extended numbers */
#define pisextnum(p) (extnumcp.cix<=(p)->cix && (p)->cix<=extnumcp.sub)
#define isextnum(p) (ispointer(p) && pisextnum(p))
#define pisratio(p) (ratiocp.cix<=(p)->cix && (p)->cix<=ratiocp.sub)
#define isratio(p) (ispointer(p) && pisratio(p))
#define piscomplex(p) (complexcp.cix<=(p)->cix && (p)->cix<=complexcp.sub)
#define iscomplex(p) (ispointer(p) && piscomplex(p))
#define pisbignum(p) (bignumcp.cix<=(p)->cix && (p)->cix<=bignumcp.sub)
#define isbignum(p) (ispointer(p) && pisbignum(p))
 
#define strlength(p) ((int)intval((p)->c.str.length))
#define vecsize(p) ((int)intval((p)->c.vec.size))
#define objsize(p) ((int)vecsize(classof(p)->c.cls.vars))
 
/* bignum */
#define bigsize(x) vecsize((x)->c.bgnm.bv)
#define bigvec(x) (x)->c.bgnm.bv->c.ivec.iv
 
/*stack*/
#define current_ctx (euscontexts[thr_self()])
#ifdef STACK_DEBUG
#define vpush(v) (*ctx->vsp++=p_print((pointer)(v),ctx))
#define vpop() (printf("vpop:[0x%lx]=0x%lx\n",ctx->vsp-1,(ctx->vsp)[-1]),*(--(ctx->vsp)))
#else
#define vpush(v) (*ctx->vsp++=((pointer)v))
#define vpop() (*(--(ctx->vsp)))
#endif
#define ckpush(v) (ctx->vsp<ctx->stacklimit?vpush(v):(pointer)error(E_STACKOVER))
 
#define ckarg(req) if (n!=(req)) error(E_MISMATCHARG)
#define ckarg2(req1,req2) if ((n<(req1))||((req2)<n)) error(E_MISMATCHARG)
 
#define breakck if (ctx->intsig>0) sigbreak()
#define stackck if (ctx->vsp>ctx->stacklimit) error(E_STACKOVER)
#define debug (speval(QDEBUG)!=NIL)
 
#ifndef RGC
#define pointer_update(l,r) { (l)=(r); }
#define take_care(p)
 
#endif
 

/****************************************************************/
/* error code definition
/*      1986-Jun-17
/****************************************************************/
 
enum errorcode {
/* first 10 codes are fatal errors */
  E_NORMAL,             /*0*/
  E_STACKOVER,          /*stack overflow*/
  E_ALLOCATION,
#ifdef RGC
  E_GCSTACKOVER,
  E_PSTACKOVER,
#else
  E_DUMMY3,
  E_DUMMY4,
#endif
  E_DUMMY5,
  E_DUMMY6,
  E_DUMMY7,
  E_DUMMY8,
  E_DUMMY9,
  E_DUMMY10,
#define E_FATAL 10
/* followings are not fatal errors */
  E_SETCONST,           /*11 attempt to set to constant*/
  E_UNBOUND,
  E_UNDEF,
  E_MISMATCHARG,
  E_ILLFUNC,
  E_ILLCH,
  E_READ,
  E_WRITE,
  E_LONGSTRING,         /*19: string too long*/
  E_NOSYMBOL,           /*20: symbol expected*/
  E_NOLIST,             /*list expected*/
  E_LAMBDA,             /*illegal lambda form*/
  E_PARAMETER,          /*illegal lambda parameter syntax*/  
  E_NOCATCHER,          /*no catch block */
  E_NOBLOCK,            /*no block to return*/
  E_STREAM,             /*stream expected*/
  E_IODIRECTION,        /*io stream direction keyword*/
  E_NOINT,              /*integer value expected*/
  E_NOSTRING,           /*string expected*/
  E_OPENFILE,           /*30: error in open*/
  E_EOF,                /*EOF encountered*/
  E_NONUMBER,           /*number expected*/
  E_CLASSOVER,          /*class table overflow*/
  E_NOCLASS,            /*class expected*/
  E_NOVECTOR,           /*vector expected*/
  E_VECSIZE,            /*error of vector size*/
  E_DUPOBJVAR,          /*duplicated object variable name*/
  E_INSTANTIATE,        /*38: cannot make an instance*/
  E_ARRAYINDEX,
  E_NOMETHOD,           /*40*/
  E_CIRCULAR,
  E_SHARPMACRO,         /*unknown sharp macro*/
  E_ALIST,              /*list expected for an element of an alist*/
  E_NOMACRO,            /*macro expected*/
  E_NOPACKAGE,          /*no such package */
  E_PKGNAME,            /*the package already exists*/
  E_NOOBJ,              /*invalid form*/
  E_NOOBJVAR,           /*48: not an object variable*/
  E_NOSEQ,              /*sequence(list,string,vector) expected*/
  E_STARTEND,           /*illegal subsequence index*/
  E_NOSUPER,            /*no superclass*/
  E_FORMATSTRING,       /*invalid format string character*/
  E_FLOATVECTOR,        /*float vector expected*/
  E_CHARRANGE,          /*0..255*/
  E_VECINDEX,           /*vector index mismatch*/
  E_NOOBJECT,           /*other than numbers expected*/
  E_TYPEMISMATCH,       /*the: type mismatch*/
  E_DECLARE,            /*illegal declaration*/
  E_DECLFORM,           /*invalid declaration form*/
  E_NOVARIABLE,         /*constant is used in let or lambda*/
  E_ROTAXIS,            /*illegal rotation axis spec*/
  E_MULTIDECL,
  E_READLABEL,          /*illegal #n= or #n# label*/
  E_READFVECTOR,        /*error of #f( expression*/
  E_READOBJECT,         /*error in #V or #J format*/
  E_SOCKET,             /*error of socket address*/
  E_NOARRAY,            /*array expected*/
  E_ARRAYDIMENSION,     /*array dimension mismatch*/
  E_KEYPARAM,           /*keyword parameter expected*/
  E_NOKEYPARAM,         /*no such keyword*/
  E_NOINTVECTOR,        /*integer vector expected*/
  E_SEQINDEX,           /*sequence index out of range*/
  E_BITVECTOR,          /*not a bit vector*/
  E_EXTSYMBOL,          /*no such external symbol*/
  E_SYMBOLCONFLICT,     /*symbol conflict in a package*/
 
/* the following error is added by APT */
    E_USER,
 
/*  E_END must locate at the end of the error list */
    E_END
  };
 
/* function prototypes */
 
#ifdef __cplusplus
extern "C" {
#endif
/*eval*/
#if alpha || IRIX6 || Solaris2 || Linux || Cygwin
#include "eus_proto.h"
#else
extern pointer eval(context *, pointer);
extern pointer eval2(context *, pointer, pointer);
extern pointer ufuncall(context *, pointer, pointer, pointer,
                         struct bindframe *, int);
extern pointer funlambda(context *, pointer, pointer, pointer, pointer *,
                         struct bindframe *, int);
extern pointer funcode(context *, pointer, pointer, int);
extern pointer progn(context *, pointer);
extern pointer csend(context *, ...);
extern pointer getval(context *, pointer);
extern pointer setval(context *, pointer, pointer);
extern pointer getfunc(context *, pointer);
extern struct  bindframe *declare(context *, pointer, struct bindframe *);
extern struct  bindframe *vbind(context *, pointer, pointer,
                                 struct bindframe *, struct bindframe*);
extern struct  bindframe *fastbind(context *, pointer, pointer,
                                struct bindframe *);
extern void bindspecial(context *, pointer, pointer);
extern void unbindspecial(context *, struct specialbindframe *);
extern struct bindframe *bindkeyparams(context *, pointer, pointer *,
                        int, struct bindframe *, struct bindframe *);
 
extern pointer Getstring();
extern pointer findpkg();
extern pointer memq();
 
/*allocater*/
extern pointer alloc(int, int, int, int);
extern pointer makebuffer(int);
extern pointer makevector(pointer, int);
extern pointer makeclass(context *, pointer, pointer, pointer,pointer, pointer,
                        int, pointer);
extern pointer makecode(pointer, pointer(*)(), pointer);
extern pointer makematrix(context *, int, int);
extern pointer makeobject(pointer);
extern pointer rawcons(context *, pointer, pointer);
extern pointer cons(context *, pointer, pointer);
extern pointer makestring(char *, int);
extern pointer findsymbol(unsigned char *, int, pointer, int *);
extern pointer makesymbol(context *, char *, int, pointer);
extern pointer intern(context *, char *, int, pointer);
extern pointer makepkg(context *, pointer, pointer, pointer);
extern pointer mkstream(context *, pointer, pointer);
extern pointer mkfilestream(context *, pointer,pointer,int,pointer);
extern pointer mkiostream(context *, pointer,pointer);
extern pointer makemodule(context *, int);
extern pointer makebig1(long);
extern pointer eusfloat_to_big(float);
extern eusfloat_t big_to_float(pointer);
extern pointer defun(context *, char *, pointer, pointer(*)(), char *);
extern pointer defmacro(context *, char *, pointer, pointer(*)());
extern pointer defspecial(context *, char *, pointer, pointer(*)());
extern pointer defunpkg(context *, char *, pointer, pointer(*)(),pointer);
extern void addcmethod(context *, pointer, pointer (*)(),
                                 pointer, pointer, pointer);
extern pointer defkeyword(context *, char *);
extern pointer defvar(context *, char *, pointer, pointer);
extern pointer deflocal(context *, char *, pointer, pointer);
extern pointer defconst(context *, char *, pointer, pointer);
extern pointer stacknlist(context *, int);
#endif
 
#if THREADED
extern pointer makethreadport(context *);
#endif
 
/*boxing,unboxing*/
#if vax
extern float fltval(),ckfltval(),bit_to_float();
extern pointer makeflt();
#else
#ifndef makeflt
extern pointer makeflt();
#endif
#endif
 
#if !alpha && !IRIX6
/*io*/
extern pointer reader(context *, pointer, pointer);
extern pointer prinx(context *, pointer, pointer);
 
/*for compiled code*/
extern pointer makeclosure(pointer,pointer,pointer(*)(),pointer, pointer*, pointer*);
extern pointer fcall();
extern pointer xcar(pointer), xcdr(pointer), xcadr(pointer);
extern pointer *ovafptr(pointer,pointer);
#endif
 
/* mutex locks*/
#if Solaris2 || SunOS4_1
extern mutex_t  mark_lock;
extern char     *mark_locking;
extern int      mark_lock_thread;
extern mutex_t  p_mark_lock;
extern rwlock_t gc_lock;
 
extern mutex_t  alloc_lock;
extern mutex_t  free_thread_lock;
extern mutex_t  qthread_lock;
extern mutex_t  qsort_lock;
extern sema_t   free_thread_sem;
#endif
#ifdef __cplusplus
}
#endif
 
extern eusinteger_t hide_ptr (pointer p);