1 /* -*- tab-width:4; -*- */ 2 /* 3 * My small scheme: include file 4 * 5 * $Id: s.h 1.49.1.61 Fri, 03 Mar 2000 01:32:32 +0100 crad $ 6 */ 7 #ifdef HAVE_CONFIG_H 8 #include <config.h> 9 #endif 10 11 #include <stdio.h> 12 #include <stdlib.h> 13 #include <stddef.h> 14 #include <errno.h> 15 #include <unistd.h> 16 #include <string.h> 17 #include <ctype.h> 18 #include <math.h> 19 #include <setjmp.h> 20 #include <limits.h> 21 22 #ifdef SCM_WITH_THREADS 23 # ifdef HAVE_LIBPTHREAD 24 # include <pthread.h> 25 # include <semaphore.h> 26 # include <signal.h> 27 # else 28 # error "No posix threads found" 29 # endif 30 #endif 31 32 #include <gmp.h> 33 34 #ifndef LONG_MIN 35 #define LONG_MIN 0x80000000 36 #endif 37 #ifndef LONG_MAX 38 #define LONG_MAX 0x7fffffff 39 #endif 40 41 #define NORETURN __attribute__ ((noreturn)) 42 #ifndef TRUE 43 #define TRUE 1 44 #define FALSE 0 45 #endif 46 47 typedef unsigned char Byte; 48 typedef unsigned long Ulong; 49 typedef unsigned int Uint; 50 51 #define Sobject struct _Sobject 52 typedef Sobject *SOBJ; 53 54 typedef SOBJ (*SCM_CPRIM)(); 55 56 #include "port.h" 57 58 /*-- table holding the primitives */ 59 typedef const struct { 60 void *address; /* the address to jump to */ 61 char *name; /* the print name of the opcode */ 62 short nargs; /* the number of args | -1 if var args */ 63 char following; /* number of compiled arguments 64 following this opcode */ 65 char terminates; /* true when this opcode terminates */ 66 char varargs; /* when 1, must have mark before call */ 67 } SCM_PRIM_TABLE; 68 69 /*-- environment frame struct: stored in the env heap and in the heap */ 70 71 #define SCM_EnvFrame struct _SCM_EnvFrame 72 SCM_EnvFrame { 73 SOBJ nslots; /* number of slots */ 74 SOBJ binding[1]; /* values */ 75 }; 76 77 #define SCM_EnvFrameHeaderSize (sizeof(SCM_EnvFrame) - sizeof(SOBJ)) 78 79 80 /*-- continuation frame structure, as stored on the stack */ 81 82 #define SCM_ContFrame struct _SCM_ContFrame 83 SCM_ContFrame { 84 SCM_ContFrame *next; /* pointer to next continuation */ 85 SOBJ env; /* pointer to environment */ 86 SOBJ *ip; /* pointer to next ip */ 87 }; 88 89 /*-- array structure */ 90 91 #define SCM_Array struct _SCM_Array 92 SCM_Array { 93 long size; /* the current size (nrof slots) */ 94 long alloced; /* the allocated size (nrof slots) */ 95 SOBJ item[1]; /* the first data slot is here :) */ 96 }; 97 98 /*-- code structure */ 99 100 #define SCM_Code struct _SCM_Code 101 SCM_Code { 102 SOBJ envlist; /* chain of env symbols */ 103 long size; /* number of instruction in code */ 104 short nargs; /* number of arguments */ 105 short optargs; /* flag: true if optionnal arguments */ 106 short nlocals; /* number of local variables */ 107 SOBJ code[1]; /* instructions follow here */ 108 }; 109 110 /*-- external function : used by dynamic loader */ 111 112 #define SCM_EF_MAX_ARGS 16 113 #define SCM_ExtFunc struct _SCM_ExtFunc 114 115 SCM_ExtFunc { 116 void *func; /* ptr to func */ 117 Byte func_type; /* ignored now: type of function (C assumed) */ 118 short return_t; /* return type */ 119 short argc; /* arg count */ 120 Byte vararg; /* variable argument flag */ 121 short arg_t[SCM_EF_MAX_ARGS]; /* argument type */ 122 }; 123 124 #define SCM_VarAux struct _SCM_VarAux 125 SCM_VarAux { 126 char *name; /* type name */ 127 SOBJ atom; /* type atom */ 128 int type; /* type of variable */ 129 int size; /* size in bytes */ 130 short align; /* alignement */ 131 SOBJ (*get)(SOBJ var, void *ptr); /* C getter */ 132 SOBJ getarg; /* Scheme getter */ 133 void (*set)(SOBJ var, void *ptr, SOBJ value); /* C setter */ 134 SOBJ setarg; /* Scheme setter */ 135 }; 136 /* NOTE: if type < 0: type is fully handled by get and set func. 137 * If type >= 0 and scm_type_hook[type] defines ext2obj and or obj2ext, 138 * data has to be converted by ext2obj() or obj2ext(). 139 */ 140 141 /*-- VM registers */ 142 #define SCM_vmRegisters struct _SCM_vmRegisters 143 SCM_vmRegisters { 144 SOBJ *sp; /* the stack pointer */ 145 SOBJ *ip; /* instruction pointer */ 146 SCM_ContFrame *cont; /* current continuation frame */ 147 SOBJ env; /* env chain */ 148 }; 149 150 /*-- VM interface */ 151 #define SCM_VMD struct _SCM_VMD 152 SCM_VMD { 153 int code; /* code */ 154 #ifdef SCM_WITH_THREADS 155 pthread_t tid; /* thread id */ 156 int tflags; /* thread flags */ 157 # define SCM_THREAD_FINISHED 1 /* thread has exited */ 158 # define SCM_THREAD_DETACHED 2 /* thread will be detached */ 159 # define SCM_THREAD_MAIN 4 /* main thread only */ 160 161 #endif 162 void *cstack_limit; /* top of the C stack for this thread */ 163 void *cstack_ptr; /* pointer to current sp. Only valid 164 after a SCM_SIG_SUSPEND signal has 165 been caught */ 166 167 SCM_vmRegisters reg; /* vm registers */ 168 169 jmp_buf errjmp; /* Where to restart in case of 170 exception. It should be the top 171 level return point. */ 172 173 SOBJ *stack_base; /* VM stack definition */ 174 SOBJ *stack_limit; 175 int stack_size; 176 177 SOBJ thunk; /* the thunk to execute when starting 178 a new thread */ 179 180 int signal; /* the signal got when suspended (THREADS)*/ 181 182 union { 183 int opcode; /* opcode, when requesting opcode :) */ 184 char *name; 185 void *addr; 186 } arg; 187 188 union { 189 void *ptr; /* returned pointer */ 190 SOBJ obj; /* returned object */ 191 SCM_PRIM_TABLE *entry; /* returned entry */ 192 } ret; 193 }; 194 195 enum SCM_VM_does { 196 SCM_VM_DO_INIT = 0, 197 SCM_VM_DO_EXECUTE, 198 SCM_VM_DO_GET_OPCODE, /* return a ptr to maching vm symbol entry*/ 199 SCM_VM_DO_GET_OPCODE_BY_NAME, 200 SCM_VM_DO_GET_OPCODE_BY_ADDR, 201 SCM_VM_DO_MAX 202 }; 203 204 #ifdef SCM_WITH_THREADS 205 /*** same as in Boehm's GC */ 206 #define SCM_SIG_SUSPEND SIGUSR1 207 #define SCM_SIG_RESUME SIGXCPU 208 #endif 209 210 /*-- catch context */ 211 #define SCM_CatchContext struct _SCM_CatchContext 212 SCM_CatchContext { 213 SOBJ tag; /* tags */ 214 SOBJ handler; /* handler function */ 215 SOBJ unwind; /* unwind functions */ 216 SCM_vmRegisters vm; /* vm register at catch time */ 217 jmp_buf env; /* execution context */ 218 }; 219 220 /*-- hash descriptor */ 221 222 #define SCM_MAX_HASH_DEPTH 3 223 224 #define SCM_Hash struct _SCM_Hash 225 SCM_Hash { 226 SOBJ *hash; /* hash array */ 227 short type; /* hash type */ 228 Uint hsize; /* size of hash array */ 229 Uint nkeys; /* number of keys in hash */ 230 Uint maxkeys; /* max number of key for this hash */ 231 }; 232 233 /*-- modules */ 234 #define SCM_Module struct _SCM_Module 235 SCM_Module { 236 SOBJ name; 237 SOBJ symbols; 238 SOBJ imports; 239 SOBJ exports; 240 int export_all; /* TRUE when all symbols are exported */ 241 }; 242 243 /*-- objects */ 244 245 #define SCM_ObjSlotDesc struct _SCM_ObjSlotDesc 246 SCM_ObjSlotDesc { 247 SOBJ name; 248 int index; 249 SOBJ getter; 250 SOBJ setter; 251 }; 252 253 #define SCM_ObjSlotAux struct _SCM_ObjSlotAux 254 SCM_ObjSlotAux { 255 int nslots; /* number of slots */ 256 SCM_ObjSlotDesc desc[1]; /* descriptor for each slots */ 257 }; 258 259 #define SCM_ObjValue struct _SCM_ObjValue 260 SCM_ObjValue { 261 }; 262 263 /*-- the mark for GC (msb of type field) */ 264 #define SCM_GCMARK_MASK (1L << ((sizeof(short)*8)-1)) 265 266 #define SCM_GCBIT_SET(x) (x)->type |= SCM_GCMARK_MASK 267 #define SCM_GCBIT_CLR(x) (x)->type &= ~(SCM_GCMARK_MASK) 268 #define SCM_GCBIT(x) ((x)->type & SCM_GCMARK_MASK) 269 270 extern int scm_in_gc; /* flag: true during gc */ 271 272 273 /*-- the circular bit mask, used during list traversal. Note that 274 * gcbit and circbit may be the same, because they should normally not 275 * be used at same time. 276 */ 277 #define SCM_CIRCULAR_MASK (1L << ((sizeof(short)*8)-2)) 278 279 #define SCM_CIRCBIT_SET(x) (x)->type |= SCM_CIRCULAR_MASK 280 #define SCM_CIRCBIT_CLR(x) (x)->type &= ~(SCM_CIRCULAR_MASK) 281 #define SCM_CIRCBIT(x) ((x)->type & SCM_CIRCULAR_MASK) 282 283 /*-- cell to hold a full or a partial scheme object (partial objects 284 * have some more memory allocated 285 */ 286 Sobject { 287 unsigned short type; /* type and gcmark: gcmark is the msb */ 288 union { 289 struct { double value; } fnum; 290 struct { MP_INT *value; } bnum; 291 struct { SOBJ car; SOBJ cdr; } pair; 292 struct { char *name; SOBJ next; } atom; 293 struct { SOBJ name; SOBJ value; } symbol; 294 struct { SOBJ name; int ofs; } lsymbol; 295 struct { SCM_Module *aux; } module; 296 struct { char c; } chr; 297 struct { char *value; long len; } string; 298 struct { SCM_PRIM_TABLE *entry; } prim; 299 struct { SCM_CPRIM fn; int nargs; } cprim; 300 struct { SOBJ *code; long size; } code; 301 struct { SOBJ env; SCM_Code *code; } proc; 302 struct { SOBJ env; SOBJ code; } closure; 303 struct { SCM_EnvFrame *frame; SOBJ next; } env; 304 struct { SOBJ func; SOBJ code; } macro; 305 struct { PORT *descr; } port; 306 struct { void *data; } cont; 307 struct { SCM_Array *descr; } array; 308 struct { SCM_Hash *h; } hash; 309 /* POINTER and AUX must be the same */ 310 struct { void *data; short attrib; } pointer; 311 struct { void *aux; short attrib; } aux; 312 struct { SCM_ExtFunc *aux; } extfunc; 313 struct { SCM_VarAux *aux; void *addr; } var; 314 struct { void (*fn)(SCM_vmRegisters *); } vmfunc; 315 struct { SCM_CatchContext *cntxt; } ccntxt; 316 } data; 317 }; 318 319 /* type descriptor */ 320 typedef struct { 321 long execute; /* execution address */ 322 char *name; /* type name */ 323 void (*mark)(SOBJ obj); /* func to mark this type of object */ 324 void (*sweep)(SOBJ obj); /* func to free this type of object */ 325 void (*print)(SOBJ obj, PORT *p); /* write human readable rep of object */ 326 void (*write)(SOBJ obj, PORT *p); /* write machine readable rep of object */ 327 328 /* token reconizer / parser */ 329 int (*creconize)(PORT *p, int c); /* starting char reconizer */ 330 SOBJ (*cparse)(PORT *p, int c); /* parser for type */ 331 int (*wreconize)(PORT *p, char *s); /* full word reconizer */ 332 SOBJ (*wparse)(PORT *p, char *s); /* full word parser */ 333 334 /* object comparer */ 335 SOBJ (*compare)(SOBJ obj1, SOBJ obj2); /* fonction to compare */ 336 337 SOBJ (*ext2obj)(int type, void *ext); /* create SOBJ from external pointer */ 338 void *(*obj2ext)(SOBJ obj); /* reverse operation */ 339 340 SOBJ finalize; /* optionnal finalizer */ 341 } SOBJ_TYPE_DESCR; 342 343 /* IMPORTANT: symbol value must be accessible as SCM_CDR(symbol) 344 * see compile_set. 345 */ 346 347 /*typedef Sobject *SOBJ; */ 348 #define SOBJ_INUM_TAG 1 349 #define SOBJ_INUM_MASK (~1) 350 #define SOBJ_INUM_SHIFT 1 351 352 #define SOBJ_INUM_MAX (0x3fffffffL) 353 #define SOBJ_INUM_MIN (~(SOBJ_INUM_MAX)) 354 355 #define SCM_INUM_RANGE(x) (((x) >= SOBJ_INUM_MIN) && ((x) <= SOBJ_INUM_MAX)) 356 357 #define SCM_INUMP(x) ((long)(x) & SOBJ_INUM_TAG) 358 359 /*!!!! keep this list sync with scm_type_hook[] in s.c !!!!*/ 360 enum SOBJ_TYPES { 361 SOBJ_T_VOID=0, 362 SOBJ_T_PAIR, 363 SOBJ_T_INUM, 364 SOBJ_T_FNUM, 365 SOBJ_T_BNUM, 366 SOBJ_T_ATOM, 367 SOBJ_T_KEYWORD, 368 SOBJ_T_SYMBOL, 369 SOBJ_T_LSYMBOL, 370 SOBJ_T_LABEL, /* share the same struct than LSYMBOL */ 371 SOBJ_T_MODULE, 372 SOBJ_T_CHAR, 373 SOBJ_T_STRING, 374 SOBJ_T_PRIM, 375 SOBJ_T_CPRIM, 376 SOBJ_T_SYNTAX, /* same struct as cprim */ 377 SOBJ_T_CODE, 378 SOBJ_T_PROC, 379 SOBJ_T_CLOSURE, 380 SOBJ_T_ENV, 381 SOBJ_T_MACRO, 382 SOBJ_T_PORT, 383 SOBJ_T_BOOLEAN, 384 SOBJ_T_UNBOUND, 385 SOBJ_T_UNDEFINED, 386 SOBJ_T_EOF, 387 SOBJ_T_CONT, 388 SOBJ_T_ARRAY, 389 SOBJ_T_HASH, 390 SOBJ_T_POINTER, 391 SOBJ_T_EXTFUNC, 392 SOBJ_T_VAR, 393 SOBJ_T_VMFUNC, /* can access vm registers */ 394 SOBJ_T_CCNTXT, /* catch context */ 395 SOBJ_T_USER 396 }; 397 398 #define SOBJ_T_MAX 256 399 #define SOBJ_T_FREE SOBJ_T_MAX /* marker for free cells */ 400 401 /*-- accessing fields */ 402 #define SCM_OBJREF(x) (x) 403 #define SCM_DATA(x) ((x)->data) 404 #define SCM_VALUE(x,t,f) ((x)->data.t.f) 405 406 /*-- some primitive macros */ 407 #define SCM_INUM(x) ((long)(x) >> SOBJ_INUM_SHIFT) 408 #define SCM_MKINUM(x) ((SOBJ)(((long)(x)<<SOBJ_INUM_SHIFT)|SOBJ_INUM_TAG)) 409 410 #define SCM_MKBOOL(x) ((x) ? scm_true : scm_false) 411 #define SCM_FALSEP(x) ((x) == scm_false) 412 #define SCM_TRUEP(x) ((x) != scm_false) 413 414 #define SCM_FNUM(x) SCM_VALUE(x,fnum,value) 415 #define SCM_BNUM(x) SCM_VALUE(x,bnum,value) 416 417 #define SCM_CAR(x) SCM_VALUE(x,pair,car) 418 #define SCM_CDR(x) SCM_VALUE(x,pair,cdr) 419 420 #define SCM_ATOM_NAME(x) SCM_VALUE(x,atom,name) 421 #define SCM_ATOM_NEXT(x) SCM_VALUE(x,atom,next) 422 423 /*-- note: symbol value is a pair when used in the local env 424 * ??? don't know what this means 425 */ 426 enum SCM_KEYWORD_WRITE_MODE { 427 SCM_KEYW_WRITE_DEFLT = 0, 428 SCM_KEYW_WRITE_DSSL, 429 SCM_KEYW_WRITE_OTHER 430 }; 431 432 433 #define SCM_KEYW_NAME(x) SCM_VALUE(x,symbol,name) 434 435 /* prefix for generated symbols. 436 * read will not accept symbol with this prefix as valid one. 437 * Note: the '@' is not part of valid symbol starter (r5rs 7 1 1) 438 */ 439 #define SCM_GENSYM_PREFIX "@G" 440 441 /* symbols: name are atoms */ 442 #define SCM_SYM_NAME(x) SCM_VALUE(x,symbol,name) 443 #define SCM_SYM_VALUE(x) SCM_VALUE(x,symbol,value) 444 445 /* local symbols: name are atoms */ 446 #define SCM_LSYM_NAME(x) SCM_VALUE(x,lsymbol,name) 447 #define SCM_LSYM_OFS(x) SCM_VALUE(x,lsymbol,ofs) 448 449 /* local labels: names are atoms */ 450 #define SCM_LABEL_NAME(x) SCM_VALUE(x,lsymbol,name) 451 #define SCM_LABEL_OFS(x) SCM_VALUE(x,lsymbol,ofs) 452 453 #define SCM_MODULE(x) SCM_VALUE(x,module,aux) 454 455 #define SCM_CHAR(x) SCM_VALUE(x,chr,c) 456 457 #define SCM_STR_LEN(x) SCM_VALUE(x,string,len) 458 #define SCM_STR_VALUE(x) SCM_VALUE(x,string,value) 459 460 #define SCM_STR_QTUM 32 461 #define SCM_STR_QTUM1 (SCM_STR_QTUM-1) 462 #define scm_str_lenq(x) (SCM_ALIGN_OFS(x,SCM_STR_QTUM)) 463 /* #define scm_str_lenq(x) (((x)+SCM_STR_QTUM1) & ~SCM_STR_QTUM1) */ 464 465 466 #define SCM_PRIM(x) SCM_VALUE(x,prim,entry) 467 468 #ifdef COMMENT 469 #define SCM_PRIM_ADDR(x) SCM_PRIM_ENTRY(x)->address 470 #define SCM_PRIM_NARGS(x) SCM_PRIM_ENTRY(x)->nargs 471 #endif 472 473 #define SCM_CPRIM_FUNC(x) SCM_VALUE(x,cprim,fn) 474 #define SCM_CPRIM_NARGS(x) SCM_VALUE(x,cprim,nargs) 475 476 #define SCM_SYNTAX_FUNC(x) SCM_VALUE(x,cprim,fn) 477 478 #define SCM_CODE_SIZE(x) SCM_VALUE(x,code,size) 479 #define SCM_CODE_CODE(x) SCM_VALUE(x,code,code) 480 481 #define SCM_PROC_ENV(x) SCM_VALUE(x,proc,env) 482 #define SCM_PROC_CODE(x) SCM_VALUE(x,proc,code) 483 484 #define SCM_ENV_FRAME(x) SCM_VALUE(x,env,frame) 485 #define SCM_ENV_NEXT(x) SCM_VALUE(x,env,next) 486 487 #define SCM_CLOSURE_CODE(x) SCM_VALUE(x,closure,code) 488 #define SCM_CLOSURE_ENV(x) SCM_VALUE(x,closure,env) 489 490 #define SCM_MACRO_CODE(x) SCM_VALUE(x,macro,code) 491 #define SCM_MACRO_FUNC(x) SCM_VALUE(x,macro,func) 492 493 #define SCM_PORT(x) SCM_VALUE(x,port,descr) 494 495 #define SCM_FILE_PORTP(x) (SCM_PORT(x)->type == PORT_T_FILE) 496 #define SCM_STRING_PORTP(x) (SCM_PORT(x)->type == PORT_T_STRING) 497 #define SCM_READ_PORTP(x) ((SCM_PORT(x)->io_flag & PORT_IO_R) != 0) 498 #define SCM_WRITE_PORTP(x) ((SCM_PORT(x)->io_flag & PORT_IO_W) != 0) 499 500 #define SCM_CONT(x) SCM_VALUE(x,cont,data) 501 502 #define SCM_ADESCR(x) SCM_VALUE(x,array,descr) 503 #define SCM_ARRAY(x) (SCM_ADESCR(x))->item 504 #define SCM_ASIZE(x) (SCM_ADESCR(x))->size 505 #define SCM_AMAX(x) (SCM_ADESCR(x))->alloced 506 #define SCM_AREF(x,i) (SCM_ADESCR(x))->item[i] 507 508 #define SCM_HASH(x) SCM_VALUE(x,hash,h) 509 510 /*-- types of hash */ 511 #define SCM_HASH_T_GEN 0 512 #define SCM_HASH_T_SYMBOL 1 513 #define SCM_HASH_T_ATOM 2 514 515 516 #define SCM_POINTER(x) SCM_VALUE(x,pointer,data) 517 #define SCM_POINTER_ATTRIB(x) SCM_VALUE(x,pointer,attrib) 518 519 /*** Pointers attributes */ 520 /* points to an allocated block that must be freed when sweeping */ 521 #define SCM_POINTER_FLAG_ALLOCED (1 << 0) 522 523 /* Points to a SOBJ that must be marked during GC */ 524 #define SCM_POINTER_FLAG_CELL (1 << 1) 525 526 527 #define SCM_EXTFUNC(x) SCM_VALUE(x,extfunc,aux) 528 529 #define SCM_VAR_ADDR(x) SCM_VALUE(x,var,addr) 530 #define SCM_VAR_AUX(x) SCM_VALUE(x,var,aux) 531 532 #define SCM_VMFUNC(x) SCM_VALUE(x,vmfunc,fn) 533 534 #define SCM_CATCH_CONTEXT(x) SCM_VALUE(x,ccntxt,cntxt) 535 #define SCM_CATCH_CONTEXT_TAG(x) SCM_CATCH_CONTEXT(x)->tag 536 #define SCM_CATCH_CONTEXT_ENV(x) SCM_CATCH_CONTEXT(x)->env 537 #define SCM_CATCH_CONTEXT_VM(x) SCM_CATCH_CONTEXT(x)->vm 538 #define SCM_CATCH_CONTEXT_HANDLER(x) SCM_CATCH_CONTEXT(x)->handler 539 #define SCM_CATCH_CONTEXT_UNWIND(x) SCM_CATCH_CONTEXT(x)->unwind 540 541 #define SCM_AUX(x) SCM_VALUE(x,aux,aux) 542 #define SCM_AUX_SET(x,v) SCM_VALUE(x,aux,aux)=(v); 543 544 /*-- type predicates */ 545 /*#define SCM_OBJTYPE(x) (SCM_INUMP(x)?SOBJ_T_INUM:(x?SCM_OBJREF(x)->type:-1)) */ 546 #define SCM_OBJTYPE(x) \ 547 (SCM_INUMP(x)?SOBJ_T_INUM:(x?SCM_OBJREF(x)->type & ~(SCM_GCMARK_MASK):-1)) 548 549 #define SCM_USERTYPEP(x) (SCM_OBJTYPE(x)>=SOBJ_T_USER && \ 550 SCM_OBJTYPE(x)<SOBJ_T_MAX) 551 552 #define SCM_TYPEP(x,t) (SCM_OBJTYPE(x) == t) 553 554 #define SCM_NULLP(x) ((x) == NULL) 555 #define SCM_NNULLP(x) ((x) != NULL) 556 #define SCM_PAIRP(x) (SCM_OBJTYPE(x) == SOBJ_T_PAIR) 557 #define SCM_FNUMP(x) (SCM_OBJTYPE(x) == SOBJ_T_FNUM) 558 #define SCM_BNUMP(x) (SCM_OBJTYPE(x) == SOBJ_T_BNUM) 559 #define SCM_ATOMP(x) (SCM_OBJTYPE(x) == SOBJ_T_ATOM) 560 #define SCM_KEYWORDP(x) (SCM_OBJTYPE(x) == SOBJ_T_KEYWORD) 561 #define SCM_SYMBOLP(x) (SCM_OBJTYPE(x) == SOBJ_T_SYMBOL) 562 #define SCM_LSYMBOLP(x) (SCM_OBJTYPE(x) == SOBJ_T_LSYMBOL) 563 #define SCM_MODULEP(x) (SCM_OBJTYPE(x) == SOBJ_T_MODULE) 564 #define SCM_CHARP(x) (SCM_OBJTYPE(x) == SOBJ_T_CHAR) 565 #define SCM_STRINGP(x) (SCM_OBJTYPE(x) == SOBJ_T_STRING) 566 #define SCM_PRIMP(x) (SCM_OBJTYPE(x) == SOBJ_T_PRIM) 567 #define SCM_CPRIMP(x) (SCM_OBJTYPE(x) == SOBJ_T_CPRIM) 568 #define SCM_SYNTAXP(x) (SCM_OBJTYPE(x) == SOBJ_T_SYNTAX) 569 #define SCM_CODEP(x) (SCM_OBJTYPE(x) == SOBJ_T_CODE) 570 #define SCM_PROCP(x) (SCM_OBJTYPE(x) == SOBJ_T_PROC) 571 #define SCM_CLOSUREP(x) (SCM_OBJTYPE(x) == SOBJ_T_CLOSURE) 572 #define SCM_ENVP(x) (SCM_OBJTYPE(x) == SOBJ_T_ENV) 573 #define SCM_MACROP(x) (SCM_OBJTYPE(x) == SOBJ_T_MACRO) 574 #define SCM_PORTP(x) (SCM_OBJTYPE(x) == SOBJ_T_PORT) 575 #define SCM_BOOLEANP(x) (SCM_OBJTYPE(x) == SOBJ_T_BOOLEAN) 576 #define SCM_ARRAYP(x) (SCM_OBJTYPE(x) == SOBJ_T_ARRAY) 577 #define SCM_HASHP(x) (SCM_OBJTYPE(x) == SOBJ_T_HASH) 578 #define SCM_POINTERP(x) (SCM_OBJTYPE(x) == SOBJ_T_POINTER) 579 #define SCM_EXTFUNCP(x) (SCM_OBJTYPE(x) == SOBJ_T_EXTFUNC) 580 581 #define SCM_VARP(x) (SCM_OBJTYPE(x) == SOBJ_T_VAR) 582 583 #define SCM_NUMBERP(x) (x && (SCM_INUMP(x) || SCM_FNUMP(x) || SCM_BNUMP(x))) 584 #define SCM_EXACTP(x) (SCM_INUMP(x) || SCM_BNUMP(x)) 585 586 #define SCM_REALP(x) (SCM_NUMBER(x)) 587 #define SCM_INTEGERP(x) (SCM_INUMP(x) || SCM_BNUMP(x)) 588 589 #define SCM_EQ(x,y) (SCM_OBJREF(x) == SCM_OBJREF(y)) 590 #define SCM_CAAR(x) SCM_CAR(SCM_CAR(x)) 591 #define SCM_CDAR(x) SCM_CDR(SCM_CAR(x)) 592 #define SCM_CDDR(x) SCM_CDR(SCM_CDR(x)) 593 #define SCM_CADR(x) SCM_CAR(SCM_CDR(x)) 594 #define SCM_CADDR(x) SCM_CAR(SCM_CDR(SCM_CDR(x))) 595 596 #define SCM_GETNUM(x) \ 597 (SCM_INUMP(x) ? SCM_INUM(x) : \ 598 ((SCM_OBJREF(x)->type == SOBJ_T_FNUM) ? SCM_FNUM(x) : 0)) 599 600 #define SCM_ANYSTRP(x) \ 601 (SCM_STRINGP(x)||SCM_ATOMP(x)||SCM_KEYWORDP(x)||SCM_SYMBOLP(x)) 602 603 static char *opc_str[]; 604 605 /*-- config */ 606 #define SCM_SYM_HASH_SIZE 101 607 608 #ifndef SCM_DEFAULT_LIB_PATH 609 #define SCM_DEFAULT_LIB_PATH "." 610 #endif 611 612 /*-- list building macros */ 613 #define SCM_LIST1(a) scm_cons((a), NULL) 614 #define SCM_LIST2(a,b) scm_cons((a), SCM_LIST1(b)) 615 #define SCM_LIST3(a,b,c) scm_cons((a), SCM_LIST2((b),(c))) 616 #define SCM_LIST4(a,b,c,d) scm_cons((a), SCM_LIST3((b),(c),(d))) 617 #define SCM_LIST5(a,b,c,d,e) scm_cons((a), SCM_LIST4((b),(c),(d),(e))) 618 #define SCM_LIST6(a,b,c,d,e,f) scm_cons((a), SCM_LIST5((b),(c),(d),(e),(f))) 619 620 #define streq(a,b) (strcmp(a,b)==0) 621 622 /*-- Align this to boundary: assume boundary is a power of 2 */ 623 #define SCM_ALIGN_OFS(ofs,bound) ((((Ulong)(ofs))+((bound)-1)) & ~((bound)-1)) 624 #define SCM_ALIGN_PTR(ofs,bound) (void*)(SCM_ALIGN_OFS(ofs,bound)) 625 626 #define SCM_ALIGNOF(type) (__alignof__(type)) 627 628 /* number.c: special definitions */ 629 SOBJ scm_exp(SOBJ x); 630 SOBJ scm_log(SOBJ x); 631 SOBJ scm_log10(SOBJ x); 632 SOBJ scm_sin(SOBJ x); 633 SOBJ scm_cos(SOBJ x); 634 SOBJ scm_tan(SOBJ x); 635 SOBJ scm_asin(SOBJ x); 636 SOBJ scm_acos(SOBJ x); 637 638 639 /* standard ports */ 640 641 extern SOBJ scm_in_port; 642 extern SOBJ scm_out_port; 643 extern SOBJ scm_err_port; 644 extern SOBJ scm_eof; 645 646 /* quick access to PORT * struct */ 647 648 #define SCM_INP SCM_PORT(scm_in_port) 649 #define SCM_OUTP SCM_PORT(scm_out_port) 650 #define SCM_ERRP SCM_PORT(scm_err_port) 651 652 653 /* err code used by longjmp */ 654 enum SCM_ERR_LONGJMP { 655 SCM_ERR_NONE = 0, 656 SCM_ERR_ABORT, 657 SCM_ERR_THROW, 658 SCM_ERR_MAX }; 659 660 struct CHR_SYM { 661 char *str; 662 char chr; 663 }; 664 665 #include "sproto.h" 666 667 #define scm_sp scm_vmd()->reg.sp 668 #define scm_stack scm_vmd()->stack_base 669 #define scm_stack_size scm_vmd()->stack_size 670 #define scm_stack_limit scm_vmd()->stack_limit 671 672 #ifdef SCM_WITH_THREADS 673 674 #define SCM_THREAD(x) ((SCM_VMD*)(SCM_AUX(x))) 675 #define SCM_MUTEX(x) ((pthread_mutex_t *)SCM_AUX(x)) 676 #define SCM_SEMAPHORE(x) ((sem_t *)SCM_AUX(x)) 677 #define SCM_MUTEX_SET SCM_AUX_SET 678 #define SCM_SEMAPHORE_SET SCM_AUX_SET 679 680 #define SCM_THREADP(x) (SCM_OBJTYPE(x) == SOBJ_T_THREAD) 681 #define SCM_MUTEXP(x) (SCM_OBJTYPE(x) == SOBJ_T_MUTEX) 682 #define SCM_SEMAPHOREP(x) (SCM_OBJTYPE(x) == SOBJ_T_SEMAPHORE) 683 684 #define scm_vmd() ((SCM_VMD*)pthread_getspecific(scm_vmd_key)) 685 686 extern pthread_mutex_t scm_heap_locker; 687 688 #define SCM_HEAP_LOCK() pthread_mutex_lock(&scm_heap_locker) 689 #define SCM_HEAP_UNLOCK() pthread_mutex_unlock(&scm_heap_locker) 690 691 #else /* no THREADS */ 692 693 extern SCM_VMD scm_vmdata; 694 695 #define scm_vmd() (&scm_vmdata) 696 697 #define SCM_HEAP_LOCK() 698 #define SCM_HEAP_UNLOCK() 699 700 #endif /* SCM_WITH_THREADS */ 701 702 /* toplevel restart point */ 703 #define scm_errjmp (scm_vmd()->errjmp) 704 705 #ifdef HAVE_FUNC_STR 706 #define SCM_ERR(msg,obj) scm_internal_err(__FUNCTION__,msg,obj) 707 #else 708 #define SCM_ERR(msg,obj) scm_internal_err(NULL,msg,obj) 709 #endif 710 711