Retro1.org codex

CALCS 
* /---   FILE TYPE = E
* /---   BLOCK      EXT        00 000   76/11/25  03.28 
          IDENT  CALCS
          TITLE  CALC / BRANCH / DOTO 
* 
*         GET COMMON SYMBOL TABLE 
* 
          CST 
* 
* 
          EXT    GETLINE,ECSPRTY,CALC=
          EXT    COMCONT,CALCNAM
          EXT    BRANNAM,DOTONAM
          EXT    CONTCOM,COMPARG,NOTLITS
          EXT    PAD,LONGI,SHORT
* 
*         -CALCACT- IS USED AS A FLAG TO TELL 
*         WHETHER A -CALC- IS ACTIVE.  -NXTLINE-
*         (IN CONDEN) LOOKS AT -CALCACT- AND
*         TERMINATES THE CALC IF THE NEXT 
*         COMMAND IS NOT A CALC-TYPE COMMAND
*         (I.E. -BRANCH-, -DOTO-, -IF-, ETC...).
*         'THE STANDARD CONDENSE ERROR ROUTINES 
*         ALWAYS CLEAR -CALCACT-.  'THUS, BE
*         VERY CAREFUL ABOUT USING THE -RJERR-
*         ROUTINES, AS YOU MAY NEED TO RESTORE
*         -CALCACT-.
* /---   BLOCK      CALC       00 000   76/12/22  12.42 
          TITLE  -CALC- COMMAND READIN
*         -CALCS-            ENTRY FOR -CALC- COMMAND 
* 
          ENTRY  CALCS
 CALCS    RJ     INITCAL     DO INITIALIZATIONS 
          SA1    TAGCNT 
          ZR     X1,OKCONT   JUMP IF BLANK LINE 
*         CHECK IF MIGHT HAVE -BRANCH- OR -DOTO-
          SA1    TAG         CHECK FOR *BRANCH* 
          SX0    X1-1RB      DOES IT START WITH A B 
          ZR     X0,CKBRDT
          SX0    X1-1RD      CHECK IF STARTS WITH A D 
          ZR     X0,CKBRDT
*         COMPILE CODE AND CHECK FOR ASSIGNMENT CALC
 CALCGO   RJ     CALCINS
          SA1    LASTKEY     SHOULD BE END OF LINE
          ZR     X1,OKCONT   GO CHECK FOR CONTINUED CALC
          EQ     CALCE1      ***TEMP NAME ONLY*** 
*         FINISH CHECK FOR -BRANCH- AND -DOTO-
 CKBRDT   SB1    1
          SB2    5           SET TO LOOK AT FIRST 5 CHARS 
          MX0    0
 CKBRDT1  LX0    6
          BX0    X0+X1       MERGE IN NEW CHARACTER 
          SA1    A1+B1       LOAD NEXT CHAR 
          SB2    B2-B1
          NZ     B2,CKBRDT1  LOOP UNTIL ALL CHARS IN
          SA2    =5RDOTO     CHECK FOR -DOTO- 
          BX2    X2-X0
          NZ     X2,CKBRDT2 
          SX6    A1          MOVE WORDPT PAST *DOTO*
          SA6    WORDPT 
          EQ     DOTO 
 CKBRDT2  LX0    6
          BX0    X0+X1       MERGE 6TH CHAR 
          SA2    =6RBRANCH
          BX2    X2-X0       CHECK FOR BRANCH 
          NZ     X2,CALCGO   JUMP IF REGULAR CALC LINE
          SX6    A1+B1       MOVE WORDPT PAST *BRANCH*
          SA6    WORDPT 
          EQ     BRANCH 
* 
*         CHECK FOR CONTINUED (BLANK) -CALC-
 OKCONT   SA2    NEXTCOM     PICK UP COMMAND NAME 
 NOCONT   EQU    OKCONT      FOR NOW, JUST USE OKCONT 
          SA3    COMCONT     CHECK AGAINST CONTINUATION COMMAND (BLANKS)
          BX3    X3-X2
          ZR     X3,CALCONTB JUMP IF CONTINUED CALC 
          SA1    IBRAN
          ZR     X1,=XNXTLINE  EXIT IF NO BRANCH -Q-
          SA4    CALCNAM     CHECK AGAINST -CALC- COMMAND 
          BX4    X4-X2
          ZR     X4,NXTLINE  JUMP IF -CALC- COMMAND 
          MX0    6           CHECK FOR STATEMENT LABEL
          BX7    X0*X2
          LX7    6
          SX3    X7-1R0      CHECK FIRST CHAR GT OR EQ TO 0 
          NG     X3,CALCONTA JUMP IF NOT
          SX3    X7-1R9-1    CHECK ALSO LT EQ TO 9
          NG     X3,NXTLINE  IF SO, GO PROCESS THE LABEL
 CALCONTA RJ     ENDCALC     TERMINATE THE CALC 
          EQ     =XNXTLINE   GO PROCESS NEXT COMMAND
 CALCONTB RJ     GETLINE     GET NEXT LINE
          EQ     CALCS
* /---   BLOCK      CALCINS    00 000   76/08/30  15.03 
* 
*         SUBROUTINE TO COMPILE NEXT CALC 
 CALCINS  EQ     *           COMPILE CODE AND CHECK FOR ASSIGNMENT CALC 
          MX7    0
          SA7    COMPALL     RE-INITIALIZE COMPILE VARIABLES
          SX7    1
          SA7    RSULTX1
          SA7    CMOVFLG
          RJ     CONTCOM     COMPILE, RETURN X1 AND B1 INFORMATION
          ZR     B1,CALCE2   ERROR IF CAN STORE INTO EXPRESSION 
          BX2    X1 
          AX2    XCODEAL     GET GETVAR TYPE
          MX0    57 
          BX2    -X0*X2      THROW AWAY I/F BIT 
          SX2    X2-4        SHOULD BE CALC TYPE
          NZ     X2,CALCE3   ***TEMP NAME ONLY*** 
          EQ     CALCINS
* /---   BLOCK      BRANCH     00 000   76/08/30  21.34 
          TITLE  -BRANCH- COMMAND READIN
*         -BRANI-            ENTRY FOR -BRANCH- COMMAND 
* 
          ENTRY  BRANI
 BRANI    RJ     INITCAL     DO INITIALIZATIONS 
          SA1    TAGCNT 
          ZR     X1,NOTAG    ERROR IF BLANK TAG 
*         -BRANCH- IN CALC TAG ENTERS HERE
 BRANCH   SX6    -1 
          SA6    XBRAN       MARK NO -BRANCH X- ENCOUNTERED 
          SA1    COMACNT     CHECK FOR UNCONDITIONAL BRANCH 
          ZR     X1,UBRANCH 
* 
*         TIME TEST IS DONE AFTER COMPUTING BRANCH ADDRESS
* 
          RJ     BRANCMP     PROCESS CONDITIONAL PART 
* 
*GETLINE COUNTS ALL COMMAS, INCLUDING SHIFTED COMMAS
*(QUOTE MARKS), AND COMMAS INSIDE MULTI-ARG FUNCTIONS.
*SO WE MUST CORRECT THE COMMA COUNT.
          SA1    LASTKEY
          ZR     X1,BDBRNCH  CONDITIONAL BRANCH MUST HAVE LABELS
          SB1    1           (COMACNT WRONG IF FUNCTIONS CONTAIN COMMAS)
          SX7    1           COUNT INITIAL COMMA
          SX0    1R,         X0 CONTAINS TEST CHAR
          SA1    WORDPT      PREPARE TO COUNT COMMAS
          SA1    X1-1 
 COUNTC   SA1    A1+B1       PICK UP CHAR 
          ZR     X1,CNTDONE  JUMP IF END OF LINE
          IX1    X1-X0       CHECK FOR COMMA
          NZ     X1,COUNTC   JUMP IF NOT COMMA
          SX7    X7+B1       COUNT THE COMMA
          EQ     COUNTC 
 CNTDONE  SA7    COMACNT     CORRECT COMMA COUNT
* 
          SX1    X7-2        UPPER BOUND IS COMMA COUNT MINUS 2 
* /---   BLOCK      BRANCH2    00 000   78/12/13  01.46 
          NG     X1,UBRANCH  UNCONDITIONAL IF ONLY ONE LABEL
          SX7    710B        TRANSMIT UPPER BOUND IN X0 
          LX7    21 
          BX7    X1+X7
          RJ     LONGI
          SX1    1           COMPILE RETURN JUMP TO *CONDITIONAL BRANCH*
          LX1    24 
          SA2    LLBRAN      ADDRESS OF -BRANFNC- 
          BX7    X1+X2
          RJ     LONGI       PUT IN INSTRUCTION STREAM
          RJ     PAD         BE SURE AT WORD BOUNDRY FOR FOLLOWING JUMPS
*         NAMELY, NINST MUST HAVE CORRECT COUNT 
* 
          SA2    TAGCNT      CHECK FOR LAST BRANCH BEING A FALL THROUGH 
          SA1    X2+TAG-1    LOAD LAST CHAR OF LINE 
          SX3    X1-1R,      IF COMMMA, IS FALL THROUGH 
          ZR     X3,LASTFALL
          SX3    X1-1RX      IS LAST CHAR AN X
          NZ     X3,BRANCHL  NO, LAST CANNOT BE A FALL THROUGH
          SA1    A1-1        LOAD PRECEEDING CHAR 
          SX3    X1-1R,      IF IT IS COMMA, LAST BRANCH IS FALL THROUGH
          NZ     X3,BRANCHL 
 LASTFALL MX7    0           CONVERT LAST COMMA TO END OF LINE
          SA7    A1 
          SA2    COMACNT     AND REDUCE COMMA COUNT 
          SX7    X2-1 
          SA7    A2 
 BRANCHL  RJ     PAD         PAD OUT INSTRUCTION WORD 
          RJ     GETSYM      GET NEXT STATEMENT NUMBER
          LX1    B2,X0       LEFT JUSTIFY SYMBOL INTO X1
          SX6    X4          SAVE LAST CHARACTER FOUND
          SA6    SAVLAST
          ZR     X0,BRANCHX  ZERO SYMBOL IS FALL THROUGH
          SX2    X0-1RX      SO IS AN *X* 
          ZR     X2,BRANCHX 
*         ONE ARGUMENT BRANCH ENTERS HERE 
 BRANCHB  MX0    6
          BX2    X0*X1       MUST START WITH A NUMBER 
          LX2    6
          SX3    X2-1R0 
          NG     X3,BADLABL 
          SX3    X2-1R9-1 
          PL     X3,BADLABL 
          MX0    42 
          BX1    X0*X1       MASK SYMBOL TO 7 CHARS 
          RJ     LABFIND     B1 = NUMBER FOR THIS LABEL 
          SA1    NINST       LOAD CURRENT INSTRUCTION WORD POINTER
          SX6    INST        AWKWARDNESS OF LOADER
          IX1    X1-X6       RELATIVE ADDRESS 
          RJ     SA5JPB5     GENERATE DEFERRED JUMP TO THIS LABEL 
*         FILL WORD WITH A -JP B3- IN CASE LABEL NOT FOUND
 BRANJP3  SX7    23B         COMPILE A CALC EXIT JUMP... MAY BE 
          LX7    21 
          RJ     LONGI       COMPILE
          SA4    SAVLAST
          NZ     X4,BRANCHL  JUMP IF MORE TEXT TO GO
          RJ     PAD
          SA1    XBRAN       CHECK IF THERE WAS A -BRANCH X-
          NG     X1,OKCONT   EXIT IF NOT
          SB1    X1+0 
          RJ     LABDEF      DEFINE THE IMAGINARY -X- LABEL 
+         LT     B1,*        HANG IF DUPLICATE LABEL
          EQ     OKCONT 
