/ compiler.c
compiler.c
1 //KRC COMPILER 2 3 // Note: What is now '{' here was '{ ' in the BCPL. 4 5 #include "bcpl.h" 6 #include "listhdr.h" 7 #include "comphdr.h" 8 9 //---------------------------------------------------------------------- 10 //The KRC system is Copyright (c) D. A. Turner 1981 11 //All rights reserved. It is distributed as free software under the 12 //terms in the file "COPYING", which is included in the distribution. 13 //---------------------------------------------------------------------- 14 15 // Local function declarations 16 STATIC BOOL ISOP(LIST X); 17 STATIC BOOL ISINFIX(LIST X); 18 STATIC BOOL ISRELOP(LIST X); 19 STATIC WORD DIPRIO(OPERATOR OP); 20 STATIC OPERATOR MKINFIX(TOKEN T); 21 STATIC VOID PRINTZF_EXP(LIST X); 22 STATIC BOOL ISLISTEXP(LIST E); 23 STATIC BOOL ISRELATION(LIST X); 24 STATIC BOOL ISRELATION_BEGINNING(LIST A,LIST X); 25 STATIC WORD LEFTPREC(OPERATOR OP); 26 STATIC WORD RIGHTPREC(OPERATOR OP); 27 STATIC BOOL ROTATE(LIST E); 28 STATIC BOOL PARMY(LIST X); 29 STATIC LIST REST(LIST C); 30 STATIC LIST SUBTRACT(LIST X, LIST Y); 31 STATIC VOID EXPR(WORD N); 32 STATIC BOOL STARTFORMAL(TOKEN T); 33 STATIC BOOL STARTSIMPLE(TOKEN T); 34 STATIC VOID COMBN(VOID); 35 STATIC VOID SIMPLE(VOID); 36 STATIC VOID COMPILENAME(ATOM N); 37 STATIC WORD QUALIFIER(VOID); 38 STATIC VOID PERFORM_ALPHA_CONVERSIONS(); 39 STATIC BOOL ISGENERATOR(LIST T); 40 STATIC VOID ALPHA_CONVERT(LIST VAR, LIST P); 41 STATIC LIST SKIPCHUNK(LIST P); 42 STATIC VOID CONV1(LIST T, LIST VAR, LIST VAR1); 43 STATIC LIST FORMAL(VOID); 44 STATIC LIST INTERNALISE(LIST VAL); 45 STATIC LIST PATTERN(VOID); 46 STATIC VOID COMPILELHS(LIST LHS, WORD NARGS); 47 STATIC VOID COMPILEFORMAL(LIST X, WORD I); 48 STATIC VOID PLANT0(INSTRUCTION OP); 49 STATIC VOID PLANT1(INSTRUCTION OP, LIST A); 50 STATIC VOID PLANT2(INSTRUCTION OP, LIST A, LIST B); 51 STATIC LIST COLLECTCODE(VOID); 52 53 54 // Global variables 55 void (*TRUEWRCH)(WORD C) = bcpl_WRCH; 56 LIST LASTLHS=NIL; 57 LIST TRUTH, FALSITY, INFINITY; 58 59 60 // SETUP_INFIXES() - Interesting elements start at [1] 61 // The indices correspond to the OPERATOR values in comphdr.h 62 STATIC TOKEN INFIXNAMEVEC[] = { 63 (TOKEN)0, 64 (TOKEN) ':', 65 PLUSPLUS_SY, 66 DASHDASH_SY, 67 (TOKEN) '|', 68 (TOKEN) '&', 69 (TOKEN) '>', 70 GE_SY, 71 NE_SY, 72 EQ_SY, //WAS (TOKEN) '=', CHANGED DT MAY 2015 73 LE_SY, 74 (TOKEN) '<', 75 (TOKEN) '+', 76 (TOKEN) '-', 77 (TOKEN) '*', 78 (TOKEN) '/', 79 (TOKEN) '%', 80 STARSTAR_SY, 81 (TOKEN) '.', 82 }; 83 STATIC WORD INFIXPRIOVEC[] = { 0, 0,0,0,1,2,3,3,3,3,3,3,4,4,5,5,5,6,6 }; 84 85 // BASES FOR GARBAGE COLLECTION 86 STATIC LIST CODEV = NIL;// store for opcodes and ther params, which 87 // may be operators, various CONStructs or the 88 // addresses of C functions. 89 STATIC LIST ENV[100]; // Appears to be a store for formal parameters 90 STATIC WORD ENVP; 91 92 VOID 93 INIT_CODEV() { 94 ENVP=-1; 95 CODEV=NIL; 96 } 97 98 99 STATIC BOOL ISOP(LIST X) { RESULTIS X==(LIST)ALPHA || X==(LIST)INDIR || 100 ((LIST)QUOTE<=X && X<=(LIST)QUOTE_OP); } 101 102 STATIC BOOL ISINFIX(LIST X) { RESULTIS (LIST)COLON_OP<=X && X<=(LIST)DOT_OP; } 103 104 STATIC BOOL ISRELOP(LIST X) { RESULTIS (LIST)GR_OP<=X && X<=(LIST)LS_OP; } 105 106 // Return the priority of an operator from its index in INFIX* 107 STATIC WORD DIPRIO(OPERATOR OP) 108 { RESULTIS OP==-1 ? -1 : INFIXPRIOVEC[OP]; } 109 110 STATIC OPERATOR 111 MKINFIX(TOKEN T)// TAKES A TOKEN , RETURNS AN OPERATOR 112 // OR -1 IF T NOT THE NAME OF AN INFIX 113 { WORD I=1; 114 IF T==(TOKEN)'=' DO RESULTIS EQ_OP; //legacy, accept "=" for "==" 115 UNTIL I>DOT_OP || INFIXNAMEVEC[I]==T DO I=I+1; 116 IF I>DOT_OP DO RESULTIS -1; 117 RESULTIS I; } 118 119 VOID 120 PRINTEXP(LIST E, WORD N) // N IS THE PRIORITY LEVEL 121 { TEST E==NIL 122 THEN WRITES("[]"); OR 123 TEST ISATOM(E) 124 THEN WRITES(PRINTNAME((ATOM)E)); OR 125 TEST ISNUM(E) 126 THEN { WORD X=GETNUM(E); 127 TEST X<0 && N>5 128 THEN { WRCH('('); WRITEN(X); WRCH(')'); } 129 OR WRITEN(X); } 130 OR { UNLESS ISCONS(E) 131 DO { TEST E==(LIST)NOT_OP THEN WRITES("'\\'"); OR 132 TEST E==(LIST)LENGTH_OP THEN WRITES("'#'"); 133 OR WRITEF("<internal value:%p>",E); 134 RETURN } 135 { LIST OP=HD(E); // Maybe could be OPERATOR 136 TEST !ISOP(OP) && N<=7 137 THEN { PRINTEXP(OP,7); 138 WRCH(' '); 139 PRINTEXP(TL(E),8); } OR 140 TEST OP==(LIST)QUOTE 141 THEN { PRINTATOM((ATOM)TL(E),TRUE); } OR 142 TEST OP==(LIST)INDIR || OP==(LIST)ALPHA 143 THEN PRINTEXP(TL(E),N); OR 144 TEST OP==(LIST)DOTDOT_OP || OP==(LIST)COMMADOTDOT_OP 145 THEN { WRCH('['); 146 E=TL(E); 147 PRINTEXP(HD(E),0); 148 IF OP==(LIST)COMMADOTDOT_OP 149 DO { WRCH(','); 150 E=TL(E); 151 PRINTEXP(HD(E),0); } 152 WRITES(".."); 153 UNLESS TL(E)==INFINITY DO PRINTEXP(TL(E),0); 154 WRCH(']'); } OR 155 TEST OP==(LIST)ZF_OP 156 THEN { WRCH('{'); 157 PRINTZF_EXP(TL(E)); 158 WRCH('}'); } OR 159 TEST OP==(LIST)NOT_OP && N<=3 160 THEN { WRCH('\\'); 161 PRINTEXP(TL(E),3); } OR 162 TEST OP==(LIST)NEG_OP && N<=5 163 THEN { WRCH('-'); 164 PRINTEXP(TL(E),5); } OR 165 TEST OP==(LIST)LENGTH_OP && N<=7 166 THEN { WRCH('#'); 167 PRINTEXP(TL(E),7); } OR 168 TEST OP==(LIST)QUOTE_OP 169 THEN { WRCH('\''); 170 TEST TL(E)==(LIST)LENGTH_OP THEN WRCH('#'); OR 171 TEST TL(E)==(LIST)NOT_OP THEN WRCH('\\'); OR 172 WRITETOKEN(INFIXNAMEVEC[(WORD)TL(E)]); 173 WRCH('\''); } OR 174 TEST ISLISTEXP(E) 175 THEN { WRCH('['); 176 UNTIL E==NIL 177 DO { PRINTEXP(HD(TL(E)),0); 178 UNLESS TL(TL(E))==NIL DO WRCH(','); 179 E=TL(TL(E)); } 180 WRCH(']'); } OR 181 TEST OP==(LIST)AND_OP && N<=3 && ROTATE(E) && ISRELATION(HD(TL(E))) 182 && ISRELATION_BEGINNING(TL(TL(HD(TL(E)))),TL(TL(E))) 183 THEN { //CONTINUED RELATIONS 184 PRINTEXP(HD(TL(HD(TL(E)))),4); 185 WRCH(' '); 186 WRITETOKEN(INFIXNAMEVEC[(WORD)HD(HD(TL(E)))]); 187 WRCH(' '); 188 PRINTEXP(TL(TL(E)),2); } OR 189 TEST ISINFIX(OP) && INFIXPRIOVEC[(WORD)OP]>=N 190 THEN { PRINTEXP(HD(TL(E)),LEFTPREC((OPERATOR)OP)); 191 UNLESS OP==(LIST)COLON_OP DO WRCH(' '); //DOT.OP should be spaced, DT 2015 192 WRITETOKEN(INFIXNAMEVEC[(WORD)OP]); 193 UNLESS OP==(LIST)COLON_OP DO WRCH(' '); 194 PRINTEXP(TL(TL(E)),RIGHTPREC((OPERATOR)OP)); } 195 OR { WRCH('('); 196 PRINTEXP(E,0); 197 WRCH(')'); } 198 } } } 199 200 STATIC VOID 201 PRINTZF_EXP(LIST X) 202 { LIST Y=X; 203 UNTIL TL(Y)==NIL DO Y=TL(Y); 204 PRINTEXP(HD(Y),0); //BODY 205 // PRINT "SUCH THAT" AS BAR IF A GENERATOR DIRECTLY FOLLOWS 206 TEST ISCONS(HD(X)) && HD(HD(X))==(LIST)GENERATOR THEN WRCH('|'); OR WRCH(';'); 207 UNTIL TL(X)==NIL 208 DO { LIST QUALIFIER=HD(X); 209 TEST ISCONS(QUALIFIER) && HD(QUALIFIER)==(LIST)GENERATOR 210 THEN { PRINTEXP(HD(TL(QUALIFIER)),0); 211 WHILE ISCONS(TL(X)) && //DEALS WITH REPEATED GENERATORS 212 #ifdef INSTRUMENT_KRC_GC 213 ISCONS(HD(TL(X))) && 214 #endif 215 HD(HD(TL(X)))==(LIST)GENERATOR && 216 EQUAL(TL(TL(HD(TL(X)))),TL(TL(QUALIFIER))) 217 DO { X=TL(X); 218 QUALIFIER=HD(X); 219 WRCH(','); 220 PRINTEXP(HD(TL(QUALIFIER)),0); } 221 WRITES("<-"); 222 PRINTEXP(TL(TL(QUALIFIER)),0); } 223 OR PRINTEXP(QUALIFIER,0); 224 X=TL(X); 225 UNLESS TL(X)==NIL DO WRCH(';'); } 226 } 227 228 STATIC BOOL 229 ISLISTEXP(LIST E) 230 { WHILE ISCONS(E) && HD(E)==(LIST)COLON_OP 231 DO { LIST E1=TL(TL(E)); 232 WHILE ISCONS(E1) && HD(E1)==(LIST)INDIR 233 DO E1=TL(E1); 234 TL(TL(E))=E1; 235 E=E1; } 236 RESULTIS E==NIL; } 237 238 STATIC BOOL 239 ISRELATION(LIST X) { RESULTIS ISCONS(X) && ISRELOP(HD(X)); } 240 241 STATIC BOOL 242 ISRELATION_BEGINNING(LIST A,LIST X) 243 { RESULTIS (ISRELATION(X) && EQUAL(HD(TL(X)),A)) || 244 (ISCONS(X) && HD(X)==(LIST)AND_OP && 245 ISRELATION_BEGINNING(A,HD(TL(X)))); } 246 247 STATIC WORD 248 LEFTPREC(OPERATOR OP) 249 { RESULTIS OP==COLON_OP||OP==APPEND_OP||OP==LISTDIFF_OP|| 250 OP==AND_OP||OP==OR_OP||OP==EXP_OP||ISRELOP((LIST)OP) ? 251 INFIXPRIOVEC[OP] + 1 : INFIXPRIOVEC[OP]; } 252 253 // RELOPS ARE NON-ASSOCIATIVE 254 // COLON, APPEND, AND, OR ARE RIGHT-ASSOCIATIVE 255 // ALL OTHER INFIXES ARE LEFT-ASSOCIATIVE 256 257 STATIC WORD 258 RIGHTPREC(OPERATOR OP) 259 { RESULTIS OP==COLON_OP || OP==APPEND_OP || OP==LISTDIFF_OP || 260 OP==AND_OP || OP==OR_OP || OP==EXP_OP ? 261 INFIXPRIOVEC[OP] : INFIXPRIOVEC[OP] + 1; } 262 263 STATIC BOOL 264 ROTATE(LIST E) 265 //PUTS NESTED AND'S INTO RIGHTIST FORM TO ENSURE 266 //DETECTION OF CONTINUED RELATIONS 267 { WHILE ISCONS(HD(TL(E))) && HD(HD(TL(E)))==(LIST)AND_OP 268 DO { LIST X=TL(HD(TL(E))), C=TL(TL(E)); 269 LIST A=HD(X), B=TL(X); 270 HD(TL(E))=A, TL(TL(E))=CONS((LIST)AND_OP,CONS(B,C)); } 271 RESULTIS TRUE; } 272 273 //DECOMPILER 274 275 VOID 276 DISPLAY(ATOM ID, BOOL WITHNOS, BOOL DOUBLESPACING) 277 // THE VAL FIELD OF EACH USER DEFINED NAME 278 // CONTAINS - CONS(CONS(NARGS,COMMENT),<LIST OF EQNS>) 279 { IF VAL(ID)==NIL 280 DO { WRITEF("\"%s\" - not defined\n",PRINTNAME(ID)); 281 RETURN } 282 { LIST X = HD(VAL(ID)), EQNS = TL(VAL(ID)); 283 WORD NARGS = (WORD)(HD(X)); 284 LIST COMMENT = TL(X); 285 WORD N = LENGTH(EQNS), I; 286 LASTLHS=NIL; 287 UNLESS COMMENT==NIL 288 DO { LIST C=COMMENT; 289 WRITEF(" %s :-",PRINTNAME(ID)); 290 UNTIL C==NIL 291 DO { WRITES(PRINTNAME((ATOM)HD(C))); 292 C = TL(C); 293 UNLESS C==NIL 294 DO { NEWLINE(); 295 IF DOUBLESPACING DO NEWLINE(); } 296 } 297 WRITES(";\n"); 298 IF DOUBLESPACING DO NEWLINE(); } 299 IF COMMENT!=NIL && N==1 && HD(TL(HD(EQNS)))==(LIST)CALL_C 300 DO RETURN 301 FOR (I=1; I<=N; I++) 302 { TEST WITHNOS && (N>1 || COMMENT!=NIL) 303 THEN WRITEF("%2" W ") ",I); 304 OR WRITES(" "); 305 REMOVELINENO(HD(EQNS)); 306 DISPLAYEQN(ID,NARGS,HD(EQNS)); 307 IF DOUBLESPACING DO NEWLINE(); 308 EQNS=TL(EQNS); 309 } } } 310 311 STATIC VOID 312 SHCH(WORD CH) 313 { TRUEWRCH(' '); } 314 315 VOID 316 DISPLAYEQN(ATOM ID, WORD NARGS, LIST EQN) //EQUATION DECODER 317 { LIST LHS = HD(EQN), CODE = TL(EQN); 318 TEST NARGS==0 319 THEN { WRITES(PRINTNAME(ID)); LASTLHS=(LIST)ID; } 320 OR { TEST EQUAL(LHS,LASTLHS) 321 THEN _WRCH=SHCH; 322 OR LASTLHS=LHS; 323 PRINTEXP(LHS,0); 324 _WRCH=TRUEWRCH; } 325 WRITES(" = "); 326 TEST HD(CODE)==(LIST)CALL_C THEN WRITES("<primitive function>"); 327 OR DISPLAYRHS(LHS,NARGS,CODE); 328 NEWLINE(); 329 } 330 331 VOID 332 DISPLAYRHS(LIST LHS, WORD NARGS, LIST CODE) 333 { LIST V[100]; 334 WORD I = NARGS, J; BOOL IF_FLAG = FALSE; 335 WHILE I>0 //UNPACK FORMAL PARAMETERS INTO V 336 DO { I = I-1; 337 V[I] = TL(LHS); 338 LHS = HD(LHS); } 339 I = NARGS-1; 340 do 341 { SWITCHON (WORD)(HD(CODE)) INTO 342 { CASE LOAD_C: CODE=TL(CODE); 343 I=I+1; 344 V[I]=HD(CODE); 345 ENDCASE 346 CASE LOADARG_C: CODE=TL(CODE); 347 I=I+1; 348 V[I]=V[(WORD)(HD(CODE))]; 349 ENDCASE 350 CASE APPLY_C: I=I-1; 351 V[I]=CONS(V[I],V[I+1]); 352 ENDCASE 353 CASE APPLYINFIX_C: CODE=TL(CODE); 354 I=I-1; 355 V[I]=CONS(HD(CODE),CONS(V[I],V[I+1])); 356 ENDCASE 357 CASE CONTINUE_INFIX_C: CODE=TL(CODE); 358 V[I-1]=CONS(HD(CODE), 359 CONS(V[I-1],V[I])); 360 //NOTE THAT 2ND ARG IS LEFT IN PLACE ABOVE 361 //NEW EXPRESSION 362 ENDCASE 363 CASE IF_C: IF_FLAG=TRUE; 364 ENDCASE 365 CASE FORMLIST_C: CODE=TL(CODE); 366 I=I+1; 367 V[I]=NIL; 368 FOR (J=1; J<=(WORD)(HD(CODE)); J++) 369 { I=I-1; 370 V[I]=CONS((LIST)COLON_OP,CONS(V[I],V[I+1])); 371 } 372 ENDCASE 373 CASE FORMZF_C: CODE=TL(CODE); 374 I=I-(WORD)(HD(CODE)); 375 V[I]=CONS(V[I],NIL); 376 FOR (J=(WORD)(HD(CODE)); J>=1; J=J-1) 377 V[I] = CONS(V[I+J],V[I]); 378 V[I] = CONS((LIST)ZF_OP,V[I]); 379 ENDCASE 380 CASE CONT_GENERATOR_C: 381 CODE = TL(CODE); 382 FOR (J=1; J<=(WORD)(HD(CODE)); J++) 383 V[I-J] = CONS((LIST)GENERATOR,CONS(V[I-J], 384 TL(TL(V[I])))); 385 ENDCASE 386 CASE MATCH_C: 387 CASE MATCHARG_C: 388 CODE=TL(CODE); 389 CODE=TL(CODE); 390 ENDCASE 391 CASE MATCHPAIR_C: CODE=TL(CODE); 392 { LIST X = V[(WORD)HD(CODE)]; 393 I=I+2; 394 V[I-1]=HD(TL(X)), V[I]=TL(TL(X)); } 395 ENDCASE 396 CASE STOP_C: PRINTEXP(V[I],0); 397 UNLESS IF_FLAG DO RETURN 398 WRITES(", "); 399 PRINTEXP(V[I-1],0); 400 RETURN 401 DEFAULT: WRITES("IMPOSSIBLE INSTRUCTION IN \"DISPLAYRHS\"\n"); 402 } //END OF SWITCH 403 CODE=TL(CODE); 404 } REPEAT; 405 } 406 407 LIST 408 PROFILE(LIST EQN) //EXTRACTS THAT PART OF THE CODE WHICH 409 //DETERMINES WHICH CASES THIS EQUATION APPLIES TO 410 { LIST CODE=TL(EQN); 411 IF HD(CODE)==(LIST)LINENO_C 412 DO CODE=TL(TL(CODE)); 413 { LIST C=CODE; 414 WHILE PARMY(HD(C)) DO C=REST(C); 415 { LIST HOLD=C; 416 UNTIL HD(C)==(LIST)IF_C||HD(C)==(LIST)STOP_C DO C=REST(C); 417 TEST HD(C)==(LIST)IF_C 418 THEN RESULTIS SUBTRACT(CODE,C); 419 OR RESULTIS SUBTRACT(CODE,HOLD); 420 } } } 421 422 STATIC BOOL 423 PARMY(LIST X) 424 { RESULTIS X==(LIST)MATCH_C||X==(LIST)MATCHARG_C||X==(LIST)MATCHPAIR_C; 425 } 426 427 STATIC LIST 428 REST(LIST C) //REMOVES ONE COMPLETE INSTRUCTION FROM C 429 { LIST X=HD(C); 430 C=TL(C); 431 IF X==(LIST)APPLY_C||X==(LIST)IF_C||X==(LIST)STOP_C DO RESULTIS C; 432 C=TL(C); 433 UNLESS X==(LIST)MATCH_C||X==(LIST)MATCHARG_C DO RESULTIS C; 434 RESULTIS TL(C); } 435 436 STATIC LIST 437 SUBTRACT(LIST X, LIST Y) //LIST SUBTRACTION 438 { LIST Z=NIL; 439 UNTIL X==Y 440 DO Z = CONS(HD(X),Z), X = TL(X); 441 RESULTIS Z; //NOTE THE RESULT IS REVERSED - FOR OUR PURPOSES THIS 442 } //DOES NOT MATTER 443 444 VOID 445 REMOVELINENO(LIST EQN) 446 //CALLED WHENEVER THE DEFINIENDUM IS SUBJECT OF A 447 //DISPLAY,REORDER OR (PARTIAL)DELETE COMMAND - HAS THE EFFECT OF 448 //RESTORING THE STANDARD LINE NUMBERING 449 { IF HD(TL(EQN))==(LIST)LINENO_C 450 DO TL(EQN)=TL(TL(TL(EQN))); 451 } 452 453 //COMPILER FOR KRC EXPRESSIONS AND EQUATIONS 454 455 LIST 456 EXP() 457 { INIT_CODEV(); 458 EXPR(0); 459 PLANT0(STOP_C); 460 RESULTIS COLLECTCODE(); 461 } 462 463 LIST 464 EQUATION() //RETURNS A TRIPLE: CONS(SUBJECT,CONS(NARGS,EQN)) 465 { LIST SUBJECT = 0, LHS = 0; 466 WORD NARGS = 0; 467 INIT_CODEV(); 468 TEST HAVEID() 469 THEN { SUBJECT=(LIST)THE_ID,LHS=(LIST)THE_ID; 470 WHILE STARTFORMAL(HD(TOKENS)) 471 DO { LHS=CONS(LHS,FORMAL()); 472 NARGS=NARGS+1; } 473 } OR 474 TEST HD(TOKENS)==(LIST)'=' && LASTLHS!=NIL 475 THEN { SUBJECT=LASTLHS,LHS=LASTLHS; 476 WHILE ISCONS(SUBJECT) 477 DO SUBJECT=HD(SUBJECT),NARGS=NARGS+1; 478 } 479 OR { SYNTAX(), WRITES("missing LHS\n"); 480 RESULTIS NIL; } 481 COMPILELHS(LHS,NARGS); 482 { LIST CODE=COLLECTCODE(); 483 CHECK((TOKEN)'='); 484 EXPR(0); 485 PLANT0(STOP_C); 486 { LIST EXPCODE=COLLECTCODE(); 487 TEST HAVE((TOKEN)',') //CHANGE FROM EMAS/KRC TO ALLOW GUARDED SIMPLE DEF 488 THEN { EXPR(0); 489 PLANT0(IF_C); 490 CODE=APPEND(CODE,APPEND(COLLECTCODE(),EXPCODE)); } 491 OR CODE=APPEND(CODE,EXPCODE); 492 UNLESS HD(TOKENS)==ENDSTREAMCH DO CHECK(EOL); 493 UNLESS ERRORFLAG DO LASTLHS=LHS; 494 IF NARGS==0 DO LHS=0;//IN THIS CASE THE LHS FIELD IS USED TO REMEMBER 495 //THE VALUE OF THE VARIABLE - 0 MEANS NOT YET SET 496 RESULTIS CONS(SUBJECT,CONS((LIST)NARGS,CONS(LHS,CODE))); // OK 497 } } } 498 499 STATIC VOID 500 EXPR(WORD N) //N IS THE PRIORITY LEVEL 501 { TEST N<=3 &&(HAVE((TOKEN)'\\') || HAVE((TOKEN)'~')) 502 THEN { PLANT1(LOAD_C,(LIST)NOT_OP); 503 EXPR(3); 504 PLANT0(APPLY_C); } OR 505 TEST N<=5 && HAVE((TOKEN)'+') THEN EXPR(5); OR 506 TEST N<=5 && HAVE((TOKEN)'-') 507 THEN { PLANT1(LOAD_C,(LIST)NEG_OP); 508 EXPR(5); 509 PLANT0(APPLY_C); } OR 510 TEST HAVE((TOKEN)'#') 511 THEN { PLANT1(LOAD_C,(LIST)LENGTH_OP); 512 COMBN(); 513 PLANT0(APPLY_C); } OR 514 TEST STARTSIMPLE(HD(TOKENS)) 515 THEN COMBN(); 516 OR { SYNTAX(); RETURN } 517 { OPERATOR OP=MKINFIX(HD(TOKENS)); 518 WHILE DIPRIO(OP)>=N 519 DO { WORD I, AND_COUNT=0; //FOR CONTINUED RELATIONS 520 TOKENS=TL(TOKENS); 521 EXPR(RIGHTPREC(OP)); 522 IF ERRORFLAG DO RETURN; 523 WHILE ISRELOP((LIST)OP) && ISRELOP((LIST)MKINFIX(HD(TOKENS))) 524 DO { //CONTINUED RELATIONS 525 AND_COUNT=AND_COUNT+1; 526 PLANT1(CONTINUE_INFIX_C,(LIST)OP); 527 OP=MKINFIX(HD(TOKENS)); 528 TOKENS=TL(TOKENS); 529 EXPR(4); 530 IF ERRORFLAG DO RETURN } 531 PLANT1(APPLYINFIX_C,(LIST)OP); 532 FOR (I=1; I<=AND_COUNT; I++) 533 PLANT1(APPLYINFIX_C,(LIST)AND_OP); 534 //FOR CONTINUED RELATIONS 535 OP=MKINFIX(HD(TOKENS)); } 536 } } 537 538 STATIC VOID 539 COMBN() 540 { SIMPLE(); 541 WHILE STARTSIMPLE(HD(TOKENS)) 542 DO { SIMPLE(); 543 PLANT0(APPLY_C); } 544 } 545 546 STATIC BOOL 547 STARTFORMAL(TOKEN T) 548 { RESULTIS ISCONS(T) ? (HD(T)==IDENT || HD(T)==(LIST)CONST) : 549 T==(TOKEN)'(' || T==(TOKEN)'[' || T == (TOKEN)'-'; } 550 551 STATIC BOOL 552 STARTSIMPLE(TOKEN T) 553 { RESULTIS ISCONS(T) ? (HD(T)==IDENT || HD(T)==(LIST)CONST) : 554 T==(TOKEN)'(' || T==(TOKEN)'[' || T==(TOKEN)'{' || T==(TOKEN)'\''; } 555 556 STATIC VOID 557 SIMPLE() 558 { TEST HAVEID() 559 THEN COMPILENAME(THE_ID); OR 560 TEST HAVECONST() 561 THEN PLANT1(LOAD_C,(LIST)INTERNALISE(THE_CONST)); OR 562 TEST HAVE((TOKEN)'(') 563 THEN { EXPR(0); CHECK((TOKEN)')'); } OR 564 TEST HAVE((TOKEN)'[') 565 THEN TEST HAVE((TOKEN)']') 566 THEN PLANT1(LOAD_C,NIL); 567 OR { WORD N=1; 568 EXPR(0); 569 IF HAVE((TOKEN)',') 570 DO { EXPR(0); 571 N=N+1; } 572 TEST HAVE(DOTDOT_SY) 573 THEN { TEST HD(TOKENS)==(TOKEN)']' 574 THEN PLANT1(LOAD_C,INFINITY); 575 OR EXPR(0); 576 IF N==2 DO PLANT0(APPLY_C); 577 PLANT1(APPLYINFIX_C, 578 (LIST)(N==1 ? DOTDOT_OP : COMMADOTDOT_OP)); } // OK 579 OR { WHILE HAVE((TOKEN)',') 580 DO { EXPR(0); 581 N=N+1; } 582 PLANT1(FORMLIST_C,(LIST)N); } // OK 583 CHECK((TOKEN)']'); } OR 584 TEST HAVE((TOKEN)'{') // ZF EXPRESSIONS BUG? 585 THEN { WORD N = 0; 586 LIST HOLD = TOKENS; 587 PERFORM_ALPHA_CONVERSIONS(); 588 EXPR(0); 589 //TEST HD(TOKENS)==BACKARROW_SY //IMPLICIT ZF BODY 590 //NO LONGER LEGAL 591 //THEN TOKENS=HOLD; OR 592 CHECK((TOKEN)';'); 593 do N = N + QUALIFIER(); REPEATWHILE(HAVE((TOKEN)';')); 594 PLANT1(FORMZF_C,(LIST)N); // OK 595 CHECK((TOKEN)'}'); } OR 596 TEST HAVE((TOKEN)'\'') //OPERATOR DENOTATION 597 THEN { TEST HAVE((TOKEN)'#') THEN PLANT1(LOAD_C,(LIST)LENGTH_OP); OR 598 TEST HAVE((TOKEN)'\\') || HAVE((TOKEN)'~') THEN PLANT1(LOAD_C,(LIST)NOT_OP); 599 OR { OPERATOR OP=MKINFIX((TOKEN)(HD(TOKENS))); 600 TEST ISINFIX((LIST)OP) THEN TOKENS=TL(TOKENS); 601 OR SYNTAX(); //MISSING INFIX OR PREFIX OPERATOR 602 PLANT1(LOAD_C,(LIST)QUOTE_OP); 603 PLANT1(LOAD_C,(LIST)OP); 604 PLANT0(APPLY_C); } 605 CHECK((TOKEN)'\''); } 606 OR SYNTAX(); //MISSING identifier|constant|(|[|{ 607 } 608 609 STATIC VOID 610 COMPILENAME(ATOM N) 611 { WORD I=0; 612 UNTIL I>ENVP || ENV[I]==(LIST)N 613 DO I=I+1; 614 TEST I>ENVP 615 THEN PLANT1(LOAD_C,(LIST)N); 616 OR PLANT1(LOADARG_C,(LIST)I); //OK 617 } 618 619 STATIC WORD 620 QUALIFIER() 621 { TEST ISGENERATOR(TL(TOKENS)) //WHAT ABOUT MORE GENERAL FORMALS? 622 THEN { WORD N=0; 623 do { 624 HAVEID(); 625 PLANT1(LOAD_C,(LIST)THE_ID); 626 N = N+1; 627 } REPEATWHILE(HAVE((TOKEN)',')); 628 CHECK(BACKARROW_SY); 629 EXPR(0); 630 PLANT1(APPLYINFIX_C,(LIST)GENERATOR); 631 IF N>1 DO PLANT1(CONT_GENERATOR_C,(LIST)(N-1)); // OK 632 RESULTIS N; } 633 OR { EXPR(0) ; RESULTIS 1; } 634 } 635 636 STATIC VOID 637 PERFORM_ALPHA_CONVERSIONS() 638 //ALSO RECOGNISES THE "SUCH THAT" BAR AND CONVERTS IT TO ';' 639 //TO DISTINGUISH IT FROM "OR" 640 { LIST P=TOKENS; 641 UNTIL HD(P)==(TOKEN)'}' || HD(P)==(TOKEN)']' || HD(P)==EOL 642 DO { IF HD(P)==(TOKEN)'[' || HD(P)==(TOKEN)'{' 643 DO { P = SKIPCHUNK(P); 644 LOOP; } 645 IF HD(P)==(TOKEN)'|' && ISID(HD(TL(P))) && ISGENERATOR(TL(TL(P))) 646 DO HD(P) = (TOKEN)';' ; 647 IF ISID(HD(P)) && ISGENERATOR(TL(P)) 648 DO ALPHA_CONVERT(HD(P),TL(P)); 649 P=TL(P); } } 650 651 BOOL 652 ISID(LIST X) { RESULTIS ISCONS(X) && HD(X)==IDENT; } 653 654 STATIC BOOL 655 ISGENERATOR(LIST T) 656 { RESULTIS !ISCONS(T) ? FALSE : 657 HD(T)==BACKARROW_SY || 658 (HD(T)==(TOKEN)',' && ISID(HD(TL(T))) && ISGENERATOR(TL(TL(T)))); 659 } 660 661 STATIC VOID 662 ALPHA_CONVERT(LIST VAR, LIST P) 663 { LIST T=TOKENS; 664 LIST VAR1=CONS((LIST)ALPHA,TL(VAR)); 665 LIST EDGE=T; 666 UNTIL HD(EDGE)==(TOKEN)';' || HD(EDGE)==BACKARROW_SY || HD(EDGE)==EOL 667 DO EDGE=SKIPCHUNK(EDGE); 668 UNTIL T==EDGE 669 DO { CONV1(T,VAR,VAR1); 670 T=TL(T); } 671 T=P; 672 UNTIL HD(T)==(TOKEN)';' || HD(T)==EOL DO T=SKIPCHUNK(T); 673 EDGE=T; 674 UNTIL HD(EDGE)==(TOKEN)'}' || HD(EDGE)==(TOKEN)']' || HD(EDGE)==EOL 675 DO EDGE=SKIPCHUNK(EDGE); 676 UNTIL T==EDGE 677 DO { CONV1(T,VAR,VAR1); 678 T=TL(T); } 679 TL(VAR)=VAR1; 680 } 681 682 STATIC LIST 683 SKIPCHUNK(LIST P) 684 { WORD KET = HD(P)==(TOKEN)'{' ? '}' : HD(P)==(TOKEN)'[' ? ']' : -1; 685 P=TL(P); 686 IF KET==-1 DO RESULTIS P; 687 UNTIL HD(P)==(LIST)KET || HD(P)==EOL // OK 688 DO P = SKIPCHUNK(P); 689 UNLESS HD(P)==EOL DO P=TL(P); 690 RESULTIS(P); 691 } 692 693 STATIC VOID 694 CONV1(LIST T, LIST VAR, LIST VAR1) 695 { IF EQUAL(HD(T),VAR) && HD(T)!=VAR DO TL(HD(T))=VAR1; } 696 697 STATIC 698 LIST FORMAL() 699 { TEST HAVEID() THEN RESULTIS (LIST)THE_ID; OR 700 TEST HAVECONST() THEN RESULTIS INTERNALISE(THE_CONST); OR 701 TEST HAVE((TOKEN)'(') 702 THEN { LIST P=PATTERN(); 703 CHECK((TOKEN)')'); 704 RESULTIS P; } OR 705 TEST HAVE((TOKEN)'[') 706 THEN { LIST PLIST=NIL,P=NIL; 707 IF HAVE((TOKEN)']') DO RESULTIS NIL; 708 do PLIST=CONS(PATTERN(),PLIST); 709 REPEATWHILE(HAVE((TOKEN)',')); //NOTE THEY ARE IN REVERSE ORDER 710 CHECK((TOKEN)']'); 711 UNTIL PLIST==NIL 712 DO { P=CONS((TOKEN)COLON_OP,CONS(HD(PLIST),P)); 713 PLIST=TL(PLIST); } //NOW THEY ARE IN CORRECT ORDER 714 RESULTIS P; } OR 715 TEST HAVE((TOKEN)'-') && HAVENUM() 716 THEN { THE_NUM = -THE_NUM; 717 RESULTIS STONUM(THE_NUM); } 718 OR { SYNTAX(); //MISSING identifier|constant|(|[ 719 RESULTIS NIL; 720 } } 721 722 STATIC LIST 723 INTERNALISE(LIST VAL) 724 { RESULTIS VAL==TL(TRUTH) ? TRUTH : 725 VAL==TL(FALSITY) ? FALSITY : 726 ISATOM(VAL) ? CONS((LIST)QUOTE,VAL) : VAL; } 727 728 STATIC LIST 729 PATTERN() 730 { LIST P=FORMAL(); 731 IF HAVE((TOKEN)':') 732 DO P=CONS((LIST)COLON_OP,CONS(P,PATTERN())); 733 RESULTIS P; } 734 735 STATIC VOID 736 COMPILELHS(LIST LHS, WORD NARGS) 737 { WORD I; 738 ENVP=NARGS-1; 739 FOR (I=1; I<=NARGS; I++) 740 { ENV[NARGS-I]=TL(LHS); 741 LHS=HD(LHS); } 742 FOR (I=0; I<=NARGS-1; I++) COMPILEFORMAL(ENV[I],I); 743 } 744 745 STATIC VOID 746 COMPILEFORMAL(LIST X, WORD I) 747 { TEST ISATOM(X) //IDENTIFIER 748 THEN { WORD J=0; 749 UNTIL J>=I || ENV[J]==X 750 DO J=J+1; // IS THIS A REPEATED NAME? 751 TEST J>=I 752 THEN RETURN // NO, NO CODE COMPILED 753 OR PLANT2(MATCHARG_C,(LIST)I,(LIST)J); } OR 754 TEST ISNUM(X) || X==NIL || (ISCONS(X) && HD(X)==(LIST)QUOTE) 755 THEN PLANT2(MATCH_C,(LIST)I,X); OR 756 TEST ISCONS(X) && HD(X)==(TOKEN)COLON_OP && ISCONS(TL(X)) 757 THEN { PLANT1(MATCHPAIR_C,(LIST)I); // OK 758 ENVP=ENVP+2; 759 { WORD A=ENVP-1,B=ENVP; 760 ENV[A]=HD(TL(X)), ENV[B]=TL(TL(X)); 761 COMPILEFORMAL(ENV[A],A); 762 COMPILEFORMAL(ENV[B],B); 763 } } 764 OR WRITES("Impossible event in \"COMPILEFORMAL\"\n"); 765 } 766 767 // PLANT stores INSTRUCTIONs and their operands in the code vector 768 // OP is always an instruction code (*_C); 769 // A and B can be operators (*_OP), INTs, CONSTs, IDs (names) or 770 // the address of a C function - all are mapped to LIST type. 771 772 // APPLY_C IF_C STOP_C 773 STATIC VOID 774 PLANT0(INSTRUCTION OP) 775 { CODEV=CONS((LIST)OP, CODEV); } 776 777 // everything else 778 STATIC VOID 779 PLANT1(INSTRUCTION OP, LIST A) 780 { CODEV=CONS((LIST)OP, CODEV); 781 CODEV=CONS(A, CODEV); } 782 783 // MATCH_C MATCHARG_C 784 STATIC VOID 785 PLANT2(INSTRUCTION OP, LIST A, LIST B) 786 { CODEV=CONS((LIST)OP, CODEV); 787 CODEV=CONS(A, CODEV); 788 CODEV=CONS(B, CODEV); } 789 790 STATIC LIST 791 COLLECTCODE() //FLUSHES THE CODE BUFFER 792 { LIST TMP=CODEV; 793 CODEV=NIL; 794 RESULTIS REVERSE(TMP); 795 } 796 797 // Mark elements in CODEV and ENV for preservation by the GC. 798 // This routine should be called by your BASES() function. 799 VOID 800 COMPILER_BASES(VOID (*F)(LIST *)) 801 { WORD I; 802 803 F(&CODEV); 804 // ENVP indexes the last used element and starts as -1. 805 FOR (I=0; I<=ENVP ; I++) F(&ENV[I]); 806 }