%EXTRINSICINTEGERARRAY A(1:255)
%EXTRINSICINTEGERARRAY TAGLINK(0:255)
%EXTRINSICINTEGERARRAY TAG(1:512)
%EXTRINSICINTEGERARRAY LINK(1:512)
!-----------------------------------------------------------------------
%EXTERNALROUTINESPEC EXPR(%INTEGER EXPRP)
%EXTERNALINTEGERFNSPEC COND(%INTEGER CONDP,TLABEL,FLABEL)
%EXTERNALSTRING(255)%FNSPEC STRINT(%INTEGER N,P)
%EXTERNALINTEGERFNSPEC GETWORK
%EXTERNALROUTINESPEC RETURNWORK(%INTEGER WORK)
%EXTERNALROUTINESPEC CLEARWORK
%EXTERNALINTEGERFNSPEC NEWTAG
%EXTERNALROUTINESPEC PUSHTAG(%INTEGER IDENT,FORM,TYPE,DIM,LEVEL,RAD)
%EXTERNALROUTINESPEC POPTAGS
%EXTERNALINTEGERFNSPEC GETLABEL(%INTEGER CONSTP)
%EXTERNALROUTINESPEC FILLLABEL(%INTEGER LABEL)
%EXTERNALINTEGERFNSPEC FILLBRANCH(%INTEGER LABEL)
%EXTERNALROUTINESPEC POPLABELS
%EXTERNALINTEGERFNSPEC NEXTPLABEL
%EXTERNALROUTINESPEC DUMP(%STRING(7) OPN,REG,BASE,%INTEGER DISP)
%EXTERNALROUTINESPEC FAULT(%STRING(63) MESS)
%EXTERNALSTRING(255)%FNSPEC NAME(%INTEGER IDENT)
%EXTERNALROUTINESPEC PUSHSTART(%INTEGER FLAG,PLAB)
%EXTERNALROUTINESPEC POPSTART(%INTEGERNAME FLAG,PLAB)
%EXTERNALROUTINESPEC CLEARSTART
%EXTERNALINTEGERFNSPEC ENTER
%EXTERNALROUTINESPEC DUMP RETURN
%EXTERNALROUTINESPEC PROC(%INTEGER PROCP)
%EXTERNALROUTINESPEC ARRAY(%INTEGER ARRAYP)
%EXTERNALROUTINESPEC ENDOFPROG
!-----------------------------------------------------------------------
%EXTERNALINTEGERARRAY NEXTRAD(0:15)
%EXTERNALSTRING(4)%ARRAY DISPLAY(0:15)="DR0","DR1","DR2","DR3","DR4",
 "DR5","DR6","DR7","DR8","DR9","DR10","DR11","DR12","DR13","DR14","DR15"
%EXTERNALINTEGER LEVEL,NEXTCAD
!-----------------------------------------------------------------------
%OWNINTEGERARRAY PROCTYPE(0:15)
%OWNINTEGERARRAY STATICALLOC(0:15)
%OWNINTEGERARRAY SKIPPROC(0:15)
!-----------------------------------------------------------------------
%EXTERNALROUTINE STATEMENT(%INTEGER STATEMENTP)
%ROUTINESPEC INSTR(%INTEGER INSTRP)
%SWITCH STTYPE(1:8)
%INTEGER CONDP,INSTRP,ELSEP,CONSTP,ARRAYP,NAMEP,NAMESP,EXPR1P,EXPR2P, %C
  INSTR2P,TLABEL,FLABEL,LABEL,FPLABEL,TPLABEL,WORK1,WORK2,FLAG,PLABEL,%C
  PROCP,FORMALP,FORMP,PARAMS,PROCID,IDENT,FORM,PARAMT,PARAML,DIM
  ->STTYPE(A(STATEMENTP))
!-----------------------------------------------------------------------
STTYPE(1):! <INSTR>
  INSTR(A(STATEMENTP+1))
  %RETURN