* 
* /---   BLOCK      BRANCH3    00 000   79/12/02  03.53 
 BRANCHX  SA5    XBRAN
          SB1    X5          IMAGINARY LABEL NUMBER FOR -X- 
          SX1    B0          SET ARGUMENT FOR -LABFIND- 
          PL     X5,BRANCHXX JUMP IF ALREADY HAVE LABEL NUMBER
          RJ     LABFIND     GENERATE IMAGINARY LABEL NUMBER
          SX6    B1 
          SA6    A5          SAVE LABEL NUMBER IN -XBRAN- 
 BRANCHXX SB2    2           TYPE = 2 
          SB3    30          UPPER INSTRUCTION
          SX2    0255B       JP  B5+* (UPPER 12 BITS) 
          SA1    NINST       COMPUTE DISPLACEMENT IN -INST- 
          SX6    INST 
          IX1    X1-X6
          RJ     CLABREF     PROCESS DEFERRED REFERENCE 
          EQ     BRANJP3     GO INCREMENT -NINST- 
* 
*         PROCESS ONE ARGUMENT BRANCH 
 UBRANCH  SX7    0100B       SET UP A  *RJ  BREAK*
          SA1    LLBREAK     ADDRESS OF EXECUTION ROUTINE 
          LX7    18 
          BX7    X1+X7
          CALL   LONGI
          CALL   PAD         FORCE NEXT INSTRUCTION UPPER 
          RJ     GETSYM      GET STATEMENT NUMBER 
          LX1    X0,B2       LEFT JUSTIFY SYMBOL INTO X1
          MX6    0           MARK END-OF-LINE 
          SA6    SAVLAST
          ZR     X0,BDBRNCH  ERROR IF ZERO SYMBOL 
          SX2    X0-1RX 
          ZR     X2,BDBRNCH  ERROR IF -X- 
          EQ     BRANCHB
* 
*         -BRANCMP- 
* 
*            'THIS SUBROUTINE PROCESSES THE CONDITIONAL 
*         PART OF THE -BRANCH-, -IF-, AND -ELSEIF- COMMANDS.
* 
 BRANCMP  DATA   0
          SX7    1           ELSE, SET UP PARAMETERS FOR SPECIAL CALC 
          SA7    COMPALL     SET TO *COMPILE* EVEN SIMPLE LITERAL LOAD
          MX7    0
          SA7    RSULTX1     SET TO LEAVE CALC RESULT IN X1 
          RJ     CONTCOM     COMPILE CALC PART OF CODITIONAL BRANCH 
          LX1    62-XCODEL   SHIFT I/F BIT TO SIGN POS
          PL     X1,BRANCMPA ALREADY INTEGER, OK
          SX7    10210B      BX2 X1 
          RJ     SHORT
          SX7    21274B      AX2 60 
          RJ     SHORT
          SX1    7130B       MAKE A *SX3  .5 SHR 45*
          SX7    17174B 
          LX1    18 
          BX7    X7+X1
          RJ     LONGI
          SX7    20355B      LX3 45 
          RJ     SHORT
          SX7    13332B      BX3 X3-X2
          RJ     SHORT
          SX7    30113B      FX1 X1+X3
          RJ     SHORT
          SX7    26111B      UX1 X1,B1
          RJ     SHORT
          SX7    22111B      LX1 X1,B1
          RJ     SHORT
 BRANCMPA SX7    1
          SA7    RSULTX1     RESET COMPILE PARAMETERS 
          MX7    0
          SA7    COMPALL
          EQ     BRANCMP
* /---   BLOCK      IF         00 000   77/01/06  01.33 
          TITLE  -IF- COMMAND READIN
*         -IF-               ENTRY FOR -IF- COMMAND 
* 
          ENTRY  IFIN 
 IFIN     RJ     INITCAL     DO INITIALIZATIONS 
          SA1    TAGCNT 
          ZR     X1,NOTAG    ERROR IF BLANK TAG 
*         PROCESS TAG 
          RJ     BRANCMP
*         SET UP AND STORE -ISTACK- INFO
          SX1    0           GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR FALSE BRANCH
          SB5    B1          B5 = LABEL FOR FALSE BRANCH
          SX1    B0          GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR END BRANCH
          SX6    10000B      TYPE = 1 FOR -IF- COMMAND
          PX6    X6,B1       PACK UP -TYPE- AND END LABEL 
          LX6    -12         -TYPE- FIELD IS SIX BITS 
*         'CALLING -CHKIND- USING THE INDENT LEVEL OF 
*         THE CURRENT LINE AS AN ARGUMENT GUARENTEES
*         THAT THE STACK IS NOT FULL.  'THUS, WE DO NOT 
*         NEED TO CHECK FOR STACK OVERFLOW.  (-GETLINE- 
*         DISCARDS LINES WITH TOO MANY INDENTS.)
          SA1    PISTACK     CURRENT LENGTH OF -ISTACK- 
          SX7    X1+1        INCREMENT -PISTACK-
          SA7    A1          STORE UPDATED VALUE
          PX6    X6,B5       ADD -FALSE- LABEL
          SA6    ISTACK+X1   STORE -IF- COMMAND INFO
*         COMPILE CODE FOR BRANCH X,FALSE (B5 HAS LABEL)
*         -ELSEIF- COMMAND ENTERS HERE (WITH B5 SET)
 IFGO     RJ     JPB3        PUT JPB3 IN INSTRUCTION STREAM 
          SX2    7105B       SX0  B5+0* 
          SB2    1           TYPE = 1 (COMMAND PART)
          SB1    B5          LABEL NUMBER 
          RJ     CLABREF     X0 WILL HOLD NEW VALUE FOR A5
          RJ     JPB3        NEXT INSTRUCTION 
          SX2    6115B       SB1  B5+0* 
          SB2    2           TYPE = 2 (EXTRA STORAGE PART)
          SB1    B5          LABEL NUMBER 
          RJ     CLABREF     B1 WILL HOLD JUMP ADDRESS
          SA5    LLSYSNT     ADDRESS OF -SYSJPNT- (NO TIME CHECK DONE)
          SX7    0321B       PL   X1,SYSJPNT
          LX7    18 
          BX7    X7+X5
          RJ     LONGI       PRESERVES X5 
          SX7    0301B       ZR   X1,SYSJPNT
          LX7    18 
          BX7    X7+X5
          RJ     LONGI
          EQ     NOCONT 
* /---   BLOCK      ELSE       00 000   77/01/06  01.34 
          TITLE  -ELSE- AND -ELSEIF- COMMAND READIN 
*         -ELSE-             ENTRY FOR -ELSE- COMMAND 
* 
          ENTRY  ELSEC
 ELSEC    RJ     IFCHECK     INITIAL PROCESSING 
          SA1    TAGCNT 
          NZ     X1,IFERR94  ERROR IF TAG 
          RJ     ELSEDO 
*         CHANGE TYPE FIELD FROM 1 TO 2 
          MX0    -6 
          BX5    X0*X5       CLEAR OLD *TYPE* 
          SX6    2           NEW TYPE = 2 
          BX5    X6+X5
          PX6    X5,B5       PACK IN NEW -FALSE- LABEL
          SA6    A5          STORE -ISTACK- INFO
          EQ     NOCONT 
* 
*         -ELSEIF-           ENTRY FOR -ELSEIF- COMMAND 
* 
          ENTRY  ELSEIFC
 ELSEIFC  RJ     IFCHECK     INITIAL PROCESSING 
          SA1    TAGCNT 
          ZR     X1,NOTAG    ERROR IF BLANK TAG 
          RJ     ELSEDO 
          PX6    X5,B5       PACK IN NEW -FALSE- LABEL
          SA6    A5          STORE -ISTACK- INFO
*         PROCESS TAG 
          RJ     BRANCMP
*         -CHKIND- GUARENTEED THAT PISTACK = INDENT+1 
          SA1    PISTACK     CURRENT LENGTH OF -ISTACK- 
          SA1    ISTACK-1+X1 GET TOP STACK ELEMENT
          UX1,B5 X1          SET B5 FOR -IFGO-
          EQ     IFGO        JUMP INTO -IF- PROCESSOR 
* 
*         THIS SUBROUTINE DOES SPECIAL PROCESSING 
*         FOR THE -ELSE- AND -ELSEIF- COMMANDS. 
* 
*         B5 IS RETURNED WITH NEXT -FALSE- BRANCH 
*         A5,X5 HOLDS REMAINDER OF ISTACK INFO
* 
 ELSEDO   DATA   0
*         MAKE SURE AN -IF- IS ACTIVE 
*         -CHKIND- GUARENTEED THAT PISTACK = INDENT+1 
          SA5    PISTACK     CURRENT LENGTH OF -ISTACK- 
          SA5    ISTACK-1+X5 GET TOP STACK ELEMENT
          MX1    -6 
          BX1    -X1*X5      GET -TYPE- FIELD 
          SX1    X1-1        CHECK FOR TYPE = 1 
          NZ     X1,IFERR91  ERROR IF NO -IF- IS ACTIVE 
*         COMPILE A DIRECT BRANCH TO END-OF-CASE LABEL
          RJ     JPB3        FIND LOC OF NEXT INSTRUCTION 
          SX2    5155B       SA5  B5+0* 
          SB2    1           TYPE = 1 (COMMAND PART)
          UX5,B5 X5          B5 = LABEL FOR FALSE BRANCH
          LX5    12 
          UX5,B1 X5          END LABEL NUMBER 
          PX5    X5,B1       PRESERVE IT
          RJ     CLABREF     A5 WILL BE UPDATED PROPERLY
          RJ     JPB3        NEXT INSTRUCTION 
          SX2    0255B       JP   B5+0* 
          SB2    2           TYPE = 2 (EXTRA STORAGE PART)
* /---   BLOCK      ENDIF      00 000   77/01/06  15.49 
          UX5,B1 X5 
          PX5    X5,B1
          RJ     CLABREF     WILL DO DIRECT JUMP INTO X-STOR
*         DEFINE LABEL FOR FALSE BRANCH OF PREVIOUS -IF-
          SB1    B5          LABEL NUMBER OF FALSE BRANCH 
          RJ     LABDEF 
          SX1    0           GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR NEXT FALSE BRANCH 
          SB5    B1          RETURN IN B5 
          LX5    -12
          EQ     ELSEDO 
          TITLE  -ENDIF- COMMAND READIN 
*         -ENDIF-            ENTRY FOR -ENDIF- COMMAND
* 
          ENTRY  ENDIFC 
 ENDIFC   SA1    TAGCNT 
          NZ     X1,IFERR94  ERROR IF TAG 
          RJ     IFCHECK     INITIAL PROCESSING 
          RJ     POPTOP      TERMINATE THE -IF- STRUCTURE 
          EQ     NOCONT      DISALLOW CONTINUED ENDIF'7S
* 
*         -IFCHECK- 
* 
*            'THIS ROUTINE IS USED BY THE -ELSEIF-, 
*         -ELSE-, AND -ENDIF- COMMANDS.  'IT MAKES
*         SURE THAT AN -IF- COMMAND IS ACTIVE, AND
*         CALLS -CHKIND- TO VERIFY THAT THE USER
*         HAS DECREASED HIS INDENTING EXACTLY ONE 
*         LEVEL.
* 
 IFCHECK  DATA   0
          RJ     INITCAL     DO INITIALIZATIONS 
*         MAKE SURE AN -IF- STRUCTURE IS ACTIVE 
          SA1    INDENT      INDENT LEVEL OF CURRENT COMMAND
          SA2    PISTACK     CURRENT LENGTH OF -ISTACK- 
          IX3    X1-X2       SEE IF -ISTACK- IS FULL ENOUGH 
          PL     X3,IFERR91  JUMP IF CAN'7T HAVE -IF- STRUCTURE 
          SA2    ISTACK+X1   STACK ELEMENT FOR THIS LEVEL 
          MX0    -6 
          BX2    -X0*X2      GET -TYPE- FIELD 
          ZR     X2,IFERR91 
          SX2    X2-3        ALLOW ONLY TYPES 1 AND 2 
          PL     X2,IFERR91  JUMP IF NO -IF- COMMAND
          SX1    X1+1        CURRENT STACK LEVEL MUST BE ONE MORE 
          RJ     CHKIND      VERIFY PROPER INDENTING
          EQ     IFCHECK
* /---   BLOCK      LOOP       00 000   77/01/06  16.27 
          TITLE  -LOOP- COMMAND READIN
