%EXTRINSICINTEGERARRAY A(1:255)
%EXTRINSICINTEGERARRAY TAGLINK(0:255)
%EXTRINSICINTEGERARRAY TAG(1:512)
%EXTRINSICSTRING(4)%ARRAY DISPLAY(0:15)
%EXTRINSICINTEGER LEVEL,CONDFLAG,EXPROPT
!-----------------------------------------------------------------------
%EXTERNALSTRING(255)%FNSPEC STRINT(%INTEGER N,P)
%EXTERNALSTRING(8)%FNSPEC STRHEX(%INTEGER N)
%EXTERNALROUTINESPEC FAULT(%STRING(63) S)
%EXTERNALSTRING(255)%FNSPEC NAME(%INTEGER IDENT)
%EXTERNALROUTINESPEC DUMP(%STRING(7) OPN,REG,BASE,%INTEGER DISP)
%EXTERNALINTEGERFNSPEC GETWORK
%EXTERNALROUTINESPEC RETURNWORK(%INTEGER WORK)
%EXTERNALROUTINESPEC PROC(%INTEGER AP)
%EXTERNALROUTINESPEC ARRAY(%INTEGER AP)
%EXTERNALINTEGERFNSPEC GETCOTI(%INTEGER CONST)
!-----------------------------------------------------------------------
%EXTERNALROUTINE EXPR(%INTEGER EXPRP)
%INTEGERFNSPEC TOTREE(%INTEGER EXPRP)
%ROUTINESPEC EVALUATE(%INTEGER NODEP)
%INTEGERARRAY TREE(1:64)
%INTEGER TREEP,TREENODE,TREENODE1,TREENODE2,TESTP,EXPR1P,EXPR2P,COMPP,%C
  I,L
%CONSTINTEGERARRAY REVERSECOMP(1:6)=1,2,5,6,3,4
  TREEP=1
  %IF CONDFLAG=0 %THEN TREENODE=TOTREE(EXPRP) %ELSE %START
    CONDFLAG=0
    TESTP=EXPRP    ;! FOR <TEST>=<EXPR><COMP><EXPR>
    EXPR1P=A(TESTP+1)
    COMPP=A(TESTP+2)
    EXPR2P=A(TESTP+3)
    TREENODE1=TOTREE(EXPR1P)
    TREENODE2=TOTREE(EXPR2P)
    %IF TREE(TREENODE1)=-4 %AND TREE(TREENODE1+1)=0 %THEN %START
      A(COMPP)=REVERSECOMP(A(COMPP))
      TREENODE=TREENODE2
    %FINISH %ELSE %START
      %IF TREE(TREENODE2)=-4 %AND TREE(TREENODE2+1)=0 %THEN %C
        TREENODE=TREENODE1 %ELSE %START
        TREE(TREEP)=10    ;! -
        TREE(TREEP+1)=TREENODE1
        TREE(TREEP+2)=TREENODE2
        TREENODE=TREEP
      %FINISH
    %FINISH
  %FINISH
  %IF EXPROPT=1 %THEN %START
    NEWLINE
    %IF 0<TREE(TREENODE)<=10 %THEN L=TREENODE+2 %ELSE L=TREENODE+1
    %CYCLE I=1,1,L
      PRINT STRING("  ".STRINT(TREE(I),1))
      %IF I=TREENODE %THEN PRINT STRING("*")
      %IF TREE(I)=-3 %THEN I=I+1 %AND PRINT STRING("  ".STRHEX(TREE(I)))
    %REPEAT
    NEWLINES(2)
  %FINISH
  EVALUATE(TREENODE)
  %RETURN
!-----------------------------------------------------------------------
%INTEGERFN TOTREE(%INTEGER EXPRP)
! CREATE TREE FORM OF EXPRESSION
%ROUTINESPEC PSEVAL(%INTEGER TYPE,DATUM)
%INTEGERARRAY OS(1:4),PS(1:5)    ;! OPERATOR & PSEUDO-EVALUATION STACKS
%INTEGER OSP,PSP,UNARYP,OPERANDP,EXPRRESTP,OPP,NAMEP,ACTUALP, %C
  IDENT,NAMETAG