!-----------------------------------------------------------------------
STTYPE(2):! "IF"<COND>"THEN"<INSTR><ELSE>
  CONDP=A(STATEMENTP+1)
  INSTRP=A(STATEMENTP+2)
  ELSEP=A(STATEMENTP+3)
  %IF A(INSTRP)=2 %THEN %START    ;! BRANCH
    CONSTP=A(INSTRP+1)
    TLABEL=GETLABEL(CONSTP)
    %IF A(ELSEP)=2 %THEN FILLLABEL(COND(CONDP,TLABEL,-1)) %ELSE %START
      INSTRP=A(ELSEP+1)
      %IF A(INSTRP)=2 %THEN %START    ;! BRANCH
        CONSTP=A(INSTRP+1)
        FLABEL=GETLABEL(CONSTP)
        FILLLABEL(COND(CONDP,TLABEL,FLABEL))
        DUMP("B","","",FILLBRANCH(FLABEL))
      %FINISH %ELSE %START
        FILLLABEL(COND(CONDP,TLABEL,-1))
        %IF A(INSTRP)=3 %THEN PUSHSTART(1,-1) %ELSE INSTR(INSTRP)
      %FINISH
    %FINISH
  %FINISH %ELSE %START
    %IF A(ELSEP)=2 %THEN %START
      FPLABEL=COND(CONDP,-1,-1)
      %IF A(INSTRP)=3 %THEN PUSHSTART(0,FPLABEL) %ELSE %C
        INSTR(INSTRP) %AND FILLLABEL(FPLABEL)
    %FINISH %ELSE %START
      INSTR2P=A(ELSEP+1)
      %IF A(INSTR2P)=2 %THEN %START    ;! BRANCH
        CONSTP=A(INSTR2P+1)
        FPLABEL=COND(CONDP,-1,GETLABEL(CONSTP))    ;! RESULT ALWAYS -1
        INSTR(INSTRP)
      %FINISH %ELSE %START
        FPLABEL=COND(CONDP,-1,-1)
        INSTR(INSTRP)
        TPLABEL=NEXTPLABEL
        DUMP("B","","",FILLBRANCH(TPLABEL))
        FILLLABEL(FPLABEL)
        %IF A(INSTR2P)=3 %THEN PUSHSTART(1,TPLABEL) %ELSE %C
          INSTR(INSTR2P) %AND FILLLABEL(TPLABEL)
      %FINISH
    %FINISH
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
STTYPE(3):! <CONST>':'<STATEMENT>
  CONSTP=A(STATEMENTP+1)
  STATEMENTP=A(STATEMENTP+2)
  LABEL=GETLABEL(CONSTP)
  FILLLABEL(LABEL)
  STATEMENT(STATEMENTP)
  %RETURN