*         -LOOP-             ENTRY FOR -LOOP- COMMAND 
* 
          ENTRY  DOUNTOC
 DOUNTOC  BSS    0
          SX5    30000B      TYPE = 3 FOR LOOP STRUCTURES 
          RJ     INITCAL     DO INITIALIZATIONS 
          SX1    0           GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR *END* BRANCH
          PX5    X5,B1       ATTACH *END* LABEL 
          SX1    B0          GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR *LOOP* BRANCH 
          AX5    12 
          PX6    X5,B1       ATTACH *LOOP* LABEL
          SA6    LOOPTEMP    LOOPTEMP = INFO FOR -STACK-
          RJ     LABDEF      DEFINE *LOOP* LABEL
+         NZ     B1,*        SYSTEM ERROR PROTECTION
          SA1    TAGCNT 
          ZR     X1,LOOPFIN  JUMP IF NO TAG 
          RJ     BRANCMP     PROCESS TAG
          SA1    LASTKEY     CHECK TERMINATING CHAR 
          NZ     X1,=XERRTERM   ERROR IF NOT E-O-L
          SA1    LOOPTEMP    STACK INFO 
          LX1    12 
          UX1,B1 X1          B1 = LABEL FOR *END* BRANCH
          SA1    PLX1ZRX1    PL  X1,*END*      ZR  X1,*END* 
          RJ     LABJUMP     COMPILE JUMP TO *END* LABEL
* 
*         -LOOPTEMP- HOLDS INFO FOR UPDATING THE STACK
* 
 LOOPFIN  SA1    LOOPTEMP    LOAD STACK INFO
          SA2    PISTACK     CURRENT LENGTH OF -ISTACK- 
          SX6    X2+1        INCREMENT -PISTACK-
          SA6    A2 
          BX6    X1 
          SA6    ISTACK+X2   STORE NEW INFO IN -ISTACK- 
          EQ     NOCONT      DISALLOW CONTINUED LINES 
 LOOPTEMP BSS    1
* /---   BLOCK      EXITLP     00 000   80/05/06  00.08 
          TITLE  -RELOOP-/-OUTLOOP- COMMAND READIN
* 
          ENTRY  REDOC       -RELOOP- 
 REDOC    RJ     LPCHECK     INITIAL PROCESSING 
          SA2    INDENT      INDENT LEVEL OF CURRENT COMMAND
          SA1    ISTACK+X2   X1 = INFO FOR THIS LOOP
          UX1,B1 X1          B1 = LABEL FOR -LOOP- BRANCH 
          EQ     REOUTC 
* 
          ENTRY  EXITDOC     -OUTLOOP-
 EXITDOC  RJ     LPCHECK
          SA2    INDENT 
          SA1    ISTACK+X2
          LX1    12 
          UX1,B1 X1          B1 = LABEL FOR -END- BRANCH
* 
*         -REOUTC-
*         COMMON READIN FOR -RELOOP- / -OUTLOOP-
* 
 REOUTC   SX6    B1          SAVE BRANCH DESTINATION
          SA6    LPINFO      OVER COMPILE 
          SA1    EQ          ASSUME NO TAG
          SA2    TAGCNT      SEE IF TAG PRESENT 
          ZR     X2,REOUTC2  EMIT BRANCH IF NOT 
* 
*         COMPILE EXPRESSION
* 
          RJ     BRANCMP     COMPILE CODE FOR TAG 
*         ADD 0 TO X1, IN CASE EXPRESSION = -0
          SX7    76000B      SX0    B0
          RJ     SHORT
          SX7    36110B      IX1    X1+X0 
          RJ     SHORT
          SA1    NGX1        NG     X1,-END-
* 
*         EMIT BRANCH, USING LABEL IN *LPINFO*
*         AND BRANCH TYPE IN X1 
* 
 REOUTC2  SA2    LPINFO 
          SB1    X2          B1 = LABEL TO BRANCH TO
          RJ     LABJUMP     COMPILE JUMP 
          EQ     NOCONT 
* 
 LPINFO   BSS    1           SAVED BRANCH DESTINATION 
* 
* /---   BLOCK      +ENDLP     00 000   81/04/09  23.12 
          TITLE  -ENDDO- COMMAND READIN 
*         -ENDDO-            ENTRY FOR -ENDDO- COMMAND
* 
          ENTRY  ENDDOC 
 ENDDOC   SA1    TAGCNT 
          NZ     X1,IFERR94  ERROR IF TAG 
          RJ     LPCHECK     INITIAL PROCESSING 
          SA1    INDENT      INDENT LEVEL OF CURRENT COMMAND
          SX1    X1+1        CURRENT STACK LEVEL MUST BE ONE MORE 
          RJ     CHKIND      VERIFY PROPER INDENTING
          SA1    EQ          SET FOR UNCONDITIONAL BRANCH 
          EQ     ENDUNTC     AND FINISH COMMAND 
* 
*          ENTRY  UNTILC
* UNTILC   RJ     LPCHECK     INITIAL PROCESSING
*          SA1    INDENT      INDENT LEVEL OF CURRENT COMMAND 
*          SX1    X1+1        CURRENT STACK SHOULD BE 1 MORE
*          RJ     CHKIND      VERIFY PROPER INDENTING 
*          RJ     BRANCMP     COMPILE CODE FOR TAG
*          SA1    LASTKEY     CHECK TERMINATING CHAR
*          NZ     X1,=XERRTERM  ERROR IF NOT E-O-L
*          SA1    PLX1ZRX1    SET BRANCH TYPE 
* 
*         END-OF-LOOP PROCESSING
* 
 ENDUNTC  BX6    X1 
          SA6    LPINFO      SAVE END-OF-LOOP BRANCH TYPE 
          RJ     POPTOP      TERMINATE THE -LOOP- STRUCTURE 
          EQ     NOCONT      DISALLOW CONTINUED ENDDO'7S
* 
*         -LPCHECK- 
* 
*            'THIS ROUTINE IS USED BY THE -REDO-, 
*         -EXITDO-, AND -ENDDO- COMMANDS.  'IT MAKES
*         SURE THAT A -LOOP- STRUCTURE IS ACTIVE
*         AT THE INDENT LEVEL OF THE CURRENT COMMAND. 
* 
 LPCHECK  DATA   0
          RJ     INITCAL     DO INITIALIZATIONS 
*         MAKE SURE A -LOOP- STRUCTURE IS ACTIVE
          SA1    INDENT      INDENT LEVEL OF CURRENT COMMAND
          SA2    PISTACK     CURRENT LENGTH OF -ISTACK- 
          IX3    X1-X2       SEE IF -ISTACK- IS FULL ENOUGH 
          PL     X3,LPERR97  JUMP IF CAN'7T HAVE -LOOP- STRUCTURE 
          SA2    ISTACK+X1   STACK ELEMENT FOR THIS LEVEL 
          MX0    -6 
          BX2    -X0*X2      GET -TYPE- FIELD 
          SX2    X2-3        ALLOW ONLY TYPE 3
          ZR     X2,LPCHECK 
 LPERR97  SB1    97          NO -DOUNTO- COMMAND
          EQ     =XERR
* /---   BLOCK      DOTO       00 000   76/08/30  21.35 
          TITLE  -DOTO- COMMAND READIN
* 
* 
*         DOTO LABEL,INDEX_INITIAL,END,(INCREMENT)
* 
* 
          ENTRY  DOTOI       ENTRY FOR -DOTO- COMMAND 
 DOTOI    RJ     INITCAL     DO INITIALIZATIONS 
          SA1    TAGCNT 
          ZR     X1,NOTAG    ERROR IF BLANK TAG 
*         -DOTO- IN CALC TAG ENTERS HERE
 DOTO     CALL   TAGSAVE     SAVE *TAG* (COMPILE MAY MODIFY)
          RJ     GETSYM 
          LX1    X0,B2       LEFT-JUSTIFY LABEL 
          MX0    -18
          BX1    X0*X1       LIMIT SYMBOL TO 7 CHARS
          MX0    6
          BX2    X0*X1       GET TOP CHAR 
          LX2    6
          SX3    X2-1R0      MAKE SURE FIRST CHAR IS NUMERIC
          NG     X3,LABLERR  ERROR IF LESS THAN ZERO
          SX3    X2-1R9-1 
          PL     X3,LABLERR  ERROR IF GREATER THAN NINE 
          RJ     LABFIND     LOCATE LABEL NAME
          SA1    LABADDR+B1  INFO FOR THIS LABEL
          BX0    X1 
          AX0    18          CHECK IF LABEL IS DEFINED
          NZ     X0,DTOE78   ERROR IF LABEL ALREADY DEFINED 
* 
*         COMPILE CODE TO INITIALIZE INDEX  (INDEX_INITIAL) 
* 
          SA1    WORDPT 
          BX6    X1          SAVE *WORDPT* OF INDEX 
          SA6    DOSAVE1
          SX6    B1 
          SA6    DOLABEL     SAVE LABEL NUMBER
          RJ     CALCINS     COMPILE INDEX_INITIAL
          SA1    WORDPT 
          BX6    X1          SAVE *WORDPT* OF END-TEST
          SA6    DOSAVE3
          SX7    67303B      ADD A  SB3  B0-B3
          CALL   SHORT
          CALL   PAD         FINISH UP CURRENT WORD 
* 
          SA1    NINST       RESERVE WORD FOR INITIAL JUMP
          SB3    DTO30       -UPNINST- WILL RETURN HERE 
          SX7    X1+1        -UPNINST- PRESERVES X7 
          EQ     =XUPNINST   INCREMENT -NINST-
* /---   BLOCK      DOTO       00 000   76/11/25  03.29 
 DTO30    SA7    DOSAVE2     SAVE ADDRESS FOR LATER 
          SA2    JPB3A       PRESET TO  SB3 -B3  JP B3
          BX6    X2 
          SA6    X7-1        STORE PRESET VALUE FOR INITIAL JUMP
          SX1    INST+1 
          IX7    X7-X1       DISPLACEMENT TO WORD HOLDING INITIAL JUMP
          SX1    B0          GENERATE IMAGINARY LABEL FOR 
          RJ     LABFIND        START OF ENDTEST CODING 
          BX1    X7 
          SX7    B1 
          RJ     SA5JPB5     GENERATE DEFERRED JUMP TO ENDTEST CODING 
          SA5    DOLABEL     NUMBER OF -DOTO- LABEL 
          LX5    12 
          SX1    B0          GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR START OF LOOP 
          SX1    B1 
          BX5    X5+X1       COMBINE WITH -DOTO- LABEL
          RJ     LABDEF      DEFINE LABEL FOR START OF LOOP 
+         LT     B1,*        HANG IF DUPLICATE LABEL
          LX5    12 
          BX7    X5+X7       COMBINE WITH ENDTEST LABEL 
          SA1    INDENT      CURRENT INDENT LEVEL 
          LX7    6
          BX7    X1+X7       COMBINE LABELS AND INDENT LEVEL
          LX7    18          MOVE TO TOP OF WORD
          SA7    A5          SAVE FOR LATER 
* 
*         COMPILE CODE TO STORE INDEX IN *COMPUSE(0)* 
* 
          CALL   TAGREST
          SA1    DOSAVE1     RE-SET *WORDPT* TO INDEX 
          BX6    X1 
          SA6    WORDPT 
          SX0    KASSIGN     ACCEPT ASSIGNMENT AS TERMINATOR
          CALL   PSCAN       FIND END OF INDEX EXPRESSION 
          BX0    X0-X1
          NZ     X0,=XERRTERM ERROR IF TERMINATOR NOT ASSIGN
          SX6    1R,
          SA6    B1          REPLACE ASSIGNMENT WITH COMMA
          SX6    B1 
          SA6    DOSAVE4     SAVE ADDRESS OF TERMINATOR 
          CALL   GCOMP1      COMPILE INDEX EXPRESSION 
          AX1    XCODEAL+2
          SX0    2           SAVE I/F TYPE OF INDEX 
          BX6    X0*X1
          SA6    DOVTYPE
          SX7    10610B 
          CALL   SHORT       ADD A  BX6  X1 
          SX7    5160B
          LX7    18          ADD A  SA6  COMPUSE
          SA1    LLCOUSE
          BX7    X1+X7       ATTACH ADDRESS OF *COMPUSE*
          CALL   LONGI
