reducer
1 ||KRC REDUCER 2 3 GET "LIBHDR" 4 GET "KRC_LISTHDR" 5 GET "KRC_COMPHDR" 6 GET "KRC_REDHDR" 7 8 ||---------------------------------------------------------------------- 9 ||The KRC system is Copyright (c) D. A. Turner 1981 10 ||All rights reserved. It is distributed as free software under the 11 ||terms in the file "COPYING", which is included in the distribution. 12 ||---------------------------------------------------------------------- 13 14 STATIC $( ETC=?; SILLYNESS=?; GUARD=?; TRUECONTINGENCY=? 15 LISTDIFF=? 16 BADFILE=?; READFN=?; WRITEFN=?; INTERLEAVEFN=? 17 NL=?; NP=?; TAB=?; VT=? 18 $) 19 20 MANIFEST $( ENDOFSTACK=-2 $) 21 22 MANIFEST $( ||INTERRUPT STATUSES 23 NORMAL=1; DELAY=2; PENDING=3 24 $) 25 26 STATIC $( INTERRUPT.STATUS=DELAY; INITIALISING=TRUE $) 27 28 LET SETUP.PRIMFNS.ETC() 29 BE $( LET R(S,F,N) ||ASSUMES IT IS OK TO STORE BCPL FN IN LIST FIELD 30 BE $( LET A=MKATOM(S) 31 LET EQN=CONS(A,CONS(CALL.C,F)) 32 UNLESS F=READ DO ENTERSCRIPT(A) 33 VAL!A:=CONS(CONS(N,NIL),CONS(EQN,NIL)) $) 34 S:=ENDOFSTACK ||S IS USED INSIDE REDUCE - IT HAS TO BE GLOBAL 35 ||SO IT CAN BE ACCESSED AFTER AN INTERRUPT (SEE 36 || CATCHINTERRUPT) 37 ETC:=MKATOM("... ") ||MISCELLANEOUS INITIALISATIONS 38 SILLYNESS:=MKATOM("<silly recursion>") 39 GUARD:=MKATOM("<non truth-value used as guard:>") 40 TRUTH:=CONS(QUOTE,MKATOM("TRUE")) 41 FALSITY:=CONS(QUOTE,MKATOM("FALSE")) 42 LISTDIFF:=MKATOM("listdiff") 43 INFINITY:=CONS(QUOTE,-3) 44 TRUECONTINGENCY:=CONTINGENCY 45 CONTINGENCY:=CATCHINTERRUPT 46 R("function",FUNCTIONP,1) ||PRIMITIVE FUNCTIONS 47 R("list",LISTP,1) 48 R("string",STRINGP,1) 49 R("number",NUMBERP,1) 50 R("char",CHAR,1) 51 R("printwidth",SIZE,1) 52 R("code",CODE,1) 53 R("decode",DECODE,1) 54 R("concat",CONCAT,1) 55 R("explode",EXPLODE,1) 56 R("read",STARTREAD,1) 57 R("read ",READ,1) 58 R("write",WRITEAP,3) 59 BADFILE:=MKATOM("<cannot open file:>") 60 READFN:=MKATOM("read ") 61 WRITEFN:=MKATOM("write") 62 INTERLEAVEFN:=MKATOM("interleave") 63 NL:=MKATOM("*N") 64 NP:=MKATOM("*P") 65 TAB:=MKATOM("*T") 66 VT:=MKATOM("*V") 67 $) 68 69 AND SCASECONV(S) = VALOF 70 $( LET T = TABLE 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 71 LET N = GETBYTE(S,0) 72 PUTBYTE(T,0,N) 73 FOR I = 1 TO (N/BYTESPERWORD + 1)*BYTESPERWORD -1 74 DO PUTBYTE(T,I,CASECONV(GETBYTE(S,I))) 75 RESULTIS T $) 76 77 AND HOLD.INTERRUPTS() 78 BE INTERRUPT.STATUS:=DELAY 79 80 AND RELEASE.INTERRUPTS() 81 BE $( IF INTERRUPT.STATUS=PENDING 82 DO $( INTERRUPT.STATUS:=NORMAL ; CONTINGENCY(65,'A') $) 83 INITIALISING:=FALSE 84 INTERRUPT.STATUS:=NORMAL 85 $) 86 87 ||THIS ROUTINE AND THE NEXT TWO ARE OBVIOUSLY SYSTEM DEPENDENT 88 AND CATCHINTERRUPT(CLASS,SUBCLASS,DUMPSEG) 89 BE TEST CLASS=65 & (SUBCLASS='A' | SUBCLASS='a') 90 THEN $( LET DUMMY=? 91 IF INITIALISING FINISH 92 IF INTERRUPT.STATUS=DELAY | INTERRUPT.STATUS=PENDING 93 DO $( INTERRUPT.STATUS:=PENDING ; RETURN $) 94 UNLESS S=ENDOFSTACK 95 DO HD!S:=QUOTE ||IN CASE INTERRUPT STRUCK WHILE REDUCE 96 ||WAS DISSECTING A CONSTANT 97 CONSOLE(7,@DUMMY,@DUMMY) ||KILL OUTPUT 98 WRCH:=TRUEWRCH 99 CLOSECHANNELS() 100 WRITES("*N****break in - return to KRC command level*****N") 101 DISCARD.ID() ||REALLOW INTERRUPTS 102 ESCAPETONEXTCOMMAND() $) 103 OR TRUECONTINGENCY(CLASS,SUBCLASS,DUMPSEG) 104 105 AND CONSOLE(EP,P1,P2) 106 BE $( EXTERNAL $( S.CONSOLE $) 107 S.CONSOLE(EP,#X28000001,P1<<2,#X28000001,P2<<2) 108 $) 109 110 AND FLUSH() 111 BE $( EXTERNAL $( TERMINATE $) 112 TERMINATE() 113 $) 114 115 AND OUTSTATS() 116 BE $( GCSTATS() 117 WRITEF(", reductions = %N(%N)*N",REDS,REDS-XSUBREDS) 118 $) 119 120 || THE POSSIBLE VALUES OF A REDUCED EXPRESSION ARE: 121 || VAL::= CONST | FUNCTION | LIST 122 || CONST::= NUM | CONS(QUOTE,ATOM) 123 || LIST::= NIL | CONS(COLON.OP,CONS(EXP,EXP)) 124 || FUNCTION::= NAME | CONS(E1,E2) 125 126 AND PRINTVAL(E,FORMAT) 127 BE $( E:=REDUCE(E) 128 TEST E=NIL 129 THEN IF FORMAT DO WRITES("[]") OR 130 TEST ISNUM(E) 131 THEN WRITEN(GETNUM(E)) OR 132 TEST ISCONS(E) 133 THEN $( LET H=HD!E 134 TEST H=QUOTE 135 THEN PRINTATOM(TL!E,FORMAT) OR 136 TEST H=COLON.OP 137 THEN $( IF FORMAT DO WRCH('[') 138 E:=TL!E 139 $( PRINTVAL(HD!E,FORMAT) 140 E:=TL!E 141 E:=REDUCE(E) 142 UNLESS ISCONS(E) BREAK 143 TEST HD!E=COLON.OP 144 THEN IF FORMAT DO WRCH(',') 145 OR BREAK 146 E:=TL!E 147 $) REPEAT 148 TEST E=NIL 149 THEN IF FORMAT DO WRCH(']') 150 OR BADEXP(CONS(COLON.OP,CONS(ETC,E))) 151 $) OR 152 TEST ISCONS(H) & HD!H=WRITEFN 153 THEN $( TL!H:=REDUCE(TL!H) 154 UNLESS ISCONS(TL!H) & HD!(TL!H)=QUOTE 155 DO BADEXP(E) 156 $( LET F=PRINTNAME(TL!(TL!H)) 157 LET OUT=FINDCHANNEL(F) 158 LET HOLD=OUTPUT() 159 UNLESS OUT>0 DO BADEXP(CONS(BADFILE,TL!H)) 160 SELECTOUTPUT(OUT) 161 PRINTVAL(TL!E,FORMAT) 162 SELECTOUTPUT(HOLD) 163 $) $) 164 OR PRINTFUNCTION(E) ||A PARTIAL APPLICATION OR COMPOSITION 165 $) 166 OR PRINTFUNCTION(E) ||ONLY POSSIBILITY HERE SHOULD BE 167 ||NAME OF FUNCTION 168 $) 169 170 AND PRINTATOM(A,FORMAT) 171 BE TEST FORMAT 172 THEN TEST A=NL THEN WRITES("<nl>") OR 173 TEST A=NP THEN WRITES("<np>") OR 174 TEST A=TAB THEN WRITES("<tab>") OR 175 TEST A=VT THEN WRITES("<vt>") 176 OR WRITEF("*"%S*"",PRINTNAME(A)) 177 OR TEST A=VT THEN FLUSH() 178 OR WRITES(PRINTNAME(A)) 179 180 AND PRINTFUNCTION(E) 181 BE $( WRCH('<') 182 PRINTEXP(E,0) 183 WRCH('>') $) 184 185 AND EQUALVAL(A,B) = VALOF ||UNPREDICTABLE RESULTS IF A,B BOTH FUNCTIONS 186 $( A:=REDUCE(A) 187 B:=REDUCE(B) 188 IF A=B RESULTIS TRUE 189 IF ISNUM(A) & ISNUM(B) 190 RESULTIS GETNUM(A)=GETNUM(B) 191 UNLESS ISCONS(A) & ISCONS(B) RESULTIS FALSE 192 IF HD!A=QUOTE=HD!B RESULTIS TL!A=TL!B 193 UNLESS HD!A=COLON.OP=HD!B RESULTIS FALSE ||UH ? 194 A,B:=TL!A,TL!B 195 UNLESS EQUALVAL(HD!A,HD!B) RESULTIS FALSE 196 A,B:=TL!A,TL!B 197 $) REPEAT 198 199 AND BADEXP(E) ||CALLED FOR ALL EVALUATION ERRORS 200 BE $( WRCH:=TRUEWRCH 201 CLOSECHANNELS() 202 WRCH:=TRUEWRCH 203 WRITES("*N****undefined expression*****N ") 204 PRINTEXP(E,0) 205 ||COULD INSERT MORE DETAILED DIAGNOSTICS HERE, 206 ||DEPENDING ON NATURE OF HD!E, FOR EXAMPLE: 207 IF ISCONS(E) &(HD!E=COLON.OP|HD!E=APPEND.OP) 208 DO WRITES("*N (non-list encountered where list expected)") 209 WRITES("*N****evaluation abandoned*****N") 210 ESCAPETONEXTCOMMAND() 211 $) 212 213 AND BUILDEXP(CODE) = VALOF ||A KLUDGE 214 $( LET E = CONS(NIL,NIL) ||A BOGUS PIECE OF GRAPH 215 OBEY(CONS(CONS(NIL,CODE),NIL),E) 216 ARGP:=ARG-1 ||RESET ARG STACK 217 RESULTIS E 218 $) 219 220 AND OBEY(EQNS,E) ||TRANSFORM A PIECE OF GRAPH, E, IN ACCORDANCE 221 ||WITH EQNS - ACTUAL PARAMS ARE FOUND IN 222 || !ARG ... !ARGP 223 || (WARNING - HAS SIDE EFFECT OF RAISING ARGP) 224 BE 225 $( IF ARGP+20>ARGMAX DO SPACE.ERROR() 226 UNTIL EQNS=NIL ||EQNS LOOP 227 DO $( LET CODE=TL!(HD!EQNS) 228 LET HOLDARG=ARGP 229 $( LET H = HD!CODE ||DECODE LOOP 230 CODE:=TL!CODE 231 SWITCHON H INTO 232 $( CASE LOAD.C: ARGP:=ARGP+1 233 !ARGP:=HD!CODE 234 CODE:=TL!CODE 235 ENDCASE 236 CASE LOADARG.C: ARGP:=ARGP+1 237 !ARGP:=ARG!(HD!CODE) 238 CODE:=TL!CODE 239 ENDCASE 240 CASE APPLYINFIX.C: !ARGP:=CONS(!(ARGP-1),!ARGP) 241 !(ARGP-1):=HD!CODE 242 CODE:=TL!CODE 243 CASE APPLY.C: ARGP:=ARGP-1 244 IF HD!CODE=STOP.C 245 DO $( HD!E,TL!E:=!ARGP,!(ARGP+1) 246 RETURN $) 247 !ARGP:=CONS(!ARGP,!(ARGP+1)) 248 ENDCASE 249 CASE CONTINUE.INFIX.C: 250 !(ARGP-1):=CONS(HD!CODE,CONS(!(ARGP-1),!ARGP)) 251 CODE:=TL!CODE 252 ENDCASE 253 CASE IF.C: !ARGP:=REDUCE(!ARGP) 254 IF !ARGP=FALSITY BREAK 255 UNLESS !ARGP=TRUTH DO BADEXP(CONS(GUARD,!ARGP)) 256 ENDCASE 257 CASE FORMLIST.C: ARGP:=ARGP+1 258 !ARGP:=NIL 259 FOR I=1 TO HD!CODE 260 DO $( ARGP:=ARGP-1 261 !ARGP:=CONS(COLON.OP, 262 CONS(!ARGP,!(ARGP+1))) 263 $) 264 CODE:=TL!CODE 265 ENDCASE 266 CASE FORMZF.C: $( LET X=CONS(!(ARGP-HD!CODE),NIL) 267 FOR P = ARGP TO ARGP-HD!CODE+1 BY -1 268 DO X:= CONS(!P,X) 269 ARGP:= ARGP-HD!CODE 270 !ARGP:= CONS(ZF.OP,X) 271 CODE:= TL!CODE 272 ENDCASE $) 273 CASE CONT.GENERATOR.C: 274 FOR I = 1 TO HD!CODE 275 DO !(ARGP-I):= CONS(GENERATOR,CONS(!(ARGP-I), 276 TL!(TL!(!ARGP)))) 277 CODE:= TL!CODE 278 ENDCASE 279 CASE MATCH.C: $( LET I=HD!CODE 280 CODE:=TL!CODE 281 UNLESS EQUALVAL(ARG!I,HD!CODE) BREAK 282 CODE:=TL!CODE 283 ENDCASE $) 284 CASE MATCHARG.C: $( LET I=HD!CODE 285 CODE:=TL!CODE 286 UNLESS EQUALVAL(ARG!I,ARG!(HD!CODE)) 287 DO BREAK 288 CODE:=TL!CODE 289 ENDCASE $) 290 CASE MATCHPAIR.C: $( LET P=ARG+HD!CODE 291 !P:=REDUCE(!P) 292 UNLESS ISCONS(!P)&HD!(!P)=COLON.OP 293 BREAK 294 ARGP:=ARGP+2 295 P:=TL!(!P) 296 !(ARGP-1),!ARGP:=HD!P,TL!P 297 CODE:=TL!CODE 298 ENDCASE $) 299 CASE LINENO.C: CODE:=TL!CODE ||NO ACTION 300 ENDCASE 301 CASE STOP.C: HD!E,TL!E:=INDIR,!ARGP 302 RETURN 303 CASE CALL.C: (CODE)(E) 304 RETURN 305 DEFAULT: WRITES("IMPOSSIBLE INSTRUCTION IN*"OBEY*"*N") 306 $) $) REPEAT ||END OF DECODE LOOP 307 EQNS:=TL!EQNS 308 ARGP:=HOLDARG 309 $) ||END OF EQNS LOOP 310 BADEXP(E) 311 $) 312 313 AND STRINGP(E) 314 BE $( !ARG:=REDUCE(!ARG) 315 HD!E,TL!E:=INDIR,ISCONS(!ARG)&HD!(!ARG)=QUOTE->TRUTH,FALSITY 316 $) 317 318 AND NUMBERP(E) 319 BE $( !ARG:=REDUCE(!ARG) 320 HD!E,TL!E:=INDIR,ISNUM(!ARG)->TRUTH,FALSITY 321 $) 322 323 AND LISTP(E) 324 BE $( !ARG:=REDUCE(!ARG) 325 HD!E,TL!E:=INDIR,(!ARG=NIL|ISCONS(!ARG)&HD!(!ARG)=COLON.OP)-> 326 TRUTH,FALSITY 327 $) 328 329 AND FUNCTIONP(E) 330 BE $( !ARG:=REDUCE(!ARG) 331 HD!E:=INDIR 332 TL!E:=ISFUN(!ARG)->TRUTH,FALSITY 333 $) 334 335 AND ISFUN(X) = ISATOM(X) | ISCONS(X) & QUOTE\=HD!X\=COLON.OP 336 337 AND CHAR(E) 338 BE $( !ARG:=REDUCE(!ARG) 339 HD!E,TL!E:=INDIR, 340 ISCONS(!ARG) & HD!(!ARG)=QUOTE & 341 GETBYTE(PRINTNAME(TL!(!ARG)),0)=1 -> TRUTH, FALSITY 342 $) 343 344 AND SIZE(E) 345 BE $( STATIC $( COUNT=0 $) 346 LET COUNTCH(CH) 347 BE COUNT:=COUNT+1 348 349 COUNT:=0 350 WRCH:=COUNTCH 351 PRINTVAL(!ARG,FALSE) 352 WRCH:=TRUEWRCH 353 HD!E,TL!E := INDIR,STONUM(COUNT) 354 $) 355 356 AND CODE(E) 357 BE $( !ARG := REDUCE(!ARG) 358 UNLESS ISCONS(!ARG) & HD!(!ARG)=QUOTE 359 DO BADEXP(E) 360 $( LET S = PRINTNAME(TL!(!ARG)) 361 UNLESS GETBYTE(S,0)=1 DO BADEXP(E) 362 HD!E , TL!E := INDIR , STONUM(GETBYTE(S,1)) 363 $) $) 364 365 AND DECODE(E) 366 BE $( !ARG := REDUCE(!ARG) 367 UNLESS ISNUM(!ARG) & 0<=TL!(!ARG)<=255 368 DO BADEXP(E) 369 BUFCH(TL!(!ARG)) 370 HD!E , TL!E := INDIR , CONS(QUOTE,PACKBUFFER()) 371 $) 372 373 AND CONCAT(E) 374 BE $( !ARG := REDUCE(!ARG) 375 $( LET A = !ARG 376 WHILE ISCONS(A) & HD!A=COLON.OP 377 DO $( LET C = REDUCE(HD!(TL!A)) 378 UNLESS ISCONS(C) & HD!C=QUOTE 379 DO BADEXP(E) 380 HD!(TL!A):= C 381 TL!(TL!A) := REDUCE(TL!(TL!A)) 382 A:= TL!(TL!A) 383 $) 384 UNLESS A=NIL 385 DO BADEXP(E) 386 A:= !ARG 387 UNTIL A=NIL 388 DO $( LET S = PRINTNAME(TL!(HD!(TL!A))) 389 FOR I = 1 TO GETBYTE(S,0) 390 DO BUFCH(GETBYTE(S,I)) 391 A:= TL!(TL!A) $) 392 A := PACKBUFFER() 393 HD!E , TL!E := INDIR , 394 A=TL!TRUTH -> TRUTH, 395 A=TL!FALSITY -> FALSITY, 396 CONS(QUOTE,A) 397 $) $) 398 399 AND EXPLODE(E) 400 BE $( !ARG := REDUCE(!ARG) 401 UNLESS ISCONS(!ARG) & HD!(!ARG)=QUOTE 402 DO BADEXP(E) 403 $( LET S = PRINTNAME(TL!(!ARG)) 404 LET X = NIL 405 FOR I = GETBYTE(S,0) TO 1 BY -1 406 DO $( BUFCH(GETBYTE(S,I)) 407 X := CONS(COLON.OP,CONS(CONS(QUOTE,PACKBUFFER()),X)) $) 408 HD!E , TL!E := INDIR , X 409 $) $) 410 411 AND STARTREAD(E) 412 BE $( !ARG:= REDUCE(!ARG) 413 UNLESS ISCONS(!ARG) & HD!(!ARG)=QUOTE 414 DO BADEXP(E) 415 $( LET IN = FINDINPUT(PRINTNAME(TL!(!ARG))) 416 UNLESS IN>0 417 DO BADEXP(CONS(BADFILE,!ARG)) 418 HD!E,TL!E := READFN,IN 419 $) $) 420 421 AND READ(E) 422 BE $( SELECTINPUT(TL!E) 423 HD!E,TL!E := INDIR,CONS(READFN,TL!E) 424 $( LET X,C = @(TL!E),RDCH() 425 UNTIL C=ENDSTREAMCH 426 DO $( LET ENDLINE = (C='*N') 427 BUFCH(C) 428 C:=CONS(QUOTE,PACKBUFFER()) 429 !X:= CONS(COLON.OP,CONS(C,!X)) 430 X:=@(TL!(TL!(!X))) 431 IF ENDLINE BREAK 432 C:=RDCH() $) 433 IF C=ENDSTREAMCH 434 DO $( ENDREAD() ; !X:=NIL $) 435 SELECTINPUT(SYSIN) 436 $) $) 437 438 AND WRITEAP(E) ||CALLED IF WRITE IS APPLIED TO >2 ARGS 439 BE BADEXP(E) 440 441 ||POSSIBILITIES FOR LEFTMOST FIELD OF A GRAPH ARE: 442 || HEAD::= NAME | NUM | NIL | OPERATOR 443 444 AND REDUCE(E) = VALOF 445 $( STATIC $( M=0; N=0 $) 446 LET HOLD.S,NARGS,HOLDARG=S,0,ARG 447 IF @E>STACKLIMIT DO SPACE.ERROR() 448 S:=ENDOFSTACK 449 ARG:=ARGP+1 450 $( ||MAIN LOOP 451 WHILE ISCONS(E) ||FIND HEAD, REVERSING POINTERS EN ROUTE 452 DO $( LET HOLD=HD!E 453 NARGS:=NARGS+1 454 HD!E,S,E:=S,E,HOLD $) 455 IF ISNUM(E) | E=NIL 456 DO $( UNLESS NARGS=0 DO HOLDARG:= -1 ||FLAGS AN ERROR 457 BREAK $) 458 TEST ISATOM(E) ||USER DEFINED NAME 459 THEN TEST VAL!E=NIL | TL!(VAL!E)=NIL THEN BADEXP(E) OR ||UNDEFINED NAME 460 TEST HD!(HD!(VAL!E))=0 ||VARIABLE 461 THEN $( LET EQN=HD!(TL!(VAL!E)) 462 IF HD!EQN=0 ||MEMO NOT SET 463 DO $( HD!EQN:=BUILDEXP(TL!EQN) 464 MEMORIES:=CONS(E,MEMORIES) $) 465 E:=HD!EQN $) ||?CAN WE GET CYCLIC EXPRESSIONS? 466 OR $( ||FUNCTION 467 LET N=HD!(HD!(VAL!E)) 468 IF N>NARGS BREAK ||NOT ENOUGH ARGS 469 $( LET EQNS=TL!(VAL!E) 470 FOR I=0 TO N-1 471 DO $( LET HOLD=HD!S ||MOVE BACK UP GRAPH, 472 ARGP:=ARGP+1 ||STACKING ARGS EN ROUTE 473 !ARGP:=TL!S 474 HD!S,E,S:=E,S,HOLD $) 475 NARGS:=NARGS-N 476 ||E NOW HOLDS A PIECE OF GRAPH TO BE TRANSFORMED 477 || !ARG ... !ARGP HOLD THE PARAMETERS 478 OBEY(EQNS,E) 479 ARGP:=ARG-1 ||RESET ARG STACK 480 $) $) 481 OR $( ||OPERATORS 482 SWITCHON E INTO 483 $( CASE QUOTE: UNLESS NARGS=1 DO HOLDARG:=-1 484 BREAK 485 CASE INDIR: $( LET HOLD=HD!S 486 NARGS:=NARGS-1 487 E,HD!S,S:=TL!S,INDIR,HOLD 488 LOOP $) 489 CASE QUOTE.OP: UNLESS NARGS>=3 BREAK 490 $( LET OP=TL!S 491 LET HOLD=HD!S 492 NARGS:= NARGS-2 493 HD!S,E,S := E,S,HOLD 494 HOLD:= HD!S 495 HD!S,E,S:=E,S,HOLD 496 TL!S,E := CONS(TL!E,TL!S),OP 497 LOOP $) 498 CASE LISTDIFF.OP: E:=CONS(LISTDIFF,HD!(TL!S)) 499 TL!S:=TL!(TL!S) 500 LOOP 501 CASE COLON.OP: UNLESS NARGS>=2 BREAK 502 ||LIST INDEXING 503 NARGS:=NARGS-2 504 $( LET HOLD=HD!S 505 HD!S,E,S:=COLON.OP,S,HOLD $) 506 M:=REDUCE(TL!S) 507 TL!S:=M 508 UNLESS ISNUM(M) & 509 VALOF $( M:=GETNUM(M) 510 RESULTIS M>=1 $) 511 DO $( HOLDARG:=-1 ; BREAK $) 512 FOR I=1 TO M-1 513 DO $( E:=REDUCE(TL!(TL!E)) 514 UNLESS ISCONS(E)&HD!E=COLON.OP 515 DO BADEXP(CONS(E,STONUM(M-I))) $) 516 E:=HD!(TL!E) 517 $( LET HOLD=HD!S 518 HD!S,TL!S,S:=INDIR,E,HOLD $) 519 REDS:=REDS+M 520 XSUBREDS := XSUBREDS + M - 1 521 || THE PURPOSE OF XSUBREDS IS TO BE ABLE TO ALSO KEEP TRACK 522 || OF REDUCTIONS AS THEY WERE COUNTED FORMERLY, COUNTING ONLY 523 || 1 FOR AN ARBITRARY LIST INDEXING OPERATION - 10/3/83 524 LOOP 525 CASE ZF.OP: $( LET HOLD=HD!S 526 NARGS:=NARGS-1 527 HD!S,E,S:=E,S,HOLD 528 IF TL!(TL!E)=NIL 529 DO $( HD!E,TL!E:=COLON.OP,CONS(HD!(TL!E),NIL) 530 LOOP $) 531 $( LET QUALIFIER=HD!(TL!E) 532 LET REST=TL!(TL!E) 533 TEST ISCONS(QUALIFIER)&HD!QUALIFIER=GENERATOR 534 THEN 535 $( LET SOURCE=REDUCE(TL!(TL!QUALIFIER)) 536 LET FORMAL=HD!(TL!QUALIFIER) 537 TL!(TL!QUALIFIER):=SOURCE 538 TEST SOURCE=NIL 539 THEN HD!E,TL!E,E:=INDIR,NIL,NIL OR 540 TEST ISCONS(SOURCE)&HD!SOURCE=COLON.OP 541 THEN HD!E,TL!E:= CONS(INTERLEAVEFN, 542 CONS(ZF.OP,SUBSTITUTE(HD!(TL!SOURCE),FORMAL,REST))), 543 CONS(ZF.OP,CONS(CONS(GENERATOR,CONS(FORMAL,TL!(TL!SOURCE))),REST)) 544 || THEN HD!E,TL!E:=APPEND.OP, 545 || CONS( 546 || CONS(ZF.OP,SUBSTITUTE(HD!(TL!SOURCE),FORMAL,REST)), 547 || CONS(ZF.OP,CONS(CONS(GENERATOR,CONS(FORMAL,TL!(TL!SOURCE))),REST)) 548 || ) 549 OR BADEXP(E) $) 550 OR $( ||QUALIFIER IS GUARD 551 QUALIFIER:=REDUCE(QUALIFIER) 552 HD!(TL!E):=QUALIFIER 553 TEST QUALIFIER=TRUTH 554 THEN TL!E:=REST OR 555 TEST QUALIFIER=FALSITY 556 THEN HD!E,TL!E,E:=INDIR,NIL,NIL 557 OR BADEXP(CONS(GUARD,QUALIFIER)) $) 558 REDS:=REDS+1 559 LOOP $) $) 560 CASE DOT.OP: UNLESS NARGS>=2 561 DO $( LET A,B=REDUCE(HD!(TL!S)),REDUCE(TL!(TL!S)) 562 UNLESS ISFUN(A) & ISFUN(B) 563 DO BADEXP(CONS(E,CONS(A,B))) 564 BREAK $) 565 $( LET HOLD=HD!S 566 NARGS:=NARGS-1 567 E,TL!HOLD:=HD!(TL!S),CONS(TL!(TL!S),TL!HOLD) 568 HD!S,S:=DOT.OP,HOLD 569 REDS:=REDS+1 570 LOOP $) 571 CASE EQ.OP: 572 CASE NE.OP: E:=EQUALVAL(HD!(TL!S),TL!(TL!S))=(E=EQ.OP)-> 573 TRUTH,FALSITY 574 ||NOTE - COULD REWRITE FOR FAST EXIT, HERE AND IN 575 ||OTHER CASES WHERE RESULT OF REDUCTION IS ATOMIC 576 $( LET HOLD=HD!S 577 NARGS:=NARGS-1 578 HD!S,TL!S,S:=INDIR,E,HOLD 579 REDS:=REDS+1 580 LOOP $) 581 CASE ENDOFSTACK: BADEXP(SILLYNESS) ||OCCURS IF WE TRY TO 582 ||EVALUATE AN EXP WE ARE ALREADY INSIDE 583 DEFAULT: ENDCASE $) ||END OF SWITCH 584 $( ||STRICT OPERATORS 585 LET A,B,STRINGS=0,0,FALSE 586 TEST E>=LENGTH.OP 587 THEN A:=REDUCE(TL!S) ||MONADIC 588 OR $( A:=REDUCE(HD!(TL!S)) ||DIADIC 589 TEST E>=GR.OP ||STRICT IN 2ND ARG ? 590 THEN $( B:=REDUCE(E=COMMADOTDOT.OP->HD!(TL!(TL!S)),TL!(TL!S)) ||YES 591 TEST ISNUM(A) & ISNUM(B) 592 THEN M,N:=GETNUM(A),GETNUM(B) OR 593 TEST E<=LS.OP & ||RELOPS 594 ISCONS(A) & ISCONS(B) & HD!A=QUOTE=HD!B 595 THEN STRINGS,M,N:=TRUE,TL!A,TL!B OR 596 TEST E=DOTDOT.OP & ISNUM(A) & B=INFINITY 597 THEN M,N := GETNUM(A),M 598 OR BADEXP(CONS(E,CONS(A,E=COMMADOTDOT.OP->CONS(B,TL!(TL!(TL!S))),B))) $) 599 OR B:=TL!(TL!S) ||NO 600 $) 601 E:=VALOF 602 SWITCHON E INTO 603 $( CASE AND.OP: RESULTIS A=FALSITY->A, 604 A=TRUTH->B, 605 BADEXP(CONS(E,CONS(A,B))) 606 CASE OR.OP: RESULTIS A=TRUTH->A, 607 A=FALSITY->B, 608 BADEXP(CONS(E,CONS(A,B))) 609 CASE APPEND.OP: IF A=NIL RESULTIS B 610 UNLESS ISCONS(A) & HD!A=COLON.OP 611 DO BADEXP(CONS(E,CONS(A,B))) 612 E:=COLON.OP 613 TL!(TL!S):=CONS(APPEND.OP, 614 CONS(TL!(TL!A),B)) 615 HD!(TL!S):=HD!(TL!A) 616 REDS:=REDS+1 617 LOOP 618 CASE DOTDOT.OP: IF M>N RESULTIS NIL 619 E:=COLON.OP 620 TL!(TL!S):=CONS(DOTDOT.OP, 621 CONS(STONUM(M+1),B)) 622 REDS:=REDS+1 623 LOOP 624 CASE COMMADOTDOT.OP: $( LET C=REDUCE(TL!(TL!(TL!S))) 625 STATIC $( P=0 $) 626 TEST ISNUM(C) 627 THEN P:=GETNUM(C) OR 628 TEST C=INFINITY THEN P:=N 629 OR BADEXP(CONS(E,CONS(A,CONS(B,C)))) 630 IF (N-M)*(P-M)<0 RESULTIS NIL 631 E:=COLON.OP 632 HD!(TL!(TL!S)):=STONUM(N+N-M) 633 TL!(TL!S):=CONS(COMMADOTDOT.OP,CONS(B,TL!(TL!S))) 634 REDS:=REDS+1 635 LOOP $) 636 CASE NOT.OP: RESULTIS A=TRUTH->FALSITY, 637 A=FALSITY->TRUTH, 638 BADEXP(CONS(E,A)) 639 CASE NEG.OP: UNLESS ISNUM(A) DO BADEXP(CONS(E,A)) 640 RESULTIS STONUM(-GETNUM(A)) 641 CASE LENGTH.OP: $( LET L=0 642 WHILE ISCONS(A) & HD!A=COLON.OP 643 DO A,L:=REDUCE(TL!(TL!A)),L+1 644 IF A=NIL RESULTIS STONUM(L) 645 BADEXP(CONS(COLON.OP,CONS(ETC,A))) 646 $) 647 CASE PLUS.OP: RESULTIS STONUM(M+N) 648 CASE MINUS.OP: RESULTIS STONUM(M-N) 649 CASE TIMES.OP: RESULTIS STONUM(M*N) 650 CASE DIV.OP: IF N=0 DO BADEXP(CONS(DIV.OP,CONS(A,B))) 651 RESULTIS STONUM(M/N) 652 CASE REM.OP: IF N=0 DO BADEXP(CONS(REM.OP,CONS(A,B))) 653 RESULTIS STONUM(M REM N) 654 CASE EXP.OP: IF N<0 DO BADEXP(CONS(EXP.OP,CONS(A,B))) 655 $( LET P=1 656 UNTIL N=0 DO P,N := P*M,N-1 657 RESULTIS STONUM(P) $) 658 CASE GR.OP: RESULTIS (STRINGS->ALFA.LS(N,M),M>N)-> 659 TRUTH, FALSITY 660 CASE GE.OP: RESULTIS (STRINGS->ALFA.LS(N,M)|N=M,M>=N)-> 661 TRUTH, FALSITY 662 CASE LE.OP: RESULTIS (STRINGS->ALFA.LS(M,N)|M=N,M<=N)-> 663 TRUTH, FALSITY 664 CASE LS.OP: RESULTIS (STRINGS->ALFA.LS(M,N),M<N)-> 665 TRUTH, FALSITY 666 DEFAULT: WRITES("IMPOSSIBLE OPERATOR IN *"REDUCE*"*N") 667 $) ||END OF SWITCH 668 $( LET HOLD=HD!S 669 NARGS:=NARGS-1 670 HD!S,TL!S,S:=INDIR,E,HOLD $) 671 $) $) ||END OF OPERATORS 672 REDS:=REDS+1 673 $) REPEAT ||END OF MAIN LOOP 674 UNTIL S=ENDOFSTACK ||UNREVERSE REVERSED POINTERS 675 DO $( LET HOLD=HD!S 676 HD!S,E,S:=E,S,HOLD $) 677 IF HOLDARG= -1 DO BADEXP(E) 678 ARG:=HOLDARG ||RESET ARG STACKFRAME 679 S:=HOLD.S 680 RESULTIS E 681 $) 682 683 AND SUBSTITUTE(ACTUAL,FORMAL,EXP) = 684 EXP=FORMAL -> ACTUAL, 685 \ISCONS(EXP) | HD!EXP=QUOTE | BINDS(FORMAL,HD!EXP) -> EXP, 686 VALOF $( LET H=SUBSTITUTE(ACTUAL,FORMAL,HD!EXP) 687 LET T=SUBSTITUTE(ACTUAL,FORMAL,TL!EXP) 688 RESULTIS H=HD!EXP & T=TL!EXP -> EXP, CONS(H,T) $) 689 690 AND BINDS(FORMAL,X) = 691 ISCONS(X) & HD!X=GENERATOR & HD!(TL!X)=FORMAL ->TRUE, FALSE