||KRC REDUCER

GET "LIBHDR"
GET "KRC_LISTHDR"
GET "KRC_COMPHDR"
GET "KRC_REDHDR"

||----------------------------------------------------------------------
||The KRC system is Copyright (c) D. A. Turner 1981
||All  rights reserved.  It is distributed as free software under the
||terms in the file "COPYING", which is included in the distribution.
||----------------------------------------------------------------------

STATIC $( ETC=?; SILLYNESS=?; GUARD=?; TRUECONTINGENCY=?
          LISTDIFF=?
          BADFILE=?; READFN=?; WRITEFN=?; INTERLEAVEFN=?
          NL=?; NP=?; TAB=?; VT=?
       $)

MANIFEST $( ENDOFSTACK=-2  $)

MANIFEST $( ||INTERRUPT STATUSES
            NORMAL=1; DELAY=2; PENDING=3
         $)

STATIC $( INTERRUPT.STATUS=DELAY; INITIALISING=TRUE  $)

LET SETUP.PRIMFNS.ETC()
BE $( LET R(S,F,N)  ||ASSUMES IT IS OK TO STORE BCPL FN IN LIST FIELD
      BE $( LET A=MKATOM(S)
            LET EQN=CONS(A,CONS(CALL.C,F))
            UNLESS F=READ DO ENTERSCRIPT(A)
            VAL!A:=CONS(CONS(N,NIL),CONS(EQN,NIL))  $)
      S:=ENDOFSTACK  ||S IS USED INSIDE REDUCE - IT HAS TO BE GLOBAL
                     ||SO IT CAN BE ACCESSED AFTER AN INTERRUPT (SEE
                     || CATCHINTERRUPT)
      ETC:=MKATOM("... ")  ||MISCELLANEOUS INITIALISATIONS
      SILLYNESS:=MKATOM("<silly recursion>")
      GUARD:=MKATOM("<non truth-value used as guard:>")
      TRUTH:=CONS(QUOTE,MKATOM("TRUE"))
      FALSITY:=CONS(QUOTE,MKATOM("FALSE"))
      LISTDIFF:=MKATOM("listdiff")
      INFINITY:=CONS(QUOTE,-3)
      TRUECONTINGENCY:=CONTINGENCY
      CONTINGENCY:=CATCHINTERRUPT
      R("function",FUNCTIONP,1)  ||PRIMITIVE FUNCTIONS
      R("list",LISTP,1)
      R("string",STRINGP,1)
      R("number",NUMBERP,1)
      R("char",CHAR,1)
      R("printwidth",SIZE,1)
      R("code",CODE,1)
      R("decode",DECODE,1)
      R("concat",CONCAT,1)
      R("explode",EXPLODE,1)
      R("read",STARTREAD,1)
      R("read ",READ,1)
      R("write",WRITEAP,3)
      BADFILE:=MKATOM("<cannot open file:>")
      READFN:=MKATOM("read ")
      WRITEFN:=MKATOM("write")
      INTERLEAVEFN:=MKATOM("interleave")
      NL:=MKATOM("*N")
      NP:=MKATOM("*P")
      TAB:=MKATOM("*T")
      VT:=MKATOM("*V")
   $)

AND SCASECONV(S) = VALOF
$( LET T = TABLE 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
   LET N = GETBYTE(S,0)
   PUTBYTE(T,0,N)
   FOR I = 1 TO (N/BYTESPERWORD + 1)*BYTESPERWORD -1
   DO PUTBYTE(T,I,CASECONV(GETBYTE(S,I)))
   RESULTIS T  $)

AND HOLD.INTERRUPTS()
BE INTERRUPT.STATUS:=DELAY

AND RELEASE.INTERRUPTS()
BE $( IF INTERRUPT.STATUS=PENDING
      DO $( INTERRUPT.STATUS:=NORMAL ; CONTINGENCY(65,'A')  $)
      INITIALISING:=FALSE
      INTERRUPT.STATUS:=NORMAL
   $)