* 
*         COMPILE CODE TO STORE END-TEST IN *COMPUSE(1)*
* 
          SA1    DOSAVE3     RE-SET *WORDPT*
          BX6    X1 
          SA6    WORDPT 
          CALL   GCOMP1      EVALUATE END-TEST EXPRESSION 
          RJ     ITFFTI      DO ANY I-F OR F-I CONVERSIONS
          SX7    10610B 
          CALL   SHORT       ADD A  BX6  X1 
          SX7    5160B
          LX7    18          ADD A  SA6  COMPUSE+1
          SA1    LLCOUSE
          SX1    X1+1 
          BX7    X1+X7       ATTACH ADDRESS OF *COMPUSE* +1 
          CALL   LONGI
* 
* /---   BLOCK      DOTO       00 000   76/07/18  19.15 
* 
*         COMPILE CODE TO GET INCREMENT TO X1 
* 
          SA1    LASTKEY     SEE IF AT END-OF-LINE
          NZ     X1,DTO100
          SX7    7110B       ASSUMED INCREMENT IS +1.0
          LX7    18 
          SX0    1           ADD A  SX1  B0+1 
          BX7    X0+X7
          CALL   LONGI
          EQ     DTO110 
* 
 DTO100   CALL   GCOMP1      EVALUATE INCREMENT EXPRESSION
 DTO110   RJ     ITFFTI 
* 
*         COMPILE RETURN JUMP TO PROPER -DO- EXECUTOR 
* 
          SX7    0100B       SET UP RJ INSTRUCTION
          LX7    18 
          SA1    DOVTYPE     GET I/F INDEX FLAG 
          NZ     X1,DTO112
          SA1    LLDOTOI     INTEGER INDEX ROUTINE
          EQ     DTO114 
* 
 DTO112   SA1    LLDOTOF     FLOATING INDEX ROUTINE 
* 
 DTO114   BX7    X1+X7       ADD AN  RJ  DOX
          CALL   LONGI
          CALL   PAD
          SA1    NINST       RESERVE WORD FOR END LOOP JUMP 
          BX6    X1          SAVE ADDRESS OF EXIT JUMP
          SA6    DOSAVE3
          SB3    DTO115      -UPNINST- RETURNS TO DTO115
          EQ     =XUPNINST   INCREMENT -NINST-
 DTO115   BSS    0
* 
*         COMPILE CODE TO STORE INDEX 
* 
          SA1    DOSAVE1     RE-SET *WORDPT* TO INDEX 
          BX6    X1 
          SA6    WORDPT 
          SA1    DOSAVE4     REPLACE ASSIGMENT WITH COMMA 
          SX6    1R,
          SA6    X1 
          CALL   PCOMP1      COMPILE CODE TO STORE INDEX
          CALL   PAD         FILL OUT REST OF WORD
* 
* /---   BLOCK      DOTO       00 000   77/12/02  21.05 
* 
*         SET UP *DOOFF* TABLE ENTRIES
* 
          SA1    NINST       RESERVE WORD FOR LOOPING JUMP
          SX7    X1+0        -UPNINST- PRESERVES X7 
          SB3    DTO116      -UPNINST- RETURNS TO DTO116
          EQ     =XUPNINST   INCREMENT -NINST-
 DTO116   SA2    DOSAVE2     BEGINNING ADDRESS OF CODE
          SA0    X2          SET UP CM ADDRESS
          IX6    X7-X2       DISPLACEMENT TO LOOPING JUMP 
          SB1    X6+1        SAVE LENGTH OF COMPILED CODE 
          SA1    DOSAVE3     ADDRESS OF END-LOOP JUMP 
          IX1    X1-X2
          LX1    18          POSITION RELATIVE JUMP ADDRESS 
          BX6    X1+X6
          SA1    IDOOFF 
          SX7    X1+1        INCREMENT -DOTO- STACK 
          SA7    A1 
          SX7    X7-DOLIM    CHECK FOR TABLE OVERFLOW 
          PL     X7,OVRERR
          LX1    1           INDEX INTO *DOOFF* TABLE 
          SA6    X1+DOOFF+1  STORE JUMP ADDRESSES 
          SA3    IDOPNT      POINTER IN -DOTO- ECS BUFFER 
          SX7    X3+B1
          SX0    X7-CDOLTH   CHECK FOR BUFFER FULL
          PL     X0,OVRERR
          SA7    A3          UPDATE ECS BUFFER POINTER
          SA2    DOLABEL
          BX7    X2+X3       COMBINE LABEL/ECS ADDRESS
          SA7    X1+DOOFF 
          SA1    ADOBUFF     ADDRESS OF ECS BUFFER
          IX0    X1+X3
+         WE     B1          WRITE COMPILED CODE TO ECS 
          RJ     ECSPRTY
          SX6    A0          BACK UP *NINST*
          SA6    NINST
          MX6    0           PRE-CLEAR FIRST WORD 
          SA6    A0 
*   TIME CHECK NOW DONE IN EXECUTION ROUTINE.... GPK
**
**         ADD CALL TO -BREAK- ROUTINE AT BEGIN OF LOOP 
**
*          SX7    0100B 
*          LX7    18          ADD AN  RJ  BREAK 
*          SA1    LLBREAK 
*          BX7    X1+X7 
*          CALL   LONGI       ADD CALL TO -BREAK- 
*          CALL   PAD 
          EQ     OKCONT 
* 
* /---   BLOCK      LABEL      00 000   76/12/22  12.44 
          TITLE  CHECK IF COMMAND IS STATEMENT LABEL
          ENTRY  LABELI 
 LABELI   SA1    COMMAND     GET POSSIBLE STATEMENT LABEL 
          MX0    6
          BX7    X0*X1       MUST START WITH A NUMBER 
          LX7    6
          SX3    X7-1R       CHECK IF FIRST CHAR IS A SPACE 
          ZR     X3,BADINDT 
          SX3    X7-1R0      CHECK FIRST CHAR GT OR EQ TO 0 
          NG     X3,BADCMND 
          SX3    X7-1R9-1    CHECK ALSO LT EQ TO 9
          PL     X3,BADCMND 
          CALL   LJUST,(1R ),0
          MX0    42 
          BX3    -X0*X1      MUST BE 7 CHARACTERS OR LESS 
          NZ     X3,BADLABL 
          BX5    X1          PRESERVE LABEL NAME
          RJ     INITCAL     INITIALIZE THE CALC
          BX1    X5          RESTORE LABEL NAME TO X1 
          RJ     LABFIND     LOCATE NUMBER FOR THIS LABEL 
          SX7    B1          X7 = LABEL NUMBER
          RJ     LABDEF      DEFINE THE LABEL 
          LT     B1,OKCONT   EXIT IF DUPLICATE LABEL
*         CHECK IF LABEL IS THE END OF A -DOTO- LOOP
          SA1    IDOOFF      SEE IF ANY UNFINISHED -DOTO- 
          ZR     X1,CALCS    TREAT AS -CALC- IF NONE
          SB7    B0          MARK NO MATCH FOUND
          LX7    48          POSITION NUMBER IN TOP 12 BITS 
          MX0    12 
          LX1    1
          SB2    X1-2        PICK UP STARTING INDEX 
          SA1    B2+DOOFF 
          BX1    X0*X1       SEE IF MATCHES LATEST -DOTO- 
          BX1    X1-X7
          NZ     X1,CHKDOTO2 GO TO SEARCH PREVIOUS LABELS 
          SB7    -1 
* 
*         BACK UP THRU -DOTO-(S) SATISFIED BY THIS LABEL
* 
 CHKDOTO1 SB2    B2-2        DECREMENT INDEX
          NG     B2,CHKDOTO3
          SA1    B2+DOOFF    LOAD NEXT -DOTO- LABEL 
          BX1    X0*X1
          BX1    X1-X7       SEE IF MATCHES IN-HAND LABEL 
          ZR     X1,CHKDOTO1
* 
*         SEARCH THRU PREVIOUS -DOTO- LABELS
*         NESTING ERROR IF ANY SATISFIED
* 
 CHKDOTO2 SB2    B2-2        DECREMENT INDEX
          NG     B2,CHKDOTO3
          SA1    B2+DOOFF 
          BX1    X0*X1
          BX1    X1-X7       SEE IF MATCHES IN-HAND LABEL 
          NZ     X1,CHKDOTO2
          EQ     NESTERR     ERROR IF FIND A MATCH
* 
 CHKDOTO3 ZR     B7,CALCS    EXIT IF NO -DOTO-S MATCHED 
          SA2    TAGCNT      COUNT OF CHARS IN TAG
          NZ     X2,DTOE82   LABEL OF DOTO MUST HAVE NO TAG 
          EQ     ENDDOTO
* /---   BLOCK      ENDDOTO    00 000   76/12/22  12.44 
          TITLE  ENDDOTO -- INSERT COMPILED CODE FOR END OF -DOTO- LOOP 
* 
*         FINISH COMPILING CODE FOR ALL -DOTOS- SATISFIED 
*         X7 HAS LABEL NUMBER IN UPPER 12 BITS
* 
 ENDDOTO  CALL   PAD         -PAD- PRESERVES X7 
          SA1    IDOOFF      NUMBER OF -DOTO-S OUTSTANDING
          NZ     X1,ENDDOTOA
          SX6    0           RE-SET ECS BUFFER POINTER
          SA6    IDOPNT 
          EQ     OKCONT 
 ENDDOTOA BX5    X1 
          LX5    1           COMPUTE INDEX IN -DOTO- TABLE
          SA5    X5+DOOFF-2  X5 = FIRST WORD OF DOOFF TABLE 
          MX0    12 
          BX2    X0*X5       X2 = LABEL NUMBER
          MX4    6
          LX4    -36
          BX4    X4*X5
          AX4    18          X4 = AMOUNT -DOTO- WAS INDENTED
          SA3    INDENT      AMOUNT LABEL IS INDENTED 
          BX4    X4-X3       CHECK IF SAME INDENTING
          BX2    X2-X7       SEE IF LABELS MATCH
          NZ     X2,OKCONT   DONE IF DIFFERENT LABELS 
          NZ     X4,DTOE83   ERROR IF NOT SAME INDENTING
          SX6    X1-1 
          SA6    A1          UPDATE -IDOOFF-
          LX0    -24
          BX1    X0*X5
          AX1    24 
          SB1    X1          B1 = LABEL FOR START OF ENDTEST CODING 
          RJ     LABDEF 
+         LT     B1,*        HANG IF DUPLICATE LABEL
          MX0    12 
          LX0    -12
          BX3    X0*X5
          AX3    36 
          SB1    X3          B1 = START-OF-LOOP LABEL 
          SA3    ADOBUFF
          SX6    X5          DISPLACEMENT TO CODE IN ADOBUFF
          IX0    X3+X6       X0 = ECS ADDRESS OF COMPILED CODE
          SA6    IDOPNT      BACK BUFFER POINTER
          SA5    A5+1        LOAD SECOND WORD OF TABLE ENTRY
          SB2    X5+1        B2 = LENGTH OF COMPILED CODE 
          SA1    NINST
          AX5    18 
          IX5    X5+X1       X5 = POINTS TO END-OF-LOOP JUMP
          SA0    X1          CM ADDRESS TO BRING CODE TO
          SX1    X1+B2       X1 = NEW VALUE FOR -NINST- 
          SX3    INST+INSTLNG-1 
          IX3    X1-X3
          PL     X3,OVRERR   ERROR IF TOO MUCH CODE 
          SX6    X1 
          SA6    A1          UPDATE -NINST- 
          SX6    B0 
          SA6    X1          PRE-CLEAR NEXT WORD
+         RE     B2          BRING IN COMPILED CODE 
          RJ     ECSPRTY
          SX0    INST+1 
          IX1    X1-X0       DISPLACEMENT TO WORD HOLDING LOOPING JUMP
          IX5    X5-X0       ADJUST END-OF-LOOP JUMP
          SX5    X5+1 
          RJ     SA5JPB5     GENERATE JUMP TO START OF LOOP 
* /---   BLOCK      ENDDOTO2   00 000   76/08/30  22.41 
          SX1    0           GENERATE IMAGINARY LABEL 
          RJ     LABFIND        FOR END OF LOOP 
          SB5    B1          PRESERVE LABEL NUMBER
          SX1    X5 
          RJ     SA5JPB5     GENERATE DEFERRED JUMP TO END OF LOOP
          SB1    B5 
          RJ     LABDEF      DEFINE END-OF-LOOP LABEL 