!-----------------------------------------------------------------------
STTYPE(4):! "FINISH"<ELSE>
  ELSEP=A(STATEMENTP+1)
  POPSTART(FLAG,PLABEL)
  %IF FLAG=0 %THEN %START    ;! FIRST %START/%FINISH
    %IF A(ELSEP)=1 %THEN %START
      INSTRP=A(ELSEP+1)
      TPLABEL=NEXTPLABEL
      DUMP("B","","",FILLBRANCH(TPLABEL))
      FILLLABEL(PLABEL)
      %IF A(INSTRP)=3 %THEN PUSHSTART(1,TPLABEL) %ELSE %C
        INSTR(INSTRP) %AND FILLLABEL(TPLABEL)
    %FINISH %ELSE FILLLABEL(PLABEL)
  %FINISH %ELSE %START    ;! SECOND %START/%FINISH
    %IF A(ELSEP)=1 %THEN FAULT("SPURIOUS %ELSE") %ELSE FILLLABEL(PLABEL)
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
STTYPE(5):! "INTEGER"<ARRAY>
  ARRAYP=A(STATEMENTP+1)
  NAMEP=A(ARRAYP+1)
  NAMESP=A(ARRAYP+2)
  %IF A(ARRAYP)=1 %THEN %START    ;! ARRAY DECLARATION
    EXPR1P=A(ARRAYP+3)
    EXPR2P=A(ARRAYP+4)
    EXPR(EXPR1P)
    WORK1=GETWORK
    DUMP("STR","ACC",DISPLAY(LEVEL),WORK1)
    EXPR(EXPR2P)
    DUMP("LDA","ACC","ACC",1)
    WORK2=GETWORK
    DUMP("STR","ACC",DISPLAY(LEVEL),WORK2)
    %CYCLE
      PUSHTAG(A(NAMEP+1),2,1,1,LEVEL,NEXTRAD(LEVEL))
      DUMP("SUB","STP",DISPLAY(LEVEL),WORK1)
      DUMP("STR","STP",DISPLAY(LEVEL),NEXTRAD(LEVEL))
      DUMP("ADD","STP",DISPLAY(LEVEL),WORK2)
      NEXTRAD(LEVEL)=NEXTRAD(LEVEL)+1
      %IF A(NAMESP)=2 %THEN %EXIT
      NAMEP=A(NAMESP+1)
      NAMESP=A(NAMESP+2)
    %REPEAT
    RETURNWORK(WORK1)
    RETURNWORK(WORK2)
  %FINISH %ELSE %START
    %CYCLE
      PUSHTAG(A(NAMEP+1),0,1,0,LEVEL,NEXTRAD(LEVEL))
      NEXTRAD(LEVEL)=NEXTRAD(LEVEL)+1
      %IF A(NAMESP)=2 %THEN %EXIT
      NAMEP=A(NAMESP+1)
      NAMESP=A(NAMESP+2)
    %REPEAT
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
STTYPE(6):! <PROC><NAME><FORMAL>
  %IF LEVEL=0 %THEN FAULT("PROCEDURE BEFORE %BEGIN")
  %IF LEVEL=15 %THEN FAULT("PROCEDURE NESTING TOO DEEP")
  PROCP=A(STATEMENTP+1)
  NAMEP=A(STATEMENTP+2)
  FORMALP=A(STATEMENTP+3)
  PROCID=A(NAMEP+1)
  SKIPPROC(LEVEL)=NEXTCAD
  DUMP("B","","",0)    ;! BRANCH ROUND PROCEDURE
  PUSHTAG(PROCID,4,A(PROCP)-1,0,LEVEL,NEXTCAD)
  LEVEL=LEVEL+1
  PROCTYPE(LEVEL)=A(PROCP)
  STATICALLOC(LEVEL)=ENTER
  NEXTRAD(LEVEL)=2
  %IF A(FORMALP)=2 %THEN %RETURN    ;! NO PARAMETERS
  PARAMS=0
  PARAML=TAGLINK(PROCID)
  %UNTIL A(FORMALP)=2 %CYCLE
    FORMP=A(FORMALP+1)
    NAMEP=A(FORMALP+2)
    NAMESP=A(FORMALP+3)
    FORMALP=A(FORMALP+4)
    %IF A(FORMP)=1 %THEN FORM=3 %AND DIM=1 %ELSE %START
      %IF A(FORMP)=2 %THEN FORM=1 %ELSE FORM=0
      DIM=0
    %FINISH
    %CYCLE
      IDENT=A(NAMEP+1)
      ! DECLARE PARAMETERS AS LOCALS
      PUSHTAG(IDENT,FORM,1,DIM,LEVEL,NEXTRAD(LEVEL))
      NEXTRAD(LEVEL)=NEXTRAD(LEVEL)+1
      ! APPEND PARAMETER TAG CELLS TO PROCEDURE TAG CELL
      PARAMT=NEWTAG
      TAG(PARAMT)=TAG(TAGLINK(IDENT))
      LINK(PARAMT)=LINK(PARAML)
      LINK(PARAML)=PARAMT
      PARAML=PARAMT
      PARAMS=PARAMS+1
      %IF PARAMS>15 %THEN FAULT(NAME(PROCID). %C
        " HAS TOO MANY PARAMETERS") %AND %STOP
      %IF A(NAMESP)=2 %THEN %EXIT
      NAMEP=A(NAMESP+1)
      NAMESP=A(NAMESP+2)
    %REPEAT
  %REPEAT
  ! INSERT NUMBER OF PARAMETERS INTO TAG CELL
  TAG(TAGLINK(PROCID))=TAG(TAGLINK(PROCID))!PARAMS<<20
  %RETURN