%CONSTINTEGERARRAY PREC(1:12)=3,3,2,1,1,3,2,2,1,1,1,4
! <<,>>,&,!!,!,**,/,*,+,-,-(UNARY),\
  UNARYP=A(EXPRP+1)
  OPERANDP=A(EXPRP+2)
  EXPRRESTP=A(EXPRP+3)
  %IF A(UNARYP)<=2 %THEN OS(1)=A(UNARYP)+10 %AND OSP=1 %ELSE OSP=0
  PSP=0
  %CYCLE    ;! FOR EACH OPERAND
    %IF A(OPERANDP)=1 %THEN %START    ;! <NAME><ACTUAL>
      NAMEP=A(OPERANDP+1)
      ACTUALP=A(OPERANDP+2)
      IDENT=A(NAMEP+1)
      %IF TAGLINK(IDENT)=0 %THEN %START
        FAULT(NAME(IDENT)." NOT DECLARED")
        PSEVAL(-3,0)    ;! PSEVAL DUMMY TAG
      %FINISH %ELSE %START
        NAMETAG=TAG(TAGLINK(IDENT))
        %IF NAMETAG>>28<=1 %THEN %START    ;! SCALAR VARIABLE
          %IF A(ACTUALP)=1 %THEN %START
            FAULT("SCALAR ".NAME(IDENT)." HAS PARAMETER")
            PSEVAL(-3,0)
          %FINISH %ELSE PSEVAL(-3,NAMETAG)
        %FINISH %ELSE %START
          %IF NAMETAG>>28<=3 %THEN PSEVAL(-2,OPERANDP) %ELSE %START
            %IF NAMETAG>>24&X'F'=0 %THEN %START
              FAULT("ROUTINE NAME ".NAME(IDENT)." IN EXPRESSION")
              PSEVAL(-3,0)
            %FINISH %ELSE PSEVAL(-1,OPERANDP)
          %FINISH
        %FINISH
      %FINISH
    %FINISH %ELSE %START
      %IF A(OPERANDP)=2 %THEN PSEVAL(-4,A(A(OPERANDP+1)+1)) %ELSE %C
        PSP=PSP+1 %AND PS(PSP)=TOTREE(A(OPERANDP+1))
    %FINISH
    %IF A(EXPRRESTP)=2 %THEN %EXIT    ;! NO MORE OPERANDS
    OPP=A(EXPRRESTP+1)
    OPERANDP=A(EXPRRESTP+2)
    EXPRRESTP=A(EXPRRESTP+3)
    %WHILE OSP>0 %AND PREC(A(OPP))<=PREC(OS(OSP)) %THEN %C
      PSEVAL(OS(OSP),0) %AND OSP=OSP-1   ;! UNSTACK WHILE PREC(NEW OP)<=
    OSP=OSP+1    ;! STACK NEW OPERATOR
    OS(OSP)=A(OPP)
  %REPEAT
  %WHILE OSP>0 %THEN PSEVAL(OS(OSP),0) %AND OSP=OSP-1    ;! UNSTACK REST
  %RESULT=PS(1)
!-----------------------------------------------------------------------
%ROUTINE PSEVAL(%INTEGER TYPE,DATUM)
%ROUTINESPEC STORE(%INTEGER T)
%INTEGER NODEP
  NODEP=TREEP
  STORE(TYPE)
  %IF TYPE>0 %THEN %START    ;! OPERATOR
    %IF TYPE>10 %THEN STORE(PS(PSP)) %ELSE STORE(PS(PSP-1)) %AND %C
      STORE(PS(PSP)) %AND PSP=PSP-1
  %FINISH %ELSE STORE(DATUM) %AND PSP=PSP+1
  PS(PSP)=NODEP
!-----------------------------------------------------------------------
%ROUTINE STORE(%INTEGER T)
  %IF TREEP>64 %THEN FAULT("EXPRESSION TOO LONG") %AND %STOP
  TREE(TREEP)=T
  TREEP=TREEP+1