+         LT     B1,*        HANG IF DUPLICATE LABEL
          EQ     ENDDOTO     CHECK NEXT -DOTO-
* 
          ENTRY  DOVTYPE
 DOVTYPE  BSS    1
* 
 JPB3A    SB3    -B3
          JP     B3 
 SJP      VFD    12/5155B,18/0,12/0250B,18/0
* 
 DOLABEL  BSS    1
 DOSAVE1  BSS    1
 DOSAVE2  BSS    1
 DOSAVE3  BSS    1
 DOSAVE4  BSS    1
* /---   BLOCK      ERRORS     00 000   81/07/28  01.05 
          TITLE  ERROR EXITS
 NOTAG    SB1    41          NO TAG 
          EQ     =XERR
* 
 BADLABL  SB1    42          BAD LABEL
          EQ     =XERR
* 
 BDBRNCH  SB1    43          BAD BRANCH 
          EQ     =XERR
* 
 BADSYM   SB1    44          BAD SYMBOL 
          EQ     =XERR
* 
 CALCE1   SB1    46          CALCERR1 
          EQ     =XERR
* 
 CALCE2   SB1    47          CALCERR2 
          EQ     =XERR
* 
 CALCE3   SB1    48          CALCERR3 
          EQ     =XERR
* 
 BADCMND  SB1    73          BAD COMMAND NAME 
          EQ     =XERR
* 
 BADINDT  SB1    75          ILLEGAL INDENTING
          EQ     =XERR
* 
 NESTERR  SB1    55          DOTO NESTING ERROR 
          EQ     =XERR
* 
 LABLERR  SB1    56          DOTO STATEMENT LABEL ERROR 
          EQ     =XERR
* 
 OVRERR   SB1    57          DOTO BUFFER OVERFLOW 
          EQ     =XERR
* 
 DTOE78   SB1    78          LABEL OF -DOTO- ALREADY DEFINED
          EQ     =XERR
* 
 DTOE82   SB1    82          LABEL OF DOTO MAY NOT HAVE TAG 
          EQ     =XERR
* 
 DTOE83   SB1    83          LABEL OF DOTO HAS BAD INDENTING
          EQ     =XERR
* 
 IFERR91  SB1    91          NO -IF- COMMAND
          EQ     =XERR
* 
 IFERR94  SB1    94          COMMAND MUST HAVE NO TAG 
          EQ     =XERR
* 
* 
 SAVLAST  BSS    1
 XBRAN    BSS    1           -1 IF NO BRANCH X YET
 IBRAN    BSS    1           -1 IF -BRANCH Q- ENCOUNTERED 
 IDOOFF   BSS    1
 IDOPNT   BSS    1
* 
          EXT    CALCACT,NLABELS  MOVED TO COND 
 TDEFER   BSS    1           POINTER TO TEMPORARY BUFFER
* /---   BLOCK      INITCALC   00 000   76/08/30  21.35 
          TITLE  INITCAL -- INITIALIZATIONS FOR FIRST CALC-TYPE COMMAND 
*         THIS ROUTINE PRESERVES ALL 4, 5, AND 7 REGISTERS
 INITCAL  DATA   0
          SA1    CALCACT
          NG     X1,INITCAL  EXIT IF CALC IS ALREADY ACTIVE 
          MX6    -1 
          SA6    A1          MARK CALC ACTIVE 
          SX6    LABLIM      MAXIMUM NUMBER OF LABELS 
          SA6    TDEFER      INIT. POINTER TO DEFERRED TEMPS
          SX6    0
          SA6    IBRAN       MARK NO -BRANCH Q- ENCOUNTERED 
          SA6    COMPALL     SET NO COMPILE OF SIMPLE REF 
          SA6    INST        CLEAR FIRST INSTRUCTION WORD 
          SX6    INST 
          SA6    NINST       INITIALIZE INST POINTER
          SX6    X6+INSTLNG 
          SA6    NINSTLIM    LIMIT ON ADVANCE OF NINST
          SX6    1
          SA6    RSULTX1     SET RESULT NOT NEEDED IN X1
          SA6    CMOVFLG     SET NOT TO MOVE CODE AFTER EACH LINE 
          SA6    NOTLITS     FOR ROUTINE -SHORT-
          SA1    DOBFPNT
          BX6    X1          SAVE COMPILED CODE POINTER 
          SA6    IDOPNT 
          SA1    NDOOFF 
          BX6    X1          SAVE VALUE OF *NDOOFF* AT ENTRY
          SA6    IDOOFF 
          EQ     INITCAL
* /---   BLOCK      ENDCALC    00 000   79/08/08  10.45 
          TITLE  ENDCALC -- TERMINATE CALC AND PROCESS TEMPORARY TABLE
* 
*         'THIS ROUTINE PRESERVES A5,B5, AND X5 
* 
          ENTRY  ENDCALC
 ENDCALC  DATA   0
          SA1    CALCACT
          PL     X1,ENDCALC  EXIT IF NO -CALC- ACTIVE 
          SX6    B0 
          SA6    A1          MARK -CALC- NOT ACTIVE 
*         COMPILE A  JP B3
          SX7    23B
          LX7    21 
          RJ     LONGI
          RJ     PAD
*         MOVE COMPILED CODE INTO -INFO- BUFFER 
          SA1    ATEMPEC     ECS WORK BUFFER POINTER
          SX3    INST        FIRST WORD OF CODE 
          BX0    X1 
          SA0    X3 
          SA1    NINST       ONE PAST LAST WORD OF CODE 
          IX3    X1-X3
          SB1    X3          B1 = LENGTH OF COMPILED CODE 
          SA2    ICX
          WE     B1 
          RJ     =XECSPRTY
          SX2    X2-1        NEW VALUE FOR -ICX-
          SA1    INX
          SA0    INFO+X1     WHERE CODE GOES IN INFO BUFFER 
          IX6    X1+X3       NEW VALUE FOR -INX-
          IX3    X6-X2       COMPARE
          PL     X3,=XLNGUNIT  ERROR EXIT IF UNIT TOO LONG
          SA6    A1          UPDATE -INX- 
          BX6    X2 
          SA6    A2          UPDATE -ICX- 
          SX3    CALC=
          SB7    X1          SET ARGUMENT FOR -TEMPREF- 
          LX1    60-XCODEL   BEGINNING OF CALC IN XSTOR 
          BX6    X1+X3       FORM COMPLETE COMMAND WORD 
          SA6    INFO+X2     STORE COMMAND WORD 
          RE     B1 
          RJ     =XECSPRTY
*         PROCESS THE TEMPORARY TABLE 
          RJ     TEMPREF
*         UPDATE -DOTO- POINTERS AND WRITE -DOOFF- TO ECS 
          SA2    IDOOFF      CURRENT INDEX IN *DOOFF* TABLE 
          SA3    IDOPNT 
          BX6    X2 
          SA6    NDOOFF      UPDATE *NDOOFF*
          BX6    X3 
          SA6    DOBFPNT     UPDATE -DOTO- CODE POINTER 
          EQ     ENDCALC
* /---   BLOCK      GETSYM     00 000   77/12/13  16.07 
          TITLE  GETSYM -- GET NEXT LABEL FOR -BRANCH- OR -DOTO-
 GETSYM   EQ     *           GET NEXT SYMBOL
          SA4    WORDPT 
          SB2    60          KEEP LEFT JUSTIFY COUNT IN B2
          SB1    1
          SA4    X4          LOAD FIRST CHAR
          MX0    0
          EQ     GETSYM1
* 
 GETSYML  LX0    6
          BX0    X0+X4       MERGE IN NEW CHAR
          SB2    B2-6 
 GETSYL1  SA4    A4+B1       LOAD NEXT CHAR 
 GETSYM1  ZR     X4,GETSEOL  JUMP IF END OF LINE
          SX7    X4-1R       REMOVE ANY SPACES
          ZR     X7,GETSYL1 
          SX7    X4-1R9-1    MUST BE A LETTER OR NUM IF PART OF SYMBOL
          NG     X7,GETSYML  OK 
*          SX7    X4-1R.      PERIOD IS ALSO OK 
*          ZR     X7,GETSYML
          SX7    A4+B1       MOVE WORDPT PAST COMMA 
          SA7    WORDPT 
          SX7    X4-1R,      ELSE CHECK FOR COMMA 
          NZ     X7,=XERRTERM  TOO BAD, FORM ERROR
          MX7    18 
          BX7    X7*X0       MASK OFF TOP 3 CHARACTERS
          NZ     X7,=XERRNAME  ERROR IF NAME TOO LONG 
          EQ     GETSYM 
 GETSEOL  SX7    A4          LEAVE WORDPT AT EOL
          SA7    WORDPT 
          MX7    18 
          BX7    X7*X0       MASK OFF TOP 3 CHARACTERS
          NZ     X7,=XERRNAME  ERROR IF NAME TOO LONG 
          EQ     GETSYM 
* /---   BLOCK      ITFFTI     00 000   77/01/06  18.12 
          TITLE  ITFFTI 
* 
* 
*         -ITFFTI-
*         GENERATE INSTRUCTIONS TO CONVERT FROM INTEGER TO
*         FLOATING OR FROM FLOATING TO INTEGER
* 
* 
          ENTRY  ITFFTI 
 ITFFTI   EQ     *
          MX0    -1 
          AX1    XCODEAL+3   POSITION I/F BIT 
          BX1    -X0*X1 
          SA2    DOVTYPE     LOAD I/F BIT OF INDEX
          BX1    X1+X2       MERGE I/F BITS 
          SB1    X1 
          JP     B1+*+1      JUMP ON COMBINED I/F BITS
* 
+         EQ     ITFFTI      0 = I TO I 
+         EQ     FTI         1 = F TO I 
+         EQ     ITF         2 = I TO F 
+         EQ     ITFFTI      3 = F TO F 
* 
 FTI      SX7    0100B       ADD A  RJ  XGFTOI
          LX7    18 
          SA1    LLFTOI      ADDRESS OF F TO I ROUTINE
          BX7    X1+X7
          CALL   LONGI
          CALL   PAD         FILL OUT REST OF WORD
          EQ     ITFFTI 
* 
 ITF      SX7    27101B      ADD A  PX1  X1,B0
          CALL   SHORT
          SX7    24101B      ADD A  NX1  X1,B0
          CALL   SHORT
          EQ     ITFFTI 
* /---   BLOCK      GLOBSYM    00 000   77/05/06  00.12 
          TITLE  PROCESS DEFERRED GLOBAL SYMBOL REFERENCES
* 
* 
* 
*         -GLOBSYM- 
*         CALLED ON COMPLETION OF UNIT TO SATISFY DEFERRED
*         REFERENCES TO STATEMENT LABELS
* 
* 
          ENTRY  GLOBSYM
 GLOBSYM  EQ     *
          SX6    0           MARK NO MISSING LABELS 
          SA6    GLOBMISS 
          SA1    NDEFERR     SEE IF ANY DEFERRED REFERENCES 
          ZR     X1,GLOBSYM  EXIT IF NONE 
          SB5    X1          B5 = NUMBER OF DEFERRED SYMBOLS
* 
*         PROCESS EACH DEFERRED REFERENCE 
 GLOBSYMA SA2    LDEFER-1+B5  LOAD NEXT REFERENCE 
          UX2,B1 X2          B1 = LABEL NUMBER
          MX0    -24
          BX1    -X0*X2      LOWER 24 BITS TO X1
          BX2    X0*X2
          LX1    -12         X1 = POINTER INTO -INST- BUFFER
          LX2    -36         X2 = OTHER INFO (DEPENDS ON TYPE)
          UX1,B2 X1          B2 = TYPE OF TABLE ENTRY 
          UX2,B3 X2          B3 = SHIFT COUNT (FOR MOST TYPES)
*         CHECK IF LABEL IS DEFINED 
          SA3    LABADDR+B1 
          AX3    19          SHIFT TEMP+XSTOR 
          NZ     X3,GLOBSYMB JUMP IF LABEL DEFINED
          SX6    -1          MARK MISSING LABELS
          SA6    GLOBMISS 
          EQ     GLOBSYMC 
 GLOBSYMB RJ     LABRF       PROCESS THE DEFERRED REFERENCE 
 GLOBSYMC SB5    B5-1        END TEST 
          GT     B5,GLOBSYMA
          SA1    GLOBMISS 
          ZR     X1,GLOBSYM  EXIT IF NO MISSING LABELS
