1 /* object.h: The Scheme object representation, and a few other important 2 * data types. 3 * 4 * $Id$ 5 * 6 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin 7 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris 8 * 9 * This software was derived from Elk 1.2, which was Copyright 1987, 1988, 10 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written 11 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project 12 * between TELES and Nixdorf Microprocessor Engineering, Berlin). 13 * 14 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co- 15 * owners or individual owners of copyright in this software, grant to any 16 * person or company a worldwide, royalty free, license to 17 * 18 * i) copy this software, 19 * ii) prepare derivative works based on this software, 20 * iii) distribute copies of this software or derivative works, 21 * iv) perform this software, or 22 * v) display this software, 23 * 24 * provided that this notice is not removed and that neither Oliver Laumann 25 * nor Teles nor Nixdorf are deemed to have made any representations as to 26 * the suitability of this software for any purpose nor are held responsible 27 * for any defects of this software. 28 * 29 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE. 30 */ 31 32 #include <stdio.h> 33 #include <stdlib.h> 34 35 typedef struct { 36 int64_t data; 37 int tag; 38 } Object; 39 40 #define FIXBITS (8 * (int)sizeof(int)) 41 #define SIGNBIT ((unsigned int)1 << (FIXBITS-1)) 42 #define CONSTBIT 1 43 #define TYPEBITS (8 * (int)sizeof(int) - 1) 44 #define MAX_TYPE ((1 << TYPEBITS) - 1) 45 46 #define UFIXNUM_FITS(i) (((i) & SIGNBIT) == 0) 47 #define FIXNUM_FITS(i) 1 48 49 #define TYPE(x) ((x).tag >> 1) 50 51 #define FIXNUM(x) ((int)(x).data) 52 #define CHAR(x) ((int)(x).data) 53 54 #define POINTER(x) ((void *)(uintptr_t)(x).data) 55 #define SETPOINTER(x,p) ((x).data = (uintptr_t)(void *)(p)) 56 #define SET(x,t,p) ((x).tag = (int)t << 1, (x).data = (p)) 57 58 #define ISCONST(x) ((x).tag & CONSTBIT) 59 #define SETCONST(x) ((x).tag |= CONSTBIT) 60 61 #define EQ(x,y) ((x).data == (y).data && (x).tag == (y).tag) 62 63 /* GC related macros: 64 */ 65 #define WAS_FORWARDED(obj) (TYPE(*(Object *)POINTER(obj)) == T_Broken_Heart) 66 #define UPDATE_OBJ(obj) SETPOINTER(obj, POINTER(*(Object *)POINTER(obj))) 67 68 #ifdef GENERATIONAL_GC 69 70 typedef int gcspace_t; /* type for space and type arrays */ 71 typedef uintptr_t gcptr_t; /* type for pointers */ 72 typedef uintptr_t pageno_t; /* type for page numbers */ 73 typedef uintptr_t addrarith_t; /* type for address arithmetic */ 74 75 extern gcspace_t *space; 76 extern gcspace_t current_space; 77 C_LINKAGE_BEGIN 78 extern int Visit (Object*); /* required for REVIVE_OBJ below */ 79 C_LINKAGE_END 80 81 # ifdef ARRAY_BROKEN 82 extern pageno_t pagebase; 83 # else 84 # define pagebase ((pageno_t)0) 85 # endif 86 87 # define PAGEBYTES 512 88 # define PAGE_TO_OBJ(p) ((Object *) (((p) + pagebase) * PAGEBYTES)) 89 # define OBJ_TO_PAGE(p) ((((gcptr_t)POINTER(p)) / PAGEBYTES) - pagebase) 90 # define STABLE(x) ((~space[(x)]) & 1) 91 # define MAKEOBJ(o,t,p) (SET(o, t, p)) 92 # define IS_ALIVE(obj) ((WAS_FORWARDED(obj)) || \ 93 (STABLE(OBJ_TO_PAGE(obj))) || \ 94 (space[OBJ_TO_PAGE(obj)] == current_space)) 95 # define REVIVE_OBJ(obj) Visit (&obj); 96 #else 97 C_LINKAGE_BEGIN 98 extern int Visit (Object*); /* required in heap.c */ 99 C_LINKAGE_END 100 # define IS_ALIVE(obj) WAS_FORWARDED(obj) 101 # define REVIVE_OBJ(obj) 102 #endif 103 104 /* Fixed types. Cannot use enum, because the set of types is extensible: 105 */ 106 #define T_Fixnum 0 /* Must be 0 */ 107 #define T_Bignum 1 108 #define T_Flonum 2 109 #define T_Null 3 /* empty list */ 110 #define T_Boolean 4 /* #t (1) and #f (0) */ 111 #define T_Unbound 5 /* only used internally */ 112 #define T_Special 6 /* only used internally */ 113 #define T_Character 7 114 #define T_Symbol 8 115 #define T_Pair 9 116 #define T_Environment 10 /* A pair */ 117 #define T_String 11 118 #define T_Vector 12 119 #define T_Primitive 13 /* Primitive procedure */ 120 #define T_Compound 14 /* Compound procedure */ 121 #define T_Control_Point 15 122 #define T_Promise 16 /* Result of (delay expression) */ 123 #define T_Port 17 124 #define T_End_Of_File 18 125 #define T_Unspecified 19 /* only used internally */ 126 #define T_Autoload 20 127 #define T_Macro 21 128 #define T_Broken_Heart 22 /* only used internally */ 129 #ifdef GENERATIONAL_GC 130 # define T_Align_8Byte 23 /* only used internally */ 131 # define T_Freespace 24 /* only used internally */ 132 #endif 133 134 #define BIGNUM(x) ((struct S_Bignum *)POINTER(x)) 135 #define FLONUM(x) ((struct S_Flonum *)POINTER(x)) 136 #define STRING(x) ((struct S_String *)POINTER(x)) 137 #define VECTOR(x) ((struct S_Vector *)POINTER(x)) 138 #define SYMBOL(x) ((struct S_Symbol *)POINTER(x)) 139 #define PAIR(x) ((struct S_Pair *)POINTER(x)) 140 #define PRIM(x) ((struct S_Primitive *)POINTER(x)) 141 #define COMPOUND(x) ((struct S_Compound *)POINTER(x)) 142 #define CONTROL(x) ((struct S_Control *)POINTER(x)) 143 #define PROMISE(x) ((struct S_Promise *)POINTER(x)) 144 #define PORT(x) ((struct S_Port *)POINTER(x)) 145 #define AUTOLOAD(x) ((struct S_Autoload *)POINTER(x)) 146 #define MACRO(x) ((struct S_Macro *)POINTER(x)) 147 148 typedef uint16_t gran_t; /* Granularity of bignums */ 149 150 struct S_Bignum { 151 Object minusp; 152 unsigned int size; /* Number of uint16_t allocated */ 153 unsigned int usize; /* Number of uint16_t actually used */ 154 gran_t data[1]; /* Data, lsw first */ 155 }; 156 157 struct S_Flonum { 158 Object tag; /* Each S_Foo must start with an Object */ 159 double val; 160 }; 161 162 struct S_Symbol { 163 Object value; 164 Object next; 165 Object name; /* A string */ 166 Object plist; 167 }; 168 169 struct S_Pair { 170 Object car, cdr; 171 }; 172 173 struct S_String { 174 Object tag; 175 unsigned int size; 176 char data[1]; 177 }; 178 179 struct S_Vector { 180 Object tag; 181 unsigned int size; 182 Object data[1]; 183 }; 184 185 enum discipline { EVAL, NOEVAL, VARARGS }; 186 struct S_Primitive { 187 Object tag; 188 Object (*fun) (); 189 const char *name; 190 int minargs; 191 int maxargs; /* Or MANY */ 192 enum discipline disc; 193 }; 194 #define MANY 100 195 196 struct S_Compound { 197 Object closure; /* (lambda (args) form ...) */ 198 Object env; /* Procedure's environment */ 199 int min_args, max_args; 200 int numforms; 201 Object name; 202 }; 203 204 typedef struct wind { 205 struct wind *next, *prev; 206 Object inout; /* Pair of thunks */ 207 } WIND; 208 209 typedef struct funct { 210 struct funct *next; 211 char *name; 212 void (*func) (void); 213 } FUNCT; 214 215 typedef struct gcnode { 216 struct gcnode *next; 217 int gclen; 218 Object *gcobj; 219 } GCNODE; 220 221 typedef struct mem_node { 222 struct mem_node *next; 223 unsigned int len; 224 unsigned long int refcnt; 225 } MEM_NODE; 226 227 #if defined(vax) || defined(__vax__) 228 typedef int jmp_buf[17]; 229 #else 230 # include <setjmp.h> 231 #endif 232 233 struct S_Control { 234 Object env; 235 GCNODE *gclist; 236 MEM_NODE *memlist; 237 Object memsave; /* string */ 238 Object gcsave; /* vector */ 239 WIND *firstwind, *lastwind; 240 int tailcall; 241 intptr_t delta; 242 #ifdef GENERATIONAL_GC 243 int reloc; 244 #endif 245 jmp_buf j; 246 unsigned int size; 247 unsigned long int intrlevel; 248 char stack[1]; /* must be word aligned */ 249 }; 250 251 struct S_Promise { 252 Object env; 253 Object thunk; 254 int done; 255 }; 256 257 struct S_Port { 258 Object name; /* string */ 259 uint16_t flags; 260 char unread; 261 unsigned int ptr; 262 FILE *file; 263 unsigned int lno; 264 int (*closefun) (FILE*); 265 }; 266 #define P_OPEN 1 /* flags */ 267 #define P_INPUT 2 268 #define P_STRING 4 269 #define P_UNREAD 8 270 #define P_BIDIR 16 271 272 #define IS_INPUT(port) (PORT(port)->flags & (P_INPUT|P_BIDIR)) 273 #define IS_OUTPUT(port) ((PORT(port)->flags & (P_INPUT|P_BIDIR)) != P_INPUT) 274 275 struct S_Autoload { 276 Object files; 277 Object env; 278 }; 279 280 struct S_Macro { 281 Object body; 282 int min_args, max_args; 283 Object name; 284 }; 285 286 287 /* "size" is called with one object and returns the size of the object. 288 * If "size" is NOFUNC, then "const_size" is taken instead. 289 * "eqv" and "equal" are called with two objects and return 0 or 1. 290 * NOFUNC may be passed instead (then eqv and equal always return #f). 291 * "print" is called with an object, a port, a flag indicating whether 292 * the object is to be printed "raw" (a la display), the print-depth, 293 * and the print-length. 294 * "visit" is called with a pointer to an object and a function. 295 * For each component of the object, the function must be called with 296 * a pointer to the component. NOFUNC may be supplied. 297 */ 298 typedef struct { 299 int haspointer; 300 const char *name; 301 int (*size) (Object); 302 int const_size; 303 int (*eqv) (Object, Object); 304 int (*equal) (Object, Object); 305 int (*print) (Object, Object, int, int, int); 306 int (*visit) (Object*, int (*)(Object*)); 307 } TYPEDESCR; 308 309 #ifdef ELK_USE_PROTOTYPES 310 # define NOFUNC 0 311 #else 312 # define NOFUNC ((int (*)())0) 313 #endif 314 315 316 typedef struct sym { 317 struct sym *next; 318 char *name; 319 unsigned long int value; 320 } SYM; 321 322 typedef struct { 323 SYM *first; 324 char *strings; 325 } SYMTAB; 326 327 typedef struct { 328 char *name; 329 int type; 330 } SYMPREFIX; 331 332 #define PR_EXTENSION 0 /* Elk extension initializers/finalizers */ 333 #define PR_CONSTRUCTOR 1 /* C++ static constructors/destructors */ 334 335 336 /* PFO, GENERIC, and MATCHFUN exist for backwards compatibility 337 */ 338 typedef Object (*PFO) (Object); 339 typedef int (*MATCHFUN) (); 340 #define GENERIC char* 341 342 typedef struct weak_node { 343 struct weak_node *next; 344 Object obj; 345 PFO term; 346 GENERIC group; 347 char flags; 348 } WEAK_NODE; 349 350 /* flags */ 351 #define WK_LEADER 1 352 353 354 typedef struct { 355 char *name; 356 unsigned long int val; 357 } SYMDESCR; 358 359 360 /* Function that can be registered as a reader by Define_Reader(): 361 */ 362 typedef Object (*READFUN) (Object, int, int); 363