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