*         SEARCH LABEL TABLE FOR UNDEFINED LABELS 
          SA1    NLABELS
          SB7    X1          B7 = NUMBER OF LABELS
          SB5    B0 
 GLOBSYMD SB5    B5+1 
          GT     B5,B7,GLOBSYM
          CALL   UERRSET     SET EDIT CONNECT GOTO UNIT CMD 
          SA2    LABADDR-1+B5   CHECK NEXT LABEL
          AX2    19          SHIFT TEMP+XSTOR 
          NZ     X2,GLOBSYMD CONTINUE IF LABEL DEFINED
*         OUTPUT ',MISSING LABEL', MESSAGE
          SA1    LABELS-1+B5    GET LABEL NAME
          ZR     X1,GLOBSYMD SKIP ANY IMAGINARY LABELS
          SB2    -1          NO BAD LINE TO SAVE
          SB1    912         MISSING LABEL MESSAGE
          RJ     =XRJERR2 
          EQ     GLOBSYMD    CONTINUE SEARCH
* 
 GLOBMISS BSS    1           TEMPORARY
* /---   BLOCK      +CHKIND    00 000   80/05/06  01.20 
          TITLE  CHKIND -- CHECK IF INDENTING IS CORRECT
*         -CHKIND-
* 
*            'THIS ROUTINE VERIFIES THAT THE USER 
*         IS INDENTING HIS CODE PROPERLY.  'CHANGING
*         THE STACK WHEN IMPROPER INDENTING IS
*         DETECTED MAKES IT SO THAT ERRORS LIKE 
*         ',MISSING ENDIF COMMAND', DO NOT PROPAGATE
*         THEMSELVES OVER MANY LINES OF CODE. 
* 
*         'ON 'ENTRY -- X1 HOLDS HOW MANY ELEMENTS
*                     THE STACK SHOULD HAVE IN IT 
*                     IF THE USER HAS INDENTED THE
*                     CURRENT LINE CORRECTLY. 
* 
*         'ON 'EXIT -- 'THE STACK IS CHANGED TO HOLD
*                    WHAT IS SHOULD HOLD.  'APPROPRIATE 
*                    ERROR MESSAGES ARE OUTPUT. 
* 
*         'THIS ROUTINE PRESERVES A5,B5, AND X5 
* 
          ENTRY  CHKIND 
 CHKIND   DATA   0
          SA2    PISTACK     CURRENT LENGTH OF -ISTACK- 
          IX7    X1-X2       COMPARE WITH DESIRED VALUE 
          SX6    B0 
          ZR     X7,CHKIND   IMMEDIATE EXIT IF THE SAME 
+         NG     X1,*        SYSTEM ERROR PROTECTION
          SX3    X1-ISTACKL-1  CAN'7T BE MORE THAN -ISTACKL-
+         PL     X3,*        SYSTEM ERROR PROTECTION
          NG     X7,CHKINDB  JUMP IF -ISTACK- IS TOO FULL 
*         INCREASE -STACK- BY INSERTING ZERO ELEMENTS 
 CHKINDA  SA6    ISTACK+X2   CLEAR NEXT -ISTACK- ELEMENT
          SX2    X2+1        ADVANCE POINTER
          SX7    X7-1 
          NZ     X7,CHKINDA  LOOP UNTIL ALL WORDS ARE ZEROED
          SX6    X2 
          SA6    A2          UPDATE -PISTACK- 
          SB1    74          ILLEGAL INDENTING
          RJ     =XRJERR     OUTPUT CONDENSE ERROR MESSAGE
          EQ     CHKIND 
*         DECREASE -ISTACK- BY TERMINATING ANY ACTIVE STRUCTURES
 CHKINDB  BX6    X1 
          SA6    CHKTEMP     SAVE ARGUMENT FOR LATER
          RJ     INITCAL     MAKE SURE -CALC- IS INITIALIZED
 CHKINDC  SA2    PISTACK
          SA1    CHKTEMP
          IX7    X2-X1
          ZR     X7,CHKIND   EXIT IF -ISTACK- LENGTH IS NOW CORRECT 
          SA2    ISTACK-1+X2 LOAD TOP -ISTACK- ELEMENT
          MX0    -6 
          BX2    -X0*X2      GET -TYPE- FIELD 
          ZR     X2,CHKINDD  NO ERROR MESSAGE IF TYPE ZERO
          SA1    CHKTAB-1+X2 GET ERROR MESSAGE FOR THIS TYPE
          SB1    X1 
          RJ     =XRJERR     OUTPUT CONDENSE ERROR MESSAGE
* /---   BLOCK      +CHKIND    00 000   81/03/18  20.43 
 CHKINDD  SA1    EQ          SET ENDLOOP BRANCH TYPE
          BX6    X1 
          SA6    LPINFO 
          RJ     POPTOP      DECREMENT THE STACK
          EQ     CHKINDC
* 
 CHKTEMP  BSS    1
*         ERROR MESSAGES FOR EACH TYPE (EXCEPT ZERO)
 CHKTAB   DATA   92          MISSING -ENDIF- COMMAND
          DATA   92          MISSING -ENDIF- COMMAND
          DATA   96          MISSING -ENDDO- COMMAND
***NOTE***ADD ENTRIES TO THE ABOVE TABLE FOR EACH NEW -TYPE-
* /---   BLOCK      +POPTOP    00 000   81/03/18  20.45 
          TITLE  POPTOP -- REMOVE TOP STACK ELEMENT 
*         -POPTOP-
* 
*            'THIS ROUTINE REMOVES THE TOP ELEMENT
*         OF -ISTACK- BY PROPERLY TERMINATING WHATEVER
*         STRUCTURE WAS ACTIVE. 
* 
*         'THIS ROUTINE PRESERVES A5,B5, AND X5 
* 
 POPTOP   DATA   0
          SA2    PISTACK     CURRENT STACK POINTER
          SX6    X2-1        DECREMENT BY ONE 
+         NG     X6,*        SYSTEM ERROR PROTECTION
          SA1    ISTACK+X6   LOAD TOP ELEMENT OF STACK
          SA6    A2          UPDATE -PISTACK- 
          SX6    B0 
          SA6    A1          CLEAR THIS -ISTACK- POSITION 
          MX0    -6 
          BX0    -X0*X1      LOWER 6 BITS ARE -TYPE- FIELD
          SB1    X0 
          SB2    POPTOPK-POPTOPJ   LENGTH OF TABLE
+         GE     B1,B2,*     SYSTEM ERROR PROTECTION
          JP     POPTOPJ+B1  DO JUMP ON -TYPE-
 POPTOPJ  EQ     POPTOP      0 = NOTHING IN STACK 
          EQ     POPENDIF    1 = -IF- COMMAND IS ACTIVE 
          EQ     POPENDIF    2 = -ELSE- COMMAND ENCOUNTERED 
          EQ     POPENDLP    3 = -LOOP- OR -FOR- COMMAND IS ACTIVE
***NOTE*** 'EACH TIME A NEW -TYPE- IS DEFINED, BE SURE TO 
***NOTE*** UPDATE THE TABLE -CHKTAB- IN ROUTINE -CHKIND-. 
 POPTOPK  BSS    0           MARKER FOR END OF TABLE
* 
*         'TERMINATE THE -IF- STRUCTURE.
*         X1 HAS STACK INFO.
 POPENDIF UX7,B7 X1          B7 = LABEL FOR -FALSE- BRANCH
          RJ     INITCAL     DO INITIALIZATIONS 
          SB1    B7 
          RJ     LABDEF      DEFINE -FALSE- LABEL 
          LX7    12 
          UX7,B1 X7          B1 = LABEL FOR -END- BRANCH
          RJ     LABDEF      DEFINE -END- BRANCH
          EQ     POPTOP 
* 
*         'TERMINATE THE -LOOP- STRUCTURE.
*         X1 HAS STACK INFO.
*         *LPINFO* HAS END-OF-LOOP BRANCH TYPE
 POPENDLP UX7,B7 X1          B7 = LABEL FOR -LOOP- BRANCH 
          RJ     INITCAL     DO INITIALIZATIONS 
          SA7    POPTEMP     SAVE LABEL FOR -END- BRANCH
          SA1    LPINFO      X1 = BRANCH TYPE 
          SB1    B7          LABEL NUMBER 
          RJ     LABJUMP     OUTPUT BRANCH TO START OF LOOP 
          SA2    POPTEMP
          LX2    12 
          UX2,B1 X2          B1 = LABEL FOR -END- BRANCH
          RJ     LABDEF      DEFINE THE LABEL 
          EQ     POPTOP 
* 
 POPTEMP  BSS    1
* 
* /---   BLOCK      LABJUMP    00 000   79/08/08  11.48 
          TITLE  LABJUMP -- COMPILE BRANCH TO SPECIFIED STATEMENT LABEL 
*         -LABJUMP- 
* 
*            'THIS ROUTINE COMPILES A BRANCH TO A 
*         SPECIFIED STATEMENT LABEL.  'IT CHECKS
*         FOR FORWARDS BRANCHES (NO TIME CHECK
*         NEEDED) AND FOR A LABEL WITHIN THE SAME 
*         CALC (NO RESET OF -A5- NEEDED).  'THE 
*         GENERATED CODE (ALWAYS) SETS B1 TO THE
*         EXTRA STORAGE PART OF THE LABEL AND 
*         (SOMETIMES) SETS X0 TO THE COMMAND PART 
*         OF THE LABEL.  'IT THEN COMPILES A BRANCH 
*         TO ONE OF THE FOLLOWING CENTRAL MEMORY
*         LOCATIONS'; 
*         A) -SYSJP-, IF THE BRANCH IS BACKWARDS
*            AND WITHIN THE SAME CALC.  'DOES A TIME
*            CHECK BUT DOES NOT RESET A5. 
*         B) -SYSJPA5-, IF THE BRANCH IS BACKWARDS
*            BUT IN A DIFFERENT CALC.  'DOES A TIME 
*            CHECK AND RESETS A5 (TO X0). 
*         C) -SYSJPNT-, IF THE BRANCH IS FORWARDS.
*            'RESETS A5 BUT DOES NO TIME CHECKS.
* 
*         'ON 'ENTRY -- 
*            B1 = LABEL NUMBER
*            X1 = 6400 INSTRUCTIONS TELLING WHEN
*                 THE BRANCHES ARE TO BE TAKEN. 
*                 'THE LOWER 12 BITS HOLD THE FIRST 
*                 INSTRUCTION.  'IF THE SAME BRANCH 
*                 IS TO BE TAKEN FOR SEVERAL CONDITIONS,
*                 THE UPPER BITS MAY HOLD ADDITIONAL
*                 INSTRUCTIONS.  (LIMIT';  4 INSTRUCTIONS 
*                 IN LOWER 48 BITS) 
* 
*         'THIS ROUTINE PRESERVES A5,B5, AND X5 
* 
 LABJUMP  DATA   0
+         SA2    CALCACT     A -CALC- MUST BE ACTIVE
*          PL     X2,*        SYSTEM ERROR PROTECTION 
          PL     X2,=XERRORC IF NOT ACTIVE
          PX6    X1,B1       SAVE ARGUMENTS IN -LJTEMP- 
          SA6    LJTEMP 
*         GENERATE SB1 TO X-STOR PART OF LABEL
          RJ     JPB3        PUT JPB3 IN INSTRUCTION STREAM 
          SX2    6115B       SB1  B5+0* 
          SB2    2           TYPE = 2 (EXTRA STORAGE PART)
          SA3    LJTEMP 
          UX3,B1 X3          LABEL NUMBER 
          SB7    B1          SAVE IN B7 
          RJ     CLABREF     B1 WILL HOLD JUMP ADDRESS
*         CHECK FOR BACKWARDS BRANCH WITHIN THE SAME CALC 
          SA1    LABADDR+B7  LOAD INFO FOR THIS LABEL 
          AX1    18          COMMAND PART OF LABEL
          SX1    X1-1        *1* MEANS LABEL IS TEMP DEFINED
          SX7    LLSYSJP     TO -SYSJP- IF SAME CALC
          ZR     X1,LABJUMPA JUMP IF LABEL IS IN SAME CALC
