1 /* rep_lisp.h -- Data structures/objects for Lisp 2 Copyright (C) 1993, 1994 John Harper <john@dcs.warwick.ac.uk> 3 $Id$ 4 5 This file is part of Jade. 6 7 Jade is free software; you can redistribute it and/or modify it 8 under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 2, or (at your option) 10 any later version. 11 12 Jade is distributed in the hope that it will be useful, but 13 WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with Jade; see the file COPYING. If not, write to 19 the Free Software Foundation, 51 Franklin Street, Fifth Floor, 20 Boston, MA 02110-1301 USA */ 21 22 /* library-private definitions are in repint.h */ 23 24 #ifndef REP_LISP_H 25 #define REP_LISP_H 26 27 #include <stdio.h> 28 29 /* Stringify X. Expands macros in X. */ 30 #define rep_QUOTE(x) rep_QUOTE__(x) 31 #define rep_QUOTE__(x) #x 32 33 /* Concat two tokens. Expands macros in X and Y. */ 34 #define rep_CONCAT(x, y) rep_CONCAT__(x, y) 35 #define rep_CONCAT__(x, y) x##y 36 37 38 /* Lisp values. */ 39 40 /* A `repv' is a lisp value, perhaps a pointer to an object, but not a real 41 pointer; it's two lowest bits define its type. */ 42 typedef unsigned rep_PTR_SIZED_INT repv; 43 44 /* The number of bits in the lisp value type. */ 45 #define rep_VALUE_BITS rep_PTR_SIZED_INT_BITS 46 47 /* Get the integer constant X in the lisp value type */ 48 #define rep_VALUE_CONST(x) rep_CONCAT(x, rep_PTR_SIZED_INT_SUFFIX) 49 50 51 /* Structure of Lisp objects and the pointers to them. */ 52 53 /* Bit definitions for repv pointers. The lowest bit is always zero 54 except during GC. If bit one is set the object is a 30-bit signed 55 integer, with the data bits stored in the pointer as bits 2->31. 56 57 Otherwise (i.e. bit 1 of the pointer is clear), the value is a 58 pointer to a "cell"; all objects other than integers are represented 59 by various types of cells. Every cell has a repv as its first 60 element (called the car), the lowest bits of this define the actual 61 type of the cell. 62 63 If bit zero of the car is unset, the cell is a cons, a pair of two 64 values the car and the cdr (the GC mark bit of the cons is bit zero 65 of the cdr). 66 67 If bit zero of the car is set, then further type information is 68 stored in bits 1->5 of the car, with bit 5 used to denote statically 69 allocated objects and bit 7 the mark bit. 70 71 So there are 2^4 possible types of cells. This isn't enough, so bit 72 6 of the car is used to denote a ``cell16'' type -- a cell in which 73 bits 8->15 give the actual type. These cell16 types are allocated 74 dynamically. 75 76 Note that some assumptions are made about data object alignment. All 77 Lisp cells _must_ be aligned to four-byte boundaries. If using GNU 78 CC, we'll use the alignment attribute. Otherwise the rep_ALIGN macro 79 needs setting.. */ 80 81 #define rep_VALUE_CONS_MARK_BIT 1 82 #define rep_VALUE_IS_INT 2 83 #define rep_VALUE_INT_SHIFT 2 84 #define rep_CELL_ALIGNMENT rep_PTR_SIZED_INT_SIZEOF 85 86 #if rep_CELL_ALIGNMENT <= rep_MALLOC_ALIGNMENT 87 /* Allocate SIZE bytes of memory, aligned to NORMAL_ALIGNMENT */ 88 # define rep_ALLOC_CELL(n) rep_alloc(n) 89 /* Free something allocated by rep_ALLOC_CELL */ 90 # define rep_FREE_CELL(x) rep_free(x) 91 #else 92 # error "Need an aligned memory allocator" 93 #endif 94 95 /* A ``null pointer'', i.e. an invalid object. This has the important 96 property of being a proper null pointer (i.e. (void *)0) when 97 converted to a pointer, i.e. rep_PTR(rep_NULL) == NULL. */ 98 #define rep_NULL (0) 99 100 /* Align the variable or struct member D to the necessary cell alignment. 101 This is used like: ``rep_ALIGN_CELL(rep_cell foo) = ...'' 102 The best examples are the uses for rep_subr and rep_xsubr below. */ 103 #ifdef __GNUC__ 104 # define rep_ALIGN_CELL(d) d __attribute__ ((aligned (rep_CELL_ALIGNMENT))) 105 #elif defined (__digital__) && defined (__unix__) && defined (__DECC) 106 # if rep_CELL_ALIGNMENT >= rep_PTR_SIZED_INT_SIZEOF 107 /* "the C compiler aligns an int (32 bits) on a 4-byte boundary and 108 a long (64 bits) on an 8-byte boundary" (Tru64 Programmer's Guide) */ 109 # define rep_ALIGN_CELL(d) d 110 # else 111 # error "You need to fix alignment for Tru64" 112 # endif 113 #else 114 /* # warning Lets hope your compiler aligns to 4 byte boundaries.. */ 115 # define rep_ALIGN_CELL(d) d 116 #endif 117 118 /* Is repv V a cell type? */ 119 #define rep_CELLP(v) (((v) & rep_VALUE_IS_INT) == 0) 120 121 /* Is repv V a fixnum (= an integer which fits in a Lisp poniter)? */ 122 #define rep_INTP(v) (!rep_CELLP(v)) 123 124 /* Convert a repv into a signed integer. */ 125 #define rep_INT(v) (((rep_PTR_SIZED_INT)(v)) \ 126 >> rep_VALUE_INT_SHIFT) 127 128 /* Convert a signed integer into a repv. */ 129 #define rep_MAKE_INT(x) (((x) << rep_VALUE_INT_SHIFT) \ 130 | rep_VALUE_IS_INT) 131 132 /* Bounds of the integer type */ 133 #define rep_LISP_INT_BITS (rep_VALUE_BITS - rep_VALUE_INT_SHIFT) 134 #define rep_LISP_MAX_INT ((rep_VALUE_CONST(1) \ 135 << (rep_LISP_INT_BITS - 1)) - 1) 136 #define rep_LISP_MIN_INT (-(rep_VALUE_CONST(1) \ 137 << (rep_LISP_INT_BITS - 1))) 138 139 /* backwards compatibility */ 140 #define rep_MAKE_LONG_INT(x) rep_make_long_int(x) 141 #define rep_LONG_INT(v) rep_get_long_int(v) 142 #define rep_LONG_INTP(v) \ 143 (rep_INTEGERP(v) \ 144 || (rep_CONSP(v) && rep_INTP(rep_CAR(v)) && rep_INTP(rep_CDR(v)))) 145 146 147 /* Structure of a cell */ 148 149 typedef struct { 150 /* Low bits of this value define type of the cell. See below. All 151 other bits (8->31) are available */ 152 repv car; 153 154 /* Data follows, in real objects. */ 155 } rep_cell; 156 157 /* If bit zero is set in the car of a cell, bits 1->4 of the car are 158 type data, bit 5 denotes a cell16 type, bit 6 is set if the object 159 is allocated statically, bit 7 is the GC mark bit. This means a 160 maximum of 2^3, i.e. 16, cell8 types. 161 162 cell16 types have eight extra type bits, bits 8->15, this gives 256 163 dynamically allocated type codes: [256 k + 0x21 | k <- [0..255]]. */ 164 165 #define rep_CELL_IS_8 0x01 166 #define rep_CELL_IS_16 0x20 167 #define rep_CELL_STATIC_BIT 0x40 168 #define rep_CELL_MARK_BIT 0x80 169 #define rep_CELL8_TYPE_MASK 0x3f 170 #define rep_CELL8_TYPE_BITS 8 171 #define rep_CELL16_TYPE_MASK 0xff21 /* is8 and is16 bits set */ 172 #define rep_CELL16_TYPE_SHIFT 8 173 #define rep_CELL16_TYPE_BITS 16 174 175 /* Build a `rep_cell *' pointer out of a repv of a normal type */ 176 #define rep_PTR(v) ((rep_cell *)(v)) 177 178 /* Build a repv out of a pointer to a Lisp_Normal object */ 179 #define rep_VAL(x) ((repv)(x)) 180 181 /* Is V of cell8 type? */ 182 #define rep_CELL8P(v) (rep_PTR(v)->car & rep_CELL_IS_8) 183 184 /* Is V a cons? */ 185 #define rep_CELL_CONS_P(v) (!rep_CELL8P(v)) 186 187 /* Is V statically allocated? */ 188 #define rep_CELL_STATIC_P(v) (rep_PTR(v)->car & rep_CELL_STATIC_BIT) 189 190 /* Is V not an integer or cons? */ 191 #define rep_CELL8_TYPE(v) (rep_PTR(v)->car & rep_CELL8_TYPE_MASK) 192 193 /* Get the actual cell8 type of V to T */ 194 #define rep_SET_CELL8_TYPE(v, t) \ 195 (rep_PTR(v)->car = (rep_PTR(v)->car & rep_CELL8_TYPE_MASK) | (t)) 196 197 /* Is V of cell16 type? */ 198 #define rep_CELL16P(v) (rep_PTR(v)->car & rep_CELL_IS_16) 199 200 /* Get the actual cell16 type of V */ 201 #define rep_CELL16_TYPE(v) (rep_PTR(v)->car & rep_CELL16_TYPE_MASK) 202 203 /* Set the actual cell16 type of V to T */ 204 #define rep_SET_CELL16_TYPE(v, t) \ 205 (rep_PTR(v)->car = (rep_PTR(v)->car & rep_CELL16_TYPE_MASK) | (t)) 206 207 208 /* Structure of a cons cell, the only non-cell8 ptr type */ 209 210 typedef struct { 211 repv car; 212 repv cdr; /* low bit is GC mark */ 213 } rep_cons; 214 215 #define rep_CONSP(v) (rep_CELLP(v) && rep_CELL_CONS_P(v)) 216 217 /* Build a repv out of a pointer to a rep_cons object */ 218 #define rep_CONS_VAL(x) rep_VAL(x) 219 220 /* Get a pointer to a cons cell from a repv. */ 221 #define rep_CONS(v) ((rep_cons *) rep_PTR(v)) 222 223 /* Get the car or cdr from a cons repv. */ 224 #define rep_CAR(v) (rep_CONS(v)->car) 225 #define rep_CDR(v) (rep_CONS(v)->cdr) 226 #define rep_CDRLOC(v) (&(rep_CONS(v)->cdr)) 227 228 /* Get the cdr when GC is in progress. */ 229 #define rep_GCDR(v) (rep_CDR(v) & ~rep_VALUE_CONS_MARK_BIT) 230 231 /* True if cons cell V is mutable (i.e. not read-only). */ 232 #define rep_CONS_WRITABLE_P(v) \ 233 (! (rep_CONS(v) >= rep_dumped_cons_start \ 234 && rep_CONS(v) < rep_dumped_cons_end)) 235 236 237 /* Type data */ 238 239 /* Information about each type */ 240 typedef struct rep_type_struct { 241 struct rep_type_struct *next; 242 char *name; 243 unsigned int code; 244 245 /* Compares two values, rc is similar to strcmp() */ 246 int (*compare)(repv val1, repv val2); 247 248 /* Prints a textual representation of the object, not necessarily in 249 a read'able format */ 250 void (*princ)(repv stream, repv obj); 251 252 /* Prints a textual representation of the object, if possible in 253 a read'able format */ 254 void (*print)(repv stream, repv obj); 255 256 /* When non-null, a function that should be called during the 257 sweep phase of garbage collection. */ 258 void (*sweep)(void); 259 260 /* When non-null, a function to mark OBJ and all objects 261 it references. */ 262 void (*mark)(repv obj); 263 264 /* When called, should mark any objects that must persist across 265 the GC, no matter what. */ 266 void (*mark_type)(void); 267 268 /* When non-null, functions called for the stream OBJ. */ 269 int (*getc)(repv obj); 270 int (*ungetc)(repv obj, int c); 271 int (*putc)(repv obj, int c); 272 int (*puts)(repv obj, void *data, int length, rep_bool lisp_obj_p); 273 274 /* When non-null, a function to ``bind'' to OBJ temporarily, 275 returning some handle for later unbinding. */ 276 repv (*bind)(repv obj); 277 278 /* When non-null, a function to ``unbind'' OBJ, the result of 279 the earlier bind call. */ 280 void (*unbind)(repv obj); 281 } rep_type; 282 283 /* Each type of Lisp object has a type code associated with it. 284 285 Note how non-cons cells are given odd values, so that the 286 rep_CELL_IS_8 bit doesn't have to be masked out. */ 287 288 #define rep_Cons 0x00 /* made up */ 289 #define rep_Symbol 0x01 290 #define rep_Int 0x02 /* made up */ 291 #define rep_Vector 0x03 292 #define rep_String 0x05 293 #define rep_Compiled 0x07 294 #define rep_Void 0x09 295 #define rep_Reserved 0x0b 296 #define rep_Number 0x0d 297 #define rep_SF 0x0f /* Special form */ 298 #define rep_Subr0 0x11 299 #define rep_Subr1 0x13 300 #define rep_Subr2 0x15 301 #define rep_Subr3 0x17 302 #define rep_Subr4 0x19 303 #define rep_Subr5 0x1b 304 #define rep_SubrN 0x1d 305 #define rep_Funarg 0x1f /* Closure */ 306 307 /* Assuming that V is a cell, return the type code */ 308 #define rep_CELL_TYPE(v) (rep_CONSP(v) ? rep_Cons \ 309 : !rep_CELL16P(v) ? rep_CELL8_TYPE(v) \ 310 : rep_CELL16_TYPE(v)) 311 312 /* Return a type code given a repv */ 313 #define rep_TYPE(v) (rep_INTP(v) ? rep_Int : rep_CELL_TYPE(v)) 314 315 /* true if V is of type T (T must be a cell8 type) */ 316 #define rep_CELL8_TYPEP(v, t) \ 317 (rep_CELLP(v) && rep_CELL8_TYPE(v) == (t)) 318 319 #define rep_CELL16_TYPEP(v, t) \ 320 (rep_CELLP(v) && rep_CELL16_TYPE(v) == (t)) 321 322 /* true if V is of type T. */ 323 #define rep_TYPEP(v, t) (rep_TYPE(v) == t) 324 325 326 /* tuples, cells containing two values */ 327 328 typedef struct { 329 repv car; 330 repv a, b; 331 } rep_tuple; 332 333 #define rep_TUPLE(v) ((rep_tuple *) rep_PTR (v)) 334 335 336 /* Numbers (private defs in numbers.c) */ 337 338 /* Is V a non-fixnum number? */ 339 #define rep_NUMBERP(v) rep_CELL8_TYPEP(v, rep_Number) 340 341 /* Is V numeric? */ 342 #define rep_NUMERICP(v) (rep_INTP(v) || rep_NUMBERP(v)) 343 344 /* bits 8-9 of car define number type (except when on freelist) */ 345 typedef rep_cell rep_number; 346 347 /* these are in order of promotion */ 348 #define rep_NUMBER_INT 0 /* faked */ 349 #define rep_NUMBER_BIGNUM 0x100 350 #define rep_NUMBER_RATIONAL 0x200 351 #define rep_NUMBER_FLOAT 0x400 352 353 #define rep_NUMBER_TYPE(v) (((rep_number *)rep_PTR(v))->car & 0x700) 354 #define rep_NUMBER_BIGNUM_P(v) (rep_NUMBER_TYPE(v) & rep_NUMBER_BIGNUM) 355 #define rep_NUMBER_RATIONAL_P(v) (rep_NUMBER_TYPE(v) & rep_NUMBER_RATIONAL) 356 #define rep_NUMBER_FLOAT_P(v) (rep_NUMBER_TYPE(v) & rep_NUMBER_FLOAT) 357 358 #define rep_NUMERIC_TYPE(v) \ 359 (rep_INTP(v) ? rep_NUMBER_INT : rep_NUMBER_TYPE(v)) 360 361 #define rep_INTEGERP(v) \ 362 (rep_INTP(v) || (rep_NUMBERP(v) && rep_NUMBER_BIGNUM_P(v))) 363 364 365 /* Strings */ 366 367 typedef struct rep_string_struct { 368 /* Bits 0->7 are standard cell8 defines. Bits 8->31 store the length 369 of the string. This means that strings can't contain more than 370 2^24-1 bytes (thats about 16.7MB) */ 371 repv car; 372 373 /* Pointer to the (zero-terminated) characters */ 374 char *data; 375 } rep_string; 376 377 #define rep_STRING_LEN_SHIFT 8 378 #define rep_MAX_STRING \ 379 ((rep_VALUE_CONST(1) << (rep_VALUE_BITS - rep_STRING_LEN_SHIFT)) - 1) 380 381 #define rep_STRINGP(v) rep_CELL8_TYPEP(v, rep_String) 382 #define rep_STRING(v) ((rep_string *) rep_PTR(v)) 383 384 #define rep_STRING_LEN(v) (rep_STRING(v)->car >> rep_STRING_LEN_SHIFT) 385 386 #define rep_MAKE_STRING_CAR(len) (((len) << rep_STRING_LEN_SHIFT) | rep_String) 387 388 /* True if this string may be written to; generally static strings 389 are made from C string-constants and usually in read-only storage. */ 390 #define rep_STRING_WRITABLE_P(s) (!rep_CELL_STATIC_P(s)) 391 392 /* Define a variable V, containing a static string S. This must be cast 393 to a repv via the rep_VAL() macro when using. */ 394 #define DEFSTRING(v, s) \ 395 rep_ALIGN_CELL(static const rep_string v) = { \ 396 ((sizeof(s) - 1) << rep_STRING_LEN_SHIFT) \ 397 | rep_CELL_STATIC_BIT | rep_String, \ 398 (char *)s \ 399 } 400 401 #define rep_STR(v) (rep_STRING(v)->data) 402 403 /* Use this to get a newline into a DEFSTRING */ 404 #define rep_DS_NL "\n" 405 406 407 /* Symbols */ 408 409 /* symbol object, actual allocated as a tuple */ 410 typedef struct { 411 repv car; /* bits 8->11 are flags */ 412 repv next; /* next symbol in rep_obarray bucket */ 413 repv name; 414 } rep_symbol; 415 416 #define rep_SF_KEYWORD (1 << (rep_CELL8_TYPE_BITS + 0)) 417 418 /* Means that the symbol's value may be in some form of local storage, 419 if so then that occurrence takes precedence. */ 420 #define rep_SF_LOCAL (1 << (rep_CELL8_TYPE_BITS + 1)) 421 422 /* This means that setting the value of the symbol always sets the 423 local value, even if one doesn't already exist. */ 424 #define rep_SF_SET_LOCAL (1 << (rep_CELL8_TYPE_BITS + 2)) 425 426 /* When a function is evaluated whose symbol has this bit set, the 427 next evaluated form will invoke the Lisp debugger. */ 428 #define rep_SF_DEBUG (1 << (rep_CELL8_TYPE_BITS + 3)) 429 430 /* Dynamically bound */ 431 #define rep_SF_SPECIAL (1 << (rep_CELL8_TYPE_BITS + 4)) 432 433 /* A special, but was first set from an environment in which specials 434 can't normally be accessed; if the symbol is later defvar'd its 435 original value will be overwritten. */ 436 #define rep_SF_WEAK (1 << (rep_CELL8_TYPE_BITS + 5)) 437 438 /* A variable that was weak, but has been modified via defvar from an 439 unrestricted special environment */ 440 #define rep_SF_WEAK_MOD (1 << (rep_CELL8_TYPE_BITS + 6)) 441 442 /* Set when the variable has been defvar'd */ 443 #define rep_SF_DEFVAR (1 << (rep_CELL8_TYPE_BITS + 7)) 444 445 #define rep_SF_LITERAL (1 << (rep_CELL8_TYPE_BITS + 8)) 446 447 #define rep_SYM(v) ((rep_symbol *)rep_PTR(v)) 448 #define rep_SYMBOLP(v) rep_CELL8_TYPEP(v, rep_Symbol) 449 450 #define rep_NILP(v) ((v) == Qnil) 451 #define rep_LISTP(v) (rep_NILP(v) || rep_CONSP(v)) 452 453 #define rep_KEYWORDP(v) (rep_SYMBOLP(v) \ 454 && (rep_SYM(v)->car & rep_SF_KEYWORD) != 0) 455 456 #define rep_SYMBOL_LITERAL_P(v) ((rep_SYM(v)->car & rep_SF_LITERAL) != 0) 457 458 459 /* Vectors */ 460 461 typedef struct rep_vector_struct { 462 repv car; /* size is bits 8->31 */ 463 struct rep_vector_struct *next; 464 repv array[1]; 465 } rep_vector; 466 467 /* Bytes to allocate for S objects */ 468 #define rep_VECT_SIZE(s) ((sizeof(repv) * ((s)-1)) + sizeof(rep_vector)) 469 470 #define rep_VECT(v) ((rep_vector *)rep_PTR(v)) 471 #define rep_VECTI(v,i) (rep_VECT(v)->array[(i)]) 472 473 #define rep_VECT_LEN(v) (rep_VECT(v)->car >> 8) 474 #define rep_SET_VECT_LEN(v,l) (rep_VECT(v)->car = ((l) << 8 | rep_Vector)) 475 476 #define rep_VECTORP(v) rep_CELL8_TYPEP(v, rep_Vector) 477 478 #define rep_VECTOR_WRITABLE_P(v) (!rep_CELL_STATIC_P(v)) 479 480 481 /* Compiled Lisp functions; this is a vector. Some of these definitions 482 are probably hard coded into lispmach.c */ 483 484 #define rep_COMPILEDP(v) rep_CELL8_TYPEP(v, rep_Compiled) 485 #define rep_COMPILED(v) ((rep_vector *)rep_PTR(v)) 486 487 /* First elt is byte-code string */ 488 #define rep_COMPILED_CODE(v) rep_VECTI(v, 0) 489 490 /* Second is constant vector */ 491 #define rep_COMPILED_CONSTANTS(v) rep_VECTI(v, 1) 492 493 /* Third is an (opaque) integer: memory requirements */ 494 #define rep_COMPILED_STACK(v) rep_VECTI(v, 2) 495 496 #define rep_COMPILED_MIN_SLOTS 3 497 498 /* Optional fifth element is documentation. */ 499 #define rep_COMPILED_DOC(v) ((rep_VECT_LEN(v) >= 4) \ 500 ? rep_VECTI(v, 3) : Qnil) 501 502 /* Optional sixth element is interactive specification. */ 503 #define rep_COMPILED_INTERACTIVE(v) ((rep_VECT_LEN(v) >= 5) \ 504 ? rep_VECTI(v, 4) : Qnil) 505 506 507 /* Files */ 508 509 /* A file object. */ 510 typedef struct rep_file_struct { 511 repv car; /* single flag at bit 16 */ 512 struct rep_file_struct *next; 513 514 /* Name as user sees it */ 515 repv name; 516 517 /* Function to call to handle file operations, 518 or t for file in local fs */ 519 repv handler; 520 521 /* Data for handler's use; for local files, this is the 522 name of the file opened in the local fs. */ 523 repv handler_data; 524 525 /* For local files, a buffered file handle; for others some sort 526 of stream. */ 527 union { 528 FILE *fh; 529 repv stream; 530 } file; 531 532 /* For input streams */ 533 int line_number; 534 } rep_file; 535 536 /* When this bit is set in flags, the file handle is never fclose()'d, 537 i.e. this file points to something like stdin. */ 538 #define rep_LFF_DONT_CLOSE (1 << (rep_CELL16_TYPE_BITS + 0)) 539 #define rep_LFF_BOGUS_LINE_NUMBER (1 << (rep_CELL16_TYPE_BITS + 1)) 540 #define rep_LFF_SILENT_ERRORS (1 << (rep_CELL16_TYPE_BITS + 2)) 541 542 #define rep_FILE(v) ((rep_file *)rep_PTR(v)) 543 #define rep_FILEP(v) rep_CELL16_TYPEP(v, rep_file_type) 544 545 #define rep_LOCAL_FILE_P(v) (rep_FILE(v)->handler == Qt) 546 547 548 /* Built-in subroutines */ 549 550 /* Calling conventions are straightforward, returned value is result 551 of function. But returning rep_NULL signifies some kind of abnormal 552 exit (i.e. an error or throw, or ..?), should be treated as 553 rep_INTERRUPTP defined below is */ 554 555 /* C subroutine, can take from zero to five arguments. 556 * (Teika writes) it seems that `subr' lisp object is cast into 557 * pointer to both struct rep_subr and rep_xsubr, depending on the need, 558 * so they have to have the (almost) same members. 559 */ 560 typedef struct { 561 repv car; 562 union { 563 repv (*fun0)(void); 564 repv (*fun1)(repv); 565 repv (*fun2)(repv, repv); 566 repv (*fun3)(repv, repv, repv); 567 repv (*fun4)(repv, repv, repv, repv); 568 repv (*fun5)(repv, repv, repv, repv, repv); 569 repv (*funv)(int, repv *); 570 } fun; 571 repv name; 572 repv int_spec; 573 repv structure; 574 } rep_subr; 575 576 typedef struct { 577 repv car; 578 repv (*fun)(); 579 repv name; 580 repv int_spec; /* put this in plist? */ 581 repv structure; 582 } rep_xsubr; 583 584 /* If set in rep_SubrN types, it'll be passed a vector of args, 585 instead of a list */ 586 #define rep_SUBR_VEC (1 << (rep_CELL8_TYPE_BITS + 0)) 587 #define rep_SUBR_VEC_P(v) (rep_SUBR(v)->car & rep_SUBR_VEC) 588 #define rep_SubrV (rep_SubrN | rep_SUBR_VEC) 589 590 #define rep_XSUBR(v) ((rep_xsubr *) rep_PTR(v)) 591 #define rep_SUBR(v) ((rep_subr *) rep_PTR(v)) 592 #define rep_SUBR0FUN(v) (rep_SUBR(v)->fun.fun0) 593 #define rep_SUBR1FUN(v) (rep_SUBR(v)->fun.fun1) 594 #define rep_SUBR2FUN(v) (rep_SUBR(v)->fun.fun2) 595 #define rep_SUBR3FUN(v) (rep_SUBR(v)->fun.fun3) 596 #define rep_SUBR4FUN(v) (rep_SUBR(v)->fun.fun4) 597 #define rep_SUBR5FUN(v) (rep_SUBR(v)->fun.fun5) 598 #define rep_SUBRNFUN(v) (rep_SUBR(v)->fun.fun1) 599 #define rep_SUBRVFUN(v) (rep_SUBR(v)->fun.funv) 600 #define rep_SFFUN(v) (rep_SUBR(v)->fun.fun2) 601 602 603 /* Closures */ 604 605 typedef struct rep_funarg_struct { 606 repv car; 607 repv fun; 608 repv name; 609 repv env; 610 repv structure; 611 } rep_funarg; 612 613 #define rep_FUNARG(v) ((rep_funarg *)rep_PTR(v)) 614 #define rep_FUNARGP(v) (rep_CELL8_TYPEP(v, rep_Funarg)) 615 616 #define rep_FUNARG_WRITABLE_P(v) (!rep_CELL_STATIC_P(v)) 617 618 619 /* Guardians */ 620 621 #define rep_GUARDIAN(v) ((rep_guardian *) rep_PTR(v)) 622 #define rep_GUARDIANP(v) rep_CELL16_TYPEP(v, rep_guardian_type) 623 624 625 /* Other definitions */ 626 627 /* Macros for other types */ 628 #define rep_VOIDP(v) rep_CELL8_TYPEP(v, rep_Void) 629 630 /* Building lists */ 631 #define rep_LIST_1(v1) Fcons(v1, Qnil) 632 #define rep_LIST_2(v1,v2) Fcons(v1, rep_LIST_1(v2)) 633 #define rep_LIST_3(v1,v2,v3) Fcons(v1, rep_LIST_2(v2, v3)) 634 #define rep_LIST_4(v1,v2,v3,v4) Fcons(v1, rep_LIST_3(v2, v3, v4)) 635 #define rep_LIST_5(v1,v2,v3,v4,v5) Fcons(v1, rep_LIST_4(v2, v3, v4, v5)) 636 637 #define rep_CAAR(obj) rep_CAR (rep_CAR (obj)) 638 #define rep_CDAR(obj) rep_CDR (rep_CAR (obj)) 639 #define rep_CADR(obj) rep_CAR (rep_CDR (obj)) 640 #define rep_CDDR(obj) rep_CDR (rep_CDR (obj)) 641 642 #define rep_CAAAR(obj) rep_CAR (rep_CAR (rep_CAR (obj))) 643 #define rep_CDAAR(obj) rep_CDR (rep_CAR (rep_CAR (obj))) 644 #define rep_CADAR(obj) rep_CAR (rep_CDR (rep_CAR (obj))) 645 #define rep_CDDAR(obj) rep_CDR (rep_CDR (rep_CAR (obj))) 646 #define rep_CAADR(obj) rep_CAR (rep_CAR (rep_CDR (obj))) 647 #define rep_CDADR(obj) rep_CDR (rep_CAR (rep_CDR (obj))) 648 #define rep_CADDR(obj) rep_CAR (rep_CDR (rep_CDR (obj))) 649 #define rep_CDDDR(obj) rep_CDR (rep_CDR (rep_CDR (obj))) 650 651 #define rep_CAAAAR(obj) rep_CAR (rep_CAR (rep_CAR (rep_CAR (obj)))) 652 #define rep_CDAAAR(obj) rep_CDR (rep_CAR (rep_CAR (rep_CAR (obj)))) 653 #define rep_CADAAR(obj) rep_CAR (rep_CDR (rep_CAR (rep_CAR (obj)))) 654 #define rep_CDDAAR(obj) rep_CDR (rep_CDR (rep_CAR (rep_CAR (obj)))) 655 #define rep_CAADAR(obj) rep_CAR (rep_CAR (rep_CDR (rep_CAR (obj)))) 656 #define rep_CDADAR(obj) rep_CDR (rep_CAR (rep_CDR (rep_CAR (obj)))) 657 #define rep_CADDAR(obj) rep_CAR (rep_CDR (rep_CDR (rep_CAR (obj)))) 658 #define rep_CDDDAR(obj) rep_CDR (rep_CDR (rep_CDR (rep_CAR (obj)))) 659 #define rep_CAAADR(obj) rep_CAR (rep_CAR (rep_CAR (rep_CDR (obj)))) 660 #define rep_CDAADR(obj) rep_CDR (rep_CAR (rep_CAR (rep_CDR (obj)))) 661 #define rep_CADADR(obj) rep_CAR (rep_CDR (rep_CAR (rep_CDR (obj)))) 662 #define rep_CDDADR(obj) rep_CDR (rep_CDR (rep_CAR (rep_CDR (obj)))) 663 #define rep_CAADDR(obj) rep_CAR (rep_CAR (rep_CDR (rep_CDR (obj)))) 664 #define rep_CDADDR(obj) rep_CDR (rep_CAR (rep_CDR (rep_CDR (obj)))) 665 #define rep_CADDDR(obj) rep_CAR (rep_CDR (rep_CDR (rep_CDR (obj)))) 666 #define rep_CDDDDR(obj) rep_CDR (rep_CDR (rep_CDR (rep_CDR (obj)))) 667 668 669 /* Garbage collection definitions */ 670 671 /* gc macros for cell8/16 values */ 672 #define rep_GC_CELL_MARKEDP(v) (rep_PTR(v)->car & rep_CELL_MARK_BIT) 673 #define rep_GC_SET_CELL(v) (rep_PTR(v)->car |= rep_CELL_MARK_BIT) 674 #define rep_GC_CLR_CELL(v) (rep_PTR(v)->car &= ~rep_CELL_MARK_BIT) 675 676 /* gc macros for cons values */ 677 #define rep_GC_CONS_MARKEDP(v) (rep_CDR(v) & rep_VALUE_CONS_MARK_BIT) 678 #define rep_GC_SET_CONS(v) (rep_CDR(v) |= rep_VALUE_CONS_MARK_BIT) 679 #define rep_GC_CLR_CONS(v) (rep_CDR(v) &= ~rep_VALUE_CONS_MARK_BIT) 680 681 /* True when cell V has been marked. */ 682 #define rep_GC_MARKEDP(v) \ 683 (rep_CELL_CONS_P(v) ? rep_GC_CONS_MARKEDP(v) : rep_GC_CELL_MARKEDP(v)) 684 685 /* Set the mark bit of cell V. */ 686 #define rep_GC_SET(v) \ 687 do { \ 688 if(rep_CELLP(v)) \ 689 rep_GC_SET_CELL(v); \ 690 else \ 691 rep_GC_SET_CONS(v); \ 692 } while(0) 693 694 /* Clear the mark bit of cell V. */ 695 #define rep_GC_CLR(v) \ 696 do { \ 697 if(rep_CELLP(v)) \ 698 rep_GC_CLR_CELL(v); \ 699 else \ 700 rep_GC_CLR_CONS(v); \ 701 } while(0) 702 703 /* Recursively mark object V. */ 704 #define rep_MARKVAL(v) \ 705 do { \ 706 if(v != 0 && !rep_INTP(v) && !rep_GC_MARKEDP(v)) \ 707 rep_mark_value(v); \ 708 } while(0) 709 710 /* A stack of dynamic GC roots, i.e. objects to start marking from. */ 711 typedef struct rep_gc_root { 712 repv *ptr; 713 struct rep_gc_root *next; 714 } rep_GC_root; 715 716 typedef struct rep_gc_n_roots { 717 repv *first; 718 int count; 719 struct rep_gc_n_roots *next; 720 } rep_GC_n_roots; 721 722 /* Push a root to VAL using ROOT as storage (ROOT is rep_GC_root type) */ 723 #define rep_PUSHGC(root, val) \ 724 do { \ 725 (root).ptr = &(val); \ 726 (root).next = rep_gc_root_stack; \ 727 rep_gc_root_stack = &(root); \ 728 } while(0) 729 730 /* Push a root to N values starting at PTR using ROOT as storage 731 (ROOT is rep_GC_n_roots type) */ 732 #define rep_PUSHGCN(root, ptr, n) \ 733 do { \ 734 (root).first = (ptr); \ 735 (root).count = (n); \ 736 (root).next = rep_gc_n_roots_stack; \ 737 rep_gc_n_roots_stack = &(root); \ 738 } while(0) 739 740 #if !defined (rep_PARANOID_GC) 741 742 # define rep_POPGC (rep_gc_root_stack = rep_gc_root_stack->next) 743 # define rep_POPGCN (rep_gc_n_roots_stack = rep_gc_n_roots_stack->next) 744 745 #else 746 747 /* Check that gc roots are popped when they should have been; 748 assumes downwards growing stack */ 749 750 # if defined (__GNUC__) && defined (sparc) 751 # define rep_get_sp(var) asm ("mov %%sp, %0" : "=r" (var)) 752 # else 753 # error "don't know how to get stack ptr on this arch, undef rep_PARANOID_GC" 754 # endif 755 756 #define rep_CHECK_GC(root) \ 757 char *sp; rep_get_sp(sp); \ 758 if (sp > (char *) root) \ 759 abort (); 760 761 # define rep_POPGC \ 762 do { \ 763 rep_CHECK_GC(rep_gc_root_stack) \ 764 rep_gc_root_stack = rep_gc_root_stack->next; \ 765 } while (0) 766 767 # define rep_POPGCN \ 768 do { \ 769 rep_CHECK_GC(rep_gc_n_roots_stack) \ 770 rep_gc_n_roots_stack = rep_gc_n_roots_stack->next; \ 771 } while (0) 772 773 #endif 774 775 776 /* Macros for declaring functions */ 777 778 /* Define a function named NAME (a string), whose function body will 779 be called FSYM, whose rep_subr will be called SSYM, with argument 780 list ARGS, of type code TYPE. */ 781 #define DEFUN(name,fsym,ssym,args,type) \ 782 DEFSTRING(rep_CONCAT(ssym, __name), name); \ 783 extern repv fsym args; \ 784 rep_ALIGN_CELL(rep_xsubr ssym) = { type, (repv (*)()) fsym, \ 785 rep_VAL(&rep_CONCAT(ssym, __name)), \ 786 rep_NULL, rep_NULL }; \ 787 repv fsym args 788 789 /* Same as above but with an extra arg -- an interactive-spec string. */ 790 #define DEFUN_INT(name,fsym,ssym,args,type,interactive) \ 791 DEFSTRING(rep_CONCAT(ssym, __name), name); \ 792 DEFSTRING(rep_CONCAT(ssym, __int), interactive); \ 793 extern repv fsym args; \ 794 rep_ALIGN_CELL(rep_xsubr ssym) = { type, (repv (*)()) fsym, \ 795 rep_VAL(&rep_CONCAT(ssym, __name)), \ 796 rep_VAL(&rep_CONCAT(ssym, __int)), \ 797 rep_NULL}; \ 798 repv fsym args 799 800 /* Add a subroutine */ 801 #define rep_ADD_SUBR(subr) rep_add_subr(&subr, rep_TRUE) 802 803 /* Add a non-exported subroutine */ 804 #define rep_ADD_INTERNAL_SUBR(subr) rep_add_subr(&subr, rep_FALSE) 805 806 /* Add an interactive subroutine */ 807 #define rep_ADD_SUBR_INT(subr) rep_add_subr(&subr, rep_TRUE) 808 809 /* Declare a symbol stored in variable QX. */ 810 #define DEFSYM(x, name) \ 811 repv Q ## x; DEFSTRING(str_ ## x, name) 812 813 /* Intern a symbol stored in QX, whose name (a lisp string) is stored 814 in str_X (i.e. declared with DEFSYM) */ 815 #define rep_INTERN(x) rep_intern_static(& Q ## x, rep_VAL(& str_ ## x)) 816 817 /* Same as above, but also marks the variable as dynamically scoped */ 818 #define rep_INTERN_SPECIAL(x) \ 819 do { \ 820 rep_intern_static (& Q ## x, rep_VAL(& str_ ## x)); \ 821 Fmake_variable_special (Q ## x); \ 822 rep_SYM(Q ## x)->car |= rep_SF_DEFVAR; \ 823 } while (0) 824 825 /* Add an error string called err_X for symbol stored in QX */ 826 #define rep_ERROR(x) \ 827 Fput(Q ## x, Qerror_message, rep_VAL(& err_ ## x)) 828 829 830 /* Macros for ensuring an object is of a certain type i.e. to ensure 831 first arg `foo' is a string, rep_DECLARE1(foo, rep_STRINGP); */ 832 833 #define rep_DECLARE(n,x,e) \ 834 do { \ 835 if(! (e)) \ 836 { \ 837 rep_signal_arg_error(x, n); \ 838 return rep_NULL; \ 839 } \ 840 } while(0) 841 842 #define rep_DECLARE1(x,t) rep_DECLARE(1,x,t(x)) 843 #define rep_DECLARE2(x,t) rep_DECLARE(2,x,t(x)) 844 #define rep_DECLARE3(x,t) rep_DECLARE(3,x,t(x)) 845 #define rep_DECLARE4(x,t) rep_DECLARE(4,x,t(x)) 846 #define rep_DECLARE5(x,t) rep_DECLARE(5,x,t(x)) 847 848 #define rep_DECLARE1_OPT(x,t) rep_DECLARE(1, x, (x) == Qnil || t(x)) 849 #define rep_DECLARE2_OPT(x,t) rep_DECLARE(2, x, (x) == Qnil || t(x)) 850 #define rep_DECLARE3_OPT(x,t) rep_DECLARE(3, x, (x) == Qnil || t(x)) 851 #define rep_DECLARE4_OPT(x,t) rep_DECLARE(4, x, (x) == Qnil || t(x)) 852 #define rep_DECLARE5_OPT(x,t) rep_DECLARE(5, x, (x) == Qnil || t(x)) 853 854 855 /* Macros for interrupt handling */ 856 857 #define rep_MAY_YIELD \ 858 do { \ 859 if (rep_pending_thread_yield && rep_thread_lock == 0) \ 860 Fthread_yield (); \ 861 } while (0) 862 863 #define rep_FORBID rep_thread_lock++ 864 #define rep_PERMIT rep_thread_lock-- 865 #define rep_PREEMPTABLE_P (rep_thread_lock <= 0) 866 867 /* rep_TEST_INT is called before testing rep_INTERRUPTP, if necessary the 868 target operating system will define it to be something useful. 869 There's also a variant rep_TEST_INT_SLOW that should be used by code that 870 only checks a few times or less a second */ 871 #ifndef rep_TEST_INT 872 873 # define rep_TEST_INT \ 874 do { \ 875 if(++rep_test_int_counter > rep_test_int_period) { \ 876 (*rep_test_int_fun)(); \ 877 rep_test_int_counter = 0; \ 878 rep_pending_thread_yield = rep_TRUE; \ 879 } \ 880 } while(0) 881 882 # define rep_TEST_INT_SLOW \ 883 do { \ 884 (*rep_test_int_fun)(); \ 885 rep_test_int_counter = 0; \ 886 if (!rep_INTERRUPTP) \ 887 Fthread_yield (); \ 888 } while(0) 889 890 #else /* !rep_TEST_INT */ 891 892 # ifndef rep_TEST_INT_SLOW 893 # define rep_TEST_INT_SLOW rep_TEST_INT 894 # endif 895 896 #endif 897 898 /* True when an interrupt has occurred; this means that the function 899 should exit as soon as possible, returning rep_NULL. */ 900 #define rep_INTERRUPTP (rep_throw_value != rep_NULL) 901 902 903 /* End-of-list / false value 904 905 The canonical method of getting '() is to access the `Qnil' variable. 906 907 But we know that that currently points to `rep_eol_datum'. So avoid 908 lots of global variable referencing by hardcoding that value for 909 library-internal code. */ 910 911 extern repv Qnil; 912 913 #ifdef rep_INTERNAL 914 extern rep_tuple rep_eol_datum; 915 # ifdef rep_DEFINE_QNIL 916 repv Qnil = rep_VAL (&rep_eol_datum); 917 # endif 918 /* OS X has problems with this */ 919 # ifndef __APPLE__ 920 # define Qnil rep_VAL(&rep_eol_datum) 921 # endif 922 #endif 923 924 925 /* Storing timestamps */ 926 927 #define rep_MAKE_TIME(time) \ 928 Fcons(rep_MAKE_INT(time / 86400), rep_MAKE_INT(time % 86400)) 929 930 #define rep_GET_TIME(time) \ 931 (rep_INT(rep_CAR(time)) * 86400 + rep_INT(rep_CDR(time))) 932 933 #define rep_TIMEP(v) rep_CONSP(v) 934 935 #endif /* REP_LISP_H */ 936