/ listpack.c
listpack.c
1 // LIST PROCESSING PACKAGE (FOR 2960/EMAS) DAT 23/11/79 2 // WARNING - MUCH OF THIS CODE IS MACHINE DEPENDENT 3 #include "listhdr.h" 4 5 //---------------------------------------------------------------------- 6 //The KRC system is Copyright (c) D. A. Turner 1981 7 //All rights reserved. It is distributed as free software under the 8 //terms in the file "COPYING", which is included in the distribution. 9 //---------------------------------------------------------------------- 10 11 #include <string.h> // for strlen() 12 #include <ctype.h> // for toupper() 13 #include <unistd.h> // for sbrk() 14 #include <sys/time.h> // for <sys/resource.h> 15 #include <sys/resource.h> // for set/getrlimit() 16 #include <stdlib.h> // for getenv() 17 #include <stdio.h> // for sscanf() 18 19 // #define DEBUG_GC 1 20 21 #ifndef HEAPSIZE 22 #define HEAPSIZE 128000 23 #endif 24 int SPACE=HEAPSIZE; //SPACE IS THE NUMBER OF LIST CELLS IN EACH 25 //SEMI-SPACE. ON 2960/EMAS MUST BE <=128K 26 27 static int DICMAX=64000; //ATOMSPACE is DICMAX/atomsize, see later 28 static int ATOMSPACE; //MAX NUMBER OF ATOMS WHICH CAN BE STORED 29 //The actual number of atoms is less 30 //because their names are also stored there 31 #define ATOMSIZE 255 //MAX NO OF CHARS IN AN ATOM 32 33 // Non-pointer value for the HD of an entry in CONS space, 34 // indicating that it is an integer, stored in the TL field. 35 #define FULLWORD (NIL-1) 36 37 // Impossible value of pointer or integer used as flag during GC. 38 #define GONETO ((LIST)(1ULL<<(sizeof(LIST)*8-1))) // just top bit set 39 40 static LIST CONSBASE, CONSLIMIT, CONSP, OTHERBASE; 41 static LIST *STACKBASE; 42 //static struct ATOM *ATOMBASE; 43 static ATOM ATOMBASE; 44 static ATOM ATOMP, ATOMLIMIT; 45 static WORD NOGCS=0, RECLAIMS=0; 46 BOOL ATGC; 47 extern char *USERLIB; 48 49 #ifdef INSTRUMENT_KRC_GC 50 // ARE WE CURRENTLY IN THE GARBAGE COLLECTOR? 51 BOOL COLLECTING = FALSE; 52 #endif 53 54 static ATOM HASHV[128]; 55 56 static char BUFFER[ATOMSIZE+1]; static WORD BUFP=0; 57 58 int ARGC; char **ARGV; // Program parameters 59 60 61 // Forward declarations 62 STATIC WORD HASH(char *S, int LEN); 63 static void GC(void); 64 static void COPY(LIST *P); 65 static void COPYHEADS(void); 66 67 void main2(); 68 69 int 70 main(int argc, char **argv) 71 { int I; 72 ARGC=argc; ARGV=argv; 73 74 // Detect when we are run from a #! script on a system that 75 // passes all parameters from the #! line as a single one. 76 // We get: argv[0]="/path/to/krc 77 // argv[1]="-n -e primes?" 78 // argv[2]="path/to/script" 79 // argv[3..]=args passed to the script 80 IF argc>1 && argv[1][0]=='-' && strchr(argv[1], ' ') != NULL DO { 81 int nspaces=0; char *cp; 82 // Allocate space for new ARGV 83 FOR (cp=argv[1]+1; *cp; cp++) IF *cp==' ' DO nspaces++; 84 // Each space generates one more argument 85 ARGV=calloc(argc+nspaces, sizeof(char *)); 86 IF ARGV==NULL DO exit(1); 87 88 // Rewrite ARGV splitting up the first arg 89 // If we find "-e ", all the rest is a single expression 90 ARGV[0]=argv[0]; ARGC=1; 91 FOR (cp=argv[1]; *cp; ) { 92 // Plant another argument 93 ARGV[ARGC++]=cp; 94 // Find end of arg 95 IF strncasecmp(cp, "-e ", 3)==0 DO { 96 // After "-e", all the rest is the expr to evaluate 97 cp += 2; *cp++='\0'; ARGV[ARGC++]=cp; 98 BREAK; 99 } 100 IF strchr(cp, ' ') == NULL DO BREAK; // No more spaces 101 cp=strchr(cp, ' '), *cp++ = '\0'; 102 } 103 // Now copy the rest of ARGV: the script name and its args 104 FOR (I=2; I<argc; I++) ARGV[ARGC++]=argv[I]; 105 } 106 107 // Terminal output should be unbuffered 108 setvbuf(stdout, NULL, _IONBF, 0); 109 110 // More Unix-ey stuff. The stack's soft limit is set to 8192K 111 // on some Linux disributions, which makes your long-running KRC 112 // program die pointlessly after the millionth prime number. 113 // Avoid this by upping the soft stack limit to the hard maximum. 114 { struct rlimit rlim; 115 if (getrlimit(RLIMIT_STACK, &rlim) == 0) { 116 rlim.rlim_cur = rlim.rlim_max; 117 setrlimit(RLIMIT_STACK, &rlim); 118 } 119 // it says that this can also affect stack growth 120 if (getrlimit(RLIMIT_AS, &rlim) == 0) { 121 rlim.rlim_cur = rlim.rlim_max; 122 setrlimit(RLIMIT_AS, &rlim); 123 } 124 } 125 126 // Handle command line arguments that affect this file 127 FOR (I=1; I<ARGC; I++) { 128 IF ARGV[I][0]=='-' DO 129 SWITCHON ARGV[I][1] INTO { 130 CASE 'g': ATGC=TRUE; ENDCASE 131 CASE 'h': IF ++I>=ARGC || (SPACE=atoi(ARGV[I]))<=0 DO { 132 WRITES("krc: -h What?\n"); FINISH } 133 ENDCASE 134 CASE 'l': TEST ++I>=ARGC //doesn't logically belong in listpack 135 THEN { WRITES("krc: -l What?\n"); FINISH } 136 OR USERLIB=ARGV[I]; 137 ENDCASE 138 CASE 'd': IF ++I>=ARGC || (DICMAX=atoi(ARGV[I]))<=0 DO { 139 WRITES("krc: -d What?\n"); FINISH } 140 ENDCASE 141 } 142 } 143 144 // TAKING ADVANTAGE OF THE FACT THAT WE HAVE VIRTUAL MEMORY, WE SET UP 145 // TWO COPIES OF LIST SPACE IN ORDER TO BE ABLE TO DO GARBAGE COLLECTIO 146 // BY DOING A GRAPH COPY FROM ONE SPACE TO THE OTHER 147 ATOMSPACE=DICMAX/atomsize; 148 CONSBASE=(LIST)sbrk(SPACE*sizeof(*CONSBASE)); 149 if (CONSBASE == (void *)-1) SPACE_ERROR("Not enough memory"); 150 CONSP=CONSBASE, CONSLIMIT=CONSBASE+SPACE; 151 OTHERBASE=(LIST)sbrk(SPACE*sizeof(*CONSBASE)); 152 if (OTHERBASE == (void *)-1) SPACE_ERROR("Not enough memory"); 153 ATOMBASE=(ATOM)sbrk(ATOMSPACE*sizeof(*ATOMBASE)); 154 if (ATOMBASE == (void *)-1) SPACE_ERROR("Not enough memory"); 155 ATOMP=ATOMBASE; ATOMLIMIT=ATOMBASE+ATOMSPACE; 156 157 main2(); 158 } 159 160 // A separate function finds STACKBASE, to avoid inclusion of any 161 // locals, temporaries and stacked stuff belonging to main(). 162 void main2() 163 { 164 LIST N; // MARKER TO FIND STACK BASE 165 STACKBASE=&N; 166 GO(); } //"GO" IS THE USER'S START ROUTINE 167 168 WORD 169 HAVEPARAM(WORD CH) 170 { 171 WORD I; 172 CH = toupper(CH); 173 FOR (I=1; I<ARGC; I++) 174 IF ARGV[I][0] == '-' && toupper(ARGV[I][1]) == toupper(CH) 175 DO RESULTIS TRUE; 176 RESULTIS FALSE; } 177 178 LIST 179 CONS(LIST X, LIST Y) 180 { 181 IF CONSP>=(CONSLIMIT-1) DO GC(); 182 HD(CONSP)=X,TL(CONSP)=Y,CONSP=CONSP+1; 183 RESULTIS CONSP-1; 184 } 185 186 #include <setjmp.h> 187 188 void GC2(jmp_buf *); 189 void GC3(jmp_buf *, LIST *STACKEND); 190 191 void 192 GC() 193 { 194 // Put all registers onto the stack so that any pointers into 195 // the CONS space will be updated during the GC and put back 196 // in the registers when GC3() returns here with longjmp. 197 jmp_buf env; 198 if (setjmp(env) == 0) GC2(&env); 199 } 200 201 void // Not static to avoid inlining 202 GC2(jmp_buf *envp) 203 { 204 // Get the address of the end of the stack 205 // including the jmp_buf containing the registers but 206 // excluding anything that the real GC() might push onto the stack 207 // for its own purposes. 208 LIST P; 209 GC3(envp, &P); 210 } 211 212 // GARBAGE COLLECTOR - DOES A GRAPH COPY INTO THE OTHER SEMI-SPACE 213 void // Not static to avoid inlining 214 GC3(jmp_buf *envp, LIST *STACKEND) 215 { LIST *P; // Examine every pointer on the stack 216 // P is a pointer to pointer, so incrementing it 217 // moved it up by the size of one pointer. 218 extern VOID HOLD_INTERRUPTS(), RELEASE_INTERRUPTS(); // In MAIN.c 219 220 #ifdef DEBUG_GC 221 int LASTUSED = 0; 222 WRITEF("\n<"); 223 224 #define SHOW(name) do{ \ 225 WRITEF(name":%d",(int)(CONSP-OTHERBASE)-LASTUSED); \ 226 LASTUSED=CONSP-OTHERBASE; \ 227 COPYHEADS(); WRITEF("+%d ",(int)(CONSP-OTHERBASE)-LASTUSED); \ 228 LASTUSED=CONSP-OTHERBASE; }while(0) 229 #else 230 #define SHOW(name) do{}while(0) 231 #endif 232 233 #ifdef INSTRUMENT_KRC_GC 234 COLLECTING = TRUE; 235 #endif 236 HOLD_INTERRUPTS(); 237 NOGCS = NOGCS+1; 238 IF ATGC DO WRITES("<gc called>\n"); 239 CONSP=OTHERBASE; 240 BASES(COPY); // USER'S STATIC VARIABLES ETC. 241 SHOW("bases"); 242 { WORD I; 243 FOR (I=0; I < 128; I++) 244 { ATOM A=HASHV[I]; // VAL FIELDS OF ATOMS 245 UNTIL A==0 246 DO { COPY((LIST *)&(VAL(A))); 247 A=LINK(A); } } } 248 SHOW("atoms"); 249 250 // Runtime detection of stack growth direction 251 TEST STACKBASE < STACKEND 252 THEN 253 // STACK GROW UPWARDS 254 FOR (P=STACKBASE+1; P<STACKEND; P++) { 255 IF CONSBASE<=(LIST)*P && (LIST)*P<CONSLIMIT DO { 256 IF ((char *)*P-(char *)CONSBASE)%sizeof(struct LIST)==0 257 DO // AN ALIGNED ADDRESS IN LISTSPACE 258 COPY(P); 259 IF ((char *)*P-(char *)CONSBASE)%sizeof(struct LIST)==sizeof(struct LIST *) 260 DO { 261 // Pointer to a tail cell, which also needs updating 262 *P = (LIST) ((LIST *)*P - 1); 263 COPY(P); 264 *P = (LIST) ((LIST *)*P + 1); 265 } 266 } 267 } 268 OR 269 // STACK GROWS DOWNWARDS 270 FOR (P=STACKBASE-1; P>STACKEND; P--) { 271 IF CONSBASE<=(LIST)*P && (LIST)*P<CONSLIMIT DO { 272 IF ((char *)*P-(char *)CONSBASE)%sizeof(struct LIST)==0 273 DO // AN ALIGNED ADDRESS IN LISTSPACE 274 COPY(P); 275 IF ((char *)*P-(char *)CONSBASE)%sizeof(struct LIST)==sizeof(struct LIST *) 276 DO { 277 // Pointer to a tail cells, which also needs updating 278 *P = (LIST) ((LIST *)*P - 1); 279 COPY(P); 280 *P = (LIST) ((LIST *)*P + 1); 281 } 282 } 283 IF P == (LIST *)(envp+1) DO { 284 SHOW("stack"); 285 #ifdef __GLIBC__ 286 // The jmp_buf has 128 bytes to save the signal mask, which 287 // are not set and provide a window onto an area of the 288 // stack which can contain old pointers to now unused parts 289 // of CONSSPACE. Apart from copying old junk pointlessly, 290 // it can makes the interpreter unable to recover from 291 // an out-of-space condition when the junk happens to be 292 // > 90% of the available space. 293 // Here we make P hop over this nasty window to take it to 294 // straight to the machine registers at the start of the 295 // buffer. 296 P = (LIST *)((char *)(&((*envp)->__jmpbuf)) 297 +sizeof((*envp)->__jmpbuf)); 298 #endif 299 } 300 } 301 SHOW("regs"); 302 #ifdef DEBUG_GC 303 WRITEF(">\n"); 304 #endif 305 306 COPYHEADS(); 307 // NOW SWAP SEMI-SPACES 308 { LIST HOLD=CONSBASE; 309 CONSBASE=OTHERBASE,CONSLIMIT=OTHERBASE+SPACE,OTHERBASE=HOLD; 310 } 311 RECLAIMS = RECLAIMS + (CONSLIMIT-CONSP); 312 #if 0 313 IF ATGC DO WRITEF("<%d cells in use>\n",(int)(CONSP-CONSBASE)); 314 #else 315 // Don't call printf, as if leaves unaligned pointers into 316 // CONS space on the stack. 317 IF ATGC DO { 318 WRITES("<"); 319 WRITEN((WORD)(CONSP-CONSBASE)); 320 WRITES(" cells in use>\n"); 321 } 322 #endif 323 RELEASE_INTERRUPTS(); 324 325 IF CONSP-CONSBASE > (9*SPACE)/10 //ABANDON JOB IF SPACE 326 DO SPACE_ERROR("Space exhausted"); //UTILISATION EXCEEDS 90% 327 328 #ifdef INSTRUMENT_KRC_GC 329 COLLECTING = FALSE; 330 #endif 331 longjmp(*envp, 1); 332 } 333 334 static void 335 COPY(LIST *P) // P IS THE ADDRESS OF A LIST FIELD 336 { 337 // DO $( WRITES("COPYING ") 338 // PRINTOB(*P) 339 // NEWLINE() $) <> 340 WHILE CONSBASE<=*P && *P<CONSLIMIT 341 DO { IF HD(*P)==GONETO 342 DO { *P=TL(*P); 343 RETURN } 344 { LIST X=HD(*P); 345 LIST Y=TL(*P); 346 LIST Z=CONSP; 347 HD(*P)=GONETO; 348 TL(*P)=Z; 349 *P=Z; 350 HD(Z)=X, TL(Z)=Y; 351 CONSP=CONSP+1; 352 IF X==FULLWORD DO RETURN 353 P=&(TL(Z)); } } } 354 355 static void 356 COPYHEADS() 357 { LIST Z = OTHERBASE; 358 UNTIL Z == CONSP 359 DO { COPY(&(HD(Z))); 360 Z = Z+1; } 361 } 362 363 WORD 364 ISCONS(LIST X) 365 #ifdef INSTRUMENT_KRC_GC 366 { IF CONSBASE<=X && X<CONSLIMIT DO 367 { IF ((char *)X - (char *)CONSLIMIT) % sizeof(struct LIST) != 0 DO 368 { WRITEF("\nMisaligned pointer %p in ISCONS\n", X); RESULTIS FALSE; } 369 RESULTIS HD(X)!=FULLWORD; } 370 RESULTIS FALSE; } 371 #else 372 { RESULTIS CONSBASE<=X && X<CONSLIMIT ? HD(X)!=FULLWORD : FALSE; } 373 #endif 374 375 WORD 376 ISATOM(LIST X) 377 { RESULTIS ATOMBASE<=(ATOM)X && (ATOM)X<ATOMP; } 378 379 WORD 380 ISNUM(LIST X) 381 #ifdef INSTRUMENT_KRC_GC 382 { IF CONSBASE<=X && X<CONSLIMIT DO 383 { IF ((char *)X - (char *)CONSLIMIT) % sizeof(struct LIST) != 0 DO 384 { WRITEF("\nMisaligned pointer %p in ISNUM\n", X); RESULTIS FALSE; } 385 RESULTIS HD(X)==FULLWORD; } 386 RESULTIS FALSE; } 387 #else 388 { RESULTIS CONSBASE<=X&&X<CONSLIMIT ? HD(X)==FULLWORD : FALSE; } 389 #endif 390 391 LIST 392 STONUM(WORD N) {RESULTIS CONS(FULLWORD,(LIST)N);} // GCC WARNING EXPECTED 393 394 WORD 395 GETNUM(LIST X) {RESULTIS (WORD)(TL(X));} // GCC WARNING EXPECTED 396 397 ATOM 398 MKATOM(char *S) // make an ATOM from a C string 399 { RESULTIS MKATOMN(S, strlen(S)); } 400 401 ATOM 402 MKATOMN(char *S, int LEN) // make an ATOM which might contain NULs 403 { ATOM *BUCKET = &(HASHV[HASH(S,LEN)]); 404 ATOM *P=BUCKET; 405 // N is size of string counted as the number of pointers it occupies 406 WORD N; 407 UNTIL *P==0 DO // SEARCH THE APPROPRIATE BUCKET 408 { IF LEN==LEN(*P) && memcmp(S, PRINTNAME(*P), (size_t)LEN) == 0 409 DO RESULTIS (ATOM)*P; 410 P=&(LINK(*P)); } 411 //CREATE NEW ATOM 412 // +1 for the BCPL size, +1 for the \0, then round up to element size 413 N = (1+LEN+1 + (sizeof(WORD *))-1) / sizeof(WORD *); 414 IF (WORD **)ATOMP+OFFSET+N > (WORD **)ATOMLIMIT 415 DO { WRITES("<string space exhausted>\n"); 416 FINISH } 417 *P=ATOMP, LINK(ATOMP)=0, VAL(ATOMP)=NIL; 418 NAME(ATOMP)[0]=LEN, 419 memcpy(NAME(ATOMP)+1, S, (size_t)LEN), 420 NAME(ATOMP)[LEN+1]= '\0'; 421 ATOMP=(ATOM)((WORD **)ATOMP+OFFSET+N); 422 RESULTIS *P; 423 } 424 425 STATIC WORD 426 HASH(char *S, int LEN) // TAKES A NAME AND RETURNS A VALUE IN 0..127 427 { int H=LEN; 428 IF LEN && S[0] DO { 429 H=H+S[0]*37; LEN=LEN-1; 430 IF LEN && S[1] DO { 431 H=H+S[1]; LEN=LEN-1; 432 IF LEN && S[2] DO { 433 H=H+S[2]; LEN=LEN-1; 434 IF LEN && S[3] DO 435 H=H+S[3]; 436 } } } 437 438 RESULTIS H&0x7F; } 439 440 VOID 441 BUFCH(WORD CH) 442 { IF BUFP>=ATOMSIZE 443 DO { SPACE_ERROR("Atom too big"); } 444 BUFFER[BUFP++] = CH; } 445 446 ATOM 447 PACKBUFFER() 448 { ATOM RESULT=MKATOMN(BUFFER,BUFP); 449 BUFP=0; 450 RESULTIS RESULT; } 451 452 // Does string A sort before string B? 453 BOOL 454 ALFA_LS(ATOM A, ATOM B) // A,B ARE ATOMS 455 { RESULTIS strcmp(PRINTNAME(A), PRINTNAME(B)) < 0; } 456 457 STATIC void 458 GCSTATS() 459 { WRITEF("Cells claimed = %d, no of gc's = %d", 460 (int)(RECLAIMS+(CONSP-CONSBASE)/2), (int)NOGCS); } 461 462 void 463 RESETGCSTATS() 464 { NOGCS=0, RECLAIMS=-(CONSP-CONSBASE); } 465 466 void 467 FORCE_GC() 468 { RECLAIMS=RECLAIMS-(CONSLIMIT-CONSP);//TO COMPENSATE FOR CALLING 469 //TOO EARLY 470 IF ATGC DO WRITEF("Max cells available = %d\n",SPACE); 471 GC(); 472 } 473 474 void 475 REPORTDIC() 476 { WRITEF("string space = %ld bytes",(long)(ATOMSPACE*atomsize)); 477 WRITEF(", used %ld\n",(long)((ATOMP-ATOMBASE)*atomsize)); 478 } 479 480 void 481 LISTPM() 482 { WORD EMPTY = 0; 483 WORD I; 484 WRITES("\n LIST POST MORTEM\n"); 485 GCSTATS(); 486 WRITEF(", current cells = %d\n",(int)((CONSP-CONSBASE)/2)); 487 IF BUFP>0 488 DO { WRITES("Buffer: "); 489 FOR (I = 0; I<BUFP; I++) { WRCH(BUFFER[I]); } 490 NEWLINE(); } 491 WRITES("Atom buckets:\n"); 492 FOR (I=0; I<128; I++) 493 TEST HASHV[I] != 0 494 THEN { ATOM P=HASHV[I]; 495 WRITEF("%d :\t", (int)I); 496 UNTIL P==0 497 DO { WRITES(PRINTNAME(P)); 498 UNLESS VAL(P)==NIL 499 DO { WRITES(" = "); 500 PRINTOB(VAL(P)); } 501 P=LINK(P); 502 IF P!=0 DO WRITES("\n\t"); 503 } 504 NEWLINE(); } 505 OR EMPTY = EMPTY + 1; 506 WRITEF("Empty buckets = %d\n", (int)EMPTY); } 507 508 WORD 509 LENGTH(LIST X) 510 { WORD N = 0; 511 UNTIL X==NIL 512 DO X=TL(X),N=N+1; 513 RESULTIS N; } 514 515 WORD 516 MEMBER(LIST X, LIST A) 517 { UNTIL X==NIL || HD(X)==A 518 DO X = TL(X); 519 RESULTIS X!=NIL; } 520 521 LIST 522 APPEND(LIST X, LIST Y) { RESULTIS SHUNT(SHUNT(X,NIL),Y); } 523 524 LIST 525 REVERSE(LIST X) { RESULTIS SHUNT(X,NIL); } 526 527 LIST 528 SHUNT(LIST X, LIST Y) 529 { UNTIL X==NIL 530 DO { Y=CONS(HD(X),Y); 531 X=TL(X); } 532 RESULTIS Y; } 533 534 LIST 535 SUB1(LIST X, ATOM A) //DESTRUCTIVELY REMOVES A FROM X (IF PRESENT) 536 { IF X==NIL DO RESULTIS NIL; 537 IF HD(X)==(LIST)A DO RESULTIS TL(X); 538 { LIST *P=&(TL(X)); 539 UNTIL (*P==NIL) || HD(*P)==(LIST)A DO P=&(TL(*P)); 540 UNLESS *P==NIL DO *P=TL(*P); 541 RESULTIS X; } } 542 543 WORD 544 EQUAL(LIST X, LIST Y) 545 { do { 546 IF X==Y DO RESULTIS TRUE; 547 IF ISNUM(X) && ISNUM(Y) 548 DO RESULTIS GETNUM(X)==GETNUM(Y); 549 UNLESS ISCONS(X) && ISCONS(Y) && EQUAL(HD(X),HD(Y)) 550 DO RESULTIS FALSE; 551 X=TL(X), Y=TL(Y); 552 } while(1); 553 } 554 555 LIST 556 ELEM(LIST X, WORD N) 557 { UNTIL N==1 DO X=TL(X),N=N-1; 558 RESULTIS HD(X); } 559 560 void 561 PRINTOB(LIST X) //or ATOM 562 { TEST X==NIL THEN WRITES("NIL"); OR 563 TEST ISATOM(X) THEN WRITEF("\"%s\"",PRINTNAME((ATOM)X)); OR 564 TEST ISNUM(X) THEN WRITEN(GETNUM(X)); OR 565 TEST ISCONS(X) 566 THEN { WRCH('('); 567 WHILE ISCONS(X) 568 DO { PRINTOB(HD(X)); 569 WRCH('.'); 570 X=TL(X); } 571 PRINTOB(X); 572 WRCH(')'); } 573 OR WRITEF("<%p>", X); 574 } 575 576 577 #ifdef INSTRUMENT_KRC_GC 578 // DEBUGGING FUNCTION: ENSURE THAT P IS A VALID POINTER INTO CONS SPACE 579 // AND BOMB IF NOT. 580 LIST 581 ISOKCONS(LIST P) 582 { 583 LIST Q; 584 IF COLLECTING DO RESULTIS P; 585 586 TEST CONSBASE<=P && P<CONSLIMIT 587 THEN 588 // (ONLY EVEN ADDRESSES IN LISTSPACE COUNT) 589 TEST ((char *)P - (char *)CONSBASE) % sizeof(struct LIST) == 0 590 THEN RESULTIS P; 591 OR { WRITEF("\nHD() or TL() called on ODD address %p\n", P); } 592 OR { WRITEF("\nHD() or TL() called on %p not in CONS space\n", P); } 593 RESULTIS (LIST)0; // Cause segfault in caller 594 } 595 #endif