||THIS ROUTINE AND THE NEXT TWO ARE OBVIOUSLY SYSTEM DEPENDENT
AND CATCHINTERRUPT(CLASS,SUBCLASS,DUMPSEG)
BE TEST CLASS=65 & (SUBCLASS='A' | SUBCLASS='a')
   THEN $( LET DUMMY=?
           IF INITIALISING FINISH
           IF INTERRUPT.STATUS=DELAY | INTERRUPT.STATUS=PENDING
           DO $( INTERRUPT.STATUS:=PENDING ; RETURN  $)
           UNLESS S=ENDOFSTACK
           DO HD!S:=QUOTE  ||IN CASE INTERRUPT STRUCK WHILE REDUCE
                           ||WAS DISSECTING A CONSTANT
           CONSOLE(7,@DUMMY,@DUMMY) ||KILL OUTPUT
           WRCH:=TRUEWRCH
           CLOSECHANNELS()
           WRITES("*N****break in - return to KRC command level*****N")
           DISCARD.ID() ||REALLOW INTERRUPTS
           ESCAPETONEXTCOMMAND()  $)
   OR TRUECONTINGENCY(CLASS,SUBCLASS,DUMPSEG)

AND CONSOLE(EP,P1,P2)
BE $( EXTERNAL $( S.CONSOLE  $)
      S.CONSOLE(EP,#X28000001,P1<<2,#X28000001,P2<<2)
   $)

AND FLUSH()
BE $( EXTERNAL $( TERMINATE $)
      TERMINATE()
   $)

AND OUTSTATS()
BE $( GCSTATS()
      WRITEF(", reductions = %N(%N)*N",REDS,REDS-XSUBREDS)
   $)

|| THE POSSIBLE VALUES OF A REDUCED EXPRESSION ARE:
||  VAL::= CONST | FUNCTION | LIST
||  CONST::= NUM | CONS(QUOTE,ATOM)
||  LIST::= NIL | CONS(COLON.OP,CONS(EXP,EXP))
||  FUNCTION::= NAME | CONS(E1,E2)

AND PRINTVAL(E,FORMAT)
BE $( E:=REDUCE(E)
      TEST E=NIL
      THEN IF FORMAT DO WRITES("[]") OR
      TEST ISNUM(E)
      THEN WRITEN(GETNUM(E)) OR
      TEST ISCONS(E)
      THEN $( LET H=HD!E
              TEST H=QUOTE
              THEN PRINTATOM(TL!E,FORMAT) OR
              TEST H=COLON.OP
              THEN $( IF FORMAT DO WRCH('[')
                      E:=TL!E
                      $( PRINTVAL(HD!E,FORMAT)
                         E:=TL!E
                         E:=REDUCE(E)
                         UNLESS ISCONS(E) BREAK
                         TEST HD!E=COLON.OP
                         THEN IF FORMAT DO WRCH(',')
                         OR BREAK
                         E:=TL!E
                      $) REPEAT
                      TEST E=NIL
                      THEN IF FORMAT DO WRCH(']')
                      OR BADEXP(CONS(COLON.OP,CONS(ETC,E)))
                   $)  OR
              TEST ISCONS(H) & HD!H=WRITEFN
              THEN $( TL!H:=REDUCE(TL!H)
                      UNLESS ISCONS(TL!H) & HD!(TL!H)=QUOTE
                      DO BADEXP(E)
                   $( LET F=PRINTNAME(TL!(TL!H))
                      LET OUT=FINDCHANNEL(F)
                      LET HOLD=OUTPUT()
                      UNLESS OUT>0 DO BADEXP(CONS(BADFILE,TL!H))
                      SELECTOUTPUT(OUT)
                      PRINTVAL(TL!E,FORMAT)
                      SELECTOUTPUT(HOLD)
                   $) $)
              OR PRINTFUNCTION(E) ||A PARTIAL APPLICATION OR COMPOSITION
           $)
      OR PRINTFUNCTION(E)  ||ONLY POSSIBILITY HERE SHOULD BE
                        ||NAME OF FUNCTION
   $)

AND PRINTATOM(A,FORMAT)
BE TEST FORMAT
   THEN TEST A=NL THEN WRITES("<nl>") OR
        TEST A=NP THEN WRITES("<np>") OR
        TEST A=TAB THEN WRITES("<tab>") OR
        TEST A=VT THEN WRITES("<vt>")
        OR WRITEF("*"%S*"",PRINTNAME(A))
   OR TEST A=VT THEN FLUSH()
      OR WRITES(PRINTNAME(A))

AND PRINTFUNCTION(E)
BE $( WRCH('<')
      PRINTEXP(E,0)
      WRCH('>') $)

AND EQUALVAL(A,B) = VALOF ||UNPREDICTABLE RESULTS IF A,B BOTH FUNCTIONS
$( A:=REDUCE(A)
   B:=REDUCE(B)
   IF A=B RESULTIS TRUE
   IF ISNUM(A) & ISNUM(B)
   RESULTIS GETNUM(A)=GETNUM(B)
   UNLESS ISCONS(A) & ISCONS(B) RESULTIS FALSE
   IF HD!A=QUOTE=HD!B RESULTIS TL!A=TL!B
   UNLESS HD!A=COLON.OP=HD!B RESULTIS FALSE  ||UH ?
   A,B:=TL!A,TL!B
   UNLESS EQUALVAL(HD!A,HD!B) RESULTIS FALSE
   A,B:=TL!A,TL!B
$) REPEAT

AND BADEXP(E) ||CALLED FOR ALL EVALUATION ERRORS
BE $( WRCH:=TRUEWRCH
      CLOSECHANNELS()
      WRCH:=TRUEWRCH
      WRITES("*N****undefined expression*****N  ")
      PRINTEXP(E,0)
      ||COULD INSERT MORE DETAILED DIAGNOSTICS HERE, 
      ||DEPENDING ON NATURE OF HD!E, FOR EXAMPLE:
      IF ISCONS(E) &(HD!E=COLON.OP|HD!E=APPEND.OP)
      DO WRITES("*N  (non-list encountered where list expected)")
      WRITES("*N****evaluation abandoned*****N")
      ESCAPETONEXTCOMMAND()
   $)

AND BUILDEXP(CODE) = VALOF  ||A KLUDGE
$( LET E = CONS(NIL,NIL)  ||A BOGUS PIECE OF GRAPH
   OBEY(CONS(CONS(NIL,CODE),NIL),E)
   ARGP:=ARG-1  ||RESET ARG STACK
   RESULTIS E
$)

AND OBEY(EQNS,E) ||TRANSFORM A PIECE OF GRAPH, E, IN ACCORDANCE
                 ||WITH EQNS - ACTUAL PARAMS ARE FOUND IN
                 || !ARG ... !ARGP
                 || (WARNING - HAS SIDE EFFECT OF RAISING ARGP)
BE
$( IF ARGP+20>ARGMAX DO SPACE.ERROR()
   UNTIL EQNS=NIL  ||EQNS LOOP
   DO $( LET CODE=TL!(HD!EQNS)
         LET HOLDARG=ARGP
         $( LET H = HD!CODE  ||DECODE LOOP
            CODE:=TL!CODE
            SWITCHON H INTO
         $( CASE LOAD.C: ARGP:=ARGP+1
                         !ARGP:=HD!CODE
                         CODE:=TL!CODE
                         ENDCASE
            CASE LOADARG.C: ARGP:=ARGP+1
                            !ARGP:=ARG!(HD!CODE)
                            CODE:=TL!CODE
                            ENDCASE
            CASE APPLYINFIX.C: !ARGP:=CONS(!(ARGP-1),!ARGP)
                               !(ARGP-1):=HD!CODE
                               CODE:=TL!CODE
            CASE APPLY.C:      ARGP:=ARGP-1
                               IF HD!CODE=STOP.C
                               DO $( HD!E,TL!E:=!ARGP,!(ARGP+1)
                                     RETURN  $)
                               !ARGP:=CONS(!ARGP,!(ARGP+1))
                               ENDCASE
            CASE CONTINUE.INFIX.C: 
                       !(ARGP-1):=CONS(HD!CODE,CONS(!(ARGP-1),!ARGP))
                       CODE:=TL!CODE
                       ENDCASE
            CASE IF.C: !ARGP:=REDUCE(!ARGP)
                       IF !ARGP=FALSITY BREAK
                       UNLESS !ARGP=TRUTH DO BADEXP(CONS(GUARD,!ARGP))
                       ENDCASE
            CASE FORMLIST.C: ARGP:=ARGP+1
                             !ARGP:=NIL
                             FOR I=1 TO HD!CODE
                             DO $( ARGP:=ARGP-1
                                   !ARGP:=CONS(COLON.OP,
                                           CONS(!ARGP,!(ARGP+1)))
                                $)
                             CODE:=TL!CODE
                             ENDCASE
            CASE FORMZF.C: $( LET X=CONS(!(ARGP-HD!CODE),NIL)
                              FOR P = ARGP TO ARGP-HD!CODE+1 BY -1
                              DO X:= CONS(!P,X)
                              ARGP:= ARGP-HD!CODE
                              !ARGP:= CONS(ZF.OP,X)
                              CODE:= TL!CODE
                              ENDCASE  $)
            CASE CONT.GENERATOR.C:
                  FOR I = 1 TO HD!CODE
                  DO !(ARGP-I):= CONS(GENERATOR,CONS(!(ARGP-I),
                                       TL!(TL!(!ARGP))))
                  CODE:= TL!CODE
                  ENDCASE
            CASE MATCH.C: $( LET I=HD!CODE
                             CODE:=TL!CODE
                             UNLESS EQUALVAL(ARG!I,HD!CODE) BREAK
                             CODE:=TL!CODE
                             ENDCASE  $)
            CASE MATCHARG.C: $( LET I=HD!CODE
                                CODE:=TL!CODE
                                UNLESS EQUALVAL(ARG!I,ARG!(HD!CODE))
                                DO BREAK
                                CODE:=TL!CODE
                                ENDCASE  $)
            CASE MATCHPAIR.C: $( LET P=ARG+HD!CODE
                                 !P:=REDUCE(!P)
                                 UNLESS ISCONS(!P)&HD!(!P)=COLON.OP
                                 BREAK
                                 ARGP:=ARGP+2
                                 P:=TL!(!P)
                                 !(ARGP-1),!ARGP:=HD!P,TL!P
                                 CODE:=TL!CODE
                                 ENDCASE  $)
            CASE LINENO.C: CODE:=TL!CODE  ||NO ACTION
                           ENDCASE
            CASE STOP.C: HD!E,TL!E:=INDIR,!ARGP
                         RETURN
            CASE CALL.C: (CODE)(E)
                         RETURN
            DEFAULT: WRITES("IMPOSSIBLE INSTRUCTION IN*"OBEY*"*N")
         $) $) REPEAT  ||END OF DECODE LOOP
         EQNS:=TL!EQNS
         ARGP:=HOLDARG
      $) ||END OF EQNS LOOP
   BADEXP(E)
$)

AND STRINGP(E)
BE $( !ARG:=REDUCE(!ARG)
      HD!E,TL!E:=INDIR,ISCONS(!ARG)&HD!(!ARG)=QUOTE->TRUTH,FALSITY
   $)

AND NUMBERP(E)
BE $( !ARG:=REDUCE(!ARG)
      HD!E,TL!E:=INDIR,ISNUM(!ARG)->TRUTH,FALSITY
   $)

AND LISTP(E)
BE $( !ARG:=REDUCE(!ARG)
      HD!E,TL!E:=INDIR,(!ARG=NIL|ISCONS(!ARG)&HD!(!ARG)=COLON.OP)->
                       TRUTH,FALSITY
   $)

AND FUNCTIONP(E)
BE $( !ARG:=REDUCE(!ARG) 
      HD!E:=INDIR
      TL!E:=ISFUN(!ARG)->TRUTH,FALSITY
   $)

AND ISFUN(X) = ISATOM(X) | ISCONS(X) & QUOTE\=HD!X\=COLON.OP

AND CHAR(E)
BE $( !ARG:=REDUCE(!ARG)
      HD!E,TL!E:=INDIR,
                 ISCONS(!ARG) & HD!(!ARG)=QUOTE & 
                 GETBYTE(PRINTNAME(TL!(!ARG)),0)=1 -> TRUTH, FALSITY
   $)

AND SIZE(E)
BE $( STATIC $( COUNT=0  $)
      LET COUNTCH(CH)
      BE COUNT:=COUNT+1

      COUNT:=0
      WRCH:=COUNTCH
      PRINTVAL(!ARG,FALSE)
      WRCH:=TRUEWRCH
      HD!E,TL!E := INDIR,STONUM(COUNT)
   $)

AND CODE(E)
BE $( !ARG := REDUCE(!ARG)
      UNLESS ISCONS(!ARG) & HD!(!ARG)=QUOTE
      DO BADEXP(E)
   $( LET S = PRINTNAME(TL!(!ARG))
      UNLESS GETBYTE(S,0)=1 DO BADEXP(E)
      HD!E , TL!E := INDIR , STONUM(GETBYTE(S,1))
   $) $)

AND DECODE(E)
BE $( !ARG := REDUCE(!ARG)
      UNLESS ISNUM(!ARG) & 0<=TL!(!ARG)<=255
      DO BADEXP(E)
      BUFCH(TL!(!ARG))
      HD!E , TL!E := INDIR , CONS(QUOTE,PACKBUFFER())
   $)

AND CONCAT(E)
BE $( !ARG := REDUCE(!ARG)
   $( LET A = !ARG
      WHILE ISCONS(A) & HD!A=COLON.OP
      DO $( LET C = REDUCE(HD!(TL!A))
            UNLESS ISCONS(C) & HD!C=QUOTE
            DO BADEXP(E)
            HD!(TL!A):= C
            TL!(TL!A) := REDUCE(TL!(TL!A))
            A:= TL!(TL!A)
         $)
      UNLESS A=NIL
      DO BADEXP(E)
      A:= !ARG
      UNTIL A=NIL
      DO $( LET S = PRINTNAME(TL!(HD!(TL!A)))
            FOR I = 1 TO GETBYTE(S,0)
            DO BUFCH(GETBYTE(S,I))
            A:= TL!(TL!A)  $)
      A := PACKBUFFER()
      HD!E , TL!E := INDIR ,
             A=TL!TRUTH -> TRUTH,
             A=TL!FALSITY -> FALSITY,
             CONS(QUOTE,A)
   $) $)

AND EXPLODE(E)
BE $( !ARG := REDUCE(!ARG)
      UNLESS ISCONS(!ARG) & HD!(!ARG)=QUOTE
      DO BADEXP(E)
   $( LET S = PRINTNAME(TL!(!ARG))
      LET X = NIL
      FOR I = GETBYTE(S,0) TO 1 BY -1
      DO $( BUFCH(GETBYTE(S,I))
            X := CONS(COLON.OP,CONS(CONS(QUOTE,PACKBUFFER()),X)) $)
      HD!E , TL!E := INDIR , X
   $) $)

AND STARTREAD(E)
BE $( !ARG:= REDUCE(!ARG)
      UNLESS ISCONS(!ARG) & HD!(!ARG)=QUOTE
      DO BADEXP(E)
   $( LET IN = FINDINPUT(PRINTNAME(TL!(!ARG)))
      UNLESS IN>0
      DO BADEXP(CONS(BADFILE,!ARG))
      HD!E,TL!E := READFN,IN
   $) $)

AND READ(E)
BE $( SELECTINPUT(TL!E)
      HD!E,TL!E := INDIR,CONS(READFN,TL!E)
   $( LET X,C = @(TL!E),RDCH()
      UNTIL C=ENDSTREAMCH
      DO $( LET ENDLINE = (C='*N')
            BUFCH(C)
            C:=CONS(QUOTE,PACKBUFFER())
            !X:= CONS(COLON.OP,CONS(C,!X))
            X:=@(TL!(TL!(!X)))
            IF ENDLINE BREAK
            C:=RDCH()  $)
      IF C=ENDSTREAMCH
      DO $( ENDREAD() ; !X:=NIL  $)
      SELECTINPUT(SYSIN)
   $) $)

AND WRITEAP(E) ||CALLED IF WRITE IS APPLIED TO >2 ARGS
BE BADEXP(E)

||POSSIBILITIES FOR LEFTMOST FIELD OF A GRAPH ARE:
|| HEAD::= NAME | NUM | NIL | OPERATOR

AND REDUCE(E) = VALOF
$( STATIC $( M=0; N=0  $)
   LET HOLD.S,NARGS,HOLDARG=S,0,ARG
   IF @E>STACKLIMIT DO SPACE.ERROR()
   S:=ENDOFSTACK
   ARG:=ARGP+1
   $( ||MAIN LOOP
      WHILE ISCONS(E)  ||FIND HEAD, REVERSING POINTERS EN ROUTE
      DO $( LET HOLD=HD!E
            NARGS:=NARGS+1
            HD!E,S,E:=S,E,HOLD  $)
      IF ISNUM(E) | E=NIL
      DO $( UNLESS NARGS=0 DO HOLDARG:= -1  ||FLAGS AN ERROR
            BREAK  $)
      TEST ISATOM(E)  ||USER DEFINED NAME
      THEN TEST VAL!E=NIL | TL!(VAL!E)=NIL THEN BADEXP(E) OR  ||UNDEFINED NAME
           TEST HD!(HD!(VAL!E))=0  ||VARIABLE
           THEN $( LET EQN=HD!(TL!(VAL!E))
                   IF HD!EQN=0 ||MEMO NOT SET
                   DO $( HD!EQN:=BUILDEXP(TL!EQN)
                         MEMORIES:=CONS(E,MEMORIES)  $)
                   E:=HD!EQN  $)  ||?CAN WE GET CYCLIC EXPRESSIONS?
           OR $( ||FUNCTION
                 LET N=HD!(HD!(VAL!E))
                 IF N>NARGS BREAK  ||NOT ENOUGH ARGS
              $( LET EQNS=TL!(VAL!E)
                 FOR I=0 TO N-1
                 DO $( LET HOLD=HD!S  ||MOVE BACK UP GRAPH,
                       ARGP:=ARGP+1   ||STACKING ARGS EN ROUTE
                       !ARGP:=TL!S
                       HD!S,E,S:=E,S,HOLD  $)
                 NARGS:=NARGS-N
                 ||E NOW HOLDS A PIECE OF GRAPH TO BE TRANSFORMED
                 || !ARG ... !ARGP  HOLD THE PARAMETERS
                 OBEY(EQNS,E)
                 ARGP:=ARG-1  ||RESET ARG STACK
              $) $)
      OR $( ||OPERATORS
            SWITCHON E INTO
         $( CASE QUOTE: UNLESS NARGS=1 DO HOLDARG:=-1
                        BREAK
            CASE INDIR: $( LET HOLD=HD!S
                           NARGS:=NARGS-1
                           E,HD!S,S:=TL!S,INDIR,HOLD
                           LOOP  $)
            CASE QUOTE.OP: UNLESS NARGS>=3 BREAK
                        $( LET OP=TL!S
                           LET HOLD=HD!S
                           NARGS:= NARGS-2
                           HD!S,E,S := E,S,HOLD
                           HOLD:= HD!S
                           HD!S,E,S:=E,S,HOLD
                           TL!S,E := CONS(TL!E,TL!S),OP
                           LOOP  $)
            CASE LISTDIFF.OP:  E:=CONS(LISTDIFF,HD!(TL!S))
                              TL!S:=TL!(TL!S)
                              LOOP
            CASE COLON.OP: UNLESS NARGS>=2 BREAK
                           ||LIST INDEXING
                           NARGS:=NARGS-2
                        $( LET HOLD=HD!S
                           HD!S,E,S:=COLON.OP,S,HOLD  $)
                           M:=REDUCE(TL!S)
                           TL!S:=M
                           UNLESS ISNUM(M) &
                                  VALOF $( M:=GETNUM(M)
                                           RESULTIS M>=1  $)
                           DO $( HOLDARG:=-1 ; BREAK  $)
                           FOR I=1 TO M-1
                           DO $( E:=REDUCE(TL!(TL!E))
                                 UNLESS ISCONS(E)&HD!E=COLON.OP
                                 DO BADEXP(CONS(E,STONUM(M-I)))  $)
                           E:=HD!(TL!E)
                        $( LET HOLD=HD!S
                           HD!S,TL!S,S:=INDIR,E,HOLD  $)
                           REDS:=REDS+M
                           XSUBREDS := XSUBREDS + M - 1
     || THE PURPOSE OF XSUBREDS IS TO BE ABLE TO ALSO KEEP TRACK
     || OF REDUCTIONS AS THEY WERE COUNTED FORMERLY, COUNTING ONLY
     || 1 FOR AN ARBITRARY LIST INDEXING OPERATION - 10/3/83
                           LOOP
            CASE ZF.OP: $( LET HOLD=HD!S
                           NARGS:=NARGS-1
                           HD!S,E,S:=E,S,HOLD
                           IF TL!(TL!E)=NIL
                           DO $( HD!E,TL!E:=COLON.OP,CONS(HD!(TL!E),NIL)
                                 LOOP  $)
                        $( LET QUALIFIER=HD!(TL!E)
                           LET REST=TL!(TL!E)
                           TEST ISCONS(QUALIFIER)&HD!QUALIFIER=GENERATOR
                           THEN
                           $( LET SOURCE=REDUCE(TL!(TL!QUALIFIER))
                              LET FORMAL=HD!(TL!QUALIFIER)
                              TL!(TL!QUALIFIER):=SOURCE
                              TEST SOURCE=NIL
                              THEN HD!E,TL!E,E:=INDIR,NIL,NIL OR
                              TEST ISCONS(SOURCE)&HD!SOURCE=COLON.OP
                              THEN HD!E,TL!E:= CONS(INTERLEAVEFN,
              CONS(ZF.OP,SUBSTITUTE(HD!(TL!SOURCE),FORMAL,REST))),
      CONS(ZF.OP,CONS(CONS(GENERATOR,CONS(FORMAL,TL!(TL!SOURCE))),REST))
||                            THEN HD!E,TL!E:=APPEND.OP,
||                                            CONS(
||            CONS(ZF.OP,SUBSTITUTE(HD!(TL!SOURCE),FORMAL,REST)),
||    CONS(ZF.OP,CONS(CONS(GENERATOR,CONS(FORMAL,TL!(TL!SOURCE))),REST))
||                                                )
                              OR BADEXP(E)  $)
                           OR $( ||QUALIFIER IS GUARD
                                 QUALIFIER:=REDUCE(QUALIFIER)
                                 HD!(TL!E):=QUALIFIER
                                 TEST QUALIFIER=TRUTH
                                 THEN TL!E:=REST OR
                                 TEST QUALIFIER=FALSITY
                                 THEN HD!E,TL!E,E:=INDIR,NIL,NIL
                                 OR BADEXP(CONS(GUARD,QUALIFIER))  $)
                           REDS:=REDS+1
                           LOOP  $)  $)
            CASE DOT.OP: UNLESS NARGS>=2
                         DO $( LET A,B=REDUCE(HD!(TL!S)),REDUCE(TL!(TL!S))
                               UNLESS ISFUN(A) & ISFUN(B)
                               DO BADEXP(CONS(E,CONS(A,B)))
                               BREAK  $)
                      $( LET HOLD=HD!S
                         NARGS:=NARGS-1
                         E,TL!HOLD:=HD!(TL!S),CONS(TL!(TL!S),TL!HOLD)
                         HD!S,S:=DOT.OP,HOLD  
                         REDS:=REDS+1
                         LOOP  $)
            CASE EQ.OP:
            CASE NE.OP: E:=EQUALVAL(HD!(TL!S),TL!(TL!S))=(E=EQ.OP)->
                           TRUTH,FALSITY
              ||NOTE - COULD REWRITE FOR FAST EXIT, HERE AND IN
              ||OTHER CASES WHERE RESULT OF REDUCTION IS ATOMIC
                     $( LET HOLD=HD!S
                        NARGS:=NARGS-1
                        HD!S,TL!S,S:=INDIR,E,HOLD
                        REDS:=REDS+1
                        LOOP  $)
            CASE ENDOFSTACK: BADEXP(SILLYNESS) ||OCCURS IF WE TRY TO
                                 ||EVALUATE AN EXP WE ARE ALREADY INSIDE
            DEFAULT: ENDCASE  $)  ||END OF SWITCH
         $( ||STRICT OPERATORS
            LET A,B,STRINGS=0,0,FALSE
            TEST E>=LENGTH.OP
            THEN A:=REDUCE(TL!S)  ||MONADIC
            OR $( A:=REDUCE(HD!(TL!S))  ||DIADIC
                  TEST E>=GR.OP  ||STRICT IN 2ND ARG ?
                  THEN $( B:=REDUCE(E=COMMADOTDOT.OP->HD!(TL!(TL!S)),TL!(TL!S))  ||YES
                          TEST ISNUM(A) & ISNUM(B)
                          THEN M,N:=GETNUM(A),GETNUM(B) OR
                          TEST E<=LS.OP &  ||RELOPS
                               ISCONS(A) & ISCONS(B) & HD!A=QUOTE=HD!B
                          THEN STRINGS,M,N:=TRUE,TL!A,TL!B OR
                          TEST E=DOTDOT.OP & ISNUM(A) & B=INFINITY
                          THEN M,N := GETNUM(A),M
                          OR BADEXP(CONS(E,CONS(A,E=COMMADOTDOT.OP->CONS(B,TL!(TL!(TL!S))),B)))  $)
                  OR B:=TL!(TL!S)  ||NO
               $)
            E:=VALOF
               SWITCHON E INTO
               $( CASE AND.OP: RESULTIS A=FALSITY->A,
                                        A=TRUTH->B,
                                        BADEXP(CONS(E,CONS(A,B)))
                  CASE OR.OP: RESULTIS A=TRUTH->A,
                                       A=FALSITY->B,
                                       BADEXP(CONS(E,CONS(A,B)))
                  CASE APPEND.OP: IF A=NIL RESULTIS B
                                  UNLESS ISCONS(A) & HD!A=COLON.OP
                                  DO BADEXP(CONS(E,CONS(A,B)))
                                  E:=COLON.OP
                                  TL!(TL!S):=CONS(APPEND.OP,
                                              CONS(TL!(TL!A),B))
                                  HD!(TL!S):=HD!(TL!A)
                                  REDS:=REDS+1
                                  LOOP
                  CASE DOTDOT.OP: IF M>N RESULTIS NIL
                                  E:=COLON.OP
                                  TL!(TL!S):=CONS(DOTDOT.OP,
                                              CONS(STONUM(M+1),B))
                                  REDS:=REDS+1
                                  LOOP
                  CASE COMMADOTDOT.OP: $( LET C=REDUCE(TL!(TL!(TL!S)))
                                          STATIC $( P=0  $)
                                          TEST ISNUM(C)
                                          THEN P:=GETNUM(C) OR
                                          TEST C=INFINITY THEN P:=N
                                          OR BADEXP(CONS(E,CONS(A,CONS(B,C))))
                                          IF (N-M)*(P-M)<0 RESULTIS NIL
                                          E:=COLON.OP
                                          HD!(TL!(TL!S)):=STONUM(N+N-M)
                                          TL!(TL!S):=CONS(COMMADOTDOT.OP,CONS(B,TL!(TL!S)))
                                          REDS:=REDS+1
                                          LOOP  $)
                  CASE NOT.OP: RESULTIS A=TRUTH->FALSITY,
                                        A=FALSITY->TRUTH,
                                        BADEXP(CONS(E,A))
                  CASE NEG.OP: UNLESS ISNUM(A) DO BADEXP(CONS(E,A))
                               RESULTIS STONUM(-GETNUM(A))
                  CASE LENGTH.OP: $( LET L=0
                                     WHILE ISCONS(A) & HD!A=COLON.OP
                                     DO A,L:=REDUCE(TL!(TL!A)),L+1
                                     IF A=NIL RESULTIS STONUM(L)
                                     BADEXP(CONS(COLON.OP,CONS(ETC,A)))
                                  $)
                  CASE PLUS.OP: RESULTIS STONUM(M+N)
                  CASE MINUS.OP: RESULTIS STONUM(M-N)
                  CASE TIMES.OP: RESULTIS STONUM(M*N)
                  CASE DIV.OP: IF N=0 DO BADEXP(CONS(DIV.OP,CONS(A,B)))
                               RESULTIS STONUM(M/N)
                  CASE REM.OP: IF N=0 DO BADEXP(CONS(REM.OP,CONS(A,B)))
                               RESULTIS STONUM(M REM N)
                  CASE EXP.OP:   IF N<0 DO BADEXP(CONS(EXP.OP,CONS(A,B)))
                              $( LET P=1
                                 UNTIL N=0 DO P,N := P*M,N-1
                                 RESULTIS STONUM(P)  $)
                  CASE GR.OP: RESULTIS (STRINGS->ALFA.LS(N,M),M>N)->
                                        TRUTH, FALSITY
                  CASE GE.OP: RESULTIS (STRINGS->ALFA.LS(N,M)|N=M,M>=N)->
                                        TRUTH, FALSITY
                  CASE LE.OP: RESULTIS (STRINGS->ALFA.LS(M,N)|M=N,M<=N)->
                                        TRUTH, FALSITY
                  CASE LS.OP: RESULTIS (STRINGS->ALFA.LS(M,N),M<N)->
                                        TRUTH, FALSITY
                  DEFAULT: WRITES("IMPOSSIBLE OPERATOR IN *"REDUCE*"*N")
               $) ||END OF SWITCH
         $( LET HOLD=HD!S
            NARGS:=NARGS-1
            HD!S,TL!S,S:=INDIR,E,HOLD  $)
         $) $) ||END OF OPERATORS
      REDS:=REDS+1
   $) REPEAT ||END OF MAIN LOOP
   UNTIL S=ENDOFSTACK   ||UNREVERSE REVERSED POINTERS
   DO $( LET HOLD=HD!S
         HD!S,E,S:=E,S,HOLD  $)
   IF HOLDARG= -1 DO BADEXP(E)
   ARG:=HOLDARG  ||RESET ARG STACKFRAME
   S:=HOLD.S
   RESULTIS E
$)

AND SUBSTITUTE(ACTUAL,FORMAL,EXP) = 
     EXP=FORMAL -> ACTUAL,
     \ISCONS(EXP) | HD!EXP=QUOTE | BINDS(FORMAL,HD!EXP) -> EXP,
     VALOF $( LET H=SUBSTITUTE(ACTUAL,FORMAL,HD!EXP)
              LET T=SUBSTITUTE(ACTUAL,FORMAL,TL!EXP)
              RESULTIS H=HD!EXP & T=TL!EXP -> EXP, CONS(H,T)  $)

AND BINDS(FORMAL,X) =
     ISCONS(X) & HD!X=GENERATOR & HD!(TL!X)=FORMAL ->TRUE, FALSE