%END
%END
%END
!-----------------------------------------------------------------------
%ROUTINE EVALUATE(%INTEGER NODEP)
! DUMP CODE TO EVALUATE EXPRESSION
%ROUTINESPEC OPN(%INTEGER OP,P)
%CONSTSTRING(4)%ARRAY STROP(0:12)="LOAD","SHL","SHR","AND","XOR","OR",
  "EXP","DIV","MLT","ADD","SUB","NEG","NOT"
%CONSTINTEGERARRAY COMMUT(1:10)=0,0,1,1,1,0,0,1,1,0
%INTEGER OP,OPD1P,OPD2P,WORK
  %IF TREE(NODEP)<0 %THEN OPN(0,NODEP) %AND %RETURN    ;! OPERAND
  OP=TREE(NODEP)
  OPD1P=TREE(NODEP+1)
  %IF OP>10 %THEN %START    ;! UNARY OPERATOR
    %IF TREE(OPD1P)>=-2 %THEN EVALUATE(OPD1P) %ELSE OPN(0,OPD1P)
    DUMP(STROP(OP),"ACC","",0)
    %RETURN
  %FINISH
  OPD2P=TREE(NODEP+2)
  %IF TREE(OPD1P)>=-2 %THEN %START      ;! OPERAND1 A NODE
    %IF TREE(OPD2P)>=-2 %THEN %START    ;! OPERAND2 A NODE
      EVALUATE(OPD2P)
      WORK=GETWORK
      DUMP("STR","ACC",DISPLAY(LEVEL),WORK)
      EVALUATE(OPD1P)
      DUMP(STROP(OP),"ACC",DISPLAY(LEVEL),WORK)
      RETURNWORK(WORK)
    %FINISH %ELSE %START
      EVALUATE(OPD1P)
      OPN(OP,OPD2P)
    %FINISH
  %FINISH %ELSE %START
    %IF TREE(OPD2P)>=-2 %THEN %START
      EVALUATE(OPD2P)
      %IF COMMUT(OP)#0 %THEN OPN(OP,OPD1P) %AND %RETURN
      WORK=GETWORK
      DUMP("STR","ACC",DISPLAY(LEVEL),WORK)
      OPN(0,OPD1P)
      DUMP(STROP(OP),"ACC",DISPLAY(LEVEL),WORK)
      RETURNWORK(WORK)
    %FINISH %ELSE %START
      OPN(0,OPD1P)
      OPN(OP,OPD2P)
    %FINISH
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
%ROUTINE OPN(%INTEGER OP,P)
! DUMP OBJECT CODE FOR SIMPLE OPERATION
%STRING(7) BASE
%INTEGER TYPE,DATUM,DISP
  TYPE=TREE(P)
  DATUM=TREE(P+1)
  %IF TYPE=-1 %THEN PROC(DATUM) %ELSE %START    ;! PROCEDURE
    %IF TYPE=-2 %THEN %START                    ;! ARRAY
      ARRAY(DATUM)
      DUMP("LOAD","ACC","ACC",0)
    %FINISH %ELSE %START
      %IF TYPE=-3 %THEN %START                  ;! SCALAR
        BASE=DISPLAY(DATUM>>16&X'F')
        DISP=DATUM&X'FFFF'
        %IF DATUM>>28=1 %THEN %START            ;! %NAME TYPE
          DUMP("LOAD","WK",BASE,DISP)
          DUMP(STROP(OP),"ACC","WK",0)
        %FINISH %ELSE DUMP(STROP(OP),"ACC",BASE,DISP)
      %FINISH %ELSE %START    ;! CONSTANT
        %IF OP>0 %OR DATUM>X'FFFF' %THEN DUMP(STROP(OP),"ACC", %C
          "COT",GETCOTI(DATUM)) %ELSE DUMP("LDA","ACC","",DATUM)
      %FINISH
    %FINISH
  %FINISH
%END
%END
%END
%ENDOFFILE