%EXTRINSICINTEGERARRAY A(1:255)
%EXTRINSICBYTEINTEGERARRAY NAMED(1:1024)
%EXTRINSICINTEGERARRAY NAMEDLINK(0:255)
%EXTRINSICINTEGERARRAY TAGLINK(0:255)
%EXTRINSICINTEGERARRAY TAG(1:512)
%EXTRINSICINTEGERARRAY LINK(1:512)
%EXTRINSICINTEGERARRAY NEXTRAD(0:15)
%EXTRINSICSTRING(4)%ARRAY DISPLAY(0:15)
%EXTRINSICINTEGER TAGASL,LEVEL,TAGSOPT,NEXTCAD,NAMEDP
!-----------------------------------------------------------------------
%EXTERNALROUTINESPEC EXPR(%INTEGER EXPRP)
!-----------------------------------------------------------------------
%OWNINTEGERARRAY WORKLIST(0:15)=0(16)
%OWNINTEGERARRAY NAMELIST(0:15)=0(16)
%OWNINTEGERARRAY BRANCHLIST(0:15)=0(16)
%OWNINTEGERARRAY STARTLIST(0:15)=0(16)
%OWNINTEGERARRAY COT(0:127)
%OWNINTEGER COTP,FAULTS,PARAMS
!-----------------------------------------------------------------------
%EXTERNALSTRING(255)%FN STRINT(%INTEGER N,P)
%STRING(255) R
%STRING(1) S
  %IF N<0 %THEN S="-" %AND N=-N %ELSE S=""
  R=""
  %UNTIL N=0 %THEN R=TOSTRING(N-N//10*10+'0').R %AND N=N//10
  R=S.R
  %WHILE LENGTH(R)<P %THEN R=" ".R
  %RESULT=R
%END
!-----------------------------------------------------------------------
%EXTERNALSTRING(8)%FN STRHEX(%INTEGER N)
%CONSTSTRING(1)%ARRAY H(0:15)="0","1","2","3","4","5","6","7","8",
  "9","A","B","C","D","E","F"
%INTEGER I
%STRING(8) SH
  SH=""
  %CYCLE I=1,1,8
    SH=H(N&X'F').SH
    N=N>>4
  %REPEAT
  %RESULT=SH
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE FAULT(%STRING(63) MESS)
  PRINT STRING("*  ".MESS."

")
  FAULTS=FAULTS+1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE DUMP(%STRING(7) OPN,REG,BASE,%INTEGER DISP)
  PRINT STRING(STRINT(NEXTCAD,5)."$          ". %C
    OPN.",".REG.",".BASE.",".STRINT(DISP,1)."
")
  NEXTCAD=NEXTCAD+1 %UNLESS OPN="FILL"
%END
!-----------------------------------------------------------------------
%EXTERNALSTRING(255)%FN NAME(%INTEGER IDENT)
  %UNLESS 0<=IDENT<=255 %AND NAMEDLINK(IDENT)#0 %THEN %RESULT=""
  %RESULT=STRING(ADDR(NAMED(NAMEDLINK(IDENT))))
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN NEWTAG
%INTEGER I
  %IF TAGASL=0 %THEN FAULT("TAG SPACE FULL") %AND %STOP
  I=TAGASL
  TAGASL=LINK(TAGASL)
%RESULT=I
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN RETURNTAG(%INTEGER TAGI)
%INTEGER L
  L=LINK(TAGI)
  LINK(TAGI)=TAGASL
  TAGASL=TAGI
  %RESULT=L
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN GETWORK
%INTEGERNAME CELL
  CELL==WORKLIST(LEVEL)
  %WHILE CELL#0 %CYCLE
    %IF TAG(CELL)<0 %THEN TAG(CELL)=-TAG(CELL) %AND %RESULT=TAG(CELL)
    CELL==LINK(CELL)
  %REPEAT
  CELL=NEWTAG
  TAG(CELL)=NEXTRAD(LEVEL)
  NEXTRAD(LEVEL)=NEXTRAD(LEVEL)+1
  LINK(CELL)=0
  %RESULT=TAG(CELL)
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE RETURNWORK(%INTEGER WORK)
%INTEGER CELL
  CELL=WORKLIST(LEVEL)
  %WHILE CELL#0 %CYCLE
    %IF TAG(CELL)=WORK %THEN TAG(CELL)=-WORK %AND %RETURN
    CELL=LINK(CELL)
  %REPEAT
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE CLEARWORK
%INTEGER CELL
  CELL=WORKLIST(LEVEL)
  %WHILE CELL#0 %THEN CELL=RETURNTAG(CELL)
  WORKLIST(LEVEL)=0
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN GETCOTI(%INTEGER CONST)
%INTEGER COTI
  %IF COTP>0 %THEN %START
    %CYCLE COTI=0,1,COTP-1
      %IF COT(COTI)=CONST %THEN %RESULT=COTI
    %REPEAT
  %FINISH
  %IF COTP=128 %THEN FAULT("CONSTANT TABLE FULL") %AND %STOP
  COT(COTP)=CONST
  COTP=COTP+1
  %RESULT=COTP-1
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE PUSHTAG(%INTEGER IDENT,FORM,TYPE,DIM,LEVEL,RAD)
%INTEGER TAGI
  %IF TAGLINK(IDENT)#0 %AND TAG(TAGLINK(IDENT))>>16&X'F'=LEVEL %THEN %C
    FAULT("NAME ".NAME(IDENT)." DECLARED TWICE")
  TAGI=NEWTAG
  TAG(TAGI)=FORM<<28!TYPE<<24!DIM<<20!LEVEL<<16!RAD
  LINK(TAGI)=TAGLINK(IDENT)
  TAGLINK(IDENT)=TAGI
  TAGI=NEWTAG
  TAG(TAGI)=IDENT
  LINK(TAGI)=NAMELIST(LEVEL)
  NAMELIST(LEVEL)=TAGI
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE POPTAGS
%INTEGER CELL,IDENT,NAMETAG,PARAMS
  %IF TAGSOPT=1 %THEN NEWLINE
  CELL=NAMELIST(LEVEL)
  %WHILE CELL#0 %CYCLE
    IDENT=TAG(CELL)
    CELL=RETURNTAG(CELL)
    NAMETAG=TAG(TAGLINK(IDENT))
    TAGLINK(IDENT)=RETURNTAG(TAGLINK(IDENT))
    %IF TAGSOPT=1 %THEN PRINTSTRING(STRINT(IDENT,3)."   ". %C
      NAME(IDENT)."   ".STRHEX(NAMETAG))
    %IF NAMETAG>>28=4 %THEN %START    ;! PROCEDURE TYPE
      PARAMS=NAMETAG>>20&X'F'
      %WHILE PARAMS#0 %CYCLE
        %IF TAGSOPT=1 %THEN PRINT STRING("   ". %C
          STRHEX(TAG(TAGLINK(IDENT))))
        TAGLINK(IDENT)=RETURNTAG(TAGLINK(IDENT)) 
        PARAMS=PARAMS-1    ;! POP UP PARAMETER TAGS
      %REPEAT
    %FINISH
    %IF TAGSOPT=1 %THEN NEWLINE
    %IF TAGLINK(IDENT)=0 %THEN NAMEDP=NAMEDLINK(IDENT) %C
      %AND NAMEDLINK(IDENT)=0    ;! BACKTRACK NAME DICTIONARY
  %REPEAT
  %IF TAGSOPT=1 %THEN NEWLINE
  NAMELIST(LEVEL)=0
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN GETLABEL(%INTEGER CONSTP)
%INTEGER LABEL
  LABEL=A(CONSTP+1)
  %IF LABEL>9999 %THEN FAULT("LABEL ".STRINT(LABEL,1)." TOO LARGE") %C
    %AND %RESULT=-1 %ELSE %RESULT=LABEL
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE FILLLABEL(%INTEGER LABEL)
%INTEGER CELL
  %RETURN %IF LABEL<0    ;! FOR CONDITIONAL STATEMENTS
  CELL=BRANCHLIST(LEVEL)
  %WHILE CELL#0 %CYCLE
    %IF TAG(CELL)>>16=LABEL %THEN %START
      %IF TAG(CELL)&X'8000'=0 %THEN FAULT("DUPLICATE LABEL ". %C
        STRINT(LABEL,1)) %ELSE %START
        DUMP("FILL",STRINT(LABEL,1),STRINT(TAG(CELL)&X'7FFF',1),NEXTCAD)
        TAG(CELL)=LABEL<<16!NEXTCAD
      %FINISH
      %RETURN
    %FINISH
    CELL=LINK(CELL)
  %REPEAT
  CELL=NEWTAG
  LINK(CELL)=BRANCHLIST(LEVEL)
  BRANCHLIST(LEVEL)=CELL
  TAG(CELL)=LABEL<<16!NEXTCAD
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN FILLBRANCH(%INTEGER LABEL)
%INTEGER CELL,CAD
  %RESULT=0 %IF LABEL<0
  CELL=BRANCHLIST(LEVEL)
  %WHILE CELL#0 %CYCLE
    %IF TAG(CELL)>>16=LABEL %THEN %START
      CAD=TAG(CELL)&X'7FFF'
      %IF TAG(CELL)&X'8000'#0 %THEN TAG(CELL)=LABEL<<16!X'8000'!NEXTCAD
      %RESULT=CAD
    %FINISH
    CELL=LINK(CELL)
  %REPEAT
  CELL=NEWTAG
  LINK(CELL)=BRANCHLIST(LEVEL)
  BRANCHLIST(LEVEL)=CELL
  TAG(CELL)=LABEL<<16!X'8000'!NEXTCAD
  %RESULT=0
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE POPLABELS
%INTEGER CELL
  CELL=BRANCHLIST(LEVEL)
  %WHILE CELL#0 %CYCLE
    %IF TAG(CELL)&X'8000'#0 %THEN FAULT("LABEL ".STRINT(TAG(CELL)>>16,%C
      1)." NOT SET (BRANCH LIST ".STRINT(TAG(CELL)&X'7FFF',1).")")
    CELL=RETURNTAG(CELL)
  %REPEAT
  BRANCHLIST(LEVEL)=0
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN NEXTPLABEL
%OWNINTEGER PLABEL=9999
  PLABEL=PLABEL+1
  %RESULT=PLABEL
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE PUSHSTART(%INTEGER FLAG,PLAB)
%INTEGER CELL
  CELL=NEWTAG
  TAG(CELL)=FLAG<<16!PLAB&X'FFFF'    ;! PLAB MAY BE -1
  LINK(CELL)=STARTLIST(LEVEL)
  STARTLIST(LEVEL)=CELL
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE POPSTART(%INTEGERNAME FLAG,PLAB)
%INTEGER CELL
  CELL=STARTLIST(LEVEL)
  %IF CELL=0 %THEN %START
    FAULT("SPURIOUS %FINISH")
    FLAG=0
    PLAB=0
  %FINISH %ELSE %START
    FLAG=TAG(CELL)>>16
    PLAB=TAG(CELL)&X'FFFF'
    %IF PLAB=X'FFFF' %THEN PLAB=-1
    STARTLIST(LEVEL)=RETURNTAG(CELL)
  %FINISH
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE CLEARSTART
%INTEGER CELL
  CELL=STARTLIST(LEVEL)
  %WHILE CELL#0 %THEN FAULT("%FINISH MISSING") %AND CELL=RETURNTAG(CELL)
  STARTLIST(LEVEL)=0
%END
!-----------------------------------------------------------------------
%EXTERNALINTEGERFN ENTER
%STRING(4) BASE
%INTEGER CAD
  %IF LEVEL=1 %THEN %START
    %IF NEXTCAD#0 %THEN FAULT("%BEGIN NOT FIRST STATEMENT")
    DUMP("LDA","COT","",0)    ;! COT BASE ADDRESS TO BE FILLED
    DUMP("LDA","DR1","",0)    ;! STACK BASE ADDRESS TO BE FILLED
    BASE="DR1"
  %FINISH %ELSE %START
    DUMP("STR",DISPLAY(LEVEL),"STP",0)
    DUMP("LDA",DISPLAY(LEVEL),"STP",0)
    DUMP("STR","WK","STP",1)
    BASE="STP"
  %FINISH
  CAD=NEXTCAD
  DUMP("LDA","STP",BASE,0)    ;! STATIC ALLOCATION TO BE FILLED
  NEXTRAD(LEVEL)=2
  %RESULT=CAD
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE DUMPRETURN
  DUMP("LDA","STP",DISPLAY(LEVEL),0)
  DUMP("LOAD",DISPLAY(LEVEL),"STP",0)
  DUMP("LOAD","WK","STP",1)
  DUMP("B","","WK",0)
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE ARRAY(%INTEGER ARRAYP)
%INTEGER NAMEP,ACTUALP,EXPRP,EXPRSP,IDENT,NAMETAG
  NAMEP=A(ARRAYP+1)
  ACTUALP=A(ARRAYP+2)
  IDENT=A(NAMEP+1)
  %IF A(ACTUALP)=1 %THEN %START
    EXPRP=A(ACTUALP+1)
    EXPRSP=A(ACTUALP+2)
    EXPR(EXPRP)
    NAMETAG=TAG(TAGLINK(IDENT))
    DUMP("ADD","ACC",DISPLAY(NAMETAG>>16&X'F'),NAMETAG&X'FFFF')
    %IF A(EXPRSP)=1 %THEN FAULT("ARRAY ".NAME(IDENT)." HAS EXTRA INDEX")
  %FINISH %ELSE FAULT("ARRAY ".NAME(IDENT)." HAS NO INDEX")
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE PROC(%INTEGER PROCP)
%STRING(4) OPN,BASE
%INTEGER NAMEP,IDENT,NAMETAG,PTAGL,L,ACTUALP,EXPRP,UNARYP,OPERANDP, %C
  NPARS,PTAG,PNAMEP,PIDENT,PNAMETAG,PACTUALP,DISP,EXPRRESTP,EXPRSP, %C
  OLDPARAMS
  %IF PARAMS>2 %THEN DUMP("LDA","STP","STP",PARAMS)
  OLDPARAMS=PARAMS
  PARAMS=2
  NAMEP=A(PROCP+1)
  ACTUALP=A(PROCP+2)
  IDENT=A(NAMEP+1)
  L=TAGLINK(IDENT)
  NAMETAG=TAG(L)
  PTAGL=LINK(L)
  NPARS=NAMETAG>>20&X'F'
  %IF NPARS=0 %THEN %START
    %IF A(ACTUALP)=1 %THEN FAULT(NAME(IDENT)." HAS PARAMETERS") %C
      %AND %RETURN
  %FINISH %ELSE %START
    %IF A(ACTUALP)=2 %THEN FAULT(NAME(IDENT)." MISSING PARAMETERS") %C
      %AND %RETURN
    EXPRP=A(ACTUALP+1)
    EXPRSP=A(ACTUALP+2)
    %CYCLE    ;! FOR EACH PARAMETER
      PTAG=TAG(PTAGL)
      %IF PTAG>>28=0 %THEN EXPR(EXPRP) %ELSE %START
        UNARYP=A(EXPRP+1)
        OPERANDP=A(EXPRP+2)
        EXPRRESTP=A(EXPRP+3)
        %UNLESS A(UNARYP)=4 %AND A(OPERANDP)=1 %AND A(EXPRRESTP)=2 %C
          %THEN FAULT("NOT A %NAME PARAMETER") %ELSE %START
          PNAMEP=A(OPERANDP+1)
          PACTUALP=A(OPERANDP+2)
          PIDENT=A(PNAMEP+1)
          %IF TAGLINK(PIDENT)=0 %THEN FAULT(NAME(PIDENT). %C
            " NOT DECLARED") %ELSE %START
            PNAMETAG=TAG(TAGLINK(PIDENT))
            %IF PNAMETAG>>28=4 %THEN FAULT(NAME(PIDENT). %C
              " NOT A %NAME") %ELSE %START
              BASE=DISPLAY(PNAMETAG>>16&X'F')
              DISP=PNAMETAG&X'FFFF'
              %IF PTAG>>28=1 %THEN %START    ;! %NAME
                %IF PNAMETAG>>28>=2 %THEN ARRAY(OPERANDP) %ELSE %START
                  %IF PNAMETAG>>28=1 %THEN OPN="LOAD" %ELSE OPN="LDA"
                  DUMP(OPN,"ACC",BASE,DISP)
                  %IF A(PACTUALP)=1 %THEN FAULT(NAME(PIDENT). %C
                    " DECLARED AS SCALAR")
                %FINISH
              %FINISH %ELSE %START
                DUMP("LOAD","ACC",BASE,DISP)    ;! %ARRAY
                %IF A(PACTUALP)=1 %THEN FAULT("%ARRAYNAME ". %C
                   NAME(PIDENT)." HAS INDEX")
              %FINISH
            %FINISH
          %FINISH
        %FINISH
      %FINISH
      DUMP("STR","ACC","STP",PARAMS)
      PARAMS=PARAMS+1
      NPARS=NPARS-1
      %IF NPARS=0 %THEN %START
        %IF A(EXPRSP)=1 %THEN FAULT(NAME(IDENT)." HAS EXTRA PARAMETERS")
        %EXIT
      %FINISH
      PTAGL=LINK(PTAGL)
      %IF A(EXPRSP)=2 %THEN FAULT(NAME(IDENT). %C
        " IS MISSING PARAMETERS") %AND %EXIT
      EXPRP=A(EXPRSP+1)
      EXPRSP=A(EXPRSP+2)
    %REPEAT
  %FINISH
  ! EXTERNAL I/O ROUTINES AT LEVEL 0
  %IF NAMETAG>>16&X'F'=0 %THEN BASE="EXT" %ELSE BASE=""
  DUMP("BAL","WK",BASE,NAMETAG&X'FFFF')
  PARAMS=OLDPARAMS
  %IF PARAMS>2 %THEN DUMP("SUB","STP","COT",GETCOTI(PARAMS))
%END
!-----------------------------------------------------------------------
%EXTERNALROUTINE ENDOFPROG
%INTEGER I
  DUMP("FILL","COT","0",NEXTCAD)
  I=0
  %WHILE I<COTP %CYCLE
    DUMP("CONST","","",COT(I))
    I=I+1
  %REPEAT
  DUMP("FILL","STACK","1",NEXTCAD)
  PRINT STRING("
     $".STRINT(FAULTS,4)." FAULTS IN PROGRAM
")
  %STOP
%END
%ENDOFFILE