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 ; 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,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,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 ; 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,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,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 ; SET UP INDEX MOVEI TB,1B^L/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,> IF2,< N2=^D36 CC=0 RELOC OP1COD RELOC DEFINE X (SYMBOL,CODE) IFE N2,> DEFINE OUTLIT < RELOC +CC RELOC N2=^D36+>> ;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, 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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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,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