* /---   BLOCK      LABJUMP2   00 000   77/01/09  21.39 
*         GENERATE SX0 TO COMMAND PART OF LABEL 
          RJ     JPB3        NEXT INSTRUCTION 
          SX2    7105B       SX0  B5+0* 
          SB2    1           TYPE = 1 (COMMAND PART)
          SA3    LJTEMP 
          UX3,B1 X3          LABEL NUMBER 
          SB7    B1          SAVE IN B7 
          RJ     CLABREF     X0 WILL HOLD NEW VALUE FOR A5
*         CHECK FOR FORWARDS BRANCH 
          SA1    LABADDR+B7  LOAD INFO FOR THIS LABEL 
          AX1    18          COMMAND PART OF LABEL
          SX7    LLSYSNT     TO -SYSJPNT- IF FORWARDS BRANCH
          ZR     X1,LABJUMPA JUMP IF LABEL IS NOT DEFINED 
          SX7    LLSYSA5     TO -SYSJPA5- IF BACKWARDS
 LABJUMPA SA2    X7          GET CM ADDRESS 
          BX6    X2 
          SA6    LJTEMP2     SAVE IN LJTEMP2
 LABJUMPB SA1    LJTEMP 
          MX0    -12
          UX6    X1 
          BX1    -X0*X1      GET NEXT INSTRUCTION 
          LX1    18          POSITION 
          ZR     X1,LABJUMP  EXIT IF NO MORE INSTRUCTIONS 
          AX6    12          DISCARD CURRENT INSTRUCTION
          SA6    A1          STORE NEW LJTEMP 
          SA2    LJTEMP2     CM LOCATION
          BX7    X1+X2       COMBINE WITH OP CODE 
          RJ     =XLONGI     OUTPUT DESIRED INSTRUCTION 
          EQ     LABJUMPB 
* 
 LJTEMP   BSS    1
 LJTEMP2  BSS    1
* 
 EQ       DATA   0400B       EQ  *
 NGX1     DATA   0331B       NG  X1,* 
 PLX1ZRX1 DATA   03010321B   PL  X1,*     ZR  X1,*
* 
* /---   BLOCK      LABFIND    00 000   79/08/08  14.51 
          TITLE  LABFIND -- RETURN INTERNAL NAME FOR LABEL HOLERITH 
*         -LABFIND- 
* 
*            'THIS ROUTINE SEARCHES THE LABEL TABLE 
*         FOR SPECIFIED NAME.  'IF NOT FOUND, IT ADDS 
*         THE NAME TO THE END OF THE TABLE.  'A ZERO
*         NAME MEANS TO CREATE AN IMAGINARY LABEL.
* 
*         'ON ENTRY --
*            X1 = LABEL HOLERITH (ZERO IF CREATING IMAGINARY LABEL) 
* 
*         'ON EXIT -- 
*            B1 = POSITION OF LABEL IN TABLE (INTERNAL NAME)
* 
*         'THIS ROUTINE PRESERVES ALL 4, 5 AND 7 REGISTERS. 
* 
 LABFIND  DATA   0
          SA2    NLABELS     NUMBER OF LABELS NOW IN TABLE
          MX0    42 
          BX6    X0*X1       GET TOP SEVEN CHARS ONLY 
          ZR     X6,LABFINDB JUMP TO CREATE NEW LABEL 
          SB1    X2+0 
 LABFINDA LE     B1,LABFINDB CREATE NEW LABEL IF NOT FOUND
          SB1    B1-1 
          SA3    LABELS+B1   LOAD NEXT TABLE ENTRY
          BX3    X3-X6       CHECK IF SAME
          NZ     X3,LABFINDA CONTINUE SEARCH IF NOT 
          EQ     LABFIND     EXIT IF NAME FOUND IN TABLE
 LABFINDB SA3    TDEFER      POINTER TO MOST RECENT DEFERRED TEMPORARY
          IX3    X2-X3
          SB1    X2          B1 = POSITION FOR NEXT ENTRY 
          PL     X3,LABFULL  ERROR IF TABLE IS FULL 
          SA6    LABELS+B1   STORE NEW LABEL NAME 
          MX6    0           ZERO LABEL ADDRESS WORD
          SA6    LABADDR+B1  STORE ADDRESS
          SX6    X2+1 
          SA6    NLABELS     UPDATE NLABELS 
          EQ     LABFIND
* /---   BLOCK      LABDEF     00 000   76/08/31  02.14 
          TITLE  LABDEF -- DEFINE LABEL FOR UNIT
*         -LABDEF-
* 
*            'ON ENTRY, B1 HOLDS THE NUMBER OF
*         THE LABEL WHICH IS TO BE DEFINED. 
*         'THIS LABEL BECOMES ASSOCIATED WITH THE 
*         'N'E'X'T COMMAND THAT IS STORED IN THE UNIT.
*         (-ICX- IS USED TO DETERMINE THIS.)
* 
*         'IF A CALC IS ACTIVE (AS SHOWN BY -CALCACT-), 
*         -PAD- IS CALLED AND THE LABEL IS ALSO 
*         ASSOCIATED WITH THE NEXT WORD OF -INST- BUFFER. 
*         'THE *TEMP* BIT IN THE LABEL TABLE IS SET 
*         AND THE ACTUAL LABEL DEFINITION IS DEFERRED 
*         UNTIL THE CALC IS COMPLETED.
* 
*         'IF A CALC IS NOT ACTIVE, THE LABEL IS
*         NOT ASSOCIATED WITH EXTRA STORAGE AND ITS 
*         DEFINITION IS DONE IMMEDIATELY. 
* 
*         'ON ENTRY, -B1-, -CALCACT-, AND -ICX- MUST
*         BE SET PROPERLY AS DESCRIBED ABOVE. 
* 
*         'ON EXIT, B1 =  0 IF NO ERROR 
*                     = -1 IF DUPLICATE LABEL 
* 
*         'THIS ROUTINE PRESERVES ALL 5 AND 7 REGISTERS.
* 
 LABDEF   DATA   0
          SA2    CALCACT     X2 = CALCACT 
*         CHECK IF LABEL ALREADY DEFINED
          SA1    LABADDR+B1  LOAD INFO FOR THE LABEL
          BX0    X1 
          AX0    1           REMAINING BITS MUST BE ZERO
          NZ     X0,LABDUP   JUMP IF DUPLICATE LABEL
          SA4    ICX         POINTER TO LAST COMMAND
          SX4    X4-INFOLTH  ZERO IF NO COMMANDS YET
          SX4    X4-2        X4 IS MINUS TWO OR LESS
          PL     X2,LABDEFA  JUMP IF NO CALC ACTIVE 
*         IF IN CALC, MUST STORE IN TEMPORARY TABLE 
          SB4    B1+0        PRESERVE B1
          RJ     PAD         SAVES ALL 4, 5, AND 7 REGISTERS
          SA1    NINST       POINTER TO NEXT WORD OF -INST- 
          SX2    INST-1      WORD BEFORE FIRST INSTRUCTION
          IX1    X1-X2       RELATIVE LABEL ADDRESS (+1)
          BX2    -X4         X2 = COMMAND LABEL IS AT (+1)
          SB1    B4          B1 = LABEL NUMBER
          SB3    B0          B3 IS NOT USED 
          SB2    4           TYPE = 4 
          RJ     CLABREF     STORE IN TEMPORARY TABLE 
          SX6    1           MARK LABEL AS TEMP. DEFINED
          LX6    18          POSITION TO TEMP DEFINE BIT
          SA6    LABADDR+B4  SAVE TEMP DEFINE 
          SB1    0           MARK NO ERROR
          EQ     LABDEF 
*         IF NOT IN CALC, DEFINE LABEL IMMEDIATELY
 LABDEFA  LX4    18          POSITION COMMAND DISPLACEMENT
          BX6    -X4         SAVE COMMAND DISPLACEMENT
          SA6    LABADDR+B1  STORE NEW LABEL ADDRESS
          SB1    0           MARK NO ERROR
          EQ     LABDEF 
* /---   BLOCK      LABDEF2    00 000   79/08/08  14.46 
*         DUPLICATE LABEL ENCOUNTERED 
 LABDUP   BX6    X2 
          SA6    LABTEMP     PRESERVE -CALCACT- 
          SA1    LABELS+B1   GET LABEL NAME 
          SX2    B0          SAVE UNIT NAME 
          SB2    0           SAVE BAD LINE
          SB1    911         DUPLICATE UNIT MESSAGE 
          RJ     =XRJERR2 
          SA1    LABTEMP     RESTORE -CALCACT-, SINCE IT
          BX6    X1              IS CLEARED BY -RJERR2- 
          SA6    CALCACT
          SB1    -1          RETURN B1=-1 IF DUPLICATE LABEL
          EQ     LABDEF 
* /---   BLOCK      LABREF     00 000   77/05/06  00.13 
          TITLE  LABRF -- PROCESS LABEL REFERENCE 
*         -LABRF- 
* 
*            'THE MAIN PURPOSE OF THIS ROUTINE
*         IS TO PROCESS REFERENCES TO LABELS. 
*         'IT ALSO HANDLES LABEL DEFINITIONS WHICH
*         HAD TO BE DEFERRED BECAUSE THEY OCCURRED
*         IN A CALC.
* 
*    ON ENTRY --
*         B1 = LABEL NUMBER 
*         B2 = TYPE OF REFERENCE';
*              1 IF INSTRUCTION AND COMMAND PART OF LABEL 
*              2 IF INSTRUCTION AND EXTRA STORAGE PART OF LABEL 
*              3 IF 9 BIT COMMAND PART OF LABEL 
*              4 IF TEMPORARY LABEL DEFINITION
*              5 IF BRANCH X
*         B3 = SHIFT COUNT FOR POSITIONING NEW INFO 
*              (COUNT OF BITS TO THE RIGHT OF INFO
*               THAT IS TO BE UPDATED)
*         X1 = DISPLACEMENT IN INFO BUFFER OF WORD
*              THAT NEEDS UPDATING
*         X2 = EXTRA INFO DEPENDING ON TYPE'; 
*              TYPE 1';  UPPER 12 BITS OF INSTRUCTION 
*                   2';  UPPER 12 BITS OF INSTRUCTION 
*                   3';  UNUSED 
*                   4';  COMMAND DISPLACEMENT (B3 IS UNUSED)
* 
*    ON EXIT -- 
*            'IF THE LABEL IS DEFINED THE REFERENCE 
*         IS UPDATED IMMEDIATELY.  'IF THE LABEL IS 
*         NOT DEFINED THE REFERENCE IS SAVED IN A 
*         DEFER BUFFER AND PROCESSED UPON COMPLETION
*         OF THE UNIT.
* 
*         'THIS ROUTINE PRESERVES ALL 5 AND 7 REGISTERS.
* 
 LABRF    DATA   0
+         LT     B2,*        SYSTEM ERROR IF B2 OUT-OF-RANGE
          SB4    4
+         GT     B2,B4,*
          JP     *+B2        JUMP ON TYPE 
          EQ     LABREF1     DO INDIVIDUALIZED PROCESSING 
          EQ     LABREF2
          EQ     *           LABREF3
          EQ     LABREF4
          EQ     *           LABREF5
* 
*         TYPE = 1
*            30 BIT INSTRUCTION, ADDRESS PORTION
*         IS SET TO THE COMMAND PART OF LABEL.
* 
*         B1 = LABEL NUMBER 
*         B3 = SHIFT COUNT TO POSITION INSTRUCTION
*         X1 = DISPLACEMENT IN INFO BUFFER OF WORD
*              THAT NEEDS UPDATING
*         X2 = UPPER 12 BITS OF INSTRUCTION 
 LABREF1  SA3    LABADDR+B1  GET ENTRY FOR THIS LABEL 
          BX0    X3 
          AX0    19          DISCARD *TEMP DEFINED* BIT 
          ZR     X0,LABREFD  JUMP IF LABEL NOT YET DEFINED
          MX6    -18
          AX3    18          GET COMMAND PART OF LABEL (+1) 
          SX3    X3-1        FIRST COMMAND GIVES X0 = 1 
          BX3    -X3         COMMANDS GO BACKWARDS
          BX0    -X6*X3      CLEAR TOP BITS 
          LX2    18          SHIFT UPPER BITS OF INSTRUCTION
          BX2    X2+X0       COMBINE WITH ADDRESS PART
          MX0    30          MASK FOR 30 BIT INSTRUCTION
          LX0    30 
          EQ     LABREFS     GO TO STORE THE INFO 
