/ reducer.c
reducer.c
1 //KRC REDUCER 2 3 #include "listhdr.h" 4 #include "comphdr.h" 5 #include "redhdr.h" 6 7 //---------------------------------------------------------------------- 8 //The KRC system is Copyright (c) D. A. Turner 1981 9 //All rights reserved. It is distributed as free software under the 10 //terms in the file "COPYING", which is included in the distribution. 11 //---------------------------------------------------------------------- 12 13 #include <string.h> // for strlen() 14 #include <unistd.h> // for sbrk() 15 #include <ctype.h> // for isprint() 16 #include <signal.h> // for raise(), SIGINT 17 18 // Global variables owned by reducer 19 LIST MEMORIES = NIL; 20 WORD REDS; 21 WORD LISTBASE=0; //base for list indexing 22 WORD ABORTED=FALSE; 23 24 STATIC ATOM ETC, SILLYNESS, GUARD, LISTDIFF, BADFILE, READFN, WRITEFN, 25 INTERLEAVEFN; 26 27 // ARGUMENT STACK. ARGP points to the last cell allocated 28 STATIC LIST *ARGSPACE=NULL; 29 STATIC LIST *ARG; 30 STATIC LIST *ARGMAX; 31 STATIC LIST *ARGP; 32 33 VOID 34 INIT_ARGSPACE(VOID) 35 { 36 IF ARGSPACE==NULL DO { 37 extern int SPACE; // Number of LIST cells, in listpack.c 38 int NARGS=SPACE/5; // Empirically, using edigits, with SPACE/6, 39 // the argstack exhausts first. with /5, it 40 // runs out of heap first. 41 ARGSPACE=(LIST *)sbrk(NARGS*sizeof(*ARGSPACE)); 42 IF ARGSPACE==(void *)-1 DO SPACE_ERROR("Cannot allocate argument stack"); 43 ARGMAX=ARGSPACE+NARGS-1; 44 } 45 ARG=ARGSPACE, ARGP=ARG-1; 46 } 47 48 // Sentinel value (impossible pointer) 49 #define ENDOFSTACK (-4) 50 51 LIST S; 52 53 // Local function declarations 54 STATIC VOID SIZE(LIST E); 55 56 //PRIMITIVE FUNCTIONS 57 STATIC VOID FUNCTIONP(LIST E); 58 STATIC VOID LISTP(LIST E); 59 STATIC VOID STRINGP(LIST E); 60 STATIC VOID NUMBERP(LIST E); 61 STATIC VOID CHAR(LIST E); 62 STATIC VOID SIZE(LIST E); 63 STATIC VOID CODE(LIST E); 64 STATIC VOID DECODE(LIST E); 65 STATIC VOID CONCAT(LIST E); 66 STATIC VOID EXPLODE(LIST E); 67 STATIC VOID ABORT(LIST E); 68 STATIC VOID STARTREAD(LIST E); 69 STATIC VOID READ(LIST E); 70 STATIC VOID WRITEAP(LIST E); 71 STATIC VOID SEQ(LIST E); 72 73 // LOCAL FUNCTION DELARATIONS 74 STATIC VOID PRINTFUNCTION(LIST E); 75 STATIC BOOL EQUALVAL(LIST A,LIST B); 76 STATIC VOID BADEXP(LIST E); 77 STATIC VOID OVERFLOW(LIST E); 78 STATIC VOID OBEY(LIST EQNS,LIST E); 79 STATIC BOOL ISFUN(LIST X);; 80 STATIC LIST REDUCE(LIST E); 81 STATIC LIST SUBSTITUTE(LIST ACTUAL,LIST FORMAL,LIST EXP); 82 STATIC BOOL BINDS(LIST FORMAL,LIST X); 83 STATIC VOID SHOWCH(unsigned char c); //DT 2015 84 85 STATIC VOID 86 R(char *S, void (*F)(LIST), WORD N) 87 { ATOM A=MKATOM(S); 88 LIST EQN=CONS((LIST)A,CONS((LIST)CALL_C,(LIST)F)); 89 UNLESS F==READ DO ENTERSCRIPT(A); 90 VAL(A)=CONS(CONS((LIST)N,NIL),CONS(EQN,NIL)); } 91 92 VOID 93 SETUP_PRIMFNS_ETC(VOID) 94 { 95 S=(LIST)ENDOFSTACK; //S IS USED INSIDE REDUCE 96 ETC=MKATOM("... "); //MISCELLANEOUS INITIALISATIONS 97 SILLYNESS=MKATOM("<unfounded recursion>"); 98 GUARD=MKATOM("<non truth-value used as guard:>"); 99 TRUTH=CONS((LIST)QUOTE,(LIST)MKATOM("TRUE")); 100 FALSITY=CONS((LIST)QUOTE,(LIST)MKATOM("FALSE")); 101 LISTDIFF=MKATOM("listdiff"); 102 INFINITY=CONS((LIST)QUOTE,(LIST)-3); 103 R("function__",FUNCTIONP,1); //PRIMITIVE FUNCTIONS 104 R("list__",LISTP,1); 105 R("string__",STRINGP,1); 106 R("number__",NUMBERP,1); 107 R("char__",CHAR,1); 108 R("printwidth__",SIZE,1); 109 R("ord__",CODE,1); 110 R("chr__",DECODE,1); 111 R("implode__",CONCAT,1); 112 R("explode__",EXPLODE,1); 113 R("abort__",ABORT,1); 114 R("read__",STARTREAD,1); 115 R("read ",READ,1); 116 R("seq__",SEQ,2); 117 R("write__",WRITEAP,3); 118 BADFILE=MKATOM("<cannot open file:>"); 119 READFN=MKATOM("read "); 120 WRITEFN=MKATOM("write"); 121 INTERLEAVEFN=MKATOM("interleave"); 122 } 123 124 // LITTLE ROUTINE TO AVOID S HAVING TO BE GLOBAL, JUST BECAUSE 125 // IT MAY NEED FIXING UP AFTER AN INTERRUPT. THIS ROUTINE DOES THAT. 126 VOID 127 FIXUP_S(VOID) 128 { 129 UNLESS S==(LIST)ENDOFSTACK 130 DO HD(S)=(LIST)QUOTE; //IN CASE INTERRUPT STRUCK WHILE REDUCE 131 //WAS DISSECTING A CONSTANT 132 } 133 134 // Return an upper-case copy of a string. 135 // Copy to static area of 80 chars, the same as BCPL 136 // also to avoid calling strdup which calls malloc() and 137 // contaminates the garbage collection done with Boehm GC. 138 char * 139 SCASECONV(char *S) 140 { static char T[80+1]; 141 char *p=S, *q=T; 142 while (*p) *q++ = CASECONV(*p++); 143 *q = '\0'; 144 RESULTIS T; } 145 146 VOID 147 INITSTATS() 148 { 149 REDS=0; 150 } 151 152 VOID 153 OUTSTATS() 154 { WRITEF("reductions = %" W "\n",REDS); } 155 156 // THE POSSIBLE VALUES OF A REDUCED EXPRESSION ARE: 157 // VAL:= CONST | FUNCTION | LIST 158 // CONST:= NUM | CONS(QUOTE,ATOM) 159 // LIST:= NIL | CONS(COLON_OP,CONS(EXP,EXP)) 160 // FUNCTION:= NAME | CONS(E1,E2) 161 162 VOID 163 PRINTVAL(LIST E, BOOL FORMAT) 164 { E=REDUCE(E); 165 TEST E==NIL 166 THEN { IF FORMAT DO WRITES("[]"); } OR 167 TEST ISNUM(E) 168 THEN WRITEN(GETNUM(E)); OR 169 TEST ISCONS(E) 170 THEN { LIST H=HD(E); 171 TEST H==(LIST)QUOTE 172 THEN PRINTATOM((ATOM)TL(E),FORMAT); OR 173 TEST H==(LIST)COLON_OP 174 THEN { IF FORMAT DO WRCH('['); 175 E=TL(E); 176 do { 177 PRINTVAL(HD(E),FORMAT); 178 E=TL(E); 179 E=REDUCE(E); 180 UNLESS ISCONS(E) DO BREAK 181 TEST HD(E)==(LIST)COLON_OP 182 THEN { IF FORMAT DO WRCH(','); } 183 OR BREAK 184 E=TL(E); 185 } REPEAT; 186 TEST E==NIL 187 THEN { IF FORMAT DO WRCH(']'); } 188 OR BADEXP(CONS((LIST)COLON_OP,CONS((LIST)ETC,E))); 189 } OR 190 TEST ISCONS(H) && HD(H)==(LIST)WRITEFN 191 THEN { TL(H)=REDUCE(TL(H)); 192 UNLESS ISCONS(TL(H)) && HD(TL(H))==(LIST)QUOTE 193 DO BADEXP(E); 194 { char *F=PRINTNAME((ATOM)TL(TL(H))); 195 FILE *OUT=FINDCHANNEL(F); 196 FILE *HOLD=OUTPUT(); 197 UNLESS OUT!=NULL DO BADEXP(CONS((LIST)BADFILE,TL(H))); 198 SELECTOUTPUT(OUT); 199 PRINTVAL(TL(E),FORMAT); 200 SELECTOUTPUT(HOLD); 201 } } 202 OR PRINTFUNCTION(E); //A PARTIAL APPLICATION OR COMPOSITION 203 } 204 OR PRINTFUNCTION(E); //ONLY POSSIBILITY HERE SHOULD BE 205 //NAME OF FUNCTION 206 } 207 208 VOID 209 PRINTATOM(ATOM A,BOOL FORMAT) 210 { TEST FORMAT 211 THEN 212 { int I; //DT 2015 213 WRCH('"'); 214 FOR (I=1; I<=LEN(A); I++) SHOWCH(NAME(A)[I]); 215 WRCH('"'); } 216 OR { int I; // OUTPUT THE BCPL STRING PRESERVING nulS 217 FOR (I=1; I<=LEN(A); I++) WRCH(NAME(A)[I]); } 218 } 219 220 STATIC VOID 221 SHOWCH(unsigned char c) 222 { switch(c) 223 { case '\a': WRCH('\\'); WRCH('a'); break; 224 case '\b': WRCH('\\'); WRCH('b'); break; 225 case '\f': WRCH('\\'); WRCH('f'); break; 226 case '\n': WRCH('\\'); WRCH('n'); break; 227 case '\r': WRCH('\\'); WRCH('r'); break; 228 case '\t': WRCH('\\'); WRCH('t'); break; 229 case '\v': WRCH('\\'); WRCH('v'); break; 230 case '\\': WRCH('\\'); WRCH('\\'); break; 231 case '\'': WRCH('\\'); WRCH('\''); break; 232 case '\"': WRCH('\\'); WRCH('\"'); break; 233 default: TEST iscntrl(c) || c>=127 234 THEN printf("\\%03u",c); 235 OR WRCH(c); 236 } } 237 238 STATIC VOID 239 PRINTFUNCTION(LIST E) 240 { WRCH('<'); 241 PRINTEXP(E,0); 242 WRCH('>'); } 243 244 STATIC BOOL 245 EQUALVAL(LIST A,LIST B) //UNPREDICTABLE RESULTS IF A,B BOTH FUNCTIONS 246 {do{ 247 A=REDUCE(A); 248 B=REDUCE(B); 249 IF A==B DO RESULTIS TRUE; 250 IF ISNUM(A) && ISNUM(B) 251 DO RESULTIS GETNUM(A)==GETNUM(B); 252 UNLESS ISCONS(A) && ISCONS(B) && (HD(A)==HD(B)) DO RESULTIS FALSE; 253 IF HD(A)==(LIST)QUOTE || HD(A) == (LIST)QUOTE_OP DO RESULTIS TL(A)==TL(B); 254 UNLESS HD(A)==(LIST)COLON_OP DO RESULTIS FALSE; //UH ? 255 A=TL(A),B=TL(B); 256 UNLESS EQUALVAL(HD(A),HD(B)) DO RESULTIS FALSE; 257 A=TL(A),B=TL(B); 258 } REPEAT } 259 260 STATIC VOID 261 BADEXP(LIST E) //CALLED FOR ALL EVALUATION ERRORS 262 { _WRCH=TRUEWRCH; 263 CLOSECHANNELS(); 264 WRITES("\n**undefined expression**\n "); 265 PRINTEXP(E,0); 266 //COULD INSERT MORE DETAILED DIAGNOSTICS HERE, 267 //DEPENDING ON NATURE OF HD!E, FOR EXAMPLE: 268 IF ISCONS(E) && (HD(E)==(LIST)COLON_OP||HD(E)==(LIST)APPEND_OP) 269 DO WRITES("\n (non-list encountered where list expected)"); 270 WRITES("\n**evaluation abandoned**\n"); 271 ESCAPETONEXTCOMMAND(); 272 } 273 274 STATIC VOID 275 OVERFLOW(LIST E) // INTEGER OVERFLOW HANDLER 276 { _WRCH=TRUEWRCH; 277 CLOSECHANNELS(); 278 WRITES("\n**integer overflow**\n "); 279 PRINTEXP(E,0); 280 WRITES("\n**evaluation abandoned**\n"); 281 ESCAPETONEXTCOMMAND(); 282 } 283 284 LIST 285 BUILDEXP(LIST CODE) //A KLUDGE 286 { LIST E = CONS(NIL,NIL); //A BOGUS PIECE OF GRAPH 287 OBEY(CONS(CONS(NIL,CODE),NIL),E); 288 ARGP=ARG-1; //RESET ARG STACK 289 RESULTIS E; 290 } 291 292 STATIC VOID 293 OBEY(LIST EQNS,LIST E) //TRANSFORM A PIECE OF GRAPH, E, IN ACCORDANCE 294 //WITH EQNS - ACTUAL PARAMS ARE FOUND IN 295 // *ARG ... *ARGP 296 // (WARNING - HAS SIDE EFFECT OF RAISING ARGP) 297 { 298 UNTIL EQNS==NIL //EQNS LOOP 299 DO { LIST CODE=TL(HD(EQNS)); 300 LIST *HOLDARG=ARGP; 301 WORD I; 302 do{LIST H = HD(CODE); //DECODE LOOP 303 CODE=TL(CODE); 304 // First, check the only cases that increment ARGP 305 SWITCHON (WORD)H INTO { 306 CASE LOAD_C: 307 CASE LOADARG_C: 308 CASE FORMLIST_C: 309 ARGP=ARGP+1; 310 IF ARGP>ARGMAX DO SPACE_ERROR("Arg stack overflow"); 311 } 312 SWITCHON (WORD)H INTO { 313 CASE LOAD_C: // ARGP=ARGP+1; 314 *ARGP=HD(CODE); 315 CODE=TL(CODE); 316 ENDCASE 317 CASE LOADARG_C: // ARGP=ARGP+1; 318 IF ARGP>ARGMAX DO SPACE_ERROR("Arg stack overflow"); 319 *ARGP=ARG[(WORD)(HD(CODE))]; 320 CODE=TL(CODE); 321 ENDCASE 322 CASE APPLYINFIX_C: *ARGP=CONS(*(ARGP-1),*ARGP); 323 *(ARGP-1)=HD(CODE); 324 CODE=TL(CODE); 325 CASE APPLY_C: ARGP=ARGP-1; 326 IF HD(CODE)==(LIST)STOP_C 327 DO { HD(E)=*ARGP,TL(E)=*(ARGP+1); 328 RETURN } 329 *ARGP=CONS(*ARGP,*(ARGP+1)); 330 ENDCASE 331 CASE CONTINUE_INFIX_C: 332 *(ARGP-1)=CONS(HD(CODE),CONS(*(ARGP-1),*ARGP)); 333 CODE=TL(CODE); 334 ENDCASE 335 CASE IF_C: *ARGP=REDUCE(*ARGP); 336 IF *ARGP==FALSITY DO GOTO BREAK_DECODE_LOOP; 337 UNLESS *ARGP==TRUTH DO BADEXP(CONS((LIST)GUARD,*ARGP)); 338 ENDCASE 339 CASE FORMLIST_C: // ARGP=ARGP+1; 340 *ARGP=NIL; 341 FOR (I=1; I<=(WORD)HD(CODE); I++) 342 { ARGP=ARGP-1; 343 *ARGP=CONS((LIST)COLON_OP, 344 CONS(*ARGP,*(ARGP+1))); 345 } 346 CODE=TL(CODE); 347 ENDCASE 348 CASE FORMZF_C: { LIST X=CONS(*(ARGP-(WORD)HD(CODE)),NIL); 349 LIST *P; 350 FOR (P=ARGP; P>=ARGP-(WORD)HD(CODE)+1; P=P-1) 351 X=CONS(*P,X); 352 ARGP=ARGP-(WORD)HD(CODE); 353 *ARGP=CONS((LIST)ZF_OP,X); 354 CODE=TL(CODE); 355 ENDCASE } 356 CASE CONT_GENERATOR_C: 357 FOR (I=1; I<=(WORD)HD(CODE); I++) 358 *(ARGP-I)=CONS((LIST)GENERATOR,CONS(*(ARGP-I), 359 TL(TL(*ARGP)))); 360 CODE=TL(CODE); 361 ENDCASE 362 CASE MATCH_C: { WORD I=(WORD)HD(CODE); 363 CODE=TL(CODE); 364 UNLESS EQUALVAL(ARG[I],HD(CODE)) DO GOTO BREAK_DECODE_LOOP; 365 CODE=TL(CODE); 366 ENDCASE } 367 CASE MATCHARG_C: { WORD I=(WORD)HD(CODE); 368 CODE=TL(CODE); 369 UNLESS EQUALVAL(ARG[I],ARG[(WORD)(HD(CODE))]) 370 DO GOTO BREAK_DECODE_LOOP; 371 CODE=TL(CODE); 372 ENDCASE } 373 CASE MATCHPAIR_C: { LIST *P=ARG+(WORD)(HD(CODE)); 374 *P=REDUCE(*P); 375 UNLESS ISCONS(*P) && HD(*P)==(LIST)COLON_OP 376 DO GOTO BREAK_DECODE_LOOP; 377 ARGP=ARGP+2; 378 *(ARGP-1)=HD(TL(*P)),*ARGP=TL(TL(*P)); 379 CODE=TL(CODE); 380 ENDCASE } 381 CASE LINENO_C: CODE=TL(CODE); //NO ACTION 382 ENDCASE 383 CASE STOP_C: HD(E)=(LIST)INDIR,TL(E)=*ARGP; 384 RETURN 385 CASE CALL_C: (*(VOID (*)())CODE)(E); 386 RETURN 387 DEFAULT: WRITEF("IMPOSSIBLE INSTRUCTION <%p> IN \"OBEY\"\n", H); 388 } } REPEAT //END OF DECODE LOOP 389 BREAK_DECODE_LOOP: 390 EQNS=TL(EQNS); 391 ARGP=HOLDARG; 392 } //END OF EQNS LOOP 393 BADEXP(E); 394 } 395 396 STATIC VOID 397 STRINGP(LIST E) 398 { *ARG=REDUCE(*ARG); 399 HD(E)=(LIST)INDIR,TL(E)=ISCONS(*ARG)&&HD(*ARG)==(LIST)QUOTE ? TRUTH:FALSITY; 400 } 401 402 STATIC VOID 403 NUMBERP(LIST E) 404 { *ARG=REDUCE(*ARG); 405 HD(E)=(LIST)INDIR,TL(E)=ISNUM(*ARG)?TRUTH:FALSITY; 406 } 407 408 STATIC VOID 409 LISTP(LIST E) 410 { *ARG=REDUCE(*ARG); 411 HD(E)=(LIST)INDIR; 412 TL(E)=(*ARG==NIL||(ISCONS(*ARG)&&HD(*ARG)==(LIST)COLON_OP))? 413 TRUTH:FALSITY; 414 } 415 416 STATIC VOID 417 FUNCTIONP(LIST E) 418 { *ARG=REDUCE(*ARG); 419 HD(E)=(LIST)INDIR; 420 TL(E)=ISFUN(*ARG)?TRUTH:FALSITY; 421 } 422 423 STATIC BOOL 424 ISFUN(LIST X) 425 { RESULTIS ISATOM(X) || (ISCONS(X) && QUOTE!=HD(X) && HD(X)!=(LIST)COLON_OP); } 426 427 STATIC VOID 428 CHAR(LIST E) 429 { *ARG=REDUCE(*ARG); 430 HD(E)=(LIST)INDIR; 431 TL(E)=ISCONS(*ARG) && HD(*ARG)==(LIST)QUOTE && 432 LEN((ATOM)TL(*ARG))==1 ? TRUTH : FALSITY; 433 } 434 435 STATIC WORD COUNT; 436 STATIC VOID 437 COUNTCH(WORD CH) { COUNT=COUNT+1; } 438 439 STATIC VOID 440 SIZE(LIST E) 441 { 442 COUNT=0; 443 _WRCH=COUNTCH; 444 PRINTVAL(*ARG,FALSE); 445 _WRCH=TRUEWRCH; 446 HD(E)=(LIST)INDIR, TL(E)=STONUM(COUNT); 447 } 448 449 STATIC VOID 450 CODE(LIST E) 451 { *ARG = REDUCE(*ARG); 452 UNLESS ISCONS(*ARG) && HD(*ARG)==QUOTE 453 DO BADEXP(E); 454 { ATOM A=(ATOM)TL(*ARG); 455 UNLESS LEN(A)==1 DO BADEXP(E); 456 HD(E)=(LIST)INDIR, TL(E)=STONUM((WORD)NAME(A)[1] & 0xff); 457 } } 458 459 STATIC VOID 460 DECODE(LIST E) 461 { *ARG = REDUCE(*ARG); 462 UNLESS ISNUM(*ARG) && 0<=(WORD)TL(*ARG) && (WORD)TL(*ARG)<=255 463 DO BADEXP(E); 464 BUFCH((WORD)TL(*ARG)); 465 HD(E)=(LIST)INDIR, TL(E)=CONS((LIST)QUOTE,(LIST)PACKBUFFER()); 466 } 467 468 STATIC VOID 469 CONCAT(LIST E) 470 { *ARG = REDUCE(*ARG); 471 { LIST A = *ARG; 472 WHILE ISCONS(A) && HD(A)==(LIST)COLON_OP 473 DO { LIST C=REDUCE(HD(TL(A))); 474 UNLESS ISCONS(C) && HD(C)==(LIST)QUOTE 475 DO BADEXP(E); 476 HD(TL(A))= C; 477 TL(TL(A))=REDUCE(TL(TL(A))); 478 A=TL(TL(A)); 479 } 480 UNLESS A==NIL 481 DO BADEXP(E); 482 A=*ARG; 483 UNTIL A==NIL 484 DO { ATOM N=(ATOM)TL(HD(TL(A))); 485 int I; 486 FOR (I=1; I<=LEN(N); I++) BUFCH(NAME(N)[I]); 487 A=TL(TL(A)); } 488 A=(LIST)PACKBUFFER(); 489 HD(E) = (LIST)INDIR, 490 TL(E) = A==TL(TRUTH) ? TRUTH: 491 A==TL(FALSITY) ? FALSITY: 492 CONS((LIST)QUOTE,A); 493 } } 494 495 STATIC VOID 496 EXPLODE(LIST E) 497 { *ARG = REDUCE(*ARG); 498 UNLESS ISCONS(*ARG) && HD(*ARG)==(LIST)QUOTE 499 DO BADEXP(E); 500 { ATOM A=(ATOM)TL(*ARG); 501 LIST X = NIL; 502 int I; 503 FOR (I=NAME(A)[0]; I>0; I--) 504 { BUFCH(NAME(A)[I]); 505 X = CONS((LIST)COLON_OP, CONS(CONS((LIST)QUOTE,(LIST)PACKBUFFER()),X)); } 506 HD(E)=(LIST)INDIR, TL(E)=X; 507 } } 508 509 STATIC VOID 510 ABORT(LIST E) 511 { FILE *HOLD=OUTPUT(); 512 SELECTOUTPUT(stderr); 513 WRITES("\nprogram error: "); 514 PRINTVAL(TL(E),FALSE); 515 WRCH('\n'); 516 SELECTOUTPUT(HOLD); 517 ABORTED=TRUE; 518 raise(SIGINT); 519 } 520 521 STATIC VOID 522 STARTREAD(LIST E) 523 { *ARG=REDUCE(*ARG); 524 UNLESS ISCONS(*ARG) && HD(*ARG)==(LIST)QUOTE 525 DO BADEXP(E); 526 { FILE *IN = FINDINPUT(PRINTNAME((ATOM)TL(*ARG))); 527 UNLESS IN!=NULL 528 DO BADEXP(CONS((LIST)BADFILE,*ARG)); 529 HD(E)=(LIST)READFN,TL(E)=(LIST)IN; 530 } } 531 532 STATIC VOID 533 READ(LIST E) 534 { FILE *IN=(FILE *)TL(E); 535 SELECTINPUT(IN); 536 HD(E)=(LIST)INDIR,TL(E)=CONS((LIST)READFN,TL(E)); 537 { LIST *X = &(TL(E)); WORD C=RDCH(); 538 // Read one character 539 IF C!=EOF 540 DO { char c=C; 541 *X=CONS((LIST)COLON_OP, CONS( 542 CONS((LIST)QUOTE,(LIST)MKATOMN(&c,1)), *X)); 543 X=&(TL(TL(*X))); 544 } 545 IF ferror(IN) DO { 546 WRITEF("\n**File read error**\n"); 547 ESCAPETONEXTCOMMAND(); 548 } 549 IF C==EOF 550 DO { ENDREAD() ; *X=NIL; } 551 SELECTINPUT(SYSIN); 552 } } 553 554 STATIC VOID 555 WRITEAP(LIST E) //CALLED IF WRITE IS APPLIED TO >2 ARGS 556 { BADEXP(E); } 557 558 STATIC VOID 559 SEQ(LIST E) //seq a b EVALUATES a THEN RETURNS b, ADDED DT 2015 560 { REDUCE(TL(HD(E))); 561 HD(E)=(LIST)INDIR; 562 } 563 564 //POSSIBILITIES FOR LEFTMOST FIELD OF A GRAPH ARE: 565 // HEAD:= NAME | NUM | NIL | OPERATOR 566 567 STATIC LIST 568 REDUCE(LIST E) 569 { STATIC WORD M=0; 570 STATIC WORD N=0; 571 LIST HOLD_S=S; WORD NARGS=0; LIST *HOLDARG=ARG; 572 // IF &E>STACKLIMIT DO SPACE_ERROR("Arg stack overflow"); 573 // IF ARGP>ARGMAX DO SPACE_ERROR("Arg stack overflow"); 574 S=(LIST)ENDOFSTACK; 575 ARG=ARGP+1; 576 do{ //MAIN LOOP 577 WHILE ISCONS(E) //FIND HEAD, REVERSING POINTERS EN ROUTE 578 DO { LIST HOLD=HD(E); 579 NARGS=NARGS+1; 580 HD(E)=S,S=E,E=HOLD; } 581 IF ISNUM(E) || E==NIL 582 DO { // UNLESS NARGS==0 DO HOLDARG=(LIST *)-1; //FLAGS AN ERROR 583 GOTO BREAK_MAIN_LOOP; } 584 TEST ISATOM(E) //USER DEFINED NAME 585 THEN TEST VAL((ATOM)E)==NIL || TL(VAL((ATOM)E))==NIL THEN BADEXP(E); OR //UNDEFINED NAME 586 TEST HD(HD(VAL((ATOM)E)))==0 //VARIABLE 587 THEN { LIST EQN=HD(TL(VAL((ATOM)E))); 588 IF HD(EQN)==0 //MEMO NOT SET 589 DO { HD(EQN)=BUILDEXP(TL(EQN)); 590 MEMORIES=CONS(E,MEMORIES); } 591 E=HD(EQN); } //?CAN WE GET CYCLIC EXPRESSIONS? 592 OR { //FUNCTION 593 WORD N=(WORD)HD(HD(VAL((ATOM)E))); // Hides the static N 594 IF N>NARGS DO GOTO BREAK_MAIN_LOOP; //NOT ENOUGH ARGS 595 { LIST EQNS=TL(VAL((ATOM)E)); 596 WORD I; 597 FOR (I=0; I<=N-1; I++) 598 { LIST HOLD=HD(S); //MOVE BACK UP GRAPH, 599 ARGP=ARGP+1; //STACKING ARGS EN ROUTE 600 IF ARGP>ARGMAX DO SPACE_ERROR("Arg stack overflow"); 601 *ARGP=TL(S); 602 HD(S)=E,E=S,S=HOLD; } 603 NARGS=NARGS-N; 604 //E NOW HOLDS A PIECE OF GRAPH TO BE TRANSFORMED 605 // !ARG ... !ARGP HOLD THE PARAMETERS 606 OBEY(EQNS,E); 607 ARGP=ARG-1; //RESET ARG STACK 608 } } 609 OR { //OPERATORS 610 SWITCHON (WORD)E INTO 611 { CASE QUOTE: UNLESS NARGS==1 DO HOLDARG=(LIST *)-1; 612 GOTO BREAK_MAIN_LOOP; 613 CASE INDIR: { LIST HOLD=HD(S); 614 NARGS=NARGS-1; 615 E=TL(S),HD(S)=(LIST)INDIR,S=HOLD; 616 LOOP; } 617 CASE QUOTE_OP: UNLESS NARGS>=3 DO GOTO BREAK_MAIN_LOOP; 618 { LIST OP=TL(S); 619 LIST HOLD=HD(S); 620 NARGS=NARGS-2; 621 HD(S)=E,E=S,S=HOLD; 622 HOLD=HD(S); 623 HD(S)=E,E=S,S=HOLD; 624 TL(S)=CONS(TL(E),TL(S)),E=OP; 625 LOOP; } 626 CASE LISTDIFF_OP: E=CONS((LIST)LISTDIFF,HD(TL(S))); 627 TL(S)=TL(TL(S)); 628 LOOP; 629 CASE COLON_OP: UNLESS NARGS>=2 DO GOTO BREAK_MAIN_LOOP; 630 //LIST INDEXING 631 NARGS=NARGS-2; 632 { LIST HOLD=HD(S); WORD M; //Hides static M 633 HD(S)=(LIST)COLON_OP,E=S,S=HOLD; 634 TL(S)=REDUCE(TL(S)); 635 UNLESS ISNUM(TL(S)) && (M=GETNUM(TL(S)))>=LISTBASE 636 DO { HOLDARG=(LIST *)-1; GOTO BREAK_MAIN_LOOP; } 637 WHILE M-- > LISTBASE 638 DO { E=REDUCE(TL(TL(E))); //Clobbers static M 639 UNLESS ISCONS(E) && HD(E)==(LIST)COLON_OP 640 DO BADEXP(CONS(E,STONUM(M+1))); } 641 E=HD(TL(E)); 642 HOLD=HD(S); 643 HD(S)=(LIST)INDIR,TL(S)=E,S=HOLD; 644 REDS=REDS+1; 645 LOOP; } 646 CASE ZF_OP: { LIST HOLD=HD(S); 647 NARGS=NARGS-1; 648 HD(S)=E,E=S,S=HOLD; 649 IF TL(TL(E))==NIL 650 DO { HD(E)=(LIST)COLON_OP,TL(E)=CONS(HD(TL(E)),NIL); 651 LOOP; } 652 { LIST QUALIFIER=HD(TL(E)); 653 LIST REST=TL(TL(E)); 654 TEST ISCONS(QUALIFIER)&&HD(QUALIFIER)==(LIST)GENERATOR 655 THEN 656 { LIST SOURCE=REDUCE(TL(TL(QUALIFIER))); 657 LIST FORMAL=HD(TL(QUALIFIER)); 658 TL(TL(QUALIFIER))=SOURCE; 659 TEST SOURCE==NIL 660 THEN HD(E)=(LIST)INDIR,TL(E)=NIL,E=NIL; OR 661 TEST ISCONS(SOURCE)&&HD(SOURCE)==(LIST)COLON_OP 662 THEN HD(E)=CONS((LIST)INTERLEAVEFN, 663 CONS((LIST)ZF_OP, SUBSTITUTE(HD(TL(SOURCE)),FORMAL,REST))), 664 TL(E)=CONS((LIST)ZF_OP, 665 CONS(CONS((LIST)GENERATOR,CONS(FORMAL,TL(TL(SOURCE)))), 666 REST)); 667 668 // THEN HD!E,TL!E:=APPEND.OP, 669 // CONS( 670 // CONS(ZF.OP,SUBSTITUTE(HD!(TL!SOURCE),FORMAL,REST)), 671 // CONS(ZF.OP,CONS(CONS(GENERATOR,CONS(FORMAL,TL!(TL!SOURCE))),REST)) 672 // ) 673 OR BADEXP(E); } 674 OR { //QUALIFIER IS GUARD 675 QUALIFIER=REDUCE(QUALIFIER); 676 HD(TL(E))=QUALIFIER; 677 TEST QUALIFIER==TRUTH 678 THEN TL(E)=REST; OR 679 TEST QUALIFIER==FALSITY 680 THEN HD(E)=(LIST)INDIR,TL(E)=NIL,E=NIL; 681 OR BADEXP(CONS((LIST)GUARD,QUALIFIER)); } 682 REDS=REDS+1; 683 LOOP; } } 684 CASE DOT_OP: UNLESS NARGS>=2 685 DO { LIST A=REDUCE(HD(TL(S))),B=REDUCE(TL(TL(S))); 686 UNLESS ISFUN(A) && ISFUN(B) 687 DO BADEXP(CONS(E,CONS(A,B))); 688 GOTO BREAK_MAIN_LOOP; } 689 { LIST HOLD=HD(S); 690 NARGS=NARGS-1; 691 E=HD(TL(S)),TL(HOLD)=CONS(TL(TL(S)),TL(HOLD)); 692 HD(S)=(LIST)DOT_OP,S=HOLD; 693 REDS=REDS+1; 694 LOOP; } 695 CASE EQ_OP: 696 CASE NE_OP: E=EQUALVAL(HD(TL(S)),TL(TL(S)))==(E==(LIST)EQ_OP)? 697 TRUTH:FALSITY; 698 //NOTE - COULD REWRITE FOR FAST EXIT, HERE AND IN 699 //OTHER CASES WHERE RESULT OF REDUCTION IS ATOMIC 700 { LIST HOLD=HD(S); 701 NARGS=NARGS-1; 702 HD(S)=(LIST)INDIR,TL(S)=E,S=HOLD; 703 REDS=REDS+1; 704 LOOP; } 705 CASE ENDOFSTACK: BADEXP((LIST)SILLYNESS); //OCCURS IF WE TRY TO 706 //EVALUATE AN EXP WE ARE ALREADY INSIDE 707 DEFAULT: ENDCASE } //END OF SWITCH 708 { //STRICT OPERATORS 709 LIST A=NIL,B=NIL; 710 BOOL STRINGS=FALSE; 711 ATOM SM, SN; // The values of M and N when STRINGS == TRUE 712 TEST (WORD)E>=LENGTH_OP 713 THEN A=REDUCE(TL(S)); //MONADIC 714 OR { A=REDUCE(HD(TL(S))); //DIADIC 715 TEST E>=(LIST)GR_OP //STRICT IN 2ND ARG ? 716 THEN { //YES 717 B=REDUCE(E==(LIST)COMMADOTDOT_OP?HD(TL(TL(S))):TL(TL(S))); 718 TEST ISNUM(A) && ISNUM(B) 719 THEN M=GETNUM(A),N=GETNUM(B); OR 720 TEST E<=(LIST)LS_OP && //RELOPS 721 ISCONS(A) && ISCONS(B) 722 && HD(A)==(LIST)QUOTE && (LIST)QUOTE==HD(B) 723 THEN STRINGS=TRUE,SM=(ATOM)TL(A),SN=(ATOM)TL(B); OR 724 TEST E==(LIST)DOTDOT_OP && ISNUM(A) && B==INFINITY 725 THEN M=GETNUM(A),N=M; 726 OR 727 BADEXP(CONS(E,CONS(A,E==(LIST)COMMADOTDOT_OP?CONS(B,TL(TL(TL(S)))):B))); 728 } 729 OR B=TL(TL(S)); //NO 730 } 731 SWITCHON (WORD)E INTO 732 { CASE AND_OP: TEST A==FALSITY THEN E=A; OR 733 TEST A==TRUTH THEN E=B; OR 734 BADEXP(CONS(E,CONS(A,B))); 735 ENDCASE 736 CASE OR_OP: TEST A==TRUTH THEN E=A; OR 737 TEST A==FALSITY THEN E=B; OR 738 BADEXP(CONS(E,CONS(A,B))); 739 ENDCASE 740 CASE APPEND_OP: IF A==NIL DO { E=B; ENDCASE } 741 UNLESS ISCONS(A) && HD(A)==(LIST)COLON_OP 742 DO BADEXP(CONS(E,CONS(A,B))); 743 E=(LIST)COLON_OP; 744 TL(TL(S))=CONS((LIST)APPEND_OP, 745 CONS(TL(TL(A)),B)); 746 HD(TL(S))=HD(TL(A)); 747 REDS=REDS+1; 748 LOOP 749 CASE DOTDOT_OP: IF M>N DO { E=NIL; ENDCASE } 750 E=(LIST)COLON_OP; 751 TL(TL(S))=CONS((LIST)DOTDOT_OP, 752 CONS(STONUM(M+1),B)); 753 REDS=REDS+1; 754 LOOP 755 CASE COMMADOTDOT_OP: { WORD M1=M,N1=N;//REDUCE clobbers M,N 756 LIST C=REDUCE(TL(TL(TL(S)))); 757 STATIC WORD P=0; 758 TEST ISNUM(C) 759 THEN P=GETNUM(C); OR 760 TEST C==INFINITY THEN P=N1; 761 OR BADEXP(CONS(E,CONS(A,CONS(B,C)))); 762 IF (N1-M1)*(P-M1)<0 DO { E=NIL; ENDCASE } 763 E=(LIST)COLON_OP; 764 HD(TL(TL(S)))=STONUM(N1+N1-M1); 765 TL(TL(S))=CONS((LIST)COMMADOTDOT_OP, 766 CONS(B,TL(TL(S)))); 767 REDS=REDS+1; 768 LOOP } 769 CASE NOT_OP: TEST A==TRUTH THEN E=FALSITY; OR 770 TEST A==FALSITY THEN E=TRUTH; OR 771 BADEXP(CONS(E,A)); 772 ENDCASE 773 CASE NEG_OP: UNLESS ISNUM(A) DO BADEXP(CONS(E,A)); 774 E = STONUM(-GETNUM(A)); 775 ENDCASE 776 CASE LENGTH_OP: { WORD L=0; 777 WHILE ISCONS(A) && HD(A)==(LIST)COLON_OP 778 DO A=REDUCE(TL(TL(A))),L=L+1; 779 IF A==NIL DO { E = STONUM(L); ENDCASE } 780 BADEXP(CONS((LIST)COLON_OP,CONS((LIST)ETC,A))); 781 } 782 CASE PLUS_OP: { WORD X = M+N; 783 IF (M>0 && N>0 && X <= 0) || 784 (M<0 && N<0 && X >= 0) || 785 // This checks for -(2**31) 786 (X==-X && X!=0) DO 787 OVERFLOW(CONS((LIST)PLUS_OP,CONS(A,B))); 788 E = STONUM(X); ENDCASE } 789 CASE MINUS_OP: { WORD X = M-N; 790 IF (M<0 && N>0 && X>0) || 791 (M>0 && N<0 && X<0) || 792 (X==-X && X!=0) DO 793 OVERFLOW(CONS((LIST)MINUS_OP,CONS(A,B))); 794 E = STONUM(X); ENDCASE } 795 CASE TIMES_OP: { WORD X = M*N; 796 // May not catch all cases 797 IF (M>0 && N>0 && X<=0) || 798 (M<0 && N<0 && X<=0) || 799 (M<0 && N>0 && X>=0) || 800 (M>0 && N<0 && X>=0) || 801 (X==-X && X!=0) DO 802 OVERFLOW(CONS((LIST)TIMES_OP,CONS(A,B))); 803 E = STONUM(X); ENDCASE } 804 CASE DIV_OP: IF N==0 DO BADEXP(CONS((LIST)DIV_OP,CONS(A,B))); 805 E = STONUM(M/N); ENDCASE 806 CASE REM_OP: IF N==0 DO BADEXP(CONS((LIST)REM_OP,CONS(A,B))); 807 E = STONUM(M%N); ENDCASE 808 CASE EXP_OP: IF N<0 DO BADEXP(CONS((LIST)EXP_OP,CONS(A,B))); 809 { WORD P=1; 810 UNTIL N==0 811 DO { WORD X=P*M; 812 // May not catch all cases 813 IF (M>0 && P>0 && X<=0) || 814 (M<0 && P<0 && X<=0) || 815 (M<0 && P>0 && X>=0) || 816 (M>0 && P<0 && X>=0) || 817 (X==-X && X!=0) DO 818 OVERFLOW(CONS((LIST)EXP_OP,CONS(A,B))); 819 P=X, N=N-1; } 820 E = STONUM(P); ENDCASE } 821 CASE GR_OP: E = (STRINGS?ALFA_LS(SN,SM):M>N)? 822 TRUTH: FALSITY; ENDCASE 823 CASE GE_OP: E = (STRINGS?ALFA_LS(SN,SM)||SN==SM:M>=N)? 824 TRUTH: FALSITY; ENDCASE 825 CASE LE_OP: E = (STRINGS?ALFA_LS(SM,SN)||SM==SN:M<=N)? 826 TRUTH: FALSITY; ENDCASE 827 CASE LS_OP: E = (STRINGS?ALFA_LS(SM,SN):M<N)? 828 TRUTH: FALSITY; ENDCASE 829 DEFAULT: WRITES("IMPOSSIBLE OPERATOR IN \"REDUCE\"\n"); 830 } //END OF SWITCH 831 { LIST HOLD=HD(S); 832 NARGS=NARGS-1; 833 HD(S)=(LIST)INDIR,TL(S)=E,S=HOLD; } 834 } } //END OF OPERATORS 835 REDS=REDS+1; 836 } REPEAT //END OF MAIN LOOP 837 BREAK_MAIN_LOOP: 838 UNTIL S==(LIST)ENDOFSTACK //UNREVERSE REVERSED POINTERS 839 DO { LIST HOLD=HD(S); 840 HD(S)=E,E=S,S=HOLD; } 841 IF HOLDARG==(LIST *)-1 DO BADEXP(E); 842 ARG=HOLDARG; //RESET ARG STACKFRAME 843 S=HOLD_S; 844 RESULTIS E; 845 } 846 847 STATIC LIST 848 SUBSTITUTE(LIST ACTUAL,LIST FORMAL,LIST EXP) 849 { TEST EXP==FORMAL THEN RESULTIS ACTUAL; 850 OR TEST !ISCONS(EXP) || HD(EXP)==(LIST)QUOTE || BINDS(FORMAL,HD(EXP)) 851 THEN RESULTIS EXP; OR 852 { LIST H=SUBSTITUTE(ACTUAL,FORMAL,HD(EXP)); 853 LIST T=SUBSTITUTE(ACTUAL,FORMAL,TL(EXP)); 854 RESULTIS H==HD(EXP) && T==TL(EXP) ? EXP : CONS(H,T); } 855 } 856 857 STATIC BOOL 858 BINDS(LIST FORMAL,LIST X) 859 { RESULTIS ISCONS(X) && HD(X)==(LIST)GENERATOR && HD(TL(X))==FORMAL; } 860 861 // Mark elements in the argument stack for preservation by the GC. 862 // This routine should be called by your BASES() function. 863 VOID 864 REDUCER_BASES(VOID (*F)(LIST *)) 865 { LIST *AP; 866 867 FOR (AP=ARGSPACE; AP<=ARGP; AP++) 868 F(AP); 869 } 870