!-----------------------------------------------------------------------
STTYPE(7):! "END"<OFPROG>
  DUMP("FILL","ALLOC",STRINT(STATICALLOC(LEVEL),1),NEXTRAD(LEVEL))
  POPTAGS
  POPLABELS
  CLEARSTART
  CLEARWORK
  %IF PROCTYPE(LEVEL)=1 %THEN DUMP RETURN %ELSE DUMP("STOP","","",0)
  LEVEL=LEVEL-1
  %IF A(A(STATEMENTP+1))=2 %THEN %START    ;! %END
    %IF LEVEL<=0 %THEN FAULT("SPURIOUS %END") %AND ENDOFPROG
    DUMP("FILL","SKIP",STRINT(SKIPPROC(LEVEL),1),NEXTCAD)
  %FINISH %ELSE %START    ;! %ENDOFPROGRAM
    %IF LEVEL#0 %THEN FAULT("TOO FEW %ENDS")
    ENDOFPROG
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
STTYPE(8):! "BEGIN"
  %IF LEVEL#0 %THEN FAULT("SPURIOUS %BEGIN") %ELSE %START
    LEVEL=1
    PROCTYPE(1)=0
    STATICALLOC(1)=ENTER
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
%ROUTINE INSTR(%INTEGER INSTRP)
%SWITCH INSTYPE(1:6)
%STRING(4) BASE
%INTEGER NAMEP,ASSIGNP,CONSTP,IDENT,ACTUALP,EXPRP,NAMETAG,DISP,WORK
  ->INSTYPE(A(INSTRP))
!-----------------------------------------------------------------------
INSTYPE(1):! <NAME><ACTUAL><ASSIGN>
  NAMEP=A(INSTRP+1)
  ACTUALP=A(INSTRP+2)
  ASSIGNP=A(INSTRP+3)
  IDENT=A(NAMEP+1)
  %IF TAGLINK(IDENT)=0 %THEN FAULT(NAME(IDENT)." NOT DECLARED") %C
    %AND %RETURN
  NAMETAG=TAG(TAGLINK(IDENT))
  %IF A(ASSIGNP)=1 %THEN %START
    %IF NAMETAG>>28=4 %THEN FAULT(NAME(IDENT)." NOT A DESTINATION") %C
      %AND %RETURN
    EXPRP=A(ASSIGNP+1)
    %IF NAMETAG>>28>=2 %THEN %START    ;! ARRAY VARIABLE
      EXPR(EXPRP)
      WORK=GETWORK
      DUMP("STR","ACC",DISPLAY(LEVEL),WORK)
      ARRAY(INSTRP)
      DUMP("LOAD","WK",DISPLAY(LEVEL),WORK)
      DUMP("STR","WK","ACC",0)
      RETURNWORK(WORK)
    %FINISH %ELSE %START
      EXPR(EXPRP)
      BASE=DISPLAY(NAMETAG>>16&X'F')
      DISP=NAMETAG&X'FFFF'
      %IF NAMETAG>>28=1 %THEN %START    ;! %NAME VARIABLE
        DUMP("LOAD","WK",BASE,DISP)
        DUMP("STR","ACC","WK",0)
      %FINISH %ELSE DUMP("STR","ACC",BASE,DISP)
      %IF A(ACTUALP)=1 %THEN FAULT(NAME(IDENT)." DECLARED AS SCALAR")
    %FINISH
  %FINISH %ELSE %START
    %IF NAMETAG>>28=4 %AND NAMETAG>>24&X'F'=0 %THEN PROC(INSTRP) %C
      %ELSE FAULT(NAME(IDENT)." NOT A ROUTINE NAME")
  %FINISH
  %RETURN
!-----------------------------------------------------------------------
INSTYPE(2):! '->'<CONST>
  CONSTP=A(INSTRP+1)
  LABEL=GETLABEL(CONSTP)
  DUMP("B","","",FILLBRANCH(LABEL))
  %RETURN
!-----------------------------------------------------------------------
INSTYPE(3):! "START"
  FAULT("ILLEGAL %START")
  %RETURN
!-----------------------------------------------------------------------
INSTYPE(4):! "RETURN"
  %IF PROCTYPE(LEVEL)#1 %THEN FAULT("%RETURN OUT OF CONTEXT")
  DUMPRETURN
  %RETURN
!-----------------------------------------------------------------------
INSTYPE(5):! "RESULT"'='<EXPR>
  %IF PROCTYPE(LEVEL)#2 %THEN FAULT("%RESULT OUT OF CONTEXT")
  EXPR(A(INSTRP+1))
  DUMPRETURN
  %RETURN
!-----------------------------------------------------------------------
INSTYPE(6):! "STOP"
  DUMP("STOP","","",0)
%END
%END
%ENDOFFILE