         Edinburgh IMP77 Compiler - Version 8.4

    1  !%ROUTINESPEC READ SYMBOL(%INTEGERNAME I)
    2  !%INTEGERFNSPEC NEXT SYMBOL
    3  !%ROUTINESPEC SKIP SYMBOL
    4  !%ROUTINESPEC PRINT SYMBOL(%INTEGER I)
    5  !%ROUTINESPEC READ(%INTEGERNAME I)
    6  !%ROUTINESPEC WRITE(%INTEGER I,J)
    7  !%ROUTINESPEC SPACE
    8  !%ROUTINESPEC SPACES(%INTEGER I)
    9  !%ROUTINESPEC NEWLINE
   10  !%ROUTINESPEC NEWLINES(%INTEGER I)
   11  !%ROUTINESPEC NEWPAGE
   12  
   13  %BEGIN
   14  %ROUTINESPEC READ PS
   15  %ROUTINESPEC READ LINE
   16  %INTEGERFNSPEC COMPARE
   17  %ROUTINESPEC SS
   18  %ROUTINESPEC FAULT(%INTEGER A,B,C,D)
   19  %INTEGERFNSPEC CHNEXT
   20  %INTEGERFNSPEC NEWCELL
   21  %INTEGERFNSPEC RETURN CELL(%INTEGER I)
   22  %ROUTINESPEC PRINT NAME(%INTEGER I)
   23  %INTEGER AP,APP,TP,PSP,ASL,BTN,CTN,CHP,FAULTS,LEVEL,CA,COMP,SCF
   24  %INTEGERARRAY PS(-1000:-600)                 ;! REDUCED PHRASE STRUCTURE
   25  %INTEGERARRAY TAG,LINK(0:1023)               ;! TAGS LISTS
   26  %INTEGERARRAY A(1:200)                       ;! ANALYSIS RECORD
   27  %INTEGERARRAY T(1:300)                       ;! SOURCE TEXT
   28  %INTEGERARRAY BAT,COT(0:1023)                ;! BRANCH, CONST TABLES
   29  %INTEGERARRAY CH(1:512)                      ;! NAME CHAR TABLE
   30  %INTEGERARRAY JUMP,STAR,BRT,NAME,RTP,BR,CHPP,START,RAD(0:15)  ;! LEVEL INFORMATION
   31  %INTEGERARRAY TRUE,FALSE(1:6)                ;! CONDITIONAL BRANCH INSTRUCTIONS
   32  %INTEGERARRAY PREC,UCN(1:12)                 ;! OPERATOR PRECEDENCES, TYPES
   33  %INTEGERARRAY OPR(0:12)                      ;! MACHINE OPERATIONS
   34  %INTEGERARRAY PT,PN,PTC(1:15)                ;! FOR RT SPECS, HEADINGS
   35       READ PS                             ;! READ IN AND REDUCE PHRASE STRUCTURE
   36       ASL=0                               ;! CLEAR HASHING AREA &
   37  L10:  TAG(ASL)=0                          ;!  CREATE AVAILABLE SPACE LIST
   38       LINK(ASL)=0                         ;!  IN REMAINDER
   39       %IF ASL>=256 %AND ASL<1023 %THEN LINK(ASL)=ASL+1
   40       ASL=ASL+1
   41       %IF ASL<=1023 %THEN ->L10
   42       ASL=256                             ;! AVAILABLE SPACE LIST POINTER
   43       BR(0)=M'BR0'                        ;! BASE REGISTER MNEMONICS
   44       BR(1)=M'BR1'
   45       BR(2)=M'BR2'
   46       BR(3)=M'BR3'
   47       BR(4)=M'BR4'
   48       BR(5)=M'BR5'
   49       BR(6)=M'BR6'
   50       BR(7)=M'BR7'
   51       BR(8)=M'BR8'
   52       BR(9)=M'BR9'
   53       BR(10)=M'BR10'
   54       BR(11)=M'BR11'
   55       BR(12)=M'BR12'
   56       BR(13)=M'BR13'
   57       BR(14)=M'BR14'
   58       BR(15)=M'BR15'
   59       TRUE(1)=M'BZ'                       ;! CONDITIONAL BRANCH MNEMONICS
   60       FALSE(1)=M'BNZ'
   61       TRUE(2)=M'BNZ'
   62       FALSE(2)=M'BZ'
   63       TRUE(3)=M'BNG'
   64       FALSE(3)=M'BG'
   65       TRUE(4)=M'BL'
   66       FALSE(4)=M'BNL'
   67       TRUE(5)=M'BNL'
   68       FALSE(5)=M'BL'
   69       TRUE(6)=M'BG'
   70       FALSE(6)=M'BNG'
   71       PREC(1)=3                           ;! OPERATOR PRECEDENCES
   72       PREC(2)=3                           ;! 4 : HIGHEST
   73       PREC(3)=2                           ;! 1 : LOWEST
   74       PREC(4)=1
   75       PREC(5)=1
   76       PREC(6)=3
   77       PREC(7)=2
   78       PREC(8)=2
   79       PREC(9)=1
   80       PREC(10)=1
   81       PREC(11)=1
   82       PREC(12)=4
   83       OPR(0)=M'LOAD'                      ;! MACHINE INSTRUCTION MNEMONICS
   84       OPR(1)=M'SHL'
   85       OPR(2)=M'SHR'
   86       OPR(3)=M'AND'
   87       OPR(4)=M'XOR'
   88       OPR(5)=M'OR'
   89       OPR(6)=M'EXP'
   90       OPR(7)=M'DIV'
   91       OPR(8)=M'MLT'
   92       OPR(9)=M'ADD'
   93       OPR(10)=M'SUB'
   94       OPR(11)=M'NEG'
   95       OPR(12)=M'NOT'
   96       UCN(1)=3                            ;! OPERATOR TYPES
   97       UCN(2)=3                            ;! 1 : UNARY
   98       UCN(3)=2                            ;! 2 : BINARY COMMUTATIVE
   99       UCN(3)=2                            ;! 3 : BINARY NON-COMMUTATIVE
  100       UCN(4)=2
  101       UCN(5)=2
  102       UCN(6)=3
  103       UCN(7)=3
  104       UCN(8)=2
  105       UCN(9)=2
  106       UCN(10)=3
  107       UCN(11)=1
  108       UCN(12)=1
  109       BTN=0                               ;! BRANCH TABLE POINTER
  110       CTN=0                               ;! CONSTANT TABLE POINTER
  111       CHP=1                               ;! NAME CHARACTER TABLE POINTER
  112       FAULTS=0                            ;! FAULT COUNT
  113       LEVEL=0                             ;! TEXTUAL LEVEL
  114       SCF=0                               ;! CONDITION FLAG
  115       JUMP(0)=0                           ;! JUMP LIST POINTER
  116       STAR(0)=0                           ;! STORAGE ALLOCATION POSITION IN COT
  117       NAME(0)=0                           ;! NAME LIST POINTER
  118       RTP(0)=-1                           ;! ROUTINE TYPE
  119       CHPP(0)=0                           ;! NAME CHARACTER TABLE POSITION
  120       START(0)=0                          ;! START/FINISH LIST
  121       RAD(0)=10                           ;! NEXT RELATIVE ADDRESS TO BE ALLOCATED
  122       CA=0                                ;! CURRENT CODE DUMPING ADDRESS
  123       PRINT SYMBOL('P')
  124       PRINT SYMBOL('R')
  125       PRINT SYMBOL('G')
  126       PRINT SYMBOL(':')
  127  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  128  L1:   READ LINE
  129       TP=1                                      ;! TEXT POINTER
  130  L2:   %IF T(TP)='!' %THEN ->L3                   ;! COMMENT - SKIP TO END
  131       PSP=-1000                                 ;! START OF <SS> IN PHRASE STRUCTURE TABLES
  132       AP=1
  133       %IF COMPARE=1 %THEN %START                ;! SUCCESSFUL ANALYSIS
  134          AP=1                                   ;! ANALYSIS RECORD POINTER
  135          SS                                     ;! PROCESS SOURCE STATEMENT
  136          %IF T(TP-1)=';' %THEN ->L2              ;! FURTHER STATEMENT ON THIS LINE
  137          ->L1 ; %FINISH                          ;! GO TO READ NEXT LINE
  138       FAULT(M'SYNT',M'AX ?',M'    ',M'    ')    ;! UNSUCCESSFUL ANALYSIS
  139  L5:   %IF T(TP)=10 %THEN ->L1                    ;! NEWLINE - READ NEXT LINE
  140       %IF T(TP)=';' %THEN %START                ;! END OF STATEMENT
  141          TP=TP+1                                ;! TP TO START OF NEXT STATEMENT
  142          ->L2 ; %FINISH                          ;! GO TO EXAMINE NEXT STATEMENT
  143  L3:   TP=TP+1                                   ;! SKIP TO NEXT CHARACTER OF STATEMENT
  144       ->L5
  145  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  146  %ROUTINE READ PS
  147  ! READ IN AND REDUCE PHRASE STRUCTURE
  148  %INTEGER PNP,ALT,P,I,J,K
  149  %INTEGERARRAY PN,PSP(256:300)    ;! PHRASE NAME CHARS & POINTERS TO START OF PHRASES IN PS
  150  %ROUTINESPEC INSERT LIT
  151  %INTEGERFNSPEC GET PN
  152       PNP=256                               ;! PN POINTER
  153       P=-1000                               ;! PS POINTER
  154  L1:   READ SYMBOL(I)
  155       %IF I='B' %THEN %START                ;! BUILT-IN PHRASE
  156  L2:      READ SYMBOL(I)                        ;! SKIP TO <
  157          %IF I\='<' %THEN ->L2
  158          J=GET PN                           ;! READ PHRASE NAME & GET POSITION IN PSP
  159  L3:      READ SYMBOL(I)                        ;! SKIP TO =
  160          %IF I\='=' %THEN ->L3
  161          READ(K)                            ;! READ PHRASE NUMBER
  162          PSP(J)=K                           ;! FILL IN PHRASE NUMBER
  163          ->L1 ; %FINISH                      ;! GO TO DEAL WITH NEXT PHRASE
  164       %IF I='P' %THEN %START                ;! PHRASE
  165  L4:      READ SYMBOL(I)                        ;! SKIP TO <
  166          %IF I\='<' %THEN ->L4
  167          PSP(GET PN)=P                      ;! READ PHRASE NAME & FILL IN PS POSITION
  168  L7:      ALT=P                              ;! REMEMBER START POSITION IN PS OF THIS ALTERNATIVE
  169  L6:      P=P+1                              ;! NEXT PS POSITION
  170  L5:      READ SYMBOL(I)                        ;! START OF NEXT ITEM IN THIS ALTERNATIVE
  171          %IF I='''' %THEN %START            ;! LITERAL TEXT
  172             INSERT LIT                      ;! READ LITERAL & INSERT IN PS
  173             ->L5 ; %FINISH                   ;! GO FOR NEXT ITEM
  174          %IF I='<' %THEN %START             ;! ITEM IS A PHRASE NAME
  175             PS(P)=GET PN                    ;! READ PHRASE NAME & FILL IN PS WITH PSP POSITION
  176             ->L6 ; %FINISH                   ;! GO FOR NEXT ITEM
  177          %IF I=',' %THEN %START             ;! END OF THIS ALTERNATIVE
  178             PS(ALT)=P                       ;! FILL IN POINTER TO END OF ALTERNATIVE
  179             ->L7 ; %FINISH                   ;! GO FOR START OF NEXT ALTERNATIVE
  180          %IF I=';' %THEN %START             ;! END OF PHRASE DEFINITION
  181             PS(ALT)=P                       ;! FILL IN POINTER TO END OF ALTERNATIVE
  182             PS(P)=0                         ;! FILL IN END OF PHRASE MARKER
  183             P=P+1                           ;! NEXT PS POSITION FOR START OF NEXT PHRASE DEFINITION
  184             ->L1 ; %FINISH                   ;! GO FOR NEXT PHRASE
  185          ->L5 ; %FINISH                      ;! SKIP TO SOMETHING SIGNIFICANT
  186       %IF I='E' %THEN %START                ;! END OF PHRASE STRUCTURE DEFINITIONS
  187          I=-1000                            ;! REPLACE ALL POINTERS TO PSP WITH CORRECT PS POINTERS
  188  L8:      %IF PS(I)>=256 %THEN PS(I)=PSP(PS(I))
  189          I=I+1
  190          %IF I\=P %THEN ->L8
  191          %RETURN ; %FINISH
  192       ->L1                                   ;! SKIP TO SOMETHING SIGNIFICANT
  193  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  194  %ROUTINE INSERT LIT
  195  ! INSERT LITERAL TEXT INTO 'PS'
  196  %INTEGER SH,I
  197       SH=0                                  ;! % SHIFT VALUE TO 0
  198  L1:   READ SYMBOL(I)
  199       %IF I='''' %THEN %START
  200          %IF NEXT SYMBOL\='''' %THEN %RETURN    ;! END OF LITERAL
  201          READ SYMBOL(I)                    ;! QUOTE INSIDE LITERAL - IGNORE ONE
  202          %FINISH
  203       %IF I='%' %THEN SH=128 %ELSE %START   ;! SHIFT VALUE TO 128 FOR %
  204          %IF I<'A' %OR I>'Z' %THEN SH=0     ;! END OF KEYWORD - SHIFT VALUE TO 0
  205          PS(P)=I+SH                     ;! STORE SHIFTED (POSSIBLY) CHAR IN PS
  206          P=P+1                          ;! MOVE TO NEXT POSITION IN PS
  207          %FINISH
  208       ->L1
  209  %END
  210  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  211  %INTEGERFN GET PN
  212  ! READ IN PHRASE NAME AND GET INDEX IN 'PSP'
  213  %INTEGER NP,S,I
  214       NP=0                            ;! TO ACCUMULATE PHRASE NAME CHARS
  215       S=24                            ;! INITIAL SHIFT VALUE TO PACK CHARS
  216  L1:   READ SYMBOL(I)
  217       %IF I\='>' %THEN %START         ;! NOT END OF NAME YET
  218          NP=NP!I<<S                   ;! PACK NEXT CHAR OF PHRASE NAME
  219          S=S-8                        ;! REDUCE SHIFT VALUE FOR NEXT CHAR
  220          ->L1 ; %FINISH
  221       %IF PNP\=256 %THEN %START       ;! NOT FIRST PHRASE NAME
  222          I=256                        ;! SCAN NAMES TO FIND IF ALREADY IN
  223  L2:      %IF NP=PN(I) %THEN %RESULT=I
  224          I=I+1
  225          %IF I\=PNP %THEN ->L2
  226          %FINISH
  227       PN(PNP)=NP                      ;! INSERT NEW NAME IN DICTIONARY
  228       PSP(PNP)=99999                  ;! UNDEFINED PHRASE MARKER
  229       PNP=PNP+1                       ;! MOVE TO NEXT DICTIONARY POSITION
  230       %RESULT=PNP-1
  231  %END
  232  %END
  233  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  234  %ROUTINE READ LINE
  235  ! LEXICAL PHASE - READ & CLEAN UP NEXT LINE OF TEXT
  236  %ROUTINESPEC STORE(%INTEGER I)
  237  %INTEGER SH,I
  238       NEWLINES(2)
  239       PRINT SYMBOL(';')
  240       SH=0                                ;! % & LITERAL SHIFT VALUE TO 0
  241       TP=1                                ;! POINTER TO TEXT ARRAY T
  242  L1:   READ SYMBOL(I)
  243       %IF I=10 %AND TP=1 %THEN ->L1
  244       PRINT SYMBOL(I)
  245       %IF I='''' %THEN %START
  246          SH=128                           ;! SHIFT VALUE FOR LITERAL
  247  L2:      STORE(I)                         ;! STORE SHIFTED CHAR IN TEXT ARRAY
  248          READ SYMBOL(I)
  249          PRINT SYMBOL(I)
  250          %IF I=10 %THEN PRINT SYMBOL(';')
  251          %IF I\='''' %THEN ->L2            ;! NOT END OF LITERAL YET
  252          READ SYMBOL(I)
  253          PRINT SYMBOL(I)
  254          %IF I='''' %THEN ->L2             ;! QUOTE IN LITERAL - IGNORE ONE
  255          SH=0                             ;! SHIFT VALUE TO 0 FOR END OF LITERAL
  256          STORE('''')                      ;! STORE UNSHIFTED VALUE TO MARK END
  257          %FINISH
  258       %IF I='%' %THEN SH=128 %ELSE %START ;! SHIFT VALUE TO 128 FOR KEYWORD
  259          %IF I<'A' %OR I>'Z' %THEN SH=0   ;! SHIFT VALUE TO 0 FOR END OF KEYWORD
  260          %IF I\=' ' %THEN %START          ;! IGNORE SPACES
  261             STORE(I)
  262             %IF I=10 %THEN %START         ;! NEWLINE CHAR
  263                %IF T(TP-2)='C'+128 %THEN %START
  264                   TP=TP-2
  265                   PRINT SYMBOL(';')
  266                   %FINISH %ELSE %RETURN
  267                %FINISH
  268             %FINISH
  269          %FINISH
  270       ->L1
  271  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  272  %ROUTINE STORE(%INTEGER I)
  273  ! STORE (POSSIBLY) SHIFTED CHARACTER IN TEXT ARRAY & CHECK LINE NOT TOO LONG
  274       %IF TP>300 %THEN %START
  275          FAULT(M'STAT',M'MNT ',M'TOO ',M'LONG')
  276          TP=1
  277          %FINISH
  278       T(TP)=I+SH                      ;! STORE CHAR IN TEXT ARRAY
  279       TP=TP+1                         ;! MOVE TO NEXT POSITION
  280  %END
  281  %END
  282  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  283  %INTEGERFN COMPARE
  284  ! ANALYSE PHRASE
  285  %INTEGERFNSPEC NAME            ;! BUILT-IN PHRASE NAME
  286  %INTEGERFNSPEC CNST            ;! BUILT-IN PHRASE <CNST>
  287  %INTEGER APP,TPP,PSPP,AE,N
  288       TPP=TP                              ;! PRESERVE INITIAL TEXT POINTER
  289       APP=AP                              ;! PRESERVE INITIAL ANALYSIS RECORD
  290       A(AP)=1                             ;! ALTERNATIVE 1 FIRST
  291  L11:  AE=PS(PSP)                          ;! POINTER TO END OF ALTERNATIVE
  292       PSP=PSP+1                           ;! FIRST ITEM OF ALTERNATIVE DEFN
  293  L12:  %IF PSP=AE %THEN %RESULT=1          ;! END OF ALT REACHED - SUCCESS
  294       N=PS(PSP)                           ;! NEXT ITEM OF ALT DEFN
  295       PSP=PSP+1                           ;! FOR FOLLOWING ITEM
  296       %IF N<0 %THEN %START                ;! SUB-PHRASE
  297          PSPP=PSP                         ;! PRESERVE PS POINTER
  298          PSP=N                            ;! POINTER TO DEFN OF SUB-PHRASE
  299          AP=AP+1                          ;! NEXT ANALYSIS RECORD POSITION
  300          N=COMPARE                        ;! RECURSIVE COMPARISON FOR SUB-PHRASE
  301          PSP=PSPP                         ;! RESTORE PS POINTER
  302          %IF N=1 %THEN ->L12               ;! SUCCESSFUL COMPARISON - GO FOR NEXT ITEM
  303          ->L13 ; %FINISH                   ;! UNSUCCESSFUL - GO FOR NEXT ALTERNATIVE
  304       %IF N=1 %THEN %START                ;! BUILT-IN PHRASE <NAME>
  305          %IF NAME=1 %THEN ->L12            ;! SUCCESS
  306          ->L13 ; %FINISH                   ;! FAILURE
  307       %IF N=2 %THEN %START                ;! BUILT-IN PHRASE CNST
  308          %IF CNST=1 %THEN ->L12            ;! SUCCESS
  309          ->L13 ; %FINISH                   ;! FAILURE
  310       %IF N=T(TP) %THEN %START            ;! LITERAL - MATCHES SOURCE CHAR
  311          TP=TP+1                          ;! MOVE TO NEXT SOURCE CHAR
  312          ->L12 ; %FINISH                   ;! GO FOR NEXT ITEM
  313  L13:  %IF PS(AE)=0 %THEN %RESULT=0        ;! END OF PHRASE
  314       PSP=AE                              ;! START OF DEFN OF NEXT ALTERNATIVE
  315       TP=TPP                              ;! BACKTRACK SOURCE TEXT
  316       AP=APP                              ;!  AND ANALYSIS RECORD POINTERS
  317       A(AP)=A(AP)+1                       ;! COUNT ALTERNATIVE NUMBER ON ONE
  318       ->L11                                ;! GO TO ANALYSE NEW ALTERNATIVE
  319  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  320  %INTEGERFN NAME
  321  ! RECOGNISE AND INSERT NAME IN HASHING AREA OF TAG/LINK ARRAYS
  322  %INTEGER I,J,K,L,M,N
  323       I=T(TP)                             ;! FIRST SOURCE CHAR
  324       %IF I<'A' %OR I>'Z' %OR (I='M' %AND T(TP+1)=''''+128) %THENRESULT=0
  325                                           ;! FAILURE - NOT A LETTER OR AN M-TYPE CONSTANT
  326       J=CHP                               ;! NEXT POSITION IN CHARACTER ARRAY
  327       K=I<<16                             ;! LEAVE HOLE FOR LENGTH & PACK FIRST CHAR
  328       L=1                                 ;! NO OF CHARS
  329       M=8                                 ;! NEXT SHIFT VALUE FOR PACKING
  330       N=I                                 ;! SUM VALUE OF CHARS FOR HASHING
  331  L1:   TP=TP+1
  332       I=T(TP)                             ;! NEXT CHAR FROM TEXT ARRAY
  333       %IF ('0'<=I %AND I<='9') %OR ('A'<=I %AND I<='Z') %THEN %START
  334                                           ;! A DIGIT OR A LETTER
  335          K=K!I<<M                         ;! PACK NEXT LETTER
  336          L=L+1                            ;! CHARACTER COUNT
  337          M=M-8                            ;! NEXT SHIFT
  338          N=N+I                            ;! SUM OF LETTERS
  339          %IF M<0 %THEN %START             ;! PACKED WORD OF CHARS FULL
  340             CH(CH NEXT)=K                 ;! STORE WORD IN CHAR ARRAY
  341             K=0                           ;! PACKING WORD TO ZERO
  342             M=24                          ;! NEW SHIFT VALUE
  343             %FINISH
  344          ->L1 ; %FINISH                    ;! GO FOR NEXT CHAR
  345       %IF K\=0 %THEN CH(CH NEXT)=K        ;! STORE ANY REMAINING CHARS IN CHAR ARRAY
  346       CH(J)=CH(J)!L<<24                   ;! FILL IN LENGTH IN HOLE LEFT IN FIRST WORD
  347       I=(N&15)<<4!N>>4&15                 ;! HASH VALUE
  348       K=I                                 ;! SCAN DICTIONARY FOR NAME
  349  L2:   %IF TAG(K)\=0 %THEN %START          ;! A NAME IN THIS POSITION
  350          L=TAG(K)                         ;! CHAR ARRAY POSITION
  351          M=J                              ;! CHAR ARRAY POSITION OF NEW NAME
  352  L4:      %IF CH(L)=CH(M) %THEN %START     ;! PACKED WORDS MATCH
  353             M=M+1                         ;! NEXT WORD OF NEW NAME
  354             %IF M=CHP %THEN %START        ;! NAMES MATCH
  355                CHP=J                      ;! MOVE CHP BACK SINCE NAME ALREADY IN
  356                ->L3 ; %FINISH
  357             L=L+1                         ;! NEXT WORD OF OLD NAME
  358             ->L4 ; %FINISH                 ;! GO FOR NEXT WORD
  359          K=(K+1)&255                      ;! NO MATCH SO TRY NEXT DICTIONARY POSITION
  360          %IF K=I %THEN %START             ;! STARTING POSITION REACHED AGAIN
  361             FAULT(M'DICT',M'IONA',M'RY F',M'ULL ')
  362             %STOP ; %FINISH
  363          ->L2 ; %FINISH
  364       TAG(K)=J                            ;! STORE CHAR ARRAY POSITION OF NAME
  365  L3:   AP=AP+1                             ;! NEXT ANALYSIS RECORD POSITION
  366       A(AP)=K                             ;! STORE IDENTIFICATION NO OF NAME
  367       %RESULT=1                           ;! SUCCESS
  368  %END
  369  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  370  %INTEGERFN CNST
  371  ! RECOGNISE INTEGER AND LITERAL TEXT CONSTANTS
  372  %INTEGER I,J,K
  373       I=T(TP)                             ;! FIRST CHAR
  374       %IF I='M' %AND T(TP+1)=''''+128 %THEN %START  ;! M-TYPE CONSTANT
  375          TP=TP+1                          ;! IGNORE THE M
  376          I=T(TP)
  377          %FINISH
  378       %IF I=''''+128 %THEN %START         ;! START OF A LITERAL
  379          J=0                              ;! TO ACCUMULATE LITERAL VALUE
  380          K=0                              ;! CHARACTER COUNT
  381  L1:      TP=TP+1
  382          I=T(TP)                          ;! NEXT CHAR
  383          %IF I\='''' %THEN %START         ;! NOT END OF LITERAL
  384             J=J<<8!I&127                  ;! PACK CHAR
  385             K=K+1                         ;! COUNT CHAR
  386             ->L1 ; %FINISH
  387          TP=TP+1                          ;! POINTER AFTER QUOTE
  388          %IF K>4 %THEN FAULT(M'STRI',M'NG T',M'OO L',M'ONG ')
  389          ->L2 ; %FINISH
  390       %IF I<'0' %OR I>'9' %THEN %RESULT=0 ;! NOT A CONSTANT
  391       J=0
  392  L3:   J=10*J+I-'0'                        ;! ACCUMULATE DECIMAL VALUE
  393       TP=TP+1
  394       I=T(TP)                             ;! NEXT CHAR
  395       %IF '0'<=I %AND I<='9' %THEN ->L3    ;! A DIGIT - STILL PART OF CONSTANT
  396  L2:   AP=AP+1                             ;! NEXT ANALYSIS RECORD POSITION
  397       A(AP)=J                             ;! FILL IN VALUE OF CONSTANT
  398       %RESULT=1                           ;! SUCCESS
  399  %END
  400  %END
  401  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  402  %ROUTINE SS
  403  ! COMPILE SOURCE STATEMENT
  404  %ROUTINESPEC UI
  405  %ROUTINESPEC SCCOND(%INTEGERNAME LABEL)
  406  %ROUTINESPEC SEXPR
  407  %INTEGERFNSPEC FIND LABEL
  408  %ROUTINESPEC CHECK
  409  %ROUTINESPEC UNSET
  410  %ROUTINESPEC PUSH START(%INTEGER FLAG,LABEL)
  411  %INTEGERFNSPEC BT NEXT
  412  %INTEGERFNSPEC CT NEXT
  413  %INTEGERFNSPEC WS NEXT
  414  %ROUTINESPEC STORE TAG(%INTEGER NAME,FORM,TYPE,DIM,LEV,AD)
  415  %ROUTINESPEC DUMP(%INTEGER OP,REG,BASE,DISP)
  416  %ROUTINESPEC SKIP SEXPR
  417  %ROUTINESPEC SKIP APP
  418  %ROUTINESPEC RT
  419  %ROUTINESPEC ARRAD
  420  %ROUTINESPEC ENTER(%INTEGER TYPE,ALLOC)
  421  %ROUTINESPEC RETURN
  422  %INTEGER I,J,K,L,M,N,P,Q,R,WS,LABEL
  423       I=A(AP)                             ;! ANALYSIS RECORD ENTRY
  424       AP=AP+1                             ;! FOR FOLLOWING ENTRY
  425       WS=2                                ;! SET WORKSPACE POINTER
  426       %IF I=1 %THEN ->L10                  ;! UNCONDITIONAL INSTRUCTION
  427       %IF I=2 %THEN ->L20                  ;! CONDITIONAL STATEMENT
  428       %IF I=3 %THEN ->L30                  ;! LABEL
  429       %IF I=4 %THEN ->L40                  ;! %FINISH
  430       %IF I=5 %THEN ->L50                  ;! DECLARATIONS
  431       %IF I=6 %THEN ->L60                  ;! ROUTINE/FN SPEC
  432       %IF I=7 %THEN ->L70                  ;! %END
  433       %IF I=8 %THEN ->L80                  ;! %BEGIN
  434       %IF I=9 %THEN ->L90                  ;! %ENDOFPROGRAM
  435       %RETURN                             ;! <SEP>
  436  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  437  ! UI
  438  L10:  UI                                  ;! COMPILE UNCONDITIONAL INSTRUCTION
  439       %RETURN
  440  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  441  ! %IF . . . %THEN . . .  %ELSE
  442  L20:  SCCOND(I)                           ;! COMPILE CONDITION
  443       %IF A(AP)=2 %THEN %START            ;! AP ON <UI> - JUMP INSTRUCTION
  444          AP=AP+2                          ;! AP ON <ELSE>
  445          J=-1                             ;! MARKER FOR 'JUMP'
  446          %FINISH %ELSE %START             ;! NOT A JUMP
  447          %IF A(AP)=3 %THEN %START         ;! %START
  448             %IF A(AP+1)=1 %THEN FAULT(M'%STA',M'RT %',M'ELSE',M' ?  ')
  449             PUSH START(0,I)
  450             %RETURN ; %FINISH
  451          UI                               ;! COMPILE REMAINING UNCOND. INSTNS.
  452          J=0                              ;! 'NOT JUMP' MARKER
  453          %FINISH
  454       %IF A(AP)=1 %THEN %START            ;! <ELSE>-CLAUSE PRESENT
  455          %IF J=0 %THEN %START             ;! <UI> WAS NOT A JUMP
  456             J=BT NEXT                     ;! JUMP ROUND <ELSE>-CLAUSE <UI>
  457             DUMP('B',0,M'BT',J)
  458             %FINISH
  459          %IF I>=0 %THEN BAT(I)=CA         ;! FILL IN LABEL ON <ELSE>-CLAUSE <UI>
  460          AP=AP+1                          ;! AP ON <UI>
  461          %IF A(AP)=3 %THEN %START         ;! %START
  462             PUSH START(1,J)
  463             %RETURN ; %FINISH
  464          UI                               ;! COMPILE REMAINING <UI>S
  465          I=J                              ;! JUMP AROUND LABEL
  466          %FINISH
  467       %IF I>=0 %THEN BAT(I)=CA            ;! TO BRANCH ROUND THE UI
  468       %RETURN
  469  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  470  ! CONST: . . .
  471  L30:  I=FIND LABEL                        ;! LOCATE/INSERT LABEL IN JUMP LIST
  472       %IF I>=0 %THEN %START               ;! VALID LABEL
  473          %IF BAT(I)>=0 %THEN %START
  474             WRITE(LABEL,1)
  475             SPACES(2)
  476             FAULT(M'LABE',M'L SE',M'T TW',M'ICE ')
  477             %FINISH
  478          BAT(I)=CA                        ;! FILL IN LABEL ADDRESS
  479          %FINISH
  480       SS                                  ;! COMPILE STATEMENT AFTER LABEL
  481       %RETURN
  482  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  483  ! %FINISH . . .
  484  L40:  I=START(LEVEL)                           ;! LINK TO FIRST CELL IN START LIST
  485       %IF I=0 %THEN %START                     ;! NO CELLS IN LIST
  486          FAULT(M'SPUR',M'IOUS',M' %FI',M'NISH')
  487          %RETURN ; %FINISH
  488       J=TAG(I)&65535                           ;! JUMP AROUND LABEL
  489       K=TAG(I)>>16                             ;! BEFORE OR AFTER %ELSE MARKER
  490       START(LEVEL)=RETURN CELL(I)              ;! POP UP CELL
  491       %IF A(AP)=1 %THEN %START                 ;! %ELSE PRESENT
  492          %IF K=1 %THEN FAULT(M'TWO ',M'%ELS',M'ES !',M'    ')
  493          K=BT NEXT                             ;! JUMP AROUND <UI>
  494          DUMP('B',0,M'BT',K)
  495          %IF J\=65535 %THEN BAT(J)=CA          ;! FILL IN LABEL ON <UI> IF NECESSARY
  496          AP=AP+1                               ;! AP ON <UI>
  497          %IF A(AP)=3 %THEN %START              ;! %START
  498             PUSH START(1,K)
  499             %RETURN ; %FINISH
  500          UI                                    ;! COMPILE REMAINING <UI>S
  501          J=K                                   ;! JUMP AROUND LABEL
  502          %FINISH
  503       %IF J\=65535 %THEN BAT(J)=CA             ;! FILL IN JUMP AROUND LABEL IF NECESSARY
  504       %RETURN
  505  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  506  ! DECLARATIONS
  507  L50:  %IF A(AP)=1 %THEN %START                        ;! <ARR> = %ARRAY
  508          APP=AP                                       ;! SAVE AP
  509  L51:     AP=AP+2                                      ;! AP ON <NAMS>
  510          %IF A(AP)=1 %THEN ->L51                       ;! SKIP DOWN TO END OF LIST OF NAMES
  511          AP=AP+1                                      ;! AP ON <+-\>
  512          SEXPR                                        ;! COMPILE EXPRESSION - LOWER BOUND
  513          DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)        ;! STORE VALUE IN WORKSPACE
  514          SEXPR                                        ;! COMPILE EXPRESSION - UPPER BOUND
  515          DUMP(M'LDA',M'ACC',M'ACC',1)                 ;! INCREMENT VALUE BY 1
  516          %IF A(AP)=1 %THEN %START                     ;! 2-DIM ARRAYS
  517             DUMP(M'SUB',M'ACC',BR(LEVEL),WS-1)        ;! PERFORM 2-DIM ARRAY DECLARATION CALCULATIONS
  518             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
  519             AP=AP+1
  520             SEXPR                                     ;! LOWER BOUND EXPR FOR 2ND DIM
  521             DUMP(M'MLT',M'ACC',BR(LEVEL),WS-1)
  522             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
  523             SEXPR                                     ;! UPPER BOUND EXPR FOR 2ND DIM
  524             DUMP(M'LDA',M'ACC',M'ACC',1)
  525             DUMP(M'MLT',M'ACC',BR(LEVEL),WS-2)
  526             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
  527             WS=WS-4                                   ;! RESTORE WORKSPACE POINTER
  528             I=2                                       ;! NO OF DIMS
  529             %FINISH %ELSE %START                      ;! 1-DIM ARRAYS
  530             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
  531             WS=WS-2                                   ;! RESTORE WORKSPACE POINTER
  532             I=1                                       ;! NO OF DIMS
  533             %FINISH
  534          J=2                                          ;! TAG FOR 'ARRAY'
  535          AP=APP                                       ;! RESTORE AP TO BEFORE LIST OF NAMES
  536          %FINISH %ELSE %START                         ;! SCALAR DECLARATIONS
  537          I=0                                          ;! DIMS=0 FOR SCALARS
  538          J=0                                          ;! TAG FOR SCALAR
  539          %FINISH
  540  L52:  STORE TAG(A(AP+1),J,1,I,LEVEL,RAD(LEVEL))       ;! PUSHDOWN TAG FOR THIS NAME
  541       %IF I=0 %THEN RAD(LEVEL)=RAD(LEVEL)+1 %ELSE %START;! ONE RELATIVE LOCATION FOR SCALARS
  542          %IF I=1 %THEN %START                         ;! 1-DIM ARRAYS
  543             DUMP(M'SUB',M'STP',BR(LEVEL),WS)
  544             DUMP(M'STR',M'STP',BR(LEVEL),RAD(LEVEL))
  545             DUMP(M'ADD',M'STP',BR(LEVEL),WS+1)
  546             %FINISH %ELSE %START                      ;! 2-DIM ARRAYS
  547             DUMP(M'LOAD',M'ACC',BR(LEVEL),WS+1)
  548             DUMP(M'STR',M'ACC',BR(LEVEL),RAD(LEVEL))
  549             DUMP(M'SUB',M'STP',BR(LEVEL),WS+2)
  550             DUMP(M'LDA',M'ACC',M'STP',0)
  551             DUMP(M'SUB',M'ACC',BR(LEVEL),WS)
  552             DUMP(M'STR',M'ACC',BR(LEVEL),RAD(LEVEL)+1)
  553             DUMP(M'ADD',M'STP',BR(LEVEL),WS+3)
  554             %FINISH
  555          RAD(LEVEL)=RAD(LEVEL)+2                      ;! 2 RELATIVE LOCATIONS FOR ARRAYS
  556          %FINISH
  557       AP=AP+2                                         ;! AP ON <NAMS>
  558       %IF A(AP)=1 %THEN ->L52                          ;! MORE NAMES IN LIST OF NAMES
  559       %RETURN
  560  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  561  ! RT SPEC? . . .
  562  L60:  I=A(AP)-1                                          ;! ROUTINE/FN
  563       J=A(AP+1)                                          ;! SPEC ?
  564       K=A(AP+2)                                          ;! NAME OF ROUTIINE OR FN
  565       AP=AP+3                                            ;! AP ON <FPP>
  566       L=0                                                ;! PARAMETER COUNT
  567       M=10                                               ;! FIRST RELATIVE ADDRESS TO BE ALLOCATED
  568  L63:  %IF A(AP)=1 %THEN %START                           ;! PARAMETERS PRESENT
  569          AP=AP+1                                         ;! AP ON <ARRN>
  570          %IF A(AP)=1 %THEN N=3 %ELSE N=3-A(AP)           ;! SET TAG FOR PARAMETER FORM
  571          P=N<<28!1<<24!(LEVEL+1)<<16                     ;! SET UP PATTERN FOR WHOLE TAG
  572  L62:     L=L+1                                           ;! PARAMETER COUNT
  573          %IF L>15 %THEN %START
  574             FAULT(M'TOO ',M'MANY',M' PAR',M'AMS ')
  575             ->L61 ; %FINISH                               ;! IGNORE SUPERFLUOUS PARAMS
  576          PT(L)=P!M                                       ;! STORE TAG FOR THIS PARAM
  577          PN(L)=A(AP+1)                                   ;! STORE THE NAMES IDENT. NO
  578          %IF N=3 %THEN M=M+2 %ELSE M=M+1                 ;! NEXT RELATIVE ADDRESS
  579          AP=AP+2                                         ;! AP ON <NAMS>
  580          %IF A(AP)=1 %THEN ->L62                          ;! MORE NAMES IN LIST
  581          AP=AP+1                                         ;! AP ON <FPS>
  582          ->L63 ; %FINISH
  583  L61:  N=LINK(K)                                          ;! LINK TO TAG FOR NAME OF ROUTINE OR FN
  584       %IF N=0 %OR TAG(N)>>16&15<LEVEL %THEN %START       ;! NAME NOT SET OR SET AT LOWER LEVEL
  585          %IF L>0 %THEN %START                            ;! PARAMETERS PRESENT
  586             P=1                                          ;! PARAMETER COUNT
  587             Q=K                                          ;! 'INSERT AFTER' POINTER
  588  L64:        R=NEWCELL                                    ;! PUSHDOWN TAG FOR PARAMETER
  589             TAG(R)=PT(P)
  590             LINK(R)=LINK(Q)
  591             PTC(P)=R                                     ;! SAVE POINTER TO TAG CELL
  592             LINK(Q)=R
  593             Q=R                                          ;! NEW VALUE FOR 'INSERT AFTER' POINTER
  594             P=P+1                                        ;! PARAMETER COUNT
  595             %IF P<=L %THEN ->L64                          ;! MORE PARAMETERS YET
  596             %FINISH
  597          STORE TAG(K,4,I,L,LEVEL,BT NEXT)                ;! PUSHDOWN TAG FOR NAME OF ROUTINE OR FN
  598          %IF LEVEL=0 %THEN BAT(BTN-1)=K+65536            ;! FLAG FOR EXTERNAL SPECS
  599          %FINISH %ELSE %START                            ;! NAME ALREADY SET AT THIS LEVEL
  600          %IF J=2 %AND TAG(N)>>28=4 %THEN %START          ;! STATEMENT NOT A SPEC & FORM OF NAME IS RT
  601             %IF TAG(N)>>24&15\=I %THEN %START
  602                PRINT NAME(K)
  603                FAULT(M'RT N',M'OT A',M'S SP',M'EC  ')
  604                %FINISH
  605             %IF BAT(TAG(N)&65535)>=0 %THEN %START
  606                PRINT NAME(K)
  607                FAULT(M'RT A',M'PPEA',M'RS T',M'WICE')
  608                %FINISH
  609             P=TAG(N)>>20&15                              ;! NO OF PARAMS IN SPEC
  610             %IF L\=P %THEN %START
  611                FAULT(M'PARS',M' NOT',M' AS ',M'SPEC')
  612                %IF L>P %THEN L=P                         ;! IGNORE SUPERFLUOUS PARAMS
  613                %FINISH
  614             %IF L>0 %THEN %START                         ;! PARAMS PRESENT
  615                P=1                                       ;! PARAM COUNT
  616                Q=LINK(N)                                 ;! LINK TO TAG OF FIRST PARAM
  617  L67:           %IF PT(P)!TAG(Q)&15<<20\=TAG(Q) %THEN %START
  618                   PRINT NAME(PN(P))
  619                   FAULT(M'PAR ',M'NOT ',M'AS S',M'PEC ')
  620                   %FINISH
  621                PTC(P)=Q                                  ;! SAVE POINTER TO TAG CELL
  622                P=P+1                                     ;! PARAM COUNT
  623                Q=LINK(Q)                                 ;! NEXT TAG CELL
  624                %IF P<=L %THEN ->L67                       ;! MORE PARAMS
  625                %FINISH
  626             %FINISH %ELSE %START
  627             PRINT NAME(K)
  628             FAULT(M'NAME',M' SET',M' TWI',M'CE  ')
  629             %FINISH
  630          %FINISH
  631  L68:  %IF J=2 %THEN %START                               ;! STATEMENT NOT A SPEC
  632          BRT(LEVEL)=BT NEXT                              ;! BRANCH ROUND ROUTINE OR FN
  633          DUMP('B',0,M'BT',BRT(LEVEL))
  634          BAT(TAG(LINK(K))&65535)=CA                      ;! FILL IN ADDRESS OF THIS ROUTINE OR FN
  635          %IF LEVEL=15 %THEN FAULT(M'TOO ',M'MANY',M' LEV',M'ELS ') %C
  636+                               %ELSE LEVEL=LEVEL+1       ;! NEXT TEXTUAL LEVEL
  637          ENTER(I,M)
  638          %IF L>0 %THEN %START                            ;! PARAMS PRESENT
  639             P=1                                          ;! PARAM COUNT
  640  L69:        I=PT(P)                                      ;! PUSHDOWN TAGS FOR PARAMS
  641             %IF I>>28=3 %THEN STORE TAG(PN(P),3,1,0,LEVEL,PTC(P)) %C
  642+               %ELSE STORE TAG(PN(P),I>>28,1,0,LEVEL,I&65535) ;! TREAT ARRAYNAMES SPECIALLY
  643             P=P+1
  644             %IF P<=L %THEN ->L69                          ;! MORE PARAMS YET
  645             %FINISH
  646          %FINISH
  647       %RETURN
  648  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  649  ! %END
  650  L70:  CHECK                                       ;! CHECK LABELS & START/FINISH BLOCKS
  651       COT(STAR(LEVEL))=RAD(LEVEL)                 ;! STORE STATIC ALLOCATION FOR THIS LEVEL
  652       UNSET                                       ;! UNSET NAMES DECLARED AT THIS LEVEL
  653       CHP=CHPP(LEVEL)
  654       %IF RTP(LEVEL)\=0 %THEN DUMP(M'STOP',0,0,0) ;! %STOP FOR FNS
  655       RETURN                                      ;! DUMP %RETURN CODE
  656       LEVEL=LEVEL-1                               ;! DECREMENT TEXTUAL LEVEL COUNT
  657       %IF LEVEL<1 %THEN %START                    ;! NOT BACK AT OUTER LEVEL YET
  658          FAULT(M'EXCE',M'SS %',M'END ',M'    ')
  659          ->L71 ; %FINISH                           ;! TREAT AS %ENDOFPROGRAM
  660       BAT(BRT(LEVEL))=CA                          ;! FILL ADDR FOR BRANCH ROUND ROUTINE/FN
  661       %RETURN
  662  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  663  ! %BEGIN
  664  L80:  %IF LEVEL\=0 %THEN %START
  665          FAULT(M'%BEG',M'IN E',M'XTRA',M'    ')   ;! NO INTERNAL BLOCKS ALLOWED
  666          %RETURN ; %FINISH
  667       %IF CA\=0 %OR RAD(0)\=10 %THEN %START
  668          FAULT(M'%BEG',M'IN N',M'OT F',M'IRST')
  669          %RETURN ; %FINISH
  670       LEVEL=1                                ;! TEXTUAL LEVEL COUNT TO 1
  671       ENTER(-1,10)
  672       %RETURN
  673  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  674  ! %ENDOFPROGRAM
  675  L90:  CHECK                                  ;! CHECK LABELS & START/FINISHES
  676       COT(STAR(LEVEL))=RAD(LEVEL)            ;! FILL IN STATIC ALLOCATION FOR OUTER BLOCK
  677       UNSET                                  ;! UNSET NAMES DECLARED AT THIS LEVEL
  678       %IF LEVEL\=1 %THEN FAULT(M'TOO ',M'FEW ',M'%END',M'S   ')
  679  L71:  DUMP(M'STOP',0,0,0)                    ;! %STOP
  680       PRINT SYMBOL('B')                      ;! PRINT OUT BRANCH TABLE
  681       PRINT SYMBOL('T')
  682       PRINT SYMBOL(':')
  683       NEWLINE
  684       CA=0
  685  L93:  %IF CA\=BTN %THEN %START
  686          DUMP('B',0,M'PRG',BAT(CA))          ;! BRANCH RELATIVE TO START OF PROGRAM
  687          ->L93 ; %FINISH
  688       PRINT SYMBOL('C')                      ;! PRINT OUT CONSTANT TABLE
  689       PRINT SYMBOL('T')
  690       PRINT SYMBOL(':')
  691       NEWLINE
  692       I=0
  693  L91:  %IF I\=CTN %THEN %START
  694          WRITE(COT(I),10)
  695          NEWLINE
  696          I=I+1
  697          ->L91 ; %FINISH
  698       PRINT SYMBOL(';')
  699       WRITE(FAULTS,1)                        ;! NUMBER OF PROGRAM FAULTS
  700       FAULT(M' FAU',M'LTS ',M'IN P',M'ROGM')
  701       %STOP
  702  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  703  %ROUTINE UI
  704  ! COMPILE UNCONDITIONAL INSTRUCTION
  705  %INTEGER I,J,K,L
  706       I=A(AP)                            ;! NEXT ANALYSIS RECORD ENTRY
  707       AP=AP+1
  708       %IF I=1 %THEN ->L10                 ;! ROUTINE CALL OR ASSIGNMENT STATEMENT
  709       %IF I=2 %THEN ->L20                 ;! JUMP INSTRUCTION
  710       %IF I=3 %THEN ->L30                 ;! %START
  711       %IF I=4 %THEN ->L40                 ;! %RETURN
  712       %IF I=5 %THEN ->L50                 ;! %RESULT=
  713       DUMP(M'STOP',0,0,0)                ;! %STOP
  714       %RETURN
  715  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  716  ! NAME APP ASS
  717  L10:  I=LINK(A(AP))                             ;! POINTER TO NAME TAGS
  718       %IF I=0 %THEN %START
  719          PRINT NAME(A(AP))
  720          FAULT(M'NAME',M' NOT',M' SET',0)
  721          %FINISH %ELSE I=TAG(I)                ;! NAME TAGS OR ZERO TO AVOID DIAGNOSTICS
  722       J=AP                                      ;! PRESERVE ANALYSIS RECORD POINTER
  723       AP=AP+1                                   ;! AP ON <APP>
  724       SKIP APP                                  ;! SKIP TO <ASS>
  725       %IF A(AP)=2 %THEN %START                  ;! ROUTINE CALL
  726          %IF I>>24=64 %THEN %START              ;! 'FORM/TYPE' IS ROUTINE
  727             AP=J                                ;! RESTORE AP TO <NAME>
  728             RT                                  ;! CALL ROUTINE
  729             %FINISH %ELSE %START
  730             %IF I\=0 %THEN %START
  731                PRINT NAME(A(J))
  732                FAULT(M'NOT ',M'ROUT',M'INE ',M'NAME')
  733                %FINISH
  734             %FINISH
  735          AP=AP+1                                ;! AP AFTER <UI>
  736          %RETURN ; %FINISH
  737       K=I>>28                                   ;! 'FORM' OF NAME
  738       %IF K=4 %THEN %START
  739          PRINT NAME(A(J))
  740          FAULT(M'NAME',M' NOT',M' A D',M'ESTN') ;! ROUTINE/FN FORM
  741          I=0                                    ;! CLEAR TAGS TO AVOID FURTHER DIAGNOSTIC
  742          %FINISH
  743       AP=AP+1                                   ;! AP ON <+-\>
  744       SEXPR
  745       %IF I=0 %THEN %RETURN                     ;! LHS NAME NOT SET
  746       %IF K>=2 %THEN %START                     ;! LHS AN ARRAY TYPE
  747          DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)  ;! PRESERVE ACCUMMULATOR
  748          K=AP                                   ;! PRESERVE AP
  749          AP=J                                    ;! RESTORE INITIALANAL REC POINTER
  750          ARRAD                                  ;! CALCULATE ARRAY ELEMENT ADDRESS
  751          WS=WS-1                                ;! RESTORE WORKSPACE POINTER
  752          DUMP(M'LOAD',M'WK',BR(LEVEL),WS)       ;! RESTORE ACCUMMULATOR
  753          DUMP(M'STR',M'WK',M'ACC',0)            ;! DUMP ASSIGNMENT
  754          AP=K                                   ;! RESTORE AP TO AFTER <UI>
  755          %RETURN ; %FINISH
  756       %IF K=1 %THEN %START
  757          DUMP(M'LOAD',M'WK',BR(I>>16&15),I&65535);! INDIRECT ASSIGMENT
  758          DUMP(M'STR',M'ACC',M'WK',0)
  759          %FINISH %ELSE DUMP(M'STR',M'ACC',BR(I>>16&15),I&65535)
  760       %IF A(J+1)=1 %THEN %START
  761          PRINT NAME(A(J))
  762          FAULT(M'SCAL',M'AR H',M'AS P',M'ARAM')
  763          %FINISH
  764       %RETURN
  765  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  766  ! -> CONST
  767  L20:  DUMP('B',0,M'BT',FIND LABEL)              ;! SCAN/INSERT JUMP LIST AND DUMP JUMP
  768       %RETURN
  769  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  770  ! %START
  771  L30:  FAULT(M'%STA',M'RT ?',M'    ',M'    ')    ;! %START ALONE SHOULD NOT BE A SOURCE STATEMENT
  772       %RETURN
  773  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  774  ! %RETURN
  775  L40:  %IF RTP(LEVEL)\=0 %THEN FAULT(M'%RET',M'URN ',M'CONT',M'EXT ')
  776       RETURN                                    ;! DUMP %RETURN CODE  -  INCORRECT FOR FN
  777       %RETURN
  778  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  779  ! %RESULT=
  780  L50:  I=RTP(LEVEL)                              ;! ROUTINE/FN TYPE
  781       %IF I<=0 %THEN FAULT(M'%RES',M'ULT ',M'CONT',M'EXT ') ;! %BEGIN/%ROUTINE
  782       SEXPR                                     ;! COMPILE RESULT EXPRESSION
  783       RETURN                                    ;! LEAVE RESULT IN ACC & DUMP RETURN CODE
  784  %END
?L unused
  785  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  786  %ROUTINE SEXPR
  787  ! COMPILE ARITHMETIC EXPRESSION
  788  %ROUTINESPEC TORP
  789  %ROUTINESPEC PSEVAL
  790  %ROUTINESPEC EVAL(%INTEGER P)
  791  %INTEGER RPP,APP
  792  %INTEGERARRAY RP,PT(1:32)                   ;! REVERSE POLISH, POINTER/TYPE ARRAYS
  793       RPP=1                                  ;! RP POINTER
  794       TORP                                   ;! EXPR TO REV POLISH
  795       %IF SCF=1 %THEN %START                 ;! PART OF A SIMPLE CONDITION
  796          SCF=0                               ;! RESET FLAG
  797          COMP=A(AP)                          ;! COMPARATOR NUMBER
  798          %IF A(AP+3)=0 %AND A(AP+4)=2 %THEN AP=AP+5 %ELSE %START
  799             AP=AP+1                          ;! 2ND EXPR NON-ZERO
  800             TORP                             ;! 2ND EXPRESSION TO REVERSE POLISH
  801             RP(RPP)=10                       ;! CODE FOR '-' I.E. (1ST-2ND)
  802             PT(RPP)=1                        ;! FLAG=OPERATOR
  803             RPP=RPP+1                        ;! INCREMENT RP POINTER
  804             %FINISH
  805          %FINISH
  806       APP=AP                                 ;! SAVE FINAL ANAL REC POINTER
  807       PSEVAL                                 ;! PSEUDO-EVALUATE EXPRESSION
  808       EVAL(RPP-1)                            ;! DUMP CODE FOR EXPR EVALUATION
  809       AP=APP                                 ;! RESTORE FINAL ANAL REC POINTER
  810  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  811  %ROUTINE TORP
  812  ! TRANSFORM EXPRESSION TO REVERSE POLISH
  813  %ROUTINESPEC STORE(%INTEGER I,J)
  814  %INTEGERARRAY OP(1:4)
  815  %INTEGER OPP,I
  816       OPP=0                              ;! OPERATOR STACK POINTER
  817       I=A(AP)                            ;! <+-\>
  818       AP=AP+1
  819       %IF I=1 %OR I=4 %THEN ->L1          ;! + OR NULL
  820       I=I+9                              ;! CODES FOR - & \
  821  L3:   OPP=OPP+1                          ;! STACK OPERATOR
  822       OP(OPP)=I
  823  L1:   I=A(AP)                            ;! <OPD>
  824       %IF I=3 %THEN %START               ;! SUB-EXPRESSION
  825          AP=AP+1                         ;! AP TO <+-\>
  826          TORP                            ;! TRANSFORM SUB-EXPR TO REV POL
  827          %FINISH %ELSE %START
  828          STORE(AP,0)                     ;! STORE ANAL REC POSITION OF OPERAND
  829          AP=AP+2                         ;! AP ON <APP> OR AFTER <CNST>
  830          %IF I=1 %THEN SKIP APP          ;! OPERAND A NAME
  831          %FINISH
  832       %IF A(AP)=2 %THEN %START           ;! END OF <EXPR>
  833          AP=AP+1                         ;! AP AFTER EXPRESSION
  834  L2:      %IF OPP=0 %THEN %RETURN         ;! OPERATOR STACK EMPTIED
  835          STORE(OP(OPP),1)                ;! UNSTACK REMAINING OPERATORS
  836          OPP=OPP-1
  837          ->L2 ; %FINISH
  838       I=A(AP+1)                          ;! <OP>
  839       AP=AP+2                            ;! AP ON <EXPR>
  840  L4:   %IF OPP=0 %OR PREC(I)>PREC(OP(OPP)) %THEN ->L3 ;! OP STACK EMPTY OR NEW OP HIGHER PREC
  841       STORE(OP(OPP),1)                   ;! UNSTACK TOP OPERATOR
  842       OPP=OPP-1
  843       ->L4
  844  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  845  %ROUTINE STORE(%INTEGER I,J)
  846  ! STORE IN RP & PT ARRAYS, I=ANAL REC PTR , J= OP/OPD FLAG
  847       %IF RPP>32 %THEN %START             ;! REV POL ARRAY FULL
  848          FAULT(M'EXPR',M' TOO',M' LON',M'G   ')
  849          RPP=1                            ;! IN ORDER TO CONTINUE
  850          %FINISH
  851       RP(RPP)=I                           ;! STORE OP/OPD
  852       PT(RPP)=J                           ;! STORE FLAG
  853       RPP=RPP+1                           ;! NEXT POSITION
  854  %END
  855  %END
  856  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  857  %ROUTINE PSEVAL
  858  ! PSEUDO-EVALUATION, CHECKING OPERANDS
  859  %INTEGERARRAY PST(1:32)                      ;! OPERAND POINTER STACK
  860  %INTEGER PSTP,I,J,K
  861       PSTP=0                                  ;! PST POINTER
  862       I=1                                     ;! REV POL ARRAY POINTER
  863  L3:   AP=RP(I)                                ;! ANAL REC POSITION OF OPERAND
  864       %IF A(AP)=1 %THEN %START                ;! OPERAND A NAME
  865          J=LINK(A(AP+1))                      ;! LINK TO TAG OF NAME
  866          %IF J=0 %THEN %START
  867             PRINT NAME(A(AP+1))
  868             FAULT(M'NAME',M' NOT',M' SET',0)
  869             K=0                               ;! DUMMY TAG VALUE
  870             ->L1 ; %FINISH
  871          K=TAG(J)                             ;! TAG OF NAME
  872          J=K>>28                              ;! 'FORM' OF NAME
  873          %IF J>1 %THEN %START                 ;! ARRAY OR ROUTINE/FN TYPE
  874             RP(I)=AP+1                        ;! STORE ANAL REC POSITION OF <NAME>
  875             %IF J=4 %THEN %START              ;! NAME IS ROUTINE/FN TYPE
  876                %IF K>>24&15=0 %THEN %START
  877                   PRINT NAME(A(AP+1))
  878                   FAULT(M'RT N',M'AME ',M'IN E',M'XPR ')
  879                   K=0                         ;! DUMMY TAG VALUE
  880                   ->L1 ; %FINISH
  881                PT(I)=-1                       ;! FLAG FOR FUNCTION
  882                %FINISH %ELSE PT(I)=-2         ;! FLAG FOR ARRAY
  883             ->L2 ; %FINISH                     ;! GO TO STACK POINTER
  884          %IF A(AP+2)=1 %THEN %START
  885             PRINT NAME(A(AP+1))
  886             FAULT(M'SCAL',M'AR H',M'AS P',M'ARAM')
  887             %FINISH
  888  L1:      RP(I)=K                              ;! STORE TAG OF NAME FOR SCALARS
  889          PT(I)=-3                             ;! FLAG FOR SCALARS
  890          %FINISH %ELSE %START                 ;! OPERAND IS A <CNST>
  891          RP(I)=A(AP+1)                        ;! STORE VALUE OF CONSTANT
  892          PT(I)=-4                             ;! FLAG FOR CONSTANTS
  893          %FINISH
  894  L2:   PSTP=PSTP+1                             ;! STACK OPERAND POINTER
  895  L4:   PST(PSTP)=I
  896       I=I+1                                   ;! REV POL ARRAY POINTER
  897       %IF I<RPP %THEN %START                  ;! NOT END OF REV POL YET
  898          %IF PT(I)=0 %THEN ->L3                ;! AN OPERAND IS NEXT
  899          %IF RP(I)<=10 %THEN %START           ;! BINARY OPERATORS
  900             PSTP=PSTP-1                       ;! PSEUDO-EVALUATE POINTERS
  901             PT(I)=PST(PSTP)                   ;! STACK POINTER TO RESULT
  902             %FINISH
  903          ->L4 ; %FINISH
  904  %END
  905  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  906  %ROUTINE EVAL(%INTEGER P)
  907  ! DUMP CODE FOR EVALUATION OF EXPRESSION
  908  %ROUTINESPEC OPN(%INTEGER OP,L)
  909  %INTEGER I,J,K
  910       I=PT(P)                                       ;! POINTER/TYPE OF LAST REV POL ENTRY
  911       %IF I<0 %THEN %START                          ;! OPERAND
  912          OPN(0,P)                                   ;! LOAD OPERAND
  913          %RETURN ; %FINISH
  914       J=RP(P)                                       ;! OPERATOR
  915       K=P-1                                         ;! START OF 2ND OPERAND
  916       %IF UCN(J)=1 %THEN %START                     ;! UNARY OPERATOR
  917          %IF PT(K)>=-2 %THEN EVAL(K) %ELSE OPN(0,K) ;! EVAL IF NODE OTHERWISE LOAD OPERAND
  918          DUMP(OPR(J),M'ACC',0,0)                    ;! DUMP UNARY OPERATION
  919          %RETURN ; %FINISH
  920       %IF PT(I)>=-2 %THEN %START                    ;! FIRST OPERAND A NODE
  921          %IF PT(K)>=-2 %THEN %START                 ;! SECOND OPERAND A NODE
  922             EVAL(K)                                 ;! EVALUATE 2ND OPERAND
  923             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)   ;!  & STORE IT IN WORKSPACE
  924             EVAL(I)                                 ;! EVALUATE 1ST OPERAND
  925             WS=WS-1                                 ;! RESTORE WORKSPACE POINTER
  926             DUMP(OPR(J),M'ACC',BR(LEVEL),WS)        ;! DUMP OPERATION
  927             %FINISH %ELSE %START                    ;! 2ND OPERAND NOT A NODE
  928             EVAL(I)                                 ;! EVALUATE 1ST OPERAND
  929             OPN(J,K)                                ;! OPERATION WITH 2ND OPERAND
  930             %FINISH
  931          %FINISH %ELSE %START                       ;! 1ST OPERAND NOT A NODE
  932          %IF PT(K)>=-2 %THEN %START                 ;! 2ND OPERAND A NODE
  933             EVAL(K)                                 ;! EVALUATE 2ND OPERAND
  934             %IF UCN(J)=2 %THEN %START               ;! OPERATOR IS COMMUTATIVE
  935                OPN(J,I)                             ;! OPERATION WITH 1ST OPERAND
  936                %RETURN ; %FINISH
  937             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)   ;! STORE VALUE OF 2ND OPERAND IN WORKSPACE
  938             OPN(0,I)                                ;! LOAD 1ST OPERAND
  939             WS=WS-1                                 ;! RESTORE WORKSPACE POINTER
  940             DUMP(OPR(J),M'ACC',BR(LEVEL),WS)        ;! DUMP OPERATION WITH 2ND OPERAND
  941             %FINISH %ELSE %START                    ;! 2ND OPERAND NOT A NODE
  942             OPN(0,I)                                ;! LOAD 1ST OPERAND
  943             OPN(J,K)                                ;! OPERATION WITH 2ND OPERAND
  944             %FINISH
  945          %FINISH
  946       %RETURN
  947  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
  948  %ROUTINE OPN(%INTEGER OP,L)
  949  ! DUMP SIMPLE OPERATION, OP=OPERATOR, L=RP POSITION OF OPERAND
  950  %INTEGER I,J
  951       I=PT(L)                                         ;! KIND OF OPERAND
  952       AP=RP(L)                                        ;! ANAL REC POINTER OR NAME TAGS
  953       %IF I=-1 %THEN %START                           ;! ROUTINE/FN TYPE
  954          RT                                           ;! DUMP CALL ON FUNCTION
  955          %RETURN ; %FINISH
  956       %IF I=-2 %THEN %START                           ;! ARRAY ACCESS
  957          ARRAD                                        ;! CALCULATE ARRAY ELEMENT ADDRESS
  958          DUMP(M'LOAD',M'ACC',M'ACC',0)                ;! LOAD VALUE
  959          %RETURN ; %FINISH
  960       %IF I=-3 %THEN %START                           ;! SCALAR TYPE
  961          %IF AP>>28=1 %THEN %START                    ;! %NAME TYPE
  962             DUMP(M'LOAD',M'WK',BR(AP>>16&15),AP&65535) ;! LOAD INDIRECT
  963             DUMP(OPR(OP),M'ACC',M'WK',0)
  964             %FINISH %ELSE DUMP(OPR(OP),M'ACC',BR(AP>>16&15),AP&65535)
  965          %RETURN ; %FINISH
  966       %IF OP\=0 %OR AP>65535 %THEN %START             ;! CONSTANT NOT 'LDA'-ABLE
  967          J=CT NEXT                                    ;! NEXT HOLE IN CONSTANT TABLE
  968          COT(J)=AP                                    ;! STORE VALUE
  969          DUMP(OPR(OP),M'ACC',M'CT',J)
  970          %FINISH %ELSE DUMP(M'LDA',M'ACC',0,AP)
  971  %END
  972  %END
  973  %END
  974  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  975  %ROUTINE SKIP SEXPR
  976  ! SKIP PAST <+-\><OPD><EXPR> IN ANALYSIS RECORD, AP INITIALLY ON <+-\>
  977  L1:   AP=AP+2                                       ;! AP ON <OPD>+1
  978       %IF A(AP-1)=3 %THEN SKIP SEXPR %ELSE %START   ;! SKIP SUB-EXPR ELSE <NAME> OR <CNST>
  979          AP=AP+1                                    ;! AP ON <APP> OR AFTER <CNST>
  980          %IF A(AP-2)=1 %THEN SKIP APP               ;! OPERAND IS A NAME
  981          %FINISH
  982       AP=AP+1                                       ;! AP AFTER <EXPR>
  983       %IF A(AP-1)=1 %THEN ->L1                       ;! MORE OPERANDS
  984  %END
  985  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  986  %ROUTINE SKIP APP
  987  ! SKIP PAST <APP> IN ANALYSIS RECORD
  988  L1:   AP=AP+1                                       ;! POINTER TO <APP>+1 OR <EXPS>+1
  989       %IF A(AP-1)=1 %THEN %START                    ;! EXPRESSIONS TO SKIP
  990          SKIP SEXPR
  991          ->L1 ; %FINISH
  992  %END
  993  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  994  %ROUTINE SCCOND(%INTEGERNAME LABEL)
  995  ! COMPILE CONDITION I.E. <SC><COND>, LABEL SET FOR POSITION AFTER UI
  996  %ROUTINESPEC SC
  997  %ROUTINESPEC COND
  998  %ROUTINESPEC STORE(%INTEGER FT)
  999  %INTEGER I,J,K,L,APP
 1000  %INTEGERARRAY CAP,LVL,TF,JMP,LBL(1:16)             ;! ANAL REC POINTERS, NESTING LEVEL,
 1001                                                     ;!  TRUE/FALSE, JUMP & LABEL ARRAYS
 1002       I=1                                           ;! INDEX TO ARRAYS
 1003       L=0                                           ;! NESTING LEVEL
 1004       SC                                            ;! PROCESS <SC>
 1005       COND                                          ;! PROCESS <COND>
 1006       APP=AP                                        ;! PRESERVE FINAL ANAL REC POINTER
 1007       L=-1
 1008       STORE(1)                                      ;! PSEUDO-FALSE AT LEVEL -1
 1009       L=-2
 1010       STORE(2)                                      ;! PSEUDO-TRUE AT LEVEL -2
 1011       K=I-1                                         ;! LAST POSITION FILLED IN IN ARRAYS
 1012       I=1
 1013  L2:   J=I                                           ;! FIND POSITIONS TO JUMP TO
 1014  L1:   J=J+1                                         ;!    AFTER COMPARISONS
 1015       %IF LVL(J)>=LVL(I) %OR TF(J)=TF(I) %THEN ->L1  ;! SKIP HIGHER LEVELS ETC
 1016       JMP(I)=J                                      ;! JUMP TO COMPARISON POSITION J
 1017       I=I+1
 1018       %IF I<K %THEN ->L2                             ;! MORE JUMPS TO FILL IN YET
 1019       %IF A(AP)\=2 %THEN ->L3                        ;! UI NOT A JUMP INSTRUCTION
 1020       AP=AP+1                                       ;! TO <CONST>
 1021       J=K-1                                         ;! LAST POSITION FILLED IN
 1022       TF(J)=2                                       ;! SET AS 'TRUE'
 1023       JMP(J)=J                                      ;! SET JUMP AS THE UI JUMP
 1024       LBL(J)=FIND LABEL                             ;! FILL IN BRANCH TABLE POSITION
 1025  L3:   I=1                                           ;! FILL IN PSEUDO-LABELS FOR INNER JUMPS
 1026  L4:   %IF LBL(JMP(I))<0 %THEN LBL(JMP(I))=BT NEXT   ;! NEXT BAT POSITION
 1027       I=I+1
 1028       %IF I<K %THEN ->L4                             ;! MORE TO FILL IN
 1029       I=1
 1030  L7:   AP=CAP(I)                                     ;! ANAL REC POINTER FOR 1ST EXPR OF COMP
 1031       SCF=1                                         ;! SET FLAG FOR SEXPR
 1032       SEXPR                                         ;! TO EVALUATE (1ST - 2ND)
 1033       %IF TF(I)=1 %THEN L=FALSE(COMP) %ELSE L=TRUE(COMP)
 1034       DUMP(L,M'ACC',M'BT',LBL(JMP(I)))              ;! BRANCH TO REQUIRED POSITION
 1035       %IF LBL(I)>=0 %AND (I\=K-1 %OR TF(I)=1) %THEN BAT(LBL(I))=CA
 1036       I=I+1                                         ;!         FILL IN LABEL ADDRESS
 1037       %IF I<K %THEN ->L7                             ;! MORE COMPARISONS YET
 1038       LABEL=LBL(K)                                  ;! FINAL LABEL
 1039       AP=APP                                        ;! FINAL ANALYSIS RECORD POINTER
 1040  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
 1041  %ROUTINE STORE(%INTEGER FT)
 1042  ! STORE LEVEL & TRUE/FALSE FLAG
 1043       %IF I>16 %THEN %START                     ;! ARRAYS FULL
 1044          FAULT(M'COND',M'N TO',M'O LO',M'NG  ')
 1045          I=1                                    ;! TO CONTINUE
 1046          %FINISH
 1047       LVL(I)=L                                  ;! SAVE NESTING LEVEL
 1048       TF(I)=FT                                  ;! SAVE TRUE/FALSE FLAG
 1049       LBL(I)=-1                                 ;! SET 'LABEL NOT FILLED IN YET' FLAG
 1050       I=I+1                                     ;! NEXT ARRAY POSITION
 1051  %END
 1052  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
 1053  %ROUTINE SC
 1054       AP=AP+1
 1055       %IF A(AP-1)=2 %THEN %START
 1056          L=L+1                               ;! NESTING LEVEL UP 1 FOR SUB-CONDITION
 1057          SC                                  ;! PROCESS SUB-<SC>
 1058          COND                                ;! PROCESS SUB-<COND>
 1059          L=L-1                               ;! NESTING LEVEL DOWN AFTER SUB-CONDITION
 1060          %FINISH %ELSE %START
 1061          CAP(I)=AP                           ;! ANAL REC POINTER FOR SIMPLE COMPARISON
 1062          SKIP SEXPR                          ;! SKIP 1ST EXPR OF COMPARISON
 1063          AP=AP+1                             ;! SKIP COMPARATOR
 1064          SKIP SEXPR                          ;! SKIP 2ND EXPR
 1065          %FINISH
 1066  %END
 1067  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
 1068  %ROUTINE COND
 1069  ! PROCESS <COND> FOR SIMPLE COMPARISONS
 1070  %INTEGER I
 1071       I=A(AP)                                ;! <COND>
 1072       AP=AP+1                                ;! AP ON <SC>
 1073       %IF I\=3 %THEN %START                  ;! NOT NULL ALTERNATIVE OF <COND>
 1074  L1:      STORE(I)                            ;! SAVE %AND OR %OR TYPE OF CONDITION
 1075          SC                                  ;! PROCESS <SC>
 1076          AP=AP+1                             ;! POINTER ON <ANDC>+1 OR <ORC>+1
 1077          %IF A(AP-1)=1 %THEN ->L1             ;! MORE %ANDS OR %ORS
 1078          %FINISH
 1079  %END
 1080  %END
 1081  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1082  %ROUTINE CHECK
 1083  ! CHECK LABELS ALL SET & STARTS MATCH FINISHES
 1084  %INTEGER I,J
 1085       I=JUMP(LEVEL)                              ;! POINTER TO JUMP LIST FOR THIS LEVEL
 1086  L1:   %IF I\=0 %THEN %START                      ;! NO LABELS OR JUMPS USED AT THIS LEVEL
 1087          %IF BAT(TAG(I)&65535)<0 %THEN %START    ;! LABEL SET INCORRECTLY
 1088             WRITE(TAG(I)>>16,1)                  ;! PRINT OUT LABEL NO OF LABEL NOT SET
 1089             FAULT(M' LAB',M'EL N',M'OT S',M'ET  ')
 1090             %FINISH
 1091          I=RETURN CELL(I)                        ;! RETURN JUMP LIST CELL TO ASL
 1092          ->L1 ; %FINISH
 1093       I=START(LEVEL)                             ;! LINK TO START LIST
 1094  L2:   %IF I\=0 %THEN %START                      ;! A CELL STILL IN LIST
 1095          FAULT(M'%FIN',M'ISH ',M'MISS',M'ING ')
 1096          I=RETURN CELL(I)                        ;! POP UP CELL
 1097          ->L2 ; %FINISH
 1098  %END
?J unused
 1099  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1100  %ROUTINE UNSET
 1101  ! UNSET NAMES AND CHECK FOR MISSING ROUTINES
 1102  %INTEGER I,J,K
 1103       I=NAME(LEVEL)                               ;! NAME LIST POINTER
 1104  L1:   %IF I\=0 %THEN %START                       ;! UNSET NAMES DECLARED AT THIS LEVEL
 1105          J=TAG(I)                                 ;! NAME IDENT NO
 1106          K=TAG(LINK(J))                           ;! TAG WORD AT TOP OF LIST
 1107          LINK(J)=RETURN CELL(LINK(J))             ;! POP UP CELL
 1108          %IF K>>28=4 %THEN %START                 ;! ROUTINE/FN TYPE
 1109             %IF BAT(K&65535)<0 %THEN %START
 1110                PRINT NAME(J)
 1111                FAULT(M'ROUT',M'INE ',M'MISS',M'ING ')
 1112                %FINISH
 1113             K=K>>20&15                            ;! NO OF PARAMS
 1114  L2:         %IF K\=0 %THEN %START                 ;! PARAMS PRESENT
 1115                LINK(J)=RETURN CELL(LINK(J))       ;! POP UP CELLS
 1116                K=K-1                              ;! PARAM COUNT
 1117                ->L2 ; %FINISH
 1118             %FINISH
 1119          %IF LINK(J)=0 %THEN TAG(J)=0             ;! A PREVIOUS DECLARATION OF SAME NAME
 1120          I=RETURN CELL(I)                         ;! RETURN NAME LIST CELL
 1121          ->L1 ; %FINISH
 1122  %END
 1123  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1124  %ROUTINE PUSH START(%INTEGER FLAG,LABEL)
 1125  ! PUSHDOWN START/FINISH BLOCK INFORMATION
 1126  %INTEGER I
 1127       I=NEWCELL
 1128       TAG(I)=FLAG<<16!LABEL&65535                 ;! PACK FLAG & LABEL
 1129       LINK(I)=START(LEVEL)                        ;! PUSH CELL DOWN
 1130       START(LEVEL)=I                              ;!  ONTO START LIST
 1131  %END
 1132  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1133  %ROUTINE ENTER(%INTEGER TYPE,ALLOC)
 1134  ! DUMP CODE FOR NEW LEVEL & INITIALISE LEVEL ARRAYS
 1135  %INTEGER I
 1136       DUMP(M'STR',BR(LEVEL),M'STP',0)            ;! ENTRY SEQUENCE
 1137       DUMP(M'LDA',BR(LEVEL),M'STP',0)
 1138       DUMP(M'STR',M'WK',M'STP',1)
 1139       I=CT NEXT                                  ;! STATIC ALLOCATION HOLE IN CONST TABLE
 1140       DUMP(M'ADD',M'STP',M'CT',I)
 1141       STAR(LEVEL)=I                             ;! REMEMBER POSITION OF HOLE
 1142       JUMP(LEVEL)=0                              ;! NO JUMPS AT NEW LEVEL YET
 1143       NAME(LEVEL)=0                              ;! NO NAMES AT NEW LEVEL YET
 1144       RTP(LEVEL)=TYPE                            ;! BLOCK/ROUTINE/FN TYPE
 1145       CHPP(LEVEL)=CHP                            ;! SAVE CHARACTER ARRAY POINTER
 1146       START(LEVEL)=0                             ;! NO START/FINISH BLOCKS YET
 1147       RAD(LEVEL)=ALLOC                           ;! NEXT RELATIVE ADDRESS TO BE ASSIGNED
 1148  %END
 1149  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1150  %ROUTINE RETURN
 1151  ! DUMP CODE FOR %RETURN
 1152       DUMP(M'LDA',M'STP',BR(LEVEL),0)             ;! RESTORE DIJKSTRA DISPLAY
 1153       DUMP(M'LOAD',BR(LEVEL),M'STP',0)
 1154       DUMP(M'LOAD',M'WK',M'STP',1)
 1155       DUMP('B',0,M'WK',0)                         ;! BRANCH TO RETURN ADDRESS
 1156  %END
 1157  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1158  %ROUTINE RT
 1159  ! DUMP CODE FOR A ROUTINE OR FUNCTION CALL
 1160  %INTEGER I,J,K,L,M,N,P
 1161       I=LINK(A(AP))                                      ;! LINK TO TAG FOR NAME
 1162       AP=AP+1                                            ;! AP ON <APP>
 1163       J=TAG(I)                                           ;! TAG OF NAME
 1164       K=J>>20&15+1                                       ;! NO OF PARAMS +1
 1165  L1:   K=K-1                                              ;! COUNT PARAMS
 1166       AP=AP+1                                            ;! AP ON <APP>+1
 1167       %IF A(AP-1)=2 %THEN %START                         ;! PARAMS ABSENT OR NO MORE TO PROCESS
 1168          DUMP(M'BAL',M'WK',M'BT',J&65535)                ;! DUMP BRANCH TO ROUTINE/FN
 1169          %IF K>0 %THEN FAULT(M'TOO ',M'FEW ',M'PARA',M'MS  ')
 1170          %RETURN ; %FINISH
 1171       %IF K<=0 %THEN %START                              ;! MORE PARAMS THAN SPEC
 1172          %IF K=0 %THEN FAULT(M'TOO ',M'MANY',M' PAR',M'AMS ') ;! ONLY MONITOR ONCE
 1173          ->L2 ; %FINISH
 1174       I=LINK(I)                                          ;! LINK TO NEXT PARAM CELL
 1175       L=TAG(I)                                           ;! TAG OF PARAM
 1176       %IF L>>28=0 %THEN %START                           ;! SCALAR VALUE
 1177          SEXPR                                           ;! COMPILE EXPRESSION
 1178          ->L3 ; %FINISH
 1179       %IF A(AP)=4 %AND A(AP+1)=1 %THEN ->L4               ;! <+-\> IS NULL & <OPD> IS A NAME
 1180  L5:   FAULT(M'NOT ',M'A NA',M'ME P',M'ARAM')
 1181  L2:   SKIP SEXPR                                         ;! SKIP INVALID PARAM TO CONTINUE
 1182       ->L1
 1183  L4:   M=LINK(A(AP+2))                                    ;! LINK TO TAG FOR PARAM NAME
 1184       %IF M=0 %THEN %START
 1185          PRINT NAME(A(AP+2))
 1186          FAULT(M'NAME',M' NOT',M' SET',M'    ')
 1187          ->L2 ; %FINISH
 1188       N=TAG(M)                                           ;! TAG OF PARAM NAME
 1189       %IF L>>28=1 %THEN %START                           ;! PARAM IS SCALAR NAME TYPE
 1190          %IF N>>28=4 %THEN %START                        ;! ACTUAL NAME IS ROUTINE/FN TYPE
 1191             PRINT NAME(A(AP+2))
 1192             ->L5 ; %FINISH
 1193          %IF N>>28>=2 %THEN %START                       ;! ACTUAL NAME IS AN ARRAY
 1194             AP=AP+2                                      ;! AP ON <NAME>
 1195             ARRAD                                        ;! CALCULATE ARRAY ELEMENT ADDRESS
 1196             AP=AP+1                                      ;! AP ON <EXPR>+1 - SHOULD BE <EXPS>
 1197             %IF A(AP-1)=1 %THEN ->L5                      ;! FURTHER OPERAND - INVALID
 1198             ->L3 ; %FINISH
 1199          %IF A(AP+3)=1 %THEN %START                      ;! <APP> NOT NULL
 1200             PRINT NAME(A(AP+2))
 1201             FAULT(M'SCAL',M'AR H',M'AS P',M'ARAM')
 1202             ->L2 ; %FINISH
 1203          %IF A(AP+4)=1 %THEN ->L5                         ;! FURTHER OPERANDS - INVALID
 1204          %IF N>>28=1 %THEN P=M'LOAD' %ELSE P=M'LDA'      ;! LOAD FOR NAME TYPE & LDA FOR VALUE TYPE
 1205          DUMP(P,M'ACC',BR(N>>16&15),N&65535)
 1206          %FINISH %ELSE %START                            ;! PARAM IS ARRAY NAME
 1207          %IF A(AP+3)\=2 %OR A(AP+4)\=2 %THEN ->L5         ;! <APP> NOT NULL OR MORE OPERANDS
 1208          %IF N>>28&2=0 %THEN %START                      ;! 'FORM' OF ACTUAL IS NOT ARRAY
 1209             PRINT NAME(A(AP+2))
 1210             FAULT(M'NOT ',M'AN A',M'RRAY',M' NME')
 1211             ->L2 ; %FINISH
 1212          %IF N>>28=3 %THEN %START                        ;! ACTUAL IS ARRAY NAME
 1213             M=N&65535                                    ;! POINTER TO TAG CELL OF PARAM LIST
 1214             N=TAG(M)                                     ;! CORRECT TAG FOR PARAM
 1215             %FINISH
 1216          %IF N>>20&15\=L>>20&15 %THEN %START             ;! DIMENSIONS DIFFERENT
 1217             %IF L>>20&15=0 %THEN %START                  ;! FORMAL PARAM DIMENSION UNKNOWN
 1218                L=TAG(I)!N&15<<20                         ;! FILL FORMAL TAG WITH DIMENSION
 1219                TAG(I)=L                                  ;!  OF ACTUAL PARAM
 1220                %FINISH %ELSE %START                      ;! DIMENSION OF FORMAL KNOWN
 1221                %IF N>>20&15=0 %THEN TAG(M)=TAG(M)!L&15<<20 %ELSE %START
 1222                                                          ;! FILL IN DIMENSION OF ACTUAL IF UNKNOWN
 1223                   PRINT NAME(A(AP+2))
 1224                   FAULT(M'ARRA',M'Y DI',M'MENS',M'ION?')
 1225                   ->L2 ; %FINISH
 1226                %FINISH
 1227             %FINISH
 1228          DUMP(M'LOAD',M'ACC',BR(N>>16&15),N&65535)
 1229          %IF L>>20&15\=1 %THEN %START                    ;! NOT 1-DIM ARRAY
 1230             DUMP(M'STR',M'ACC',M'STP',L&65535)
 1231             DUMP(M'LOAD',M'ACC',BR(N>>16&15),N&65535+1)
 1232             L=L+1
 1233             %FINISH
 1234          %FINISH
 1235       AP=AP+5                                            ;! AP ON <EXPS>
 1236  L3:   DUMP(M'STR',M'ACC',M'STP',L&65535)
 1237       ->L1
 1238  %END
 1239  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1240  %ROUTINE ARRAD
 1241  ! DUMP CODE TO CALCULATE ARRAY ELEMENT ADDRESS
 1242  %INTEGER I,J,K,L
 1243       L=A(AP)
 1244       I=LINK(L)                                          ;! LINK TO TAG FOR NAME OF ARRAY
 1245       J=TAG(I)
 1246       %IF J>>28=3 %THEN %START                           ;! NAME IS AN ARRAY NAME
 1247          I=J&65535                                       ;! SUBSTITUTE CORRECT TAG VALUE
 1248          J=TAG(I)
 1249          %FINISH
 1250       AP=AP+2                                            ;! AP ON <APP>+1
 1251       %IF A(AP-1)=1 %THEN %START                         ;! INDEXES PRESENT
 1252          SEXPR                                           ;! COMPILE EXPR FOR FIRST INDEX
 1253          AP=AP+1                                         ;! AP ON <EXPS>+1
 1254          %IF A(AP-1)=1 %THEN %START                      ;! 2ND INDEX PRESENT
 1255             DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)        ;! STORE 1ST INDEX IN WORKSPACE
 1256             SEXPR                                        ;! COMPILE EXPR FOR 2ND INDEX
 1257             %IF A(AP)=1 %THEN %START                     ;! 3RD INDEX PRESENT
 1258                PRINT NAME(L)
 1259                FAULT(M'TOO ',M'MANY',M' IND',M'EXES')
 1260                SKIP APP                                  ;! SKIP EXCESS INDEXES
 1261                %FINISH %ELSE AP=AP+1                     ;! AP AFTER EXPRESSION
 1262             DUMP(M'MLT',M'ACC',BR(J>>16&15),J&65535)
 1263             WS=WS-1                                      ;! RESTORE WORKSPACE POINTER
 1264             DUMP(M'ADD',M'ACC',BR(LEVEL),WS)
 1265             DUMP(M'ADD',M'ACC',BR(J>>16&15),J&65535+1)
 1266             K=2                                          ;! DIMENSION MARKER
 1267             %FINISH %ELSE %START                         ;! ONLY ONE INDEX PRESENT
 1268             DUMP(M'ADD',M'ACC',BR(J>>16&15),J&65535)
 1269             K=1                                          ;! DIMENSION MARKER
 1270             %FINISH
 1271          %IF K\=J>>20&15 %THEN %START                    ;! DIMS FOUND DO NOT AGREE WITH TAG
 1272             %IF J>>20&15=0 %THEN TAG(I)=TAG(I)!K<<20 %ELSE %C
 1273+               PRINT NAME(L)
 1274                FAULT(M'ARRA',M'Y DI',M'MENS',M'ION?')    ;! FILL IN DIMS IF UNKNOWN
 1275             %FINISH
 1276          %FINISH %ELSE %START
 1277          PRINT NAME(L)
 1278          FAULT(M'NO A',M'RRAY',M' IND',M'EXES')
 1279          %FINISH
 1280  %END
 1281  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1282  %INTEGERFN BT NEXT
 1283  ! ALLOCATE NEXT POSITION IN BRANCH TABLE
 1284       %IF BTN>1023 %THEN %START                 ;! FULL
 1285          FAULT(M'TOO ',M'MANY',M'LABE',M'LS  ')
 1286          BTN=0                                  ;! TRY TO CONTINUE
 1287          %FINISH
 1288       BAT(BTN)=-1                               ;! MARKER FOR ADDRESS NOT FILLED IN YET
 1289       BTN=BTN+1                                 ;! NEXT POSITION
 1290       %RESULT=BTN-1                             ;! THIS POSITION
 1291  %END
 1292  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1293  %INTEGERFN CT NEXT
 1294  ! ALLOCATE NEXT POSITION IN CONSTANT TABLE
 1295       %IF CTN>1023 %THEN %START                 ;! FULL
 1296          FAULT(M'TOO ',M'MANY',M' CON',M'STS ')
 1297          CTN=0                                  ;! TRY TO CONTINUE
 1298          %FINISH
 1299       CTN=CTN+1                                 ;! NEXT POSITION
 1300       %RESULT=CTN-1                             ;! THIS POSITION
 1301  %END
 1302  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1303  %INTEGERFN WS NEXT
 1304  ! ALLOCATE NEXT WORK SPACE POSITION
 1305       WS=WS+1
 1306       %IF WS=11 %THEN FAULT(M'COMP',M'ILER',M' WKS',M'PACE')
 1307       %RESULT=WS-1
 1308  %END
 1309  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1310  %INTEGERFN FIND LABEL
 1311  ! CHECK & LOCATE OR INSERT LABEL IN JUMP LIST FOR THIS LEVEL
 1312  %INTEGER I,J
 1313       LABEL=A(AP)                               ;! VALUE OF CONST
 1314       AP=AP+1                                   ;! AFTER <CONST>
 1315       %IF LABEL>>16\=0 %THEN %START             ;! INVALID LABEL NUMBER
 1316          WRITE(LABEL,1)
 1317          SPACES(2)
 1318          FAULT(M'INVA',M'LID ',M'LABE',M'L   ')
 1319          %RESULT=-1                             ;! 'FAULTY' RESULT
 1320          %FINISH
 1321       I=JUMP(LEVEL)                             ;! JUMP LIST POINTER
 1322  L1:   %IF I\=0 %THEN %START                     ;! SOMETHING IN LIST
 1323          %IF LABEL=TAG(I)>>16 %THEN %RESULT=TAG(I)&65535 ;! LABEL ALREADY IN
 1324          I=LINK(I)                              ;! NEXT CELL IN LIST
 1325          ->L1 ; %FINISH
 1326       I=NEWCELL                                 ;! LABEL NOT IN LIST SO GET NEW CELL
 1327       J=BT NEXT                                 ;! GET NEXT BRANCH TABLE POSITION
 1328       TAG(I)=LABEL<<16!J                        ;! FILL IN LIST ENTRY
 1329       LINK(I)=JUMP(LEVEL)                       ;! PUSHDOWN ONTO JUMP LIST
 1330       JUMP(LEVEL)=I                             ;! NEW JUMP LIST POINTER
 1331       %RESULT=J                                 ;! NEW BRANCH TABLE POSITION
 1332  %END
 1333  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1334  %ROUTINE STORE TAG(%INTEGER NAM,FORM,TYPE,DIM,LEV,AD)
 1335  ! STORE TAGS I.E. SET NAME & CHECK NOT SET ALREADY
 1336  %INTEGER M,N
 1337       M=LINK(NAM)                               ;! POINTER TO EXISTING TAGS WORD FOR THIS
 1338       %IF M\=0 %AND LEV=TAG(M)>>16&15 %AND FORM\=4 %THEN %START
 1339          PRINT NAME(NAM)
 1340          FAULT(M'NAME',M' SET',M' TWI',M'CE  ')
 1341          %RETURN ; %FINISH
 1342       N=NEWCELL                                 ;! NEW CELL FOR TAGS
 1343       TAG(N)=FORM<<28!TYPE<<24!DIM<<20!LEV<<16!AD ;! FILL IN TAGS
 1344       LINK(N)=LINK(NAM)                         ;! PUSHDOWN ONTO TAGS LIST FOR THIS NAME
 1345       LINK(NAM)=N
 1346       N=NEWCELL
 1347       TAG(N)=NAM                                ;! PUSHDOWN NEW CELL ONTO NAME LIST
 1348       LINK(N)=NAME(LEVEL)                       ;!  FOR NAMES DECLARED AT THIS LEVEL
 1349       NAME(LEVEL)=N
 1350  %END
 1351  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1352  %ROUTINE DUMP(%INTEGER OP,REG,BASE,DISP)
 1353  ! PRINT OUT CURRENT ADDRESS, OPERATION MNEMONIC & OPERANDS
 1354  %ROUTINESPEC PMN(%INTEGER I)
 1355  %INTEGER COM
 1356       SPACES(10)
 1357       COM=' '
 1358       PMN(OP)                                   ;! OPERATOR MNEMONIC
 1359       COM=','
 1360       PMN(REG)                                  ;! REGISTER MNEMONIC
 1361       %IF DISP>=65536 %THEN %START
 1362          PRINT SYMBOL(',')
 1363          SPACES(7)
 1364          PRINT NAME(DISP-65536)
 1365          %FINISH %ELSE %START
 1366          %IF BASE=M'BT' %OR BASE=M'CT' %OR BASE=M'PRG' %THEN %START
 1367             PRINT SYMBOL(',')
 1368             SPACES(7)
 1369             %FINISH
 1370          PMN(BASE)                              ;! BASE MNEMONIC
 1371          WRITE(DISP,1)                          ;! DISPLACEMENT
 1372          %FINISH
 1373       NEWLINE
 1374       CA=CA+1                                   ;! INCREMENT CURRENT ADDRESS COUNT
 1375  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
 1376  %ROUTINE PMN(%INTEGER I)
 1377  ! PRINT MNEMONIC - CHARS INTO ONE WORD
 1378  %INTEGER J,K,L
 1379       J=2                                   ;! AT LEAST TWO SPACES
 1380       K=24                                  ;! FIRST SHIFT VALUE
 1381  L1:   L=I>>K&255                            ;! UNPACK NEXT CHARACTER
 1382       %IF L=0 %THEN J=J+1 %ELSE PRINT SYMBOL(L)
 1383       K=K-8                                 ;! NEXT SHIFT VALUE
 1384       %IF K>=0 %THEN ->L1                    ;! MORE CHARS POSSIBLY YET
 1385       %IF I=M'BT' %OR I=M'CT' %OR I=M'PRG' %THEN %C
 1386+            PRINT SYMBOL('+') %ELSE %START
 1387          PRINT SYMBOL(COM)
 1388          SPACES(J)                          ;! TO ALLIGN FIELDS CORRECTLY
 1389          %FINISH
 1390  %END
 1391  %END
 1392  %END
?L68 unused
 1393  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1394  %ROUTINE FAULT(%INTEGER A,B,C,D)
 1395  ! MONITOR FAULT - A 'PRINT STRING' ROUTINE
 1396  %ROUTINESPEC OUT(%INTEGER I)
 1397       OUT(A)
 1398       OUT(B)
 1399       OUT(C)
 1400       OUT(D)
 1401       NEWLINE
 1402       FAULTS=FAULTS+1                     ;! INCREMENT FAULT COUNT
 1403  ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
 1404  %ROUTINE OUT(%INTEGER I)
 1405  ! PRINT OUT PACKED CHARS
 1406       PRINT SYMBOL(I>>24) %if I>>24 # 0
 1407       PRINT SYMBOL(I>>16&255) %if I>>16&255 # 0
 1408       PRINT SYMBOL(I>>8&255) %if I>>8&255 # 0
 1409       PRINT SYMBOL(I&255) %if I&255 # 0
 1410  %END
 1411  %END
 1412  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1413  %INTEGERFN CH NEXT
 1414  ! ALLOCATE NEXT POSITION IN 'CH' ARRAY
 1415       %IF CHP>512 %THEN %START            ;! CHARACTER ARRAY FULL
 1416          FAULT(M'NAME',M'S TO',M'O LO',M'NG  ')
 1417          %STOP ; %FINISH
 1418       CHP=CHP+1
 1419       %RESULT=CHP-1
 1420  %END
 1421  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1422  %INTEGERFN NEWCELL
 1423  ! ALLOCATE NEW CELL FOR LIST PROCESSING
 1424  %INTEGER I
 1425       %IF ASL=0 %THEN %START              ;! END OF AVAILABLE SPACE LIST
 1426          FAULT(M'ASL ',M'EMPT',M'Y   ',M'   ')
 1427          %STOP ; %FINISH
 1428       I=ASL                               ;! POINTER TO TOP CELL OF ASL
 1429       ASL=LINK(ASL)                       ;! ASL POINTER TO NEXT CELL DOWN
 1430       TAG(I)=0                            ;! CLEAR NEW CELL OUT
 1431       LINK(I)=0
 1432       %RESULT=I                           ;! INDEX TO NEW CELL
 1433  %END
 1434  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1435  %INTEGERFN RETURN CELL(%INTEGER I)
 1436  ! DEALLOCATE CELL AND RETURN IT TO ASL
 1437  %INTEGER J
 1438       J=LINK(I)                           ;! PRESENT LINK VALUE OF CELL
 1439       LINK(I)=ASL                         ;! LINK TO TOP OF ASL
 1440       ASL=I                               ;! ASL POINTER TO RETURNED CELL
 1441       %RESULT=J                           ;! RETURN VALUE OF LINK
 1442  %END
 1443  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1444  %ROUTINE PRINT NAME(%INTEGER I)
 1445  ! PRINT NAME FROM HASH POSITION
 1446  %INTEGER J,K,L,M
 1447       J=TAG(I)                             ;! POINTER TO CH ARRAY
 1448       K=CH(J)                              ;! LENGTH & FIRST 3 CHARS
 1449       L=K>>24                              ;! NUMBER OF CHARS IN NAME
 1450       M=16                                 ;! FIRST SHIFT VALUE
 1451  L1:   PRINT SYMBOL(K>>M&255)
 1452       L=L-1
 1453       %IF L=0 %THEN %START
 1454          SPACES(2)
 1455          %RETURN ; %FINISH
 1456       M=M-8                                ;! NEXT SHIFT VALUE
 1457       %IF M<0 %THEN %START
 1458          J=J+1
 1459          K=CH(J)                           ;! NEXT WORD OF CHARS
 1460          M=24
 1461          %FINISH
 1462       ->L1
 1463  %END
 1464  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 1465  %ENDOFPROGRAM

 1396 Statements compiled