* 
* /---   BLOCK      LABREF2    00 000   79/08/08  12.28 
* 
*         TYPE = 2
*            30 BIT INSTRUCTION, ADDRESS PORTION
*         IS SET TO THE EXTRA STORAGE PART OF LABEL.
* 
*         B1 = LABEL NUMBER 
*         B3 = SHIFT COUNT TO POSITION INSTRUCTION
*         X1 = DISPLACEMENT IN INFO BUFFER OF WORD
*              THAT NEEDS UPDATING
*         X2 = UPPER 12 BITS OF INSTRUCTION 
* 
*            'FOR NOW, IT IS ILLEGAL TO USE THIS TYPE 
*         WITH A LABEL WHICH HAS NO EXTRA STORAGE.
 LABREF2  SA3    LABADDR+B1  GET INFO FOR THIS LABEL
          BX0    X3 
          AX0    19          DISCARD *TEMP DEFINED* BIT 
          ZR     X0,LABREFD  JUMP IF LABEL NOT YET DEFINED
          MX0    -18         LOWER 9 BITS HOLD X-STOR INFO
          BX0    -X0*X3      GET EXTRA STORAGE POINTER (+1) 
+         ZR     X0,*        HANG IF LABEL NOT IN X-STOR
          SX0    X0-1        LOWEST POSSIBLE VALUE IS ZERO
          LX2    18          SHIFT UPPER BITS OF INSTRUCTION
          BX2    X2+X0       COMBINE WITH ADDRESS BITS
          MX0    30          SET MASK FOR 30 BIT INSTRUCTION
          LX0    30 
          EQ     LABREFS     GO TO STORE THE INFO 
* 
*         TYPE = 4
*            'LABEL OCCURRED INSIDE A CALC, AND 
*         HENCE WAS ONLY TEMPORARILY DEFINED.  'COME
*         HERE TO DEFINE IT PERMANENTLY.
* 
*         B1 = LABEL NUMBER 
*         B3 = 0 (UNUSED) 
*         X1 = LOCATION OF LABEL IN EXTRA STORAGE (+1)
*         X2 = LOCATION OF LABEL IN COMMAND STORAGE (+1)
 LABREF4  LX2    18          POSITION COMMAND LABEL IS AT 
          BX6    X1+X2       ATTACH TO X-STOR DISPLACEMENT
          SA6    LABADDR+B1  STORE DEFINED LABEL INFO 
          EQ     LABRF       EXIT 
* /---   BLOCK      LABREF3    00 000   80/03/20  11.35 
* 
*            'COME HERE IF LABEL IS UNDEFINED.
*         'THE REFERENCE IS PROCESSED WHEN THE UNIT 
*         IS COMPLETED. 
 LABREFD  PX1    X1,B2       PACK REGISTERS INTO ONE WORD 
          PX2    X2,B3
          LX1    12 
          LX2    36 
          BX6    X1+X2
          PX6    X6,B1
          SA3    NDEFERR     CHECK IF STILL ROOM IN TABLE 
          SX3    X3+1 
          SX0    X3-DEFRLIM 
          PL     X0,LABFULL  JUMP IF -DEFERR- IS FULL 
          SA6    LDEFER-1+X3 SAVE TEMP LABEL
          SX6    X3 
          SA6    A3          UPDATE TABLE POINTER 
          EQ     LABRF
* 
*         'COME HERE TO PROCESS THE LABEL REFERENCE 
*         X0 = MASK 
*         X1 = INFO WORD THAT NEEDS UPDATING
*         X2 = NEW INFO 
*         B3 = SHIFT COUNT FOR INFO AND MASK
 LABREFS  LX0    X0,B3       POSITION MASK
          LX2    X2,B3       POSITION NEW INFO
          SA3    INFO+X1     WORD THAT NEEDS UPDATING 
          BX3    -X0*X3      CLEAR OLD INFO 
          BX6    X2+X3       INSERT NEW INFO
          SA6    INFO+X1     STORE UPDATED WORD 
          EQ     LABRF
* 
 LABTEMP  BSS    1
* 
* /---   BLOCK      CLABREF    00 000   79/08/08  12.40 
          TITLE  CLABREF -- SAVE LABEL REFERENCE IN TEMPORARY TABLE 
*         -CLABREF- 
*            'THIS ROUTINE IS CALLED WHEN THE 
*         INSTRUCTION WHICH REFERENCES THE LABEL
*         IS IN THE -INST- BUFFER.  'THE INFO IS
*         STORED TEMPORARILY AT THE END OF THE
*         LABEL TABLE AND PROCESSED WHEN -INST- 
*         IS MOVED INTO EXTRA STORAGE (SEE -TEMPREF-).
* 
*         'ON ENTRY --
*            'ARGUMENTS ARE EXACTLY AS IN -LABREF-, 
*         'E'X'C'E'P'T -- X1 HOLDS THE DISPLACEMENT INTO
*         -INST-, NOT -INFO-. 
* 
*         'THIS ROUTINE PRESERVES ALL 5 AND 7 REGISTERS 
*         'IT ALSO PRESERVES ALL INPUT ARGS. (B1,B2,B3,X1,X2) 
* 
 CLABREF  DATA   0
          PX0    X1,B2       BEGIN PACKING REGISTERS
          PX3    X2,B3
          LX3    24 
          BX0    X0+X3
*         CHECK IF STILL ROOM IN LABEL TABLE
          SA3    TDEFER      POINTER TO LAST TEMP ENTRY 
          SA4    NLABELS     NUMBER OF LABEL NAMES
          IX4    X4-X3
          PL     X4,LABFULL  JUMP IF TABLE IS FULL
          SX6    X3-1 
          SA6    A3          UPDATE -TDEFER-
          LX0    12          FINISH PACKING REGISTERS 
          PX6    X0,B1
          SA6    LABADDR-1+X3 STORE THE REFERENCE 
          EQ     CLABREF
*         FOR NOW, GIVE ',LONG UNIT', IF TABLE IS FULL
 LABFULL  EQ     =XLNGUNIT
* 
* /---   BLOCK      TEMPREF    00 000   79/08/08  12.41 
          TITLE  TEMPREF -- PROCESS THE TEMPORARY TABLE 
*         -TEMPREF- 
* 
*            'THIS ROUTINE IS CALLED UPON COMPLETION
*         OF A CALC TO PROCESS THE DEFERRED REFERENCE 
*         ENTRIES THAT ARE SAVED TEMPORARILY AT THE 
*         END OF THE LABEL TABLE.  'THE MAIN REASON 
*         FOR THIS IS BECAUSE CODE IS GENERATED INTO
*         THE -INST- BUFFER;  WE DO NOT KNOW ITS
*         LOCATION IN EXTRA STORAGE UNTIL THE CALC
*         IS COMPLETED. 
* 
*         'ON ENTRY --
*            B7 = DISPLACEMENT TO WHERE THE -INST-
*                 BUFFER WAS PUT IN EXTRA STORAGE.
* 
*         'THIS ROUTINE PRESERVES A5,B5, AND X5 
* 
 TEMPREF  DATA   0
          SA1    TDEFER      POINTER TO LAST TEMP ENTRY 
          SX6    LABLIM      LENGTH OF -LABELS- 
          SA6    A1          RESET -TDEFER- TO -LABLIM- 
          SX7    X1          X7 = POINTER TO NEXT ENTRY 
 TEMPREFL SB1    X7-LABLIM   CHECK IF NO MORE TO DO 
          GE     B1,TEMPREF 
          SA2    LABADDR+X7  LOAD NEXT ENTRY
          UX2,B1 X2          B1 = LABEL NUMBER
          MX0    -24
          BX1    -X0*X2      LOWER 24 BITS TO X1
          BX2    X0*X2
          LX1    -12         X1 = POINTER INTO -INST- BUFFER
          LX2    -36         X2 = OTHER INFO (DEPENDS ON TYPE)
          UX1,B2 X1          B2 = TYPE OF TABLE ENTRY 
          UX2,B3 X2          B3 = SHIFT COUNT (FOR MOST TYPES)
          SX1    X1+B7       UPDATE X1 TO POINT INTO X-STOR 
          RJ     LABRF       PROCESS ENTRY (SAVES B7 AND X7)
          SX7    X7+1 
          EQ     TEMPREFL 
* 
* /---   BLOCK      JP B3      00 000   79/08/08  12.42 
          TITLE  JPB3 -- COMPUTE POSITION OF NEXT INSTRUCTION 
*         -JPB3-
* 
*            'THIS ROUTINE OUTPUTS A -JP B3- INSTRUCTION
*         AND COMPUTES ITS POSITION IN THE -INST- BUFFER. 
* 
*         'ON 'EXIT --
*            X1 = INST DISPLACEMENT TO WORD WITH THE -JP B3-
*            B3 = SHIFT COUNT GIVING BIT POSITION OF -JP B3-
* 
*         'THIS ROUTINE PRESERVES A5,B5, AND X5 
* 
 JPB3     DATA   0
          SX7    0233B       JP  B3+0 
          LX7    18 
          RJ     LONGI
*         FIGURE OUT WHERE THE INSTRUCTION WAS PUT
          SA1    NINST
          SX0    INST 
          SA2    X1          CURRENT INSTRUCTION WORD 
          IX1    X1-X0       DISPLACEMENT TO CURRENT WORD 
          ZR     X2,JPB3C    JUMP IF EMPTY
          MX0    30 
          BX2    X0*X2       CHECK TOP 30 BITS
          NZ     X2,JPB3B    JUMP IF ONLY 15 BITS LEFT
          SB3    30          TOP HALF OF WORD 
          EQ     JPB3 
 JPB3C    SX1    X1-1        BACK UP TO PREVIOUS WORD 
          SB3    0           LOWER HALF OF WORD 
          EQ     JPB3 
 JPB3B    SB3    15          MIDDLE OF WORD 
          EQ     JPB3 
* 
* /---   BLOCK      SA5 JP B5  00 000   79/08/08  12.43 
          TITLE  SA5JPB5 -- OLD WAY OF HANDLING DEFERRED REFERENCES 
*         -SA5JPB5- 
* 
*            'THIS ROUTINE SETS UP DEFERRED 
*         PROCESSING FOR A ',SA5 B5+(COMMAND
*         DISPLACEMENT OF LABEL)', AND A
*         ',JP  B5+(X-STOR DISPLACEMENT OF LABEL)', 
*         'IT IS USED BY ROUTINES WHICH WERE
*         USING THE OLD DEFERRED REFERENCE STUFF. 
* 
*         'ON ENTRY --
*            B1 = LABEL NUMBER
*            X1 = INST DISPLACEMENT TO WORD WHICH 
*                 IS TO BRANCH TO THE LABEL IN (B1).
* 
*         'THIS ROUTINE PRESERVES ALL 5 AND 7 REGISTERS.
* 
 SA5JPB5  DATA   0
*         CHECK IF LABEL IS DEFINED WITHIN THIS CALC
          SA3    LABADDR+B1  LOAD INFO FOR THIS LABEL 
          AX3    18 
          SX3    X3-1        *1* MEANS TEMP DEFINED 
          SB3    30          SET FOR UPPER INSTRUCTION
          ZR     X3,SA5JPA   JUMP IF LABEL IS IN THIS CALC
*         PUT IN A *SA5* DEFERRED REFERENCE 
          SB2    1           TYPE = 1 
          SX2    5155B       SA5  B5+* (UPPER 12 BITS)
          RJ     CLABREF     STORE IN TEMP TABLE
          SB3    0           SET FOR LOWER INSTRUCTION
*         PUT IN A *JP B5* DEFERRED REFERENCE 
 SA5JPA   SB2    2           TYPE = 2 
          SX2    0255B       JP  B5+* (UPPER 12 BITS) 
          RJ     CLABREF     STORE IN TEMP TABLE
          EQ     SA5JPB5
* 
* /---   BLOCK      END        00 000   79/08/08  12.43 
* 
          END