Trailing-Edge
-
PDP-10 Archives
-
decuslib20-06
-
decus/20-153/rpgiid.mac
There is 1 other file named rpgiid.mac in the archive. Click here to see a list.
TITLE RPGIID FOR RPGII V1
SUBTTL CALCULATION STATEMENT SYNTAX SCANNER
;
; RPGIID PHASE D FOR RPGII V1
;
; THIS SECTION OF THE COMPILER SCANS THE CALCULATION SPECIFICATIONS
; WHICH IT PULLS OUT OF CALFIL, AND GENERATES OUR FIRST INTERMEDIATE
; CODE IN GENFIL, AS WELL AS SETTING UP NECESSARY DATAB AND VALTAB
; ENTRIES. CONTROL IS THEN PASSED TO PHASE E WHICH WILL TAKE THE
; CODE OUT OF GENFIL AND GENERATE THE ASYFIL'S.
;
; BOB CURRIER SEPTEMBER 18, 1975 22:54:37
;
; ALL RIGHTS RESERVED, BOB CURRIER
;
TWOSEG
RELOC 400000
ENTRY RPGIID
;RPGIID ENTRY POINT INTO PHASE D
;
;
;
RPGIID: PORTAL .+1 ; COME ON IN
SETFAZ D; ; SET UP ALL THE PHASE D JUNK
SWOFF <FTOT!FLR!FSR!FEOF!FREGCH>;
SWON FDET; ; WE START IN DETAIL CALCS
CLOSE CAL, ; CLOSE OUT CALFIL
MOVEI DA,CALDEV##
SETZ I1, ; ASCII MODE
MOVE I2,DEVDEV(DA) ; GET DEVICE NAME
MOVEI DA,SRCDEV## ; GET SOURCE DATA
MOVEI I3,DEVBH(DA) ; CREATE AN XWD
OPEN SRC,I1 ; OPEN
JRST CANTOP ; CAN'T
MOVE TE,CALHDR## ; GET CALFIL DATA
MOVE TD,CALHDR##+1 ;
SETZB TC,TB ;
LOOKUP SRC,TE ; FIND IT
JRST KNOCAL ; NOT FOUND - BAD
SKIPN TA,DEVBUF(DA)
MOVE TA,.JBFF
MOVEM TA,.JBFF## ; START AT FREE CORE
MOVEM TA,DEVBUF(DA)
INBUF SRC,1 ; [340] get a buffer
SETZM SRCBLK## ; CLEAR BLOCK COUNT
SWON FNOCPY; ; TURN OFF COPY
MOVE LN,CALLIN## ; RESTORE LINE NUMBER SAVED IN PHASE C
SUBI LN,1 ; DECREMENT SO THINGS LINE UP
MOVEM LN,SAVELN##
CA.00: SWOFF FDIV; ; LAST VERB SEEN WAS NOT A DIVIDE
;ENTER AT CA.00 NORMALLY, ENTER AT CA.00+1 FOR DIVIDE OPERATION
PUSHJ PP,GETSRC## ; GET A CHARACTER
TSWF FEOF; ; HIT EOF?
JRST FIND ; YES -
SWON FREGCH; ; SET TO REGET
PUSHJ PP,GETCRD## ; GET A CARD IMAGE
AOS SAVELN ; INCREMENT LINE NUMBER
MOVE TB,FRMTYP## ; get the form type
CAIE TB,"C" ; is it a C card?
JRST FIND ; no - go finish up
MOVE TB,COMMNT## ; GET COMMENT COLUMN
CAIN TB,"*" ; IS COMMENT?
JRST CA.00 ; YES - GET ANOTHER
CA.01: MOVE TA,[BPNT 6,] ; SET UP TO GET CONTROL LEVEL
ILDB CH,TA ; GET FIRST CHAR OF IT
LSH CH,7 ; MAKE ROOM FOR MORE
ILDB TB,TA ; GET ANOTHER CHAR
IOR TB,CH ; OR IT ON IN
CAIN TB," " ; DO WE GOT THE BLANKS?
JRST CA.01B ; YES - DETAIL
CAIN CH,"L"_7 ; FIRST CHAR AN L?
JRST CA.03 ; YES - TOTAL OR LAST RECORD
CAIN TB,"SR" ; SR?
JRST CA.04 ; YES - SUBROUTINE CALCS
CAIE TB,"AN"
CAIN TB,"OR"
JRST CA.01A ; AND/OR LINE
WARN 123; ; GARBAGE
JRST CA.00 ; LOOP AND GET ANOTHER CARD
CA.01A: TSWF FANDOR; ; ARE WE ON AND/OR LINE
JRST .+3 ; YEP-
WARN 517; ; NOPE - ERROR
JRST CA.00 ; LOOP AND HOPE FOR BETTER
SETZ TC, ; SET "AND" FLAG
CAIN TB,"OR" ; IS IT OR?
MOVEI TC,1 ; YES - SET "OR" FLAG
MOVE TA,CURIND## ; GET CURRENT INDTAB ENTRY
DPB TC,ID.OR## ; RESET PREVIOUS FLAG
JRST CA.01C ; AND GO PROCESS
EXTERNAL DEVBH, DEVDEV, DEVBUF
CA.01B: TSWF FDET; ; ARE WE IN DETAIL CALCS STILL?
JRST CA.04C ; YES -
WARN 189; ; NO - ERROR
JRST CA.00 ; LOOP AND PRAY
CA.01C: MOVE TB,[BPNT 27,] ; GET POINTER TO OP-CODE
MOVEI TC,^D5 ; IS FIVE CHARS LONG
PUSHJ PP,BLNKCK## ; IS OP-CODE BLANK?
JRST CA.01F ; NO - MUST BE REAL OP
MOVE TB,[BPNT 8,] ; START OF INDICATORS
MOVEI TC,^D9 ; NINE CHARACTERS
PUSHJ PP,BLNKCK ; ALL BLANK
TRNA ; NO - ALL'S WELL
JRST CA.01H ; YES - ERROR
MOVE TB,[BPNT 17,] ; YES - SHOULD BE FOLLOWED BY AND/OR LINE
MOVEI TC,^D57 ; FIRST MAKE SURE THE REST OF IT'S BLANK
PUSHJ PP,BLNKCK
JRST CA.01D ; IT'S NOT
PUSHJ PP,GETIND ; GET AN INDTAB ENTRY
TSWF FANDOR; ; ARE WE ALREADY THERE?
JRST CA.01E ; YES -
MOVEM TA,TB ; NO - MAKE AND STORE A POINTER
SUB TB,INDLOC## ; SUBTRACT BASE
IORI TB,<CD.IND>B20 ; MAKE OUR MARK
MOVEM TB,INDLNK## ; STORE FOR LATER
PUSHJ PP,INDL ; SET UP INDTAB ENTRY IF L0-LR
CA.01E: PUSHJ PP,SETIND ; SET UP INDTAB ENTRIES FOR INDICATORS
SWON FANDOR; ; DREAD FANDOR
JRST CA.00 ; LOOP ON AROUND FOR ANOTHER CARD
CA.01D: WARN 708; ; GARBAGE ON CARD
JRST CA.00 ; IGNORE ALL ELSE
CA.01F: TSWF FANDOR; ; IS IT FANDOR?
JRST CA.01I ; YES - ALREADY SET UP
MOVE TB,[BPNT 8,] ; NO - GET POINTER TO INDICATPORS
MOVEI TC,^D9 ; TRY NINE TIMES
PUSHJ PP,BLNKCK ; CHECK IT ON OUT
JRST CA.01I ; IS REAL
MOVE TB,[BPNT 6,] ; IS BLANK - CHECK FOR L0-LR
ILDB CH,TB ; GET A CHAR
CAIN CH,"L" ; AN ELL?
JRST CA.01I ; YES - BUSINESS AS USUAL
SETZM INDLNK ; NO - ZERO THE LINK
JRST CA.02 ; AND FORGET ABOUT INDTAB
CA.01I: PUSHJ PP,GETIND ; GET AN ENTRY
TSWF FANDOR; ; HAVE WE ALREADY SET UP INDLNK?
JRST CA.01G ; YES - HOPE SO ANYWAY
SUB TA,INDLOC ; NO - SET IT UP NOW
IORI TA,<CD.IND>B20 ;
MOVEM TA,INDLNK ; STASH
PUSHJ PP,INDL ; CHECK OUT POSSIBILITY OF L0-LR
CA.01G: PUSHJ PP,SETIND ; SET UP INDICATORS
SWOFF FANDOR; ; SAY FAREWELL TO FANDOR
JRST CA.02 ; NOW GO DO THE REST
CA.01H: WARN 709; ; BLANK INDICATORS & BLANK OP-CODE
JRST CA.00 ; IGNORE CARD
;CA.02 GET ALL RELEVANT DATA OFF CARD
;
;
CA.02: SWOFF FANDOR; ; AWAY MIGHTY FANDOR!
SKIPN INDLNK ; GOT AN INDTAB ENTRY?
JRST .+4 ; NO -
MOVE TA,CURIND ; YES - GET POINTER
MOVEI TB,1 ; GET A FLAG
DPB TB,ID.END## ; FLAG END
PUSHJ PP,VRBSCN ; LOOK FOR THE OP
JRST CA.02A ; GOT IT
WARN 128; ; NOT FOUND, TELL IDIOT
JRST CA.00 ; AND GET ANOTHER CARD
CA.02A: SETZM F1INDX## ; RESET ALL SORTS OF GARBAGE
SETZM F2INDX##
SETZM F1LINK##
SETZM F2LINK##
SWOFF <F1LIT!F2LIT!F1NUM!F2NUM!F1DAT!F2DAT!F1LNK!F2LNK>;
MOVE TB,[BPNT 17,] ; GET POINTER
SETZ LN, ; ZAP FLAG
PUSHJ PP,GETFAC ; GET THE FACTOR
MOVEM TB,F1LINK ; AND STORE IT
MOVE TB,[BPNT 32,] ; GET ANOTHER POINTER
SETO LN, ; SET FLAG
PUSHJ PP,GETFAC ; GET FACTOR 2
MOVEM TB,F2LINK ; AND STORE IT
SETZM NAMWRD ; RESET NAMWRD
SETZM NAMWRD+1
SETZM REINDX ; ZAP RESULT INDEX
MOVE TC,[BPNT 42,] ; GET A POINTER TO RESULT
MOVE TB,[POINT 6,NAMWRD] ; STUFF INTO NAMWRD
CA.02B: ILDB CH,TC ; GET A CHARACTER
CAIN CH," " ; IS IT SPACE?
JRST CA.02G ; YES - ALL DONE
CAIN CH,"," ; COMMA?
JRST CA.02C ; YES - SHOULD BE INDEX
SUBI CH,40 ; NO - MAKETH A SIXBIT
IDPB CH,TB ; STASH CHARACTER
TLNE TB,770000 ; ALL OUT OF ROOM?
JRST CA.02B ; NO - LOOP
JRST CA.02G ; YES - HIT THE END, EXIT
CA.02C: PUSH PP,TC ; SAVE BYTE POINTER
PUSHJ PP,TRYNAM ; IF INDEXED, MUST ALREADY BE DEFINED
JRST CA.02H ; NOT DEFINED - ERROR
MOVEI TB,CD.DAT ; GET DATAB POINT
MOVSS TA ; GET RELATIVE LINK
PUSHJ PP,FNDLNK## ; LOOKUP NAMTAB LINK IN DATAB
JRST CA.02H ; NOT FOUND - ERROR
MOVE TA,TB ; [135] GET DATAB LINK INTO TA
LDB TB,DA.OCC## ; GET NUMBER OF OCCURANCES
JUMPLE TB,CA.02I ; INVALID IF NOT POSITIVE
MOVE TB,[POINT 6,REINDX##] ; IS - MAKE POINTER INTO STORAGE
POP PP,TC ; RECOVER BYTE POINTER
ILDB CH,TC ; GET ANOTHER CHARACTER
CAIL CH,"0" ; IS IT A DIGIT?
CAILE CH,"9"
JRST CA.02E ; NO -
CA.02D: SUBI CH,40 ; YES - MAKE INTO SIXBIT
IDPB CH,TB ; STASH
TLNN TB,770000 ; OUT OF ROOM IN REINDX?
JRST CA.02H ; YES - BAD FORMAT
ILDB CH,TC ; NO - GET ANOTHER CHARACTER
CAIN CH," " ; A SPACE?
JRST CA.02G ; YES - ALL DONE
CAIL CH,"0" ; NO - VALID DIGIT?
CAILE CH,"9" ;
JRST CA.02J ; NO - ERROR
JRST CA.02D ; YES - LOOP
CA.02E: CAIN CH," " ; FIRST CHAR SPACE?
JRST CA.02J ; YES - ERROR
CA.02F: SUBI CH,40 ; MAKE A SIXBIT
IDPB CH,TB ; STASH
TLNN TB,770000 ; ALL OUT OF ROOM?
JRST CA.02H ; YES - GARBO
ILDB CH,TC ; NO - GET ANOTHER CHAR
CAIE CH," " ; SPACE?
JRST CA.02F ; NO - LOOP
CA.02G: MOVE TA,NAMWRD ; GET MAIN ITEM
MOVEM TA,RELINK## ; STORE FOR FUTURE GENERATIONS
MOVE TA,VRBNUM## ; RECOVER OP-CODE
SWOFF FMAGIC; ; NO MAGIC FOR NOW
JRST @VRBDIS(TA) ; AND OFF INTO A GENERATOR
CA.02H: WARN 135; ; GARBAGE!!!!
JRST CA.00 ; GET ANOTHER CARD
CA.02I: WARN 229; ; INDEXING INVALID WITH TABLE OR FIELD
JRST CA.00 ; IGNORE REST
CA.02J: WARN 228; ; INVALID INDEX
JRST CA.00 ; LIKEWISE
CA.03: CAIE TB,"LR" ; TOTAL?
JRST CA.03B ; MUST BE -
TSWF FLR; ; ARE WE ALREADY IN LR?
JRST CA.01C ; YES -
TSWT FDET; ; NO - WERE WE IN DET OR LR?
TSWF FTOT;
JRST .+3 ; MUST BE -
CA.03A: WARN 189; ; NO - OUT OF SEQ
JRST CA.00 ; LOOP -
TSWF FANDOR; ; ARE WE STILL ON AND/OR?
JRST CA.04B ; YES - ERROR!
TSWF FTOT; ; ANY TOTALS?
JRST .+6 ; YES -
MOVEI CH,OPDET## ; NO - FLAG DETAIL ESCAPE
ROT CH,-^D9 ; GET EVERYTHING INTO PLACE
PUSHJ PP,PUTGEN ; OUPUT IT
SETZ CH, ; OUTPUT A ZERO
PUSHJ PP,PUTGEN ; AS SECOND WORD
SWOFF FDET!FTOT; ; RESET
SWON FLR; ; SAY WHO I AM
JRST CA.01C ; AND GO DO IT
CA.03B: ANDI TB,177 ; GET LAST CHARACTER
CAIL TB,"0"
CAILE TB,"9"
JRST CA.03C ; GARBO (AND NOT GRETA)
TSWF FTOT; ; ALREADY IN TOTAL?
JRST CA.04C ; YES - OK
TSWT FDET; ; NO - WE IN DETAIL?
JRST CA.03A ; NO - ERROR
TSWF FANDOR; ; STILL IN FANDOR?
JRST CA.04B ; YES - ERROR
SWOFF FDET; ; YES - RESET
SWON FTOT; ; STAKE OUR CLAIM
MOVEI CH,OPDET ; GET DETAIL ESCAPE OP
ROT CH,-^D9 ; ROT!
PUSHJ PP,PUTGEN ; OUTPUT IT
SETZ CH, ; OUTPUT A ZERO
PUSHJ PP,PUTGEN ; THUSLY
JRST CA.01C
CA.03C: WARN 123; ; JUNK
JRST CA.00 ; IGNORE REST
CA.04: TSWF FSR; ; ALREADY IN SUBROUTINES?
JRST CA.04C ; YES - OK
TSWF FDET; ; STILL IN DETAIL?
PUSHJ PP,CA.04D ; YES - OUTPUT AN OPDET
TSWF FANDOR; ; ALREADY IN FANDOR?
JRST CA.04B ; YES - NO GOOD
SWOFF FDET!FTOT!FLR; ; RESET.
SWON FSR; ; SAY WHO WE ARE
MOVEI CH,OPCAL## ; OUTPUT TOTAL ESCAPE
ROT CH,-^D9 ; MOVE IT AROUND A BIT
PUSHJ PP,PUTGEN ; LIKE THIS
SETZ CH, ; AND AS USUAL...
PUSHJ PP,PUTGEN ; OUTPUT A ZERO WORD
JRST CA.01C ; AND GO DO IT
CA.04C: TSWT FANDOR; ; FANDOR ON?
JRST CA.01C ; NO - ALL OK
CA.04B: WARN 520; ; YES - FLAG IT AS ERROR
SWOFF FANDOR; ; TURN IT OFF
JRST CA.00 ; AND GET ANOTHER CARD
CA.04D: MOVEI CH,OPDET ; GET THE OP
ROT CH,-^D9 ; AGE FOR PROPER FLAVOR
PUSHJ PP,PUTGEN ; SERVE IT UP
SETZ CH, ; EMPTY THE GARBAGE
PUSHJ PP,PUTGEN ; AND TAKE OUT TO THE CAN
POPJ PP, ; CAN LEAVE NOW
;GETFAC GET A FACTOR
;
;GET A LITERAL (NUMERIC OR ALPHA) OR A DATA-NAME.
;
;
GETFAC: MOVE TA,TB ; STORE FOR LATER USE
ILDB CH,TB ; GET FIRST CHARACTER
CAIN CH,"'" ; IS IT ALPHA-LIT?
JRST GTFAC2 ; APPARENTLY SO -
CAIL CH,"0" ; IS IT NUM-LIT?
CAILE CH,"9" ; ?
SKIPA TB,[POINT 6,NAMWRD] ; FANCY MOVE
JRST GTFAC3 ; YES, IS NUM-LIT....
CAIN CH,"+" ; [304] a plus sign?
JRST GTFAC3 ; [304] yes - ok
CAIE CH,"-" ; [072] IS IT UNARY MINUS?
CAIN CH,"." ; ONE MORE CHANCE, DO WE TAKE IT?
JRST GTFAC3 ; YES -
MOVE TC,TA ; NO - MUST BE DATA-ITEM.
SETZM NAMWRD## ; ZAP SOME STUFF SO THAT WE
SETZM NAMWRD+1 ; DON'T EAT LEFTOVERS
GTFC1C: ILDB CH,TC ; GET A CHARACTER
CAIN CH," " ; SPACE (I.E. END OF ENTRY) ?
JRST GTF1C1 ; YES -
CAIN CH,"," ; COMMA (I.E. SUBSCRIPT) ?
JRST GTFC1E ; YES, GOD DAMN IT
SUBI CH,40 ; I PRONOUCE THEE SIXBIT
IDPB CH,TB ; STASH CHARACTER
TLNE TB,770000 ; HIT END OF NAMWRD?
JRST GTFC1C ; NO - LOOP
GTF1C1: SKIPN TB,NAMWRD ; GET ANYTHING?
JRST GTFC1D ; NO - IS STILL OK
ILDB CH,TC ; [362] get next character
CAIN CH,"," ; [362] a comma (subscript)?
JRST GTFC1E ; [362] yes - handle it
PUSH PP,TB ; [321] don't let TB get clobbered
PUSHJ PP,NMVRFY## ; [271] verify name's validity
WARN 710; ; [271] not valid - type error
POP PP,TB ; [321] bring back TB
PUSHJ PP,TRYNAM## ; YES - SEE IF DATA-ITEM EXISTS
JRST GTFC1K ; IT DOESN'T - TOO BAD CHUCKO
MOVE TB,TA ; GET LINK INTO PROPER AC
JRST GTFC1D ; IT DOES - GO FINISH UP
GTFC1E: PUSH PP,TC ; SAVE BYTE POINTER
PUSHJ PP,TRYNAM ; SEE IF TABLE/ARRAY EXISTS
JRST GTFC1L ; [314] it doesn't
JUMPE LN,.+2 ; WHICH FACTOR?
SKIPA TB,[POINT 6,F2INDX##] ; MUST BE FACTOR 2
MOVE TB,[POINT 6,F1INDX##] ; MUST BE FACTOR 1
POP PP,TC ; GET BYTE POINTER BACK
ILDB CH,TC ; GRAB ANOTHER CHARACTER
CAIL CH,"0" ; NUMERIC ( I SURE HOPE SO )
CAILE CH,"9"
JRST GTFC1G ; NO - GUY WANTS TO MAKE IT HARD
;GETFAC (CONT'D) CONTINUE HANDLEING OF DATA NAME
;
GTFC1F: SUBI CH,40 ; INTO THE LAND OF THE SIX BIT'S
IDPB CH,TB ; STASH INTO INDEX WORD
TLNN TB,770000 ; ALL OUT OF WORD?
JRST GTFC1A ; YES - ERROR
JUMPN LN,.+4 ; WHICH FACTOR?
CAMN TC,[BPNT 28,] ; F1 - ARE WE AT END OF FIELD?
JRST GTF1C1 ; YES - ALL DONE
JRST .+3 ; NO - CONTINUE
CAMN TC,[BPNT 42,] ; F2 - ARE WE AT END OF FIELD?
JRST GTF1C1 ; YES - ALL DONE
ILDB CH,TC ; GET ANOTHER CHAR
CAIN CH," " ; THE MAGIC DELIMITER?
JRST GTF1C1 ; YES - GO FINISH
CAIL CH,"0" ; NO - LEGAL DIGIT?
CAILE CH,"9" ;
JRST GTFC1A ; NO - ERROR
JRST GTFC1F ; YES - LOOP FOR MORE
GTFC1G: CAIN CH," " ; BLANKER?
JRST GTFC1A ; YES - TURKEY IS STUPID
GTFC1H: SUBI CH,40 ; MAKE A SIXBIT
IDPB CH,TB ; STASH
TLNN TB,770000 ; ALL OUT OF ROOM?
JRST GTFC1A ; YES - ERROR
JUMPN LN,.+4 ; WHICH FACTOR
CAMN TC,[BPNT 28,] ; F1 - ARE WE AT END OF FIELD?
JRST GTFC1D ; YES - ALL DONE
JRST .+3 ; NO - CONTINUE
CAMN TC,[BPNT 42,] ; F2 - ARE WE AT END OF FIELD?
JRST GTFC1D ; YES - ALL DONE
ILDB CH,TC ; NO - GET ANOTHER CHAR
CAIE CH," " ; SPACE?
JRST GTFC1H ; NO - LOOP
JRST GTF1C1 ; yes - go finish up
GTFC1D: JUMPE LN,.+2 ; WHICH FACTOR?
SWONS F2DAT; ; 2
SWON F1DAT; ; 1
POPJ PP, ; POP OUT FOR A SPOT OF TEA
GTFC1L: POP PP,(PP) ; [314] pop garbage off stack
GTFC1A: WARN 710;
POPJ PP, ; SCREW EVERYONE
GTFC1K: JUMPE LN,.+2
SWONS F2LNK; ; FLAG AS SYMBOLIC RATHER THAN LINK
SWON F1LNK; ; LIKEWISE FOR FACTOR 1
MOVE TB,NAMWRD ; [300] restore name
JRST GTFC1D ; GO FINISH
;GETFAC (CONT'D) HANDLE AN ALPHAMERIC LITERAL
;
GTFAC2: PUSHJ PP,GETVAL## ; IT..IT....IT....IT'S....ALPHA-LIT!!
MOVE TC,TA ; RECOVER POINTER
SUB TC,VALLOC## ; SUBTRACT BASE
IORI TC,<CD.VAL>B20 ; SAY WHO WE ARE
MOVEM TC,VALLNK## ; STASH AS LINK
MOVEI TD,-^D9 ; GET CHARACTER COUNT
MOVE TC,[POINT 7,(TA),6] ; GET POINTER INTO VALTAB
GTFC2A: ILDB CH,TB ; GET A CHARACTER
CAIN CH,"'" ; SINGLE QUOTE?
JRST GTFC2C ; YES -
GTFC2D: IDPB CH,TC ; NO - STORE CHARACTER
AOJE TD,GTFC2F ; JUMP IF WE ARE DONE
TLNE TC,760000 ; OUT OF ROOM?
JRST GTFC2A ; NO - LOOP ON BACK AROUND
PUSHJ PP,GETVAL ; YES - GET ANOTHER VALTAB LINK
MOVE TC,[POINT 7,(TA)] ; RESET POINTER (IN CASE VALTAB MOVED)
JRST GTFC2A ; AND LOOP
GTFC2C: ILDB CH,TB ; GET CHARACTER AFTER QUOTE
CAIN CH,"'" ; IS IT SECOND QUOTE?
JRST GTFC2D ; YES - OK
JRST GTFC2E ; NO - MUST BE END
GTFC2F: JUMPE LN,.+3 ; NO - ERROR
WARN 131;
POPJ PP,
WARN 125;
POPJ PP,
GTFC2E: ADDI TD,^D9+1 ; RECOVER CHARACTER COUNT
MOVE TA,VALLNK ; GET LINK
PUSHJ PP,LNKSET## ; SET LINKERS
DPB TD,[POINT 7,(TA),6] ; STASH IN VALTAB
MOVE TB,VALLNK ; RECOVER STANDARD LINK
JUMPE LN,.+2 ; WHICH FACTOR?
SWONS F2LIT; ; 2
SWON F1LIT; ; 1
POPJ PP,
;GETFAC (CONT'D) HANDLE A NUMERIC LITERAL
;
GTFAC3: MOVE TB,TA ; RECOVER THE BYTE POINTER
PUSHJ PP,GETVAL ; GET VALTAB ENTRY
MOVE TC,TA ; GET LINK
SUB TC,VALLOC ; CONVERT TO RELATIVE LINK
IORI TC,<CD.VAL>B20 ; SAY RELATIVE TO WHAT
MOVEM TC,VALLNK ; STASH
MOVEI TD,-^D10
MOVE TC,[POINT 7,(TA),6] ; SET UP POINTER INTO INDTAB
GTFC3A: SKIPE LN ; WHICH FACTOR?
CAME TB,[BPNT (42)] ; FACTOR 2 - AT END?
CAMN TB,[BPNT (26)] ; FACTOR 1 - AT END?
JRST GTFC3C ; YES -
ILDB CH,TB ; GET A CHARACTER
CAIN CH," " ; SPACE?
JRST GTFC3C ; YES - SHOULD BE END
CAIN CH,"+" ; [304] unary plus?
JRST GTFC3B ; [304] yes - ok
CAIE CH,"-" ; UNARY MINUS?
CAIN CH,"." ; OR DECIMAL?
JRST .+4 ; YES - BYPASS VALIDITY CHECK
CAIL CH,"0" ; NO - VALID DIGIT?
CAILE CH,"9" ; ?
JRST GTFC2F ; NO -
GTFC3B: IDPB CH,TC ; [304] YES - STASH IN VALTAB
AOJE TD,GTFC3C ; JUMP IF DONE
TLNE TC,760000 ; OUT OF VALTAB?
JRST GTFC3A ; NO - CONTINUE
PUSHJ PP,GETVAL ; YES - GET MORE
MOVE TC,[POINT 7,(TA)] ; RESET POINTER
JRST GTFC3A ; LOOP
GTFC3C: MOVEI CH,"_" ; GET AN EOL CHAR
IDPB CH,TC ; STASH IT
AOJ TD, ; BUMP TALLY
ADDI TD,^D10 ; RECOVER COUNT
MOVE TA,VALLNK ; GET FIRST WORD OF VALTAB ENTRY
PUSHJ PP,LNKSET ; SET LINK
DPB TD,[POINT 7,(TA),6] ; STORE COUNT
MOVE TB,VALLNK ; RECOVER STANDARD LINK
JUMPE LN,.+2
SWONS F2LIT!F2NUM; ; FACTOR 2
SWON F1LIT!F1NUM; ; FACTOR 1
POPJ PP, ; EXIT
;VRBSCN LOOKUP OP-CODE IN TABLE
;
;CALL: PUSHJ 17,VRBSCN
; RETURN IF FOUND
; RETURN IF NOT FOUND
;
;
VRBSCN: SETZ TE, ; ZAP TE
MOVE TA,[BPNT 27,] ; GET POINTER TO OP
MOVE TB,[POINT 6,TE] ; GET POINTER TO PLACE TO PUT IT
MOVEI TC,5 ; GET FIVE CHARACTERS
PUSHJ PP,CRDSIX## ; AND READ IT ON IN
MOVEI TA,1B^L<OP1END-OP1TOP> ; SET UP INDEX
MOVEI TB,1B^L<OP1END-OP1TOP>/2; SET UP INCREMENT
VRB1A: CAMN TE,OP1TOP(TA) ; ARE WE THERE YET MOMMY?
JRST VRB1C ; YES -
JUMPE TB,VRB1D ; TEST FOR END OF TABLE
CAML TE,OP1TOP(TA) ; NO - SHOULD WE MOVE DOWN?
TDOA TA,TB ; NO - INCREMENT
VRB1B: SUB TA,TB ; YES - DECREMENT
ASH TB,-1 ; HALVE INCREMENT
CAIG TA,OP1END-OP1TOP ; ARE WE OUT OF BOUNDS?
JRST VRB1A ; NO - TRY AGAIN
JRST VRB1B ; YES - BRING IT DOWN
VRB1C: MOVE TC,TA ; IF WE USED TA, REMAINDER GOES IN AC17
IDIVI TC,4 ; TC HAS INDEX USED IN OPTTAB
LDB TB,OPTTAB(TB) ; GET OP-CODE
MOVEM TB,VRBNUM## ; STORE FOR POSTERITY
POPJ PP, ; AND EXIT
VRB1D: AOS (PP) ; TAKE ERROR RETURN
POPJ PP, ; THUSLY
OPTTAB: POINT 9,OP1COD-1(TC),35
POINT 9,OP1COD(TC),8
POINT 9,OP1COD(TC),17
POINT 9,OP1COD(TC),26
;VRBSCN (CONT'D) DEFINE TABLE BUILDING MACRO
;
.XCREF ; DON'T CREF THIS CRAP
RELOC .-1
OP1TOP:
RELOC
IF1,<N1=0
DEFINE X <N1=N1+1 ;>>
IF2,<
N2=^D36
CC=0
RELOC OP1COD
RELOC
DEFINE X (SYMBOL,CODE)
<SIXBIT /SYMBOL/
CC=CC+CODE_<N2=N2-9>
IFE N2,<OUTLIT>>
DEFINE OUTLIT <
RELOC
+CC
RELOC
N2=^D36+<CC=0>>>
;DEFINE OP-CODES
;
X ADD , 1
X BEGSR , 35
X BITOF , 23
X BITON , 22
X CHAIN , 44
X COMP , 20
X DEBUG , 45
X DIV , 6
X DSPLY , 42
X ENDSR , 36
X EXCPT , 41
X EXIT , 31
X EXSR , 37
X FORCE , 40
X GOTO , 27
X LOKUP , 33
X MHHZO , 15
X MHLZO , 17
X MLHZO , 16
X MLLZO , 14
X MOVE , 12
X MOVEA , 50
X MOVEL , 13
X MULT , 5
X MVR , 7
X READ , 43
X RLABL , 32
X SETOF , 26
X SETON , 25
X SQRT , 11
X SUB , 3
X TAG , 30
X TESTB , 24
X TESTZ , 21
X TIME , 51
X XFOOT , 10
X Z-ADD , 2
X Z-SUB , 4
IF1,<BLOCK N1>
OP1END: -1B36
OP1COD: BLOCK N1/4
CC
.CREF
;DISPATCH TABLE FOR VERBS
VRBDIS: EXP OPZERO ; ILLEGAL OP-CODE
EXP ADD. ; ADD
EXP ZADD. ; ZADD
EXP SUB. ; SUB
EXP ZSUB. ; ZSUB
EXP MULT. ; MULT
EXP DIV. ; DIV
EXP MVR. ; MVR
EXP XFOOT. ; XFOOT
EXP SQRT. ; SQRT
EXP MOVE. ; MOVE
EXP MOVEL. ; MOVEL
EXP MLLZO. ; MLLZO
EXP MHHZO. ; MHHZO
EXP MLHZO. ; MLHZO
EXP MHLZO. ; MHLZO
EXP COMP. ; COMP
EXP TESTZ. ; TESTZ
EXP BITON. ; BITON
EXP BITOF. ; BITOF
EXP TESTB. ; TESTB
EXP SETON. ; SETON
EXP SETOF. ; SETOF
EXP GOTO. ; GOTO
EXP TAG. ; TAG
EXP EXIT. ; EXIT
EXP RLABL. ; RLABL
EXP LOKUP. ; LOKUP (TABLE)
EXP LOKUP. ; LOKUP (ARRAY)
EXP BEGSR. ; BEGSR
EXP ENDSR. ; ENDSR
EXP EXSR. ; EXSR
EXP FORCE. ; FORCE
EXP EXCPT. ; EXCPT
EXP DSPLY. ; DSPLY
EXP READ. ; READ
EXP CHAIN. ; CHAIN
EXP DEBUG. ; DEBUG
EXP NOTVRB ; DET
EXP NOTVRB ; CAL
EXP MOVEA. ; MOVEA
EXP TIME. ; TIME
;ADD. GENERATE GENFIL CODE FOR THE ADD OP
;
;
;
ADD.: PUSHJ PP,SETRES ; MAKE SURE RESULT EXISTS
PUSHJ PP,F1NUMC ; MAKE SURE F1 EXISTS AND IS NUMERIC
PUSHJ PP,F2NUMC ; MAKE SURE F2 EXISTS AND IS NUMERIC
SETZM OPRTR## ; ZAP SPECIAL WORD
MOVEI TB,OPADD## ; GET OP-CODE
ADD.00: DPB TB,OP.OP## ; STASH IN WORD
MOVE TB,SAVELN## ; GET LINE NUMBER
DPB TB,OP.LN## ; STASH THIS TOO
MOVE CH,OPRTR ; GET WORD
PUSHJ PP,PUTGEN## ; OUTPUT TO GENFIL
HRLZ CH,INDLNK ; GET INDTAB LINK
PUSHJ PP,RESGEN ; OUTPUT RESULTING IND'S IF ANY
PUSHJ PP,PUTGEN ; OUTPUT IT AS SECOND OPERATOR WORD
ADD.0A: SETZM OPRTR ; ZAP ANY RESIDUE
MOVEI TB,1 ; FOR FLAGS
DPB TB,OP.OPR## ; WE'RE NOT AN OPERAND
TSWT F1LIT; ; ARE WE A LITERAL?
JRST ADD.01 ; NO -
DPB TB,OP.LIT## ; YES - SET FLAG
TSWF F1NUM; ; ARE WE NUMERIC LITERAL?
DPB TB,OP.NUM## ; YES - STASH AS FLAG
ADD.01: MOVE TB,F1LINK ; GET LINK
DPB TB,OP.LNK## ; STORE AS LINK
MOVE CH,OPRTR ; GET WORD 2
PUSHJ PP,PUTGEN ; STASH IN GENFIL
CAMN TB,F2LINK ; ARE F1 AND F2 EQUAL ?
JRST ADD.03 ; YES - SAVE SOME TIME
ADD.1A: SETZM OPRTR ; NO - START ALL OVER AGAIN
MOVEI TB,1 ; START WITH NEW FLAG
DPB TB,OP.OPR ; NOT OPERAND
TSWT F2LIT; ; LITERAL?
JRST ADD.02 ; NO -
DPB TB,OP.LIT ; YES - FLAG IT AS SUCH
TSWF F2NUM; ; NUMERIC LITERAL?
DPB TB,OP.NUM ; YES - FLAG
ADD.02: MOVE TB,F2LINK ; GET LINK
DPB TB,OP.LNK ; STASH
MOVE CH,OPRTR ; GET WORD
ADD.03: PUSHJ PP,PUTGEN ; STASH WORD IN GENFIL
MOVE TB,VRBNUM ; GET THE OP-CODE
CAIN TB,OPCOMP ; IS IT A COMP?
JRST CA.00 ; YES - EXIT
CAIN TB,OPTLOK ; IS IT LOKUP?
POPJ PP, ; YES - EXIT
SETZM OPRTR ; NO - ZAP ANY LEFTOVERS
MOVEI TB,1 ; ALWAYS A FLAG
DPB TB,OP.OPR ; "NOT A OPERAND"
MOVE TB,RELINK ; GET RESULT LINK
DPB TB,OP.LNK ; STASH
MOVE CH,OPRTR ; GET WORD
PUSHJ PP,PUTGEN ; OUTPUT
MOVE TB,VRBNUM ; GET THE OP
CAIN TB,OPDIV ; IS IT A DIVIDE?
JRST CA.00+1 ; YES - LEAVE FDIV TURNED ON
JRST CA.00 ; NO - LOOP
;SUB. GENERATE GENFIL CODE FOR THE SUB OP
;
;
;
SUB.: MOVEI TB,OPSUB## ; GET OP CODE
SUB.1: PUSH PP,TB ; STASH FOR LATER
PUSHJ PP,SETRES ; MAKE SURE RESULT IS OK
PUSHJ PP,F1NUMC ; CHECK UP ON 1
PUSHJ PP,F2NUMC ; LIKEWISE FOR 2
SETZM OPRTR ; ZAP!
POP PP,TB ; GET OP-CODE
JRST ADD.00 ; GO DO REST ELSEWHERE
;MULT. GENERATE GENFIL CODE FOR THE MULT OP
;
;
;
MULT.: MOVEI TB,OPMULT## ; GET THE OP-CODE
JRST SUB.1 ; GO DO IT ELSEWHERE
;DIV. GENERATE GENFIL CODE FOR THE DIV OP
;
;
;
DIV.: MOVEI TB,OPDIV## ; GET OP-CODE
SWON FDIV; ; THIS IS A DIVIDE!!
JRST SUB.1 ; GO STASH
;MVR. GENERATE GENFIL CODE FOR MVR OP
;
;
;
MVR.: TSWT FDIV; ; DID WE JUST SEE A DIVIDE?
JRST MVR.01 ; NO - ERROR
PUSHJ PP,SETRES ; YES - GO SET UP RESULT
SKIPE F1LINK ; DO WE HAVE A FACTOR 1?
WARN 216; ; YES - ERROR
SKIPE F2LINK ; HOW ABOUT F2LINK??
WARN 218; ; SAME STORY
SETZM OPRTR ; GET READY
MOVEI TB,OPMVR## ; GET SET
MVR.00: DPB TB,OP.OP ; GO -
MOVE TB,SAVELN ; GET LINE NUMBER
DPB TB,OP.LN ; STASH IN GENFIL WORD
MOVE CH,OPRTR ; GET THE WORD
PUSHJ PP,PUTGEN ; STASH IN GENFIL
HRLZ CH,INDLNK ; GET INDICATORS
PUSHJ PP,RESGEN ; GET RESULTING INDICATORS
PUSHJ PP,PUTGEN ; OUTPUT THAT TOO
SETZM OPRTR ; ZAP ANY REMAINING STUFF
MOVEI TB,1 ; GET A FLAG
DPB TB,OP.OPR ; FLAG AS OPERAND
MOVE TB,RELINK ; GET RESULT LINK
DPB TB,OP.LNK ; STASH
MOVE CH,OPRTR ; GET WORD
PUSHJ PP,PUTGEN ; OUTPUT IT
JRST CA.00 ; AND LOOP - CLEARING FDIV
MVR.01: WARN 202; ; MVR DOES NOT FOLLOW DIVIDE OP
JRST CA.00 ; AND LOOP, IGNORING THIS OP
;ZADD. GENERATE GENFIL CODE FOR ZADD OP
;
;
;
ZADD.: PUSHJ PP,SETRES ; SET UP RESULT
SKIPE F1LINK ; FACTOR 1 DEFINED?
WARN 216; ; YES - ERROR
PUSHJ PP,F2NUMC ; NO - CHECKOUT FACTOR 2
SETZM OPRTR ; START FRESH
MOVEI TB,OPZADD## ; GET OPCODE
ZADD.0: DPB TB,OP.OP ; STASH OP-CODE
MOVE TB,SAVELN ; GET LINE NUMBER
DPB TB,OP.LN ; STASH THAT TOO
MOVE CH,OPRTR ; GET WORD
PUSHJ PP,PUTGEN ; OUTPUT IT
HRLZ CH,INDLNK ; GET INDICATORS
PUSHJ PP,RESGEN ; OUTPUT RESULTING INDICATORS
PUSHJ PP,PUTGEN ; OUTPUT THAT TOO
JRST ADD.1A ; GO DO SOME MORE ELSEWHERES
;ZSUB. GENERATE GENFIL CODE FOR ZSUB OP
;
;
;
ZSUB.: PUSHJ PP,SETRES ; SET UP RESULT
SKIPE F1LINK ; MAKE SURE NO FACTOR 1
WARN 216; ; CAN'T SAY THE TURKEY DIDN'T TRY
PUSHJ PP,F2NUMC ; SET UP FACTOR 2
SETZM OPRTR ; A CLEAN START
MOVEI TB,OPZSUB## ; GET THAT OP-CODE
JRST ZADD.0 ; AND GO DO IT TO IT
;SQRT. Generate Genfil code for SQRT op
;
;
;
SQRT.: SKIPE F1LINK ; any factor 1?
WARN 216; ; yes - error
PUSHJ PP,SETRES ; check out result field
PUSHJ PP,F2NUMC ; and factor 2
PUSHJ PP,BLKIND ; no resulting indicators allowed
SETZM OPRTR ; start fresh
MOVEI TB,OPSQRT## ; get op-code
JRST ZADD.0 ; go finish up
;SETON. GENERATE GENFIL CODE FOR SETON OP
;
;
;
SETON.: SKIPE F1LINK ; WE DON'T WANT A FACTOR 1
WARN 216; ; BUT WE GOT ONE ANYWAY
SKIPE F2LINK ; WHAT ABOUT FACTOR 2
WARN 218; ; GOT ONE OF THOSE TOO
PUSHJ PP,STIND2 ; SET UP INDICATORS
JUMPE W1,SETN.2 ; MUST HAVE RESULTING INDICATORS
MOVEI TB,OPSETN## ; GET OP-CODE
PUSHJ PP,SETN.1 ; SET UP GENFIL CRUD
JRST CA.00 ; END EXIT
SETN.1: SETZM OPRTR ; DUMP THE GARBAGE
DPB TB,OP.OP ; STORE OP
MOVE TB,SAVELN ; GET LINE NUMBER
DPB TB,OP.LN ; STASH
MOVE CH,OPRTR ; GET WORD
PUSHJ PP,PUTGEN ; STASH WORD
HRLZ CH,INDLNK ; GET INDICATOR WORD
PUSHJ PP,PUTGEN ; STASH INDICATOR WORD
PUSHJ PP,GETIND ; GET INDTAB WORD
MOVEM W1,(TA) ; STASH INDICATORS IN WORD
SUB TA,INDLOC ; SUBTRACT BASE WORD
IORI TA,<CD.IND>B20 ; IDENTIFY WORD
HRLZ CH,TA ; PUT IN GEN WORD
TLO CH,1B18 ; SET "NOT AN OPERATOR"
PUSHJ PP,PUTGEN ; STASH GEN WORD
POPJ PP, ; EXIT
SETN.2: WARN 558; ; BLANK RESULTING INDICATORS
JRST CA.00 ; IGNORE OP
;SETOF. GENERATE GENFIL CODE FOR SETOF OP
;
;
;
SETOF.: SKIPE F1LINK ; CHECK FOR FACTOR 1
WARN 216; ; GOT ONE - BAD
SKIPE F2LINK ; WHAT ABOUT FACTOR 2
WARN 218; ; SAME STORY
PUSHJ PP,STIND2 ; SET UP INDICATORS
JUMPE W1,SETN.2 ; BLANK INDICATORS (IF JUMP)
MOVEI TB,OPSETF## ; GET OP-CODE
PUSHJ PP,SETN.1 ; GO DUMP STUFF TO GENFIL
JRST CA.00 ; EXIT
;COMP. GENERATE GENFIL CODE FOR COMP OP
;
;
;
COMP.: PUSHJ PP,F1ANY ; MAKE SURE THERE IS A FACTOR 1
PUSHJ PP,F2ANY ; MAKE SURE THERE IS A FACTOR 2
PUSHJ PP,STIND2 ; SET UP INDICATORS
JUMPE W1,SETN.2 ; BLANK RESULT INDICATORS NO GOOD
MOVEI TB,OPCOMP## ; GET OP-CODE
PUSHJ PP,SETN.1 ; DUMP SOME GENFIL DATA
JRST ADD.0A ; GO DUMP MORE
;TAG. GENERATE GENFIL CODE FOR TAG OP
;
;
;
TAG.: MOVEI TB,OPTAG## ; GET OP-CODE
PUSH PP,TB ; SAVE IT ON THE STACK
SKIPE F2LINK ; DO WE HAVE A FACTOR 2?
WARN 218; ; YES - BUT WE DON'T WANT ONE
PUSHJ PP,BLKRES ; RESULT FIELD SHOULD BE BLANK
PUSHJ PP,BLKIND ; AS SHOULD INDICATORS
MOVE TB,[BPNT 8,] ; get pointer to indicators-1
MOVEI TC,^D9 ; look at nine columns
PUSHJ PP,BLNKCK ; are there any indicators?
WARN 225; ; YES - BAD
TSWF F1LIT; ; FACTOR 1 LITERAL?
JRST TAG.1 ; YES - MOST BAD
SKIPN TA,F1LINK ; DO WE EVEN HAVE A FACTOR 1?
JRST TAG.2 ; NO - OOPS
TAG.4: TSWT F1LNK; ; ARE WE LEFT WITH SIXBIT?
JRST .+4 ; NO -
MOVEM TA,NAMWRD ; YES - STASH IN NAMWRD
PUSHJ PP,TRYNAM ; SEE IF IT EXISTS
PUSHJ PP,BLDNAM ; NO - BUILD IT
MOVEM TA,CURNAM ; STASH NAMTAB LINK
MOVEI TB,CD.PRO ; GET PROTAB ID
MOVSS TA ; WANT THE RELATIVE LINK
PUSHJ PP,FNDLNK ; LOOKUP NAMTAB LINK IN PROTAB
CAIA ; WE SHOULDN'T FIND IT
JRST TAG.3 ; ALREADY USED
MOVE TA,[XWD CD.PRO,SZ.PRO] ; GET VITAL STATISTICS
PUSHJ PP,GETENT ; GET PROTAB ENTRY
MOVS TC,CURNAM ; GET BACK NAMTAB LINK
DPB TC,PR.NAM## ; STASH IN PROTAB
MOVEI TC,CD.PRO ; GET ID
DPB TC,PR.ID## ; STASH THAT TOO
MOVEI TC,1 ; GET A FLAG'S WORTH
POP PP,TB ; GET OP-CODE OFF OF STACK
CAIN TB,OPBGSR ; BEGSR TIME?
DPB TC,PR.BSR## ; YES - FLAG IT AS SUCH
SUB TA,PROLOC## ; MAKE A RELATIVE LINK
IORI TA,<CD.PRO>B20 ; IDENTIFY OURSELVES
TAG.0: SETZM OPRTR ; START FRESH
DPB TB,OP.OP ; STASH OPCODE
MOVE TB,SAVELN ; GET CURRENT LINE NUMBER
DPB TB,OP.LN ; STASH THAT TOO
MOVE CH,OPRTR ; GET THE WORD
PUSHJ PP,PUTGEN ; OUTPUT
SETZB CH,OPRTR ; ZAP
PUSH PP,TA ; save an AC
HRLZ CH,INDLNK ; get indicators in case others call us
PUSHJ PP,RESGEN ; likewise with resulting indicators
PUSHJ PP,PUTGEN ; and output second word
POP PP,TA ; restore the AC
DPB TA,OP.LNK ; STASH PROTAB LINK
MOVEI TB,1 ; GET A FLAG
DPB TB,OP.OPR ; THIS IS A OPERAND
MOVE CH,OPRTR ; FETCH WORD
PUSHJ PP,PUTGEN ; OUTPUT AND EXIT
TSWFZ FMAGIC; ; HMMMMMMMM....ARE WE CHEATING?
POPJ PP, ; YEP- POP OUT
JRST CA.00 ; NO - JRST OUT
TAG.1: WARN 710; ; LITERAL IS INVALID
JRST CA.00
TAG.2: WARN 215; ; FACTOR 1 IS BLANK
JRST CA.00
TAG.3: WARN 232; ; WOULD YOU BUY A USED TAG FROM THIS MAN?
JRST CA.00
;GOTO. GENERATE GENFIL CODE FOR GOTO OP
;
;
;
GOTO.: MOVEI TB,OPGOTO## ; GET OP-CODE
PUSH PP,TB ; STASH ON STACK
SKIPE F1LINK ; HAVE WE GOT A FACTOR 1?
WARN 216; ; TOO BAD...
PUSHJ PP,BLKRES ; DON'T WANT RESULT EITHER
PUSHJ PP,BLKIND ; OR RESULTING INDICATORS
TSWF F2LIT; ; IS FACTOR 2 A LITERAL?
JRST TAG.1 ; NO GOOD
SKIPN TA,F2LINK ; NO - DO WE HAVE A FACTOR 2?
JRST GOTO.2 ; NO - BLOW UP
TSWT F2LNK; ; DO WE HAVE TO DO SYMBOL LOOKUP?
JRST .+4 ; NO -
MOVEM TA,NAMWRD ; STASH TAG IN NAMWRD
PUSHJ PP,TRYNAM ; YES - LOOKUP
PUSHJ PP,BLDNAM ; BUILD
MOVSS TA ; GET JUST THE RELATIVE LINK
POP PP,TB ; GET THAT OP-CODE
JRST TAG.0 ; GO FINISH UP
GOTO.2: WARN 217; ; FACTOR 2 IS BLANK
JRST CA.00
;EXIT. Generate GENFIL code for EXIT op
;
;
;
EXIT.: SKIPE F1LINK ; do we have factor 1?
WARN 216; ; yes - error
PUSHJ PP,BLKRES ; no - make sure we don't have result field
PUSHJ PP,BLKIND ; or resulting indicators
TSWF F2LIT; ; factor 2 a literal?
JRST TAG.1 ; yes - error
SKIPN TA,F2LINK ; do we even have factor 2?
JRST TAG.2 ; no - is required
TSWT F2LNK; ; NAMTAB pointer all set up?
JRST .+4 ; yep-
MOVEM TA,NAMWRD ; no - stash symbol
PUSHJ PP,TRYNAM ; look it up in NAMTAB
PUSHJ PP,BLDNAM ; Not there - put it there now
MOVEM TA,CURNAM ; save it
MOVEI TB,CD.EXT ; get table to look in
MOVSS TA ; get the proper pointer
PUSHJ PP,FNDLNK ; look up in EXTtab
CAIA ; not found - not previously referenced
PUSHJ PP,EXIT.1 ; previously used - set up links
EXIT.0: MOVE TB,EXTNXT## ; get pointer
AOBJP TB,EXIT.2 ; room for first word?
MOVS TC,CURNAM ; yes - get namtab link
TRO TC,TC.EXT## ; identify it
HRLZM TC,(TB) ; stash as first word
HRRZI TA,(TB) ; get the address
HRRZ TE,EXTLOC## ; get start of table
SUBI TA,(TE) ; get relative address
TRO TA,TC.EXT ; identify it
AOBJP TB,EXIT.2 ; room for second word?
MOVE TC,[XWD 220000,777777] ; get flags
MOVEM TC,(TB) ; stash as seconf word
MOVEM TB,EXTNXT ; restore extnxt
MOVEI TB,OPEXIT## ; get op-code
JRST TAG.0 ; and finish up with TAG routine
EXIT.1: MOVE TA,EXTNXT## ; get next table entry we're going to assign
SUB TA,EXTLOC ; make relative to start
TRO TA,TC.EXT ; id
EXCH TA,TB ; get pointer in TA where it belongs
HRR TA,(TA) ; get same name link
JUMPE TA,.+3 ; zero is end of chain
PUSHJ PP,LNKSET ; else set up link
JRST .-3 ; and loop
HRRM TB,(TA) ; save new link
POPJ PP, ; and exit
EXIT.2: PUSHJ PP,XPNEXT## ; expand the table
JRST EXIT.0 ; and try again
;RLABL. Generate GENFIL code for RLABL op
;
;
;
RLABL.: SKIPE F1LINK ; do we have factor 1?
WARN 216; ; yes - but we don't want one
SKIPE F2LINK ; factor 2?
WARN 218; ; likewise
PUSHJ PP,BLKIND ; don't want resulting indicators
PUSHJ PP,SETRES ; all I want is a result field
MOVEI TB,OPRLAB## ; get that op-code
MOVE TA,RELINK ; get link to stash in genfil
JRST TAG.0 ; go finish up
;LOKUP. GENERATE GENFIL CODE FOR LOKUP OP
;
;
;
LOKUP.: PUSHJ PP,F1ANY ; SET UP FACTOR 1
PUSHJ PP,F2ANY ; SET UP FACTOR 2
MOVE TA,F2LINK ; GET LINK WE JUST SET UP
PUSHJ PP,LNKSET ; RESET IT UP
SKIPE F2INDX ; [363] bounded search?
PUSHJ PP,LOK.11 ; [363] yes - get original link
LDB TB,DA.OCC ; GET NUMBER OF OCCURS
SKIPN TB ; [363] do we have table/array?
PUSHJ PP,LOK.11 ; [363] don't look it
LOK.00: LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC## ; FROM RELATIVE TO REAL
HLRZ TC,1(TC) ; GET FIRST 3 CHARACTERS
CAIE TC,'TAB' ; IS IT 'TAB'?
JRST LOK.01 ; NOPE - MUST BE ARRAY
SKIPE F2INDX ; YES - IS TABLE
JRST LOK.07 ; CAN'T HAVE INDEX ON TABLE
SKIPN TC,RELINK ; DO WE HAVE A RESULT FIELD?
JRST LOK.02 ; NO - OK IS THE EASY WAY
PUSH PP,TB ; SAVE NUMBER OF OCCURS
PUSHJ PP,SETRES ; SET UP RESULT FIELD
MOVE TA,RELINK ; GET RESULT LINK
PUSHJ PP,LNKSET ; SET IT UP
MOVE TC,SAVESZ+3 ; GET NUMBER OF OCCURS
JUMPE TC,LOK.07 ; MUST BE > 0
POP PP,TB ; GET BACK FACTOR 2 OCCURS
CAMGE TC,TB ; FACTOR 2 MUST BE > RESULT
JRST LOK.08 ; SUCH IS NOT THE CASE
LDB TC,DA.NAM ; GET NAMTAB POINTER
ADD TC,NAMLOC ; MAKE REAL
HLRZ TC,1(TC) ; GET FIRST 3 AGAIN
CAIE TC,'TAB' ; IS THIS A TABLE?
JRST LOK.07 ; NO - IS BAD
LOK.02: HRLZI TB,(1B9) ; FLAG AS TABLE
LOK.03: PUSH PP,TB ; SAVE FLAGS
PUSHJ PP,STIND2 ; SETUP RESULTING INDICATORS
JUMPE W1,LOK.10 ; INDICATORS ARE NECESSARY
MOVE TA,F2LINK ; GET LINK
PUSHJ PP,LNKSET ; SET IT
SKIPE F2INDX ; [363] bounded search?
PUSHJ PP,LOK.11 ; [363] yes - get real link
LDB TB,DA.SEQ## ; SET SEQUENCE
JUMPE TB,LOK.05 ; IS UNORDERED
LDB TB,INDT ; GET HI INDICATOR
JUMPE TB,LOK.04 ; IF NONE - ALL OK
LDB TB,INDT+1 ; IS THERE A LO INDICATOR?
JUMPN TB,LOK.09 ; ERROR IF IS
; FALL THRU TO LOK.04
;LOKUP. (CONT'D) CONTINUE GENERATING GENFIL CODE FOR LOKUP
;
;
LOK.04: POP PP,TB ; GET FLAGS BACK
MOVEM TB,OPRTR ; STICK IN OUTPUT WORD
MOVEI TB,OPTLOK## ; GET OP-CODE
TSWT F1LIT!F2LIT; ; SWAP F1&F2
JRST .+4 ; DO IT THE HARD WAY TO SAVE SOME SPACE
TSWF F1LIT; ;
TSWT F2LIT; ;
TSWC F1LIT!F2LIT; ; IF NOT =, COMPLEMENT BOTH
TSWT F1NUM!F2NUM; ; DO THE SAME FOR F?NUM
JRST .+4 ;
TSWF F1NUM; ;
TSWT F2NUM; ;
TSWC F1NUM!F2NUM; ;
MOVE TC,F1LINK ; SWAP F?LINK
EXCH TC,F2LINK ; GOOD OL' EXCH SAVES A REGISTER
MOVEM TC,F1LINK ; BACK WE GO
PUSHJ PP,ADD.00 ; GENERATE TONS OF CODE
PUSHJ PP,GETIND ; GET AN INDTAB ENTRY
MOVEM W1,(TA) ; PUT IN RESULTING INDIICATORS
SUB TA,INDLOC ; MAKE RELATIVE POINTER
TRO TA,<CD.IND>B20 ; THE MARK OF CAIN IS UPON US
HRRZ CH,TA ; GET INTO PROPER HALF OF PROPER AC
TLO CH,1B18 ; WELL, MARK MY WORDS!
PUSHJ PP,PUTGEN ; OUTPUT IT
HRRZ CH,RELINK ; [315] get related table entry (if any)
TLO CH,1B18 ; [315] identify as operand
PUSHJ PP,PUTGEN ; [315] output to genfil
JRST CA.00 ; EXIT
;HANDLE ARRAY ENTRY FOR FACTOR 2
LOK.01: SKIPE RELINK ; DID WE GET A RESULT?
JRST LOK.07 ; YES - ERROR
SETZ TB, ; CLEAR ALL FLAGS
SKIPE F2INDX ; ARE WE BOUNDED?
HRLZI TB,(1B10) ; YES - SAY SO
JRST LOK.03 ; CONTINUE
;HANDLE INDICATORS FOR UNORDERED SEARCH
LOK.05: LDB TB,INDT ; GET HI INDICATOR
JUMPN TB,LOK.06 ; SHOULD NOT BE ONE
LDB TB,INDT+1 ; GET LO INDICATOR
JUMPE TB,LOK.04 ; DON'T WANT ONE
LOK.06: WARN 198; ;
JRST LOK.04 ; JUST WARN HIM
;LOKUP. (CONT'D) HANDLE ERRORS FOR LOOKUP VERB
;
;
LOK.07: WARN 196;
JRST CA.00
LOK.08: WARN 197;
JRST CA.00
LOK.09: WARN 199;
JRST CA.00
LOK.10: WARN 200;
JRST CA.00
LOK.11: SKIPN F2INDX ; bounded search?
JRST LOK.12 ; no -
LDB TA,DA.NAM ; get NAMTAB link
MOVEI TB,CD.DAT ; get a table ID
PUSHJ PP,FNDLNK ; find original entry
JRST LOK.13 ; not found - error
MOVE TA,TB ; get link into proper AC
JRST LOK.12+3 ; go try it now
LOK.12: LDB TA,DA.SNM ; get same name link
JUMPE TA,LOK.07 ; error if none
PUSHJ PP,LNKSET ; set it up
LDB TB,DA.OCC ; get number of occurances
JUMPE TB,LOK.12 ; [363] loop if no luck
SKIPE F2INDX ; bounded?
JRST LOK.14 ; [363] yes - don't replace link
MOVE TC,TA ; get into AC we can mess over
SUB TC,DATLOC ; get relative pointer
TRO TC,TC.DAT## ; identify
MOVEM TC,F2LINK ; resave the link
LOK.14: POPJ PP, ; [363] and continue on our merry way
LOK.13: OUTSTR [ASCIZ #?Inexplicable error @LOK.13 in phase E - Table/Array item not found when expected.
#]
JRST KILL
;XFOOT. Generate GENFIL code for the XFOOT op
;
;
;
XFOOT.: SKIPE F1LINK ; do we have a factor 1?
WARN 216; ; yes - but we don't want one
PUSHJ PP,SETRES ; set up the result field
PUSHJ PP,F2NUMC ; and factor 2
SETZM OPRTR ; start anew
MOVEI TB,OPXFOT## ; get that OpCode
JRST ZADD.0 ; go finish up
;MOVE. GENERATE GENFIL CODE FOR THE MOVE OP
;
;
;
MOVE.: PUSHJ PP,SETRES ; CHECK OUT THAT RESULT
PUSHJ PP,F2ANY ; CHECK OUT THAT FACTOR 2
SKIPE F1LINK ; WE DON'T WANT A FACTOR 1
WARN 216; ; BUT WE GOT ONE ANYWAYS
PUSHJ PP,BLKIND ; WE ALSO DON'T WANT RESULTING IND'S
MOVEI TB,OPMOVE## ; GET THAT OL' OP-CODE
MOVE.0: SETZM OPRTR ; ZAP THAT STORAGE
DPB TB,OP.OP ; STASH OP-CODE
MOVE TB,SAVELN ; GET CURRENT LINE NUMBER
DPB TB,OP.LN ; STASH THAT TOO
MOVE CH,OPRTR ; GET THE STORAGE WORD
PUSHJ PP,PUTGEN ; OUTPUT TO GENFIL
HRLZ CH,INDLNK ; GET INDTAB LINK
PUSHJ PP,PUTGEN ; OUTPUT THAT TOO
JRST ADD.1A ; GO FINISH UP WITH OTHER PEOPLES CODE
;MOVEL. GENERATE GENFIL CODE FOR THE MOVEL OP
;
;
;
MOVEL.: PUSHJ PP,SETRES ; SET UP RESULT FIELD
PUSHJ PP,F2ANY ; SET UP FACTOR 2
SKIPE F1LINK; ; IF WE HAVE A FACTOR 1
WARN 216; ; WE DON'T WANT ONE
PUSHJ PP,BLKIND ; SAME WITH RESULTING INDICATORS
MOVEI TB,OPMOVL## ; GET THAT MOVEL OP-CODE
JRST MOVE.0 ; GO OUTPUT THE REST
;MOVEA. Generate GENFIL code for the MOVEA op
;
;
;
MOVEA.: PUSHJ PP,SETRES ; set up result field
PUSHJ PP,F2ANY ; make sure there is a factor 2
SKIPE F1LINK ; but we don't want a factor 1
WARN 216; ; but we got one anyway
PUSHJ PP,BLKIND ; we shouldn't have any resulting inds
MOVEI TB,OPMOVA## ; get the OpCode
JRST MOVE.0 ; and go finish up
;MXXZO. GENERATE GENFIL CODE FOR THE MOVE ZONE OPS
;
;
;
MLLZO.: SKIPA TB,[OPMLLZ##] ; GET OP-CODE FOR MLLZO
MHHZO.: MOVEI TB,OPMHHZ## ; GET OP-CODE FOR MHHZO
MXXZO.: PUSH PP,TB ; SAVE THE OP-CODE
PUSHJ PP,SETRES ; SET UP RESULT FIELD
PUSHJ PP,F2ANY ; MAKE SURE WE HAVE AN F2
SKIPE F1LINK ; HAVE WE GOT A FACTOR 1?
WARN 216; ; YES - ERROR
PUSHJ PP,BLKIND ; MAKE SURE WE HAVE NO RESULTING INDICATORS
POP PP,TB ; GET BACK THAT OP
JRST MOVE.0 ; GO FINISH UP
MLHZO.: SKIPA TB,[OPMLHZ##] ; GET OP-CODE FOR MLHZO
MHLZO.: MOVEI TB,OPMHLZ## ; GET OP-CODE FOR MHLZO
JRST MXXZO. ; GO DO THE REST
;TESTZ. Generate GENFIL code for the TESTZ verb
;
;
;
TESTZ.: SKIPE F1LINK; ; we need no factor 1
WARN 216; ; but we got one
SKIPE F2LINK; ; nor do we want a factor 2
WARN 218; ; but we got one
PUSHJ PP,SETRES ; we do want a result field
MOVE TA,RELINK ; get that link
MOVEI TB,OPTSTZ## ; get the op-code
JRST TAG.0 ; and output some stuff
;BITON. Generate GENFIL code for the BITON op
;
;
;
BITON.: SKIPE F1LINK; ; do we have factor 1?
WARN 216; ; yes - error
PUSHJ PP,SETRES ; set up result field
PUSHJ PP,F2ANY ; set up a factor 2
PUSHJ PP,BLKIND ; make sure no resulting indicators
SETZM OPRTR ; start fresh
MOVEI TB,OPBITN## ; get op-code
JRST ZADD.0 ; and go finish up
;BITOF. Generate GENFIL code for the BITOF op
;
;
;
BITOF.: SKIPE F1LINK; ; any factor 1?
WARN 216; ; yes - error
PUSHJ PP,SETRES ; set up result
PUSHJ PP,F2ANY ; and factor 2
PUSHJ PP,BLKIND ; check out indicators
SETZM OPRTR ; refreshen
MOVEI TB,OPBITF## ; get op-code
JRST ZADD.0 ; and off
;TESTB. Generate GENFIL code for the TESTB op
;
;
;
TESTB.: SKIPE F1LINK ; any op1?
WARN 216; ; yes - error
PUSHJ PP,SETRES ; set up result
PUSHJ PP,F2ANY ; set up factor 2
SETZM OPRTR ; renew
MOVEI TB,OPTSTB## ; get Op-Code
JRST ZADD.0 ; finish off
;BEGSR. GENERATE GENFIL CODE FOR THE BEGSR OP
;
;
;
BEGSR.: TSWT FSR; ; ARE WE IN SR'S?
JRST BEGSR1 ; NO - ERROR
SKIPE .INSR## ; ARE WE ALREADY IN BEGSR?
JRST BEGSR2 ; YES - NO NESTED SR'S ALLOWED
SETOM .INSR ; SAY WE'RE IN BEGSR
MOVEI TB,OPBGSR## ; GET OP-CODE
JRST TAG.+1 ; GO GENERATE SOME CODE
BEGSR1: WARN 189; ; INVALID SEQUENCE OR BEGSR NOT IN SR
JRST CA.00 ; FORGET IT
BEGSR2: WARN 190; ; INVALID SEQUENCE OF BEGSR/ENDSR
JRST CA.00 ; FORGET ME TOO
;ENDSR. GENERATE GENFIL CODE FOR THE ENDSR OP
;
;
;
EXSR.: MOVEI TB,OPEXSR## ; GET OP-CODE
JRST GOTO.+1 ; GO GENERATE SOME CODE ELSEWHERE
;ENDSR. GENERATE GENFIL CODE FOR THE ENDSR OP
;
;
;
ENDSR.: TSWT FSR; ; ARE WE IN SR'S OK?
JRST BEGSR1 ; NO - ERROR
SKIPN .INSR ; WERE WE IN A SR?
JRST BEGSR2 ; NO - ERROR
SETZM .INSR ; NO LONGER IN SR
PUSHJ PP,BLKRES ; MAKE SURE NO RESULT FIELD
PUSHJ PP,BLKIND ; AND NO RESULTING INDICATORS
SKIPE INDLNK ; ANY CONDITIONING INDICATORS?
WARN 225; ; YES - ERROR
TSWF F1LIT; ; FACTOR 1 A LITERAL?
JRST TAG.1 ; YES - ERROR
SKIPN TA,F1LINK ; ANY F1?
JRST ENDSR1 ; NO - OK, SO NO TAG
PUSH PP,[ENDSR1] ; YES - STASH OUR RETURN ADDRESS
PUSH PP,[OPTAG] ; PUSH THE OP-CODE ONTO THE STACK
SWON FMAGIC; ; TURN ON MAGIC STONE
PJRST TAG.4 ; GO OUTPUT TAG CODE
ENDSR1: MOVEI TB,OPENSR## ; GET OP-CODE
SETZM OPRTR ; START FRESH
DPB TB,OP.OP ; STASH OP-CODE IN GENFIL WORD
MOVE TB,SAVELN ; GET LINE NUMBER
DPB TB,OP.LN ; STASH IN GENFIL WORD
MOVE CH,OPRTR ; GET THAT GENFIL WORD
PUSHJ PP,PUTGEN ; OUTPUT IT
HRLZ CH,INDLNK ; get indicator link for other callers
PUSHJ PP,RESGEN ; and resulting indicators too
PUSHJ PP,PUTGEN ; OUTPUT THAT TOO
JRST CA.00 ; EXIT
;EXCPT. Generate GENFIL code for EXCPT op
;
;
;
EXCPT.: SKIPE F1LINK ; any op1?
WARN 216; ; yes - too bad we don't want one
SKIPE F2LINK ; how about op2?
WARN 218; ; don't want one of those either
PUSHJ PP,BLKRES ; nor a result field
PUSHJ PP,BLKIND ; nor any resulting indicators
MOVEI TB,OPXCPT## ; get that op code
JRST ENDSR1+1 ; and go generate GENFIL code
;FORCE. Generate GENFIL code for FORCE op
;
;
;
FORCE.: SKIPE F1LINK ; have we got a factor 1?
WARN 216; ; of course we don't want one
PUSHJ PP,BLKRES ; and no resulting indicators
PUSHJ PP,BLKIND ; or result field
TSWF FTOT; ; are we doing total calcs?
JRST FOR.03 ; yes - FORCE not legal at total time
SKIPN TA,F2LINK ; do we have a factor 2?
JRST FOR.01 ; no - error
TSWF F2LIT; ; no literals are allowed
JRST FOR.02 ; so tell the turkey
TSWT F2LNK; ; link already set up?
JRST FOR.05 ; yes -
MOVEM TA,NAMWRD ; stash that word
LDB TB,[BPNT 39,] ; get character 7
SUBI TB,40 ; make into sixbit
DPB TB,[POINT 6,NAMWRD+1,5] ; stash
LDB TB,[BPNT 40,] ; get character 8
SUBI TB,40 ; make into sixbit
DPB TB,[POINT 6,NAMWRD+1,11]; stash
PUSHJ PP,TRYNAM ; look it up in NAMTAB
JRST FOR.02 ; not found - error
FOR.05: MOVEI TB,CD.FIL ; look up NAMTAB link in FILTAB
MOVSS TA ; get the correct type of link
PUSHJ PP,FNDLNK ; look it up
JRST FOR.02 ; error - link not found
MOVE TA,TB ; get link into proper AC
LDB TB,FI.DES## ; get file description
CAILE TB,1 ; primary or secondary?
JRST FOR.04 ; no - error
LDB TB,FI.TYP## ; get file type
JUMPE TB,.+4 ; input?
CAIL TB,2 ; update?
CAILE TB,3 ; combined?
JRST FOR.04 ; no - error - wrong file type
SUB TA,FILLOC## ; yes - get relative FILTAB pointer
IORI TA,<CD.FIL>B20 ; mark it as FILTAB entry
MOVEI TB,OPFORC## ; get the OpCode
JRST TAG.0 ; go output GENFIL code
FOR.01: WARN 217; ; factor 2 required
JRST CA.00
FOR.02: WARN 132; ; factor 2 must be filename
JRST CA.00
FOR.03: WARN 208; ; FORCE not legal at total time
JRST CA.00
FOR.04: WARN 525; ; file is wrong type
JRST CA.00
;READ. Generate GENFIL code for the READ op
;
;
;
READ.: SKIPE F1LINK ; do we have a factor 1?
WARN 216; ; no-
PUSHJ PP,BLKRES ; don't want any result field
TSWF F2LIT; ; nor any literals
JRST FOR.02 ; got one anyway
SKIPN TA,F2LINK ; any factor 2?
JRST FOR.01 ; but we need one!
TSWT F2LNK; ; NAMTAB link already set up?
JRST READ.1 ; yes -
MOVEM TA,NAMWRD ; no - we must set it ourselves
LDB TB,[BPNT 39,] ; get a character
SUBI TB,40 ; make into sixbit
DPB TB,[POINT 6,NAMWRD+1,5] ; stash it
LDB TB,[BPNT 40,] ; and another
SUBI TB,40 ; make into sixbit
DPB TB,[POINT 6,NAMWRD+1,11]; and stash it too
PUSHJ PP,TRYNAM ; look it up in NAMTAB
JRST FOR.02 ; not found
READ.1: MOVEI TB,CD.FIL ; look in FILTAB
MOVSS TA ; for the correct link
PUSHJ PP,FNDLNK ; see if we can find it
JRST FOR.02 ; we couldn't
MOVE TA,TB ; get link into proper AC
LDB TB,FI.DES## ; get the file description
CAIE TB,5 ; demand file?
JRST FOR.04 ; no - error
LDB TB,FI.TYP ; get file type
JUMPE TB,.+4 ; input?
CAIL TB,2 ; update?
CAILE TB,3 ; combined?
JRST FOR.04 ; no - error
SUB TA,FILLOC ; yes - make relative pointer
IORI TA,<CD.FIL>B20 ; identify
MOVEI TB,OPREAD## ; get the OpCode
JRST TAG.0 ; and go output it
;CHAIN. Generate GENFIL code for the CHAIN op
;
;
;
CHAIN.: PUSHJ PP,F1ANY ; make sure there is a factor 1
PUSHJ PP,BLKRES ; and isn't any result
TSWF F2LIT; ; no literal files
JRST FOR.02 ; he tried
SKIPN TA,F2LINK ; is there any factor 2?
JRST FOR.01 ; but we need one!
TSWT F2LNK; ; is NAMTAB link all set up?
JRST CHAN.1 ; yes -
MOVEM TA,NAMWRD ; no - bombo namwrd
LDB TB,[BPNT 39,] ; get the eighth char (TOBOR!)
SUBI TB,40 ; make sixbit
DPB TB,[POINT 6,NAMWRD+1,5] ; stash
LDB TB,[BPNT 40,] ; get another
SUBI TB,40 ; make into a sixbit character
DPB TB,[POINT 6,NAMWRD+1,11]; and stash
PUSHJ PP,TRYNAM ; see if it's in NAMTAB
JRST FOR.02 ; nope - error
CHAN.1: MOVEI TB,CD.FIL ; get place to look
MOVSS TA ; get the proper type of link
PUSHJ PP,FNDLNK ; and see if we can find it
JRST FOR.02 ; couldn't - error
MOVE TA,TB ; get pointer into proper AC
LDB TB,FI.DES ; ok - get file description
CAIE TB,2 ; chained?
JRST FOR.04 ; no - error
SUB TA,FILLOC ; yes - make real pointer
IORI TA,<CD.FIL>B20 ; stash table id
MOVEI TB,OPCHAN## ; get OpCode
SWON FMAGIC; ; switch on secret flag
PUSHJ PP,TAG.0 ; and output first three words
SETZM OPRTR ; clear out the residue
MOVEI TB,1 ; get a flag
DPB TB,OP.OPR ; not an operator
TSWT F1LIT; ; a literal?
JRST CHAN.2 ; no - whew!
DPB TB,OP.LIT ; yes -
TSWF F1NUM; ; numeric literal?
DPB TB,OP.NUM ; yes - flag it
CHAN.2: MOVE TB,F1LINK ; get link
DPB TB,OP.LNK ; stash
MOVE CH,OPRTR ; get the word brother
PUSHJ PP,PUTGEN ; output to GENFIL
JRST CA.00 ; and exit
;Generate GENFIL code for the DSPLY op
;
;
;
DSPLY.: PUSHJ PP,BLKIND ; make sure no resulting indicators
SKIPN F2LINK ; any factor 2?
JRST FOR.01 ; yes - we need one
SKIPN F1LINK ; [322] have factor 1?
SKIPE RELINK ; [322] no - how about result?
JRST DPY.0A ; [322] have factor 1 and/or result
WARN 552; ; [322] must have at least a factor 1 or result
JRST CA.00 ; [322] travel on
DPY.0A: SKIPE F1LINK ; [322] do we have a factor 1?
PUSHJ PP,F1ANY ; yes - set it up
SKIPE RELINK ; a result field?
PUSHJ PP,SETRES ; yes - set that up
MOVE TA,F2LINK ; get file link
TSWT F2LNK; ; all set up?
JRST DPY.01 ; yes -
MOVEM TA,NAMWRD ; no - stash in NAMWRD
LDB TB,[BPNT 39,] ; get the seventh character
SUBI TB,40 ; make into a sixbit
DPB TB,[POINT 6,NAMWRD+1,5] ; stash in NAMWRD
LDB TB,[BPNT 40,] ; get the eighth char
SUBI TB,40 ; into the realm of sixbit
DPB TB,[POINT 6,NAMWRD+1,11]; stash
PUSHJ PP,TRYNAM ; look up in NAMTAB
JRST FOR.02 ; not found - error
DPY.01: MOVEI TB,CD.FIL ; get FILTAB id
MOVSS TA ; get correct (relative) link
PUSHJ PP,FNDLNK ; look up NAMTAB item in FILTAB
JRST FOR.02 ; Not found
MOVE TA,TB ; get pointer into correct AC
LDB TB,FI.TYP ; get file type
CAIE TB,4 ; display?
JRST FOR.04 ; no - error
SUB TA,FILLOC ; make FILTAB relative
IORI TA,TC.FIL## ; identify
EXCH TA,F1LINK ; make F1LINK be FILTAB link
MOVEM TA,F2LINK ; and F2LINK be F1LINK
TSWT F1LIT; ; [322] swap the flags
TSWF F1LIT!F2LIT; ; [322]
TSWF F2LIT; ; [322]
CAIA ; [322]
TSWC F1LIT!F2LIT; ; [322]
MOVEI TB,OPDSPL## ; get op-code
SETZM OPRTR ; start fresh
JRST ADD.00 ; go do rest elsewhere
;TIME. Generate GENFIL code for the TIME op
;
;
;
TIME.: PUSHJ PP,SETRES ; set up the result field
SKIPE F1LINK ; do we have a factor 1?
WARN 216; ; yes - but we don't want one
SKIP F2LINK ; what about factor 2?
WARN 218; ; same story
PUSHJ PP,BLKIND ; make sure we don't have resulting indicators
SETZM OPRTR ; start anew
MOVEI TB,OPTIME## ; get TIME op-code
JRST MVR.00 ; go output rest of code
;Generate GENFIL code for the DEBUG verb
;
;
;
DEBUG.: TSWT FDBUG; ; do we really want it?
JRST DEBG.2 ; no - tell the turkey
PUSHJ PP,BLKIND ; yes we have no indicators
SKIPN F2LINK ; what about factor 2?
JRST FOR.01 ; but we want one of those
SKIPE F1LINK ; do we have factor 1?
PUSHJ PP,F1ANY ; looks that way
SKIPE RELINK ; result field?
PUSHJ PP,SETRES ; yep -
MOVE TA,F2LINK ; get factor 2 link
TSWT F2LNK; ; set up?
JRST DEBG.1 ; yes -
LDB TB,[BPNT 39,] ; no - get seventh character
SUBI TB,40 ; make sixbit
DPB TB,[POINT 6,NAMWRD+1,5] ; stash
LDB TB,[BPNT 40,] ; get another
SUBI TB,40 ; also sixbit
DPB TB,[POINT 6,NAMWRD+1,11]; stash also
PUSHJ PP,TRYNAM ; look up in NAMTAB
JRST FOR.02 ; no luck
DEBG.1: MOVEI TB,CD.FIL ; get the place to look
MOVSS TA ; get the right link
PUSHJ PP,FNDLNK ; see if we find it in FILTAB
JRST FOR.02 ; no - error
MOVE TA,TB ; get link into proper AC
LDB TB,FI.TYP ; get file type
CAIE TB,1 ; output?
JRST FOR.04 ; no -error
SUB TA,FILLOC ; yes - make pointer relative
TRO TA,TC.FIL ; identify table
EXCH TA,F1LINK ; first comes file
MOVEM TA,F2LINK ; then factor 1
TSWT F1LIT; ; swap flags
TSWF F1LIT!F2LIT; ;
TSWF F2LIT; ;
CAIA ;
TSWC F1LIT!F2LIT; ;
TSWT F1NUM; ;
TSWF F1NUM!F2NUM; ;
TSWF F2NUM; ;
CAIA ;
TSWC F1NUM!F2NUM; ;
MOVEI TB,OPDBUG## ; get op code
SETZM OPRTR ; start fresh
JRST ADD.00 ; finish up
DEBG.2: WARN 141; ; he didn't say he wanted it on H card
JRST CA.00 ; so ignore it
;FATAL ERRORS
;
;
;
NOTVRB: OUTSTR [ASCIZ /?RPGDNV Dispatch to non-verb operator in phase E
/]
JRST KILL## ; GO DIE
;BLKRES ROUTINE TO CHECK FOR BLANK RESULT FIELD
;
;
;
BLKRES: MOVE TB,[BPNT 42,] ; POINTER TO RESULT FIELD
MOVEI TC,6 ; SIX CHARS
PUSHJ PP,BLNKCK
WARN 220; ; DON'T WANT RESULT
MOVE TB,[BPNT 48,] ; POINTER TO FIELD LENGTH
MOVEI TC,3
PUSHJ PP,BLNKCK
WARN 127; ; DON'T WANT IT
LDB CH,[BPNT 53,] ; GET HALF ADJUST
CAIE CH," "
WARN 204; ; DON'T WANT IT
LDB CH,[BPNT 52,] ; GET DECIMAL POSITIONS
CAIE CH," "
WARN 138; ; AUGGGGHHHH!
POPJ PP, ; EXIT
;BLKIND ROUTINE TO CHECK FOR BLANK RESULTING INDICATORS
;
;
;
BLKIND: MOVE TB,[BPNT 53,] ; POINTER TO INDICATORS
MOVEI TC,6 ; SIX CHARACTERS
PUSHJ PP,BLNKCK ; CHECK IT ON OUT
WARN 200; ; IT BLEW IT
POPJ PP, ; EXIT
;SETIND SET UP INDTAB ENTRIES FOR CALCULATION SPECS
;
;
SETIND: SETZB LN,TB ; INITIALIZE COUNTERS
SWOFF FALTSQ; ; CHEAT AND STEAL A FLAG
SETI01: LDB CH,INDTB1(LN) ; GET FIRST CHARACTER
MOVE TA,CURIND## ; GET POINTER TO CURRENT ENTRY
CAIL CH,"0" ; IS INDICATOR NUMERIC (I.E. 01-99)?
CAILE CH,"9"
JRST SETI02 ; NOT A DIGIT
MOVEI TC,-"0"(CH) ; CONVERT TO REAL NUMBER
IMULI TC,12 ; SHIFTY CHARACTER
LDB CH,INDTB2(LN) ; GET SECOND CHARACTER
SETI.C: CAIL CH,"0" ; IS THIS NUMERIC?
CAILE CH,"9"
JRST SETI03 ; INVALID INDICATOR - IT'S NOT
ADDI TC,-"0"(CH) ; ADD IN NEW DIGIT
JUMPE TC,SETI03 ; INDICATOR OF ZERO IS INVALID
SETI.H: CAIL LN,3 ; IF ON RESULT
JRST .+3 ; SKIP IT
TSWFS FALTSQ; ; ELSE JUST SKIP FIRST TIME
PUSHJ PP,GETIND## ; ELSE GET AN INDICATOR
DPB TC,ID.IND## ; STASH INDICATOR
CAIL LN,3 ; ARE WE IN RESULTING INDICATORS?
JRST SETI.D ; LOOKS THAT WAY
LDB CH,INDTB3(LN) ; GET NOT ENTRY
CAIN CH," " ; SPACE?
JRST SETI.D ; YES - NOT NOT
CAIE CH,"N" ; NO - "N"?
JRST SETI.E ; NO - INVALID NOT
MOVEI TC,1 ; YES - NOT
DPB TC,ID.NOT## ; SET NOT FLAG
SETI.D: AOJ LN, ; INCREMENT INDEX
CAIL LN,3 ; HIT THE END?
POPJ PP, ; YES - EXIT
JRST SETI01 ; NO - LOOP FOR MORE
;SETIND (CONT'D)
;
SETI03: CAIN CH," " ; A SPACE?
JRST SETI.N ; YES - MAYBE BLANK INDICATOR
CAIGE LN,3 ; RESULTING INDICATORS?
JRST .+3 ; NO -
WARN 558; ; YES - OUTPUT THIS ERROR
JRST SETI.D ; AND EXIT
WARN 304; ; INVALID INDICATOR
JRST SETI.D ; TRY AGAIN
SETI.E: WARN 124; ; INVALID NOT ENTRY
JRST SETI.D-2 ; TRY AGAIN
SETI02: MOVEI TC,INDTB4 ; GET TABLE ADDR
PUSHJ PP,TABSCN## ; SCAN FOR OUR ENTRY
JRST SETI03 ; NOT FOUND - ERROR
LDB CH,INDTB2(LN) ; GET SECOND CHARACTER
MOVE TA,CURIND ; GET CURRENT POINTER
JRST @INDTB5(TB) ; AND DISPATCH
;SETIND (CONT'D)
;
SETI.I: CAIN CH,"R" ; L
JRST SET.I1 ; IS "LR"
CAIE CH,"0" ; IS L0?
JRST SET.I2 ; NO - MUST BE 1-9
MOVEI TC,211 ; YES
JRST SETI.H
SET.I2: MOVEI TC,154 ; GET BASE OF L1-1
JRST SETI.C ; GO FINISH UP
SET.I1: MOVEI TC,166 ; LR
JRST SETI.H ; GO SET IT
SETI.J: MOVEI TC,143 ; GET H1-1
CAIE CH,"0" ; H
JRST SETI.C ; ALL OK
JRST SETI03 ; NO H0
SETI.K: CAIL CH,"1" ; U
CAILE CH,"8" ; IS ONLY U1-U8
JRST SETI03 ; NOT VALID
MOVEI TC,212 ; U1-1
JRST SETI.C ; IS ALRIGHT
SETI.L: MOVEI TC,INDTB6 ; O
PUSHJ PP,TABSCN ; SEARCH FOR PROPER TYPE
JRST SETI03 ; NOT FOUND - ERROR
MOVEI TC,167(TB) ; [034] MAKE INTO REAL INDICATOR
JRST SETI.H ; GO FLAG
SETI.M: CAIE CH,"R" ; M
JRST SETI03 ; MR IS ONLY VALID
MOVEI TC,210 ; SET TC TO MR
JRST SETI.H
SETI.N: LDB CH,INDTB2(LN) ; GET SECONF CHARACTER
CAIN CH," " ; IS SPACE?
JRST SETI.D ; IGNORE BLANK FIELDS
WARN 304; ; NO - ERROR
JRST SETI.D ; TRY AGAIN
;SETIND (CONT'D)
;
;
;DEFINE TABLES FOR SETIND
;
;
INDTB1: BPNT 10;
BPNT 13;
BPNT 16;
BPNT 54;
BPNT 56;
BPNT 58;
INDTB2: BPNT 11;
BPNT 14;
BPNT 17;
BPNT 55;
BPNT 57;
BPNT 59;
INDTB3: BPNT 9;
BPNT 12;
BPNT 15;
INDTB4: " "
"L"
"H"
"U"
"O"
"M"
Z
INDTB5: EXP SETI.N
EXP SETI.I
EXP SETI.J
EXP SETI.K
EXP SETI.L
EXP SETI.M
INDTB6: "A"
"B"
"C"
"D"
"E"
"F"
"G"
"V"
Z
;INDL ROUTINE TO SET UP INDTAB ENTRIES FOR L0,L1-L9,LR LINES
;
;
;
INDL: MOVE TB,[BPNT 6,] ; POINTER TO COLUMN
ILDB CH,TB ; GET FIRST CHARACTER
CAIE CH,"L" ; IS IT A CONTROL LEVEL
POPJ PP, ; APPARENTLY NOT
ILDB CH,TB ; GET ANOTHER CHARACTER
CAIN CH,"R" ; LR?
JRST INDL2 ; YES -
CAIN CH,"0" ; L0?
JRST INDL3 ; YES -
MOVEI TC,154 ; NO - GET L1-1
ADDI TC,-"0"(CH) ; GET OTHER PORTION
INDL1: MOVE TA,CURIND ; GET INDTAB POINTER
DPB TC,ID.IND## ; STORE INDICATOR
SETO TC, ; GET A -1
DPB TC,ID.POS## ; STILL MORE SORCERY
PUSHJ PP,GETIND ; GET A REPLACEMENT
POPJ PP, ; EXIT
INDL2: MOVEI TC,166 ; LR
JRST INDL1
INDL3: MOVEI TC,211 ; L0
JRST INDL1
;STIND2 ROUTINE TO SET UP RESULTING INDICATORS IN TD
;
;
;
STIND2: SETZB TB,TE ; ZAP A BUNCH OF STUFF
SETZ W1,
MOVEI LN,3 ; START AT 3
MOVEI TC,TE ; GET PLACE TO PUT IT
MOVEM TC,CURIND ; STASH AS POINTER
STIN21: PUSHJ PP,SETI01 ; GO STEAL A ROUTINE
JUMPE TE,STIN22 ; SKIP IF NO LUCK
LDB TB,ID.IND ; ELSE GET INDICATOR
DPB TB,INDT-4(LN) ; STASH INTO W1
STIN22: SETZB TB,TE ; ZAP SOME STUFF
CAIGE LN,6 ; ARE WE DONE?
JRST STIN21 ; NO - LOOP
POPJ PP, ; YES
INDT: POINT 8,W1,7
POINT 8,W1,15
POINT 8,W1,23
;RESGEN ROUTINE TO GET RESULTING INDICATORS AND PUT IN RH OF CH
;
;
;
RESGEN: PUSH PP,CH ; SAVE WHAT WE ALREADY HAVE
PUSHJ PP,STIND2 ; GET THOSE INDICATORS
JUMPE W1,RESG.2 ; LEAP IF NONE
PUSHJ PP,GETIND ; GET AN INDTAB ENTRY
MOVEM W1,(TA) ; STASH INDICATORS
SUB TA,INDLOC ; MAKE RELATIVE POINTER
TRO TA,<CD.IND>B20 ; IDENTIFY
POP PP,CH ; RESTORE CH
HRR CH,TA ; STASH THAT LINK
POPJ PP, ; EXIT
RESG.2: POP PP,CH ; RESTORE AC
POPJ PP, ; EXIT
;SUPPORT ROUTINES
;
;
;
;F1NUMC MAKE SURE FACTOR 1 EXISTS AND IS NUMERIC
;
;
F1NUMC: TSWT F1LIT; ; FACTOR 1 LITERAL?
JRST F1NMC1 ; NO -
TSWF F1NUM; ; NUMERIC LITERAL?
POPJ PP, ; YES -
F1NMC2: WARN 207; ; NO - NOT NUMERIC
F1NMC3: POP PP,TA ; POP OFF RETURN ADDRESS
JRST CA.00 ; AND IGNORE REMAINDER OF CARD
F1NMC1: SKIPN TA,F1LINK ; IS THERE A LINK?
JRST F1NMC4 ; NO - ERROR
TSWT F1LNK; ; IS NAMTAB ITEM SET UP?
JRST .+4 ; YES -
MOVEM TA,NAMWRD ; PUT IT WHERE WE CAN GET AT IT
PUSHJ PP,TRYNAM ; ALREADY THERE?
PUSHJ PP,BLDNAM ; NO - PUT IT THERE
MOVEI TB,CD.DAT ; GET OUR NAME
MOVSS TA ; GET RELATIVE LINK
PUSHJ PP,FNDLNK ; LOOKUP DATAB ENTRY
PUSHJ PP,F2NMC3 ; GO GET AN ENTRY
MOVE TA,TB ; GET LINK INTO PROPER AC
MOVE TD,TB ; SAVE FOR POSSIBLE LATER USE
F1NMC5: LDB TB,DA.SIZ ; GET SIZE FIELD
JUMPN TB,F1NMC6 ; IF WE FOUND IT, WE'RE OK
LDB TB,DA.SNM ; ELSE HOPE THERE A SAMENAME LINK
JUMPE TB,F1NMC7 ; THERE NOT-
MOVE TA,TB ; GET PROPER AC
PUSHJ PP,LNKSET ; SET UP LINK
JRST F1NMC5 ; AND LOOP
F1NMC6: LDB TB,DA.OCC ; DO WE HAVE ARRAY/TABLE?
JUMPN TB,F1NMC8 ; SHO'NUFF
SKIPE F1INDX ; NO - DID WE GET INDEX ANYWAYS?
JRST F1NMC0 ; YES - ERROR
F1NMC9: HRRZ TB,DATLOC ; [363] get base of DATAB
SUB TA,TB ; [363] make into relative pointer
IORI TA,<CD.DAT>B20 ; IDENTIFY
MOVEM TA,F1LINK ; AND STORE FOR OTHERS
POPJ PP, ; ELSE ALL OK
F1NMC4: WARN 215; ; NO FACTOR 1 DEFINED
JRST F1NMC3 ; OUT
F1NMC7: MOVE TA,TD ; RESTORE ORIGINAL POINTER
JRST F1NMC6 ; AND KEEP ON TRYING
F1NMC8: MOVE TB,F1INDX ; GET THAT INDEX
JUMPE TB,F1NMC9 ; IS WHOLE TABLE OR ARRAY
PUSHJ PP,INDFAC ; SET UP THE BASTARD
JRST F1NMC9 ; GO SET THOSE LINKERS
F1NMC0: WARN 229; ; INDEX ILLEGAL ON TABLES AND SCALARS
JRST F1NMC3
;F2NUMC MAKE SURE FACTOR 2 DEFINED AND NUMERIC
;
;
;
F2NUMC: TSWT F2LIT; ; LITERAL?
JRST F2NMC1 ; NO -
TSWF F2NUM; ; YES - NUMERIC LITERAL?
POPJ PP, ; YES - OK
JRST F1NMC2 ; NO -
F2NMC1: SKIPN TA,F2LINK ; DEFINED?
JRST F2NMC2 ; NO -
TSWT F2LNK; ; IS NAMTAB ITEM ALREADY SET UP?
JRST .+4 ; YES -
MOVEM TA,NAMWRD ; STASH
PUSHJ PP,TRYNAM ; TRY TO FIND IT
PUSHJ PP,BLDNAM ; COULDN'T - PUT IT THERE INSTEAD
MOVEI TB,CD.DAT ; GET TABLE ID
MOVSS TA ; GET RELATIVE LINK INTO RH
PUSHJ PP,FNDLNK ; LOOKUP NAMTAB LINK IN DATAB
PUSHJ PP,F2NMC3 ; GO GET ONE
MOVE TA,TB ; GET LINK INTO PROPER AC
MOVE TD,TB ; SAVE
F2NMC5: LDB TB,DA.SIZ ; GET SIZE ENTRY
JUMPN TB,F2NMC6 ; ALL OK IF NON-ZERO
LDB TB,DA.SNM ; NO OK, HOPE FOR SNM LINK
JUMPE TB,F2NMC4 ; ERROR IF ISN'T ONE
MOVE TA,TB ; OK - PLAY FOOTSIES WITH AC'S
PUSHJ PP,LNKSET ; SET UP LINKS
JRST F2NMC5 ; AND LOOP
F2NMC6: LDB TB,DA.OCC ; TABLE/ARRAY?
JUMPN TB,F2NMC8 ; MUST BE
SKIPE F2INDX ; INDEXED SCALAR?
JRST F1NMC0 ; YES - IDIOT AIN'T TOO BRIGHT
F2NMC9: HRRZ TB,DATLOC ; [363] get base of DATAB
SUB TA,TB ; [363] make into relative pointer
IORI TA,<CD.DAT>B20 ; WITH REAL TABLE ID AND EVERYTHING
MOVEM TA,F2LINK ; AND STORE IT FOR OTHERS
POPJ PP, ; ALL OK
F2NMC2: WARN 217; ; NO FACTOR 2 DEFINED
JRST F1NMC3 ; ECKS-IT
F2NMC3: PUSH PP,TA ; SAVE NAMTAB LINK
MOVE TA,[XWD CD.DAT,SZ.DAT] ; GET NECESSARY DATA
PUSHJ PP,GETENT ; AND GET A DATAB ENTRY
MOVE TB,TA ; GET LINK INTO OK AC
POP PP,TC ; GET NAMTAB LINK
DPB TC,DA.NAM## ; STASH INTO DATAB ENTRY
POPJ PP, ; AND EXIT
F2NMC4: MOVE TA,TD ; GET BACK FIRST POINTER
JRST F2NMC6 ; AND BACK
F2NMC8: MOVE TB,F2INDX ; GET THAT INDEX
JUMPE TB,F2NMC9 ; IF ZERO MUST BE TABLE OR WHOLE ARRAY
PUSHJ PP,INDFAC ; SET IT UP
JRST F2NMC9 ; IF WE CAN GET IT UP
;FxANY MAKE SURE FACTOR EXISTS
;
;
;
F1ANY: TSWF F1LIT; ; LITERAL?
POPJ PP, ; YES- OK
JRST F1NMC1 ; NO- CHECK FURTHER
F2ANY: TSWF F2LIT; ; LITERAL?
POPJ PP, ; YES-
JRST F2NMC1 ; NO- KEEP LOOKING
;INDFAC ROUTINE TO SET UP FOR ARRAY ENTRIES
;
;
INDFAC: LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC ; MAKE INTO REAL LINK
HLRZ TC,1(TC) ; GET FIRST THREE CHARS
CAIN TC,'TAB' ; IS IT A TABLE?
JRST F1NMC0 ; ICCCCH!!
LDB TC,[POINT 6,TB,5] ; GET FIRST CHAR OF INDEX
CAIL TC,'0' ; is it numeric?
CAILE TC,'9' ; ?
CAIA ; no -
JRST INDFC1 ; YES - IS IMMEDIATE INDEX
PUSH PP,TA ; NO - SAVE ARRAY POINTER
MOVEM TB,NAMWRD ; STASH INDEX WHERE WE CAN USE IT
SETZM NAMWRD+1 ; BE SMART
PUSHJ PP,TRYNAM ; LOOK IT UP
PUSHJ PP,BLDNAM ; MUST BUILD IT
MOVEI TB,CD.DAT ; GET THAT ID
MOVSS TA ; GET PROPER LINK
PUSHJ PP,FNDLNK ; SEE IF WE FIND IT IN DATAB
PUSHJ PP,F2NMC3 ; NO - MUST BUILD ONE
SUB TB,DATLOC ; MAKE INTO RELATIVE
TRO TB,<CD.DAT>B20 ; FLAG IT
PUSH PP,TB ; save TB
MOVE TA,-1(PP) ; GET THAT LINK WE PUSH'D
LDB TA,DA.NAM ; GET IT'S NAMTAB LINK
PUSHJ PP,F2NMC3 ; GET ARRAY ENTRY
POP PP,TB ; restore index pointer
DPB TB,DA.INP ; STICK IN ENTRY ENTRY
MOVEI TB,1 ; GET A FLAG
DPB TB,DA.ARE ; FLAG AS ARRAY ENTRY
POP PP,TB ; GET ARRAY ENTRY
SUB TB,DATLOC ; MAKE RELATIVE
TRO TB,<CD.DAT>B20 ; MAKE RECOGNIZABLE
DPB TB,DA.ARP ; STASH AS ARRAY POINTER
POPJ PP, ; EXIT
;INDFAC (CONT'D)
;
INDFC1: PUSH PP,TB ; SAVE INDEX
PUSH PP,TA ; SAVE ARRAY POINTER
LDB TA,DA.NAM ; GET NAMTAB LINK
PUSHJ PP,F2NMC3 ; GET ARRAY ENTRY ENTRY
MOVEI TB,1 ; GET A FLAG
DPB TB,DA.ARE ; MARK AS ARRAY ENTRY
DPB TB,DA.IMD ; MARK AS IMMEDIATE
POP PP,TB ; GET ARRAY POINTER BACK
SUB TB,DATLOC ; MAKE RELATIVE POINTER
TRO TB,<CD.DAT>B20 ; IDENTIFY
DPB TB,DA.ARP ; STORE AS ARRAY POINTER
POP PP,TB ; GET INDEX BACK
SETZ TC, ; ZAP THE SUM
MOVE TD,[POINT 6,TB] ; GET A LIKELY LOOKING POINTER
INDFC2: ILDB CH,TD ; GET A CHARACTER
JUMPE CH,INDFC3 ; SPACE IS BREAK
IMULI TC,^D10 ; SHIFT
ADDI TC,-'0'(CH) ; ADD IN NEW DIGIT
JRST INDFC2 ; LOOP
INDFC3: DPB TC,DA.INP ; STASH AS INDEX
POPJ PP, ; EXIT
;SETRES SET UP RESULT FIELD AND MAKE SURE NUMERIC
;
;
SETRES: SKIPN TA,RELINK ; RESULT FIELD EXIST?
JRST SETR10 ; NO - BLANK FIELD INVALID
PUSHJ PP,TRYNAM## ; LOOKUP NAME
PUSHJ PP,BLDNAM## ; BUILD IF NOT THERE
MOVEM TA,CURNAM## ; STASH LINK
MOVEI TB,CD.DAT ; GET DATAB ID
MOVSS TA ; GET RELATIVE NAMTAB LINK
PUSHJ PP,FNDLNK## ; LOOK UP NAMTAB LINK IN DATAB
JRST SETR09 ; MUST BUILD ANEW
MOVE TA,TB ; GET INTO RIGHT AC
SETZM SAVESZ ; ZAP IT FOR NOW
SETR00: LDB TD,DA.SIZ## ; GET SIZE OF FIELD
JUMPN TD,SETR0B ; IS REAL FIELD
SETR0A: LDB TB,DA.SNM ; GET SAME NAME LINK
JUMPE TB,SETR01 ; EXIT IF ZERO LINK
MOVE TA,TB ; ELSE SWAP AC'S
PUSHJ PP,LNKSET## ; MAKE INTO REAL LINK
JRST SETR00 ; AND TRY AGAIN
SETR0B: LDB TB,DA.FLD## ; GET FIELD TYPE
MOVEM TB,SAVESZ+2 ; STASH (USED IN SETR1A IF EVER)
LDB TB,DA.OCC ; [211] get number of occurs
MOVEM TB,SAVESZ+3 ; [211] save it
MOVEM TD,SAVESZ## ; STASH FIELD SIZE
LDB TD,DA.DEC## ; GET DECIMAL POSITIONS
MOVEM TD,SAVESZ+1 ; AND STASH THAT TOO
PUSH PP,TA ; SAVE THE GOOD LINK
LDB TB,DA.SNM ; [144] GET SAME NAME LINK
JUMPE TB,SETR01 ; [144] EXIT IF AT END OF CHAIN
MOVE TA,TB ; [144] ELSE GET LINK INTO PROPER AC
PUSHJ PP,LNKSET ; [144] SET UP LINK
JRST .-4 ; [144] AND LOOP UNTIL END OF CHAIN
SETR01: MOVEM TA,CURDAT ; [037] STASH LINK IN CASE OF TABLE EXPANSION
MOVE TA,[XWD CD.DAT,SZ.DAT] ; GET NEEDED DATA
PUSHJ PP,GETENT## ; AND GET A DATAB ITEM
MOVE TE,CURDAT## ; [037] GET BACK LINK SAVED @ SETR01
MOVEM TA,CURDAT ; [037] SAVE NEW LINK
EXCH TA,TE ; [037] SWAP AROUND POINTERS
SKIPN TD,SAVESZ ; DID WE FIND A REAL FIELD?
JRST SETR18 ; NO - GO MAKE ONE
SUB TE,DATLOC## ; YES - MAKE A POINTER TO IT
IORI TE,<CD.DAT>B20 ; IDENTIFY TABLE
DPB TE,DA.SNM## ; STASH LINK
MOVE TE,SAVESZ+1 ; REGET DECIMAL POSITIONS
MOVE TB,[BPNT 48,] ; GET APPROPRIATE POINTER
MOVEI TC,4 ; 4 CHARS
PUSHJ PP,BLNKCK ; ARE THEY BLANK?
JRST SETR08 ; NO - GONNA MAKE IT HARD ON US
;SETRES (CONT'D)
SETR1A: MOVE TA,CURDAT ; MAKE SURE WE HAVE POINTER
MOVE TC,SAVESZ+2 ; RESTORE DA.FLD (SAVED IN SETR0B)
DPB TD,DA.SIZ ; STORE SIZE
DPB TE,DA.DEC ; DECIMAL POSITIONS
DPB TC,DA.FLD ; AND FIELD TYPE
MOVS TB,CURNAM ; GET NAMTAB LINK
DPB TB,DA.NAM## ; AND STORE
SETR02: MOVE TB,CURDAT ; GET DATAB POINTER
SUB TB,DATLOC ; MAKE INTO A POINTER
IORI TB,<CD.DAT>B20 ; THUSLY
MOVEM TB,RELINK ; AND STORE FOR LATER
MOVEI TB,1 ; GET A FLAG
DPB TB,DA.FLS## ; AND FAKE LIKE THIS IS THE FILE SECTION
;WE DO THIS BECAUSE WE KNOW THAT DA.NDF IS NEVER GOING TO BE SET FOR
;ANY OF THE ITEMS WE CREATE IN THIS ROUTINE. SO, WE FAKE OUT PHASE
;E BY SETTING THIS FLAG. IT'S NOT EXACTLY KOSHER, BUT IT WORKS. JUST THOUGHT
;I'D LET YOU KNOW WHY THIS RATHER STRANGE THING IS HERE.
LDB CH,[BPNT 53,] ; GET HALF ADJUST ENTRY
CAIN CH," " ; A SPACE?
JRST SETR2A ; YES - NO FLAGS
CAIE CH,"H" ; NO - AN "H"?
WARN 140; ; NO - ERROR
DPB TB,DA.RND## ; YES - FLAG AS ROUNDED
SETR2A: POP PP,TE ; GET ORIGINAL DATAB LINK
SKIPN TB,REINDX ; GET INDEX IF ANY
JRST SETR6A ; NO INDEX - COULD BE WHOLE ARRAY/TABLE
MOVE TC,[POINT 6,TB] ; GET POINTER INTO TB
SETZ TD, ; ZAP SUMMER
ILDB CH,TC ; GET A CHARACTER
CAIL CH,'0' ; VALID DIGIT?
CAILE CH,'9' ;
JRST SETR06 ; NOT IMMEDIATE
MOVEI TD,-'0'(CH) ; CONVERT TO REAL NUMBER
SETR03: TLNN TC,770000 ; HIT THE END?
JRST SETR04 ; YES -
ILDB CH,TC ; NO - GET ANOTHER CHARACTER
JUMPE CH,SETR04 ; SPACE IS END
IMULI TD,12 ; BULL SHIFT
ADDI TD,-'0'(CH) ; ADD IN NEW DIGIT
JRST SETR03 ; LOOP
SETR04: MOVE TA,CURDAT ; RECOVER DATAB POINTER
MOVEI TB,1 ; GET A ONE
DPB TB,DA.IMD## ; SET IMMEDIATE FLAG
SETR05: DPB TD,DA.INP## ; STASH INPUT POINTER/INDEX
DPB TB,DA.ARE## ; FLAG ARRAY ENTRY
SUB TE,DATLOC ; WE SET UP LINK IN SETR2A - MAKE DATAB RELATIVE
TRO TE,<CD.DAT>B20 ; SAY SO
DPB TE,DA.ARP## ; STORE AS ARRAY POINTER
POPJ PP, ; AND EXIT
;SETRES (CONT'D)
;
SETR06: MOVE TA,REINDX ; GET INDEX NAME
MOVEM TA,NAMWRD ; STASH IN NAMWRD
SETZM NAMWRD+1 ; ZAP RESIDUE
PUSH PP,TE ; save an AC for SETR05
PUSHJ PP,TRYNAM ; LOOKUP NAME
PUSHJ PP,BLDNAM ; well build it stupid
MOVEI TB,CD.DAT ; MAY I SEE YOUR ID PLEASE?
MOVSS TA ; GET RELATIVE LINK INTO RH
PUSHJ PP,FNDLNK ; LOOKUP DATAB ITEM
PUSHJ PP,F2NMC3 ; well go build an entry then
POP PP,TE ; restore the AC
MOVE TA,TB ; get link into proper AC
SUB TA,DATLOC ; MAKETH A POINTER
IORI TA,<CD.DAT>B20 ; SAME ROUTINE EVERY TIME
MOVE TD,TA ; GET IN PROPER AC
MOVE TA,CURDAT ; RECOVER NEEDED POINTER
MOVEI TB,1 ; SET A FLAG
JRST SETR05 ; AND GO FINISH UP ELSEWHEN
SETR6A: MOVE TA,TE ; GET DATAB POINTER INTO STANDARD AC
LDB TB,DA.OCC ; GET NUMBER OF OCCURANCES
JUMPE TB,SETR6B ; NOTHING MUCH
MOVE TA,CURDAT ; IS WHOLE ARRAY/TABLE
JRST SETR05+2 ; GO SET UP SOME POINTERS
SETR6B: POPJ PP, ; EXIT
;SETRES (CONT'D)
;
SETR08: MOVE TA,[BPNT 48,] ; GET POINTER TO FIELD SIZE
MOVEI TB,3 ; 3 DIGITS
PUSHJ PP,GETDCB## ; GET THE NUMBER
CAME TC,TD ; SAME AS PREVIOUSLY DEFINED SIZE?
PUSHJ PP,SETR12 ; NO - ERROR
LDB CH,[BPNT 52,] ; GET DECIMAL POSITIONS
CAIN CH," " ; SPACE?
JRST SETR1A ; YES - ALL OK
CAIL CH,"0" ; ELSE CHECK FOR VALID DIGIT
CAILE CH,"9" ;
PUSHJ PP,SETR14 ; INVALID DEC POSITIONS
CAIE TE,-"0"(CH) ; IS IT THE SAME?
PUSHJ PP,SETR12 ; NO -
JRST SETR1A ; OK - ALL THIS MESSING AROUND DONE
;SETRES (CONT'D)
;
SETR09: MOVE TA,[XWD CD.DAT,SZ.DAT] ; GET THE VITALS
PUSHJ PP,GETENT ; GET A DATAB ENTRY
MOVEM TA,CURDAT ; STASH POINTER
PUSH PP,TA ; KEEP SETR2A HAPPY
SETR9B: MOVS TB,CURNAM ; GET NAMTAB POINTER
DPB TB,DA.NAM## ; STASH NAMTAB LINK
MOVE TB,[BPNT 48,] ; GET POINTER TO DEFINITION FIELDS
MOVEI TC,4 ; FOUR OF THE LITTLE MONSTERS
PUSHJ PP,BLNKCK ; ARE THEY BLANK?
TRNA ; NO - OK
JRST SETR02 ; YES - IGNORE DEFINTION TRY
MOVE TA,[BPNT 48,] ; GET POINTER TO FIELD SIZE
MOVEI TB,3 ; THATS THREE DIGITS
PUSHJ PP,GETDCB ; GO FOR IT
JUMPN TC,.+2 ; SHOULD NOT BE ZERO
PUSHJ PP,SETR15 ; BAD IF IS
MOVE TA,CURDAT ; GET DATAB POINTER
DPB TC,DA.SIZ ; STORE AS FIELD SIZE
LDB CH,[BPNT 52,] ; GET DECIMAL POSITIONS
CAIN CH," " ; SPACE?
JRST SETR9C ; YES - HANDLE UNIQUELY
CAIL CH,"0" ; VALIDATE YOUR DIGIT SIR?
CAILE CH,"9" ; WHY YES, THANK YOU
PUSHJ PP,SETR14 ; SORRY, MACHINE BUSTED
MOVEI TB,-"0"(CH) ; DO IT IN ONE FELL SWOOP
DPB TB,DA.DEC ; STASH
MOVEI TB,3 ; UNPACKED NUMERIC
DPB TB,DA.FLD ; STASH IT
JRST SETR02 ; GO FINISH UP
SETR9C: SETZ TB, ; GET CODE FOR ALPHA
DPB TB,DA.FLD ; STASH
JRST SETR02 ; AND CONTINUE
;SETRES (CONT'D)
;
;
;THE TURKEYS GRAVEYARD
;
;IT IS HERE THAT ALL TURKEYS COME TO DIE WHEN THEY FEEL THERE TIME
;HAS COME. LONG SOUGHT AFTER BY MANY EXPLORERS FOR THE VALUABLE WISH-
;BONES, YOU HAVE FOUND IT.
;
SETR10: WARN 219;
JRST F1NMC3
SETR11: WARN 207;
JRST F1NMC3
SETR12: WARN 122;
POPJ PP,
SETR14: WARN 139;
MOVEI CH,"0" ; DEFAULT TO ZERO
POPJ PP,
SETR15: WARN 137;
MOVEI TC,^D15 ; DEFAULT TO 15
POPJ PP,
SETR16: WARN 711; ; ********** NOT NUMERIC RESULT
MOVEI CH,"0" ; DEFAULT TO ZERO
POPJ PP,
SETR17: WARN 711; ; ********* NOT NUMERIC RESULT
JRST F1NMC3
SETR18: PUSH PP,TE ; STASH POINTER
SUB TE,DATLOC ; MAKE A POINTER
IORI TE,<CD.DAT>B20 ; FLAG IT
DPB TE,DA.SNM ; STORE LINK
MOVE TA,CURDAT ; GET CURRENT DATAB POINTER
JRST SETR9B ; GO DO REST ELSEWHERE
KNOCAL: OUTCHR ["?"]
HRLZ TA,CALHDR ; GET FILENAME
PUSHJ PP,SIXOUT## ; OUTPUT IT
OUTSTR [ASCIZ " not found
"]
JRST KILL##
CANTOP: OUTSTR [ASCIZ "?Can't open DSK for CALFIL input
"]
JRST KILL
OPZERO: OUTSTR [ASCIZ /?Op-code of zero used in phase D
/]
JRST KILL
;FINISH UP EVERYTHING
;
;
;
;
FIND: TSWF FDET; ; ARE WE STILL IN DETAIL?
PUSHJ PP,CA.04D ; YES - OUTPUT AN OPDET
TSWF FSR; ; ARE WE IN SR?
JRST .+6 ; YES - ALREADY PUT OUT CODE
MOVEI CH,OPCAL ; NO - NEED TO GENERATE ESCAPE CODE
ROT CH,-^D9 ; ROTATE
PUSHJ PP,PUTGEN ; STICK IT
SETZ CH, ; ZAP A WORD
PUSHJ PP,PUTGEN ; AND OUTPUT THAT WORD
ENDFAZ D;
END RPGIID