TITLE RPGIIE FOR RPGII 1 SUBTTL GENERATE CODE AND TABLES ; ; RPGIIE PHASE E FOR RPGII V1 ; ; THIS PHASE BUILDS THE RUNTIME TABLES, WRITES THEM TO THE ; ASSEMBLY FILE, GENERATES THE CALCULATION CODE, AND CLOSES ; UP VARIOUS FILES. ; ; BOB CURRIER AUGUST 28, 1975 03:06:19 ; ; ALL RIGHTS RESERVED, BOB CURRIER ; TWOSEG RELOC 400000 ENTRY RPGIIE FIXNUM==^D9 ; NUMBER OF FIXED ITEMS RPGIIE: PORTAL .+1 ; YOU MAY NOW ENTER SETFAZ E; ; INITIALIZE THE PHASE SWOFF FLAG!FAS3; ; RESET TIME SETOM @CPYBHO##+1 ; FLAG END OF CPYFIL CLOSE CPY, ; CLOSE CPYFIL MOVE TA,AS2BUF## ; SET UP AS2FIL MOVEM TA,.JBFF## ; START AT THE BEGINNING OUTBUF AS2,2 ; GRAB 2 BUFFERS MOVE TA,AS3BUF## ; SET UP AS3FIL MOVEM TA,.JBFF## ; START AT FIRST FREE OUTBUF AS3,2 ; GET TWO BUFFERS SETZM EINITL## ; ZAP ALL THE JUNK MOVE TE,[XWD EINITL,EINITL+1]; SET UP FOR BLIT BLT TE,EZEROH## ; ZAP! SETZM HILOC## ; ZAP ME TOO DADDY! MOVE TA,LITLOC## ; MAKE SURE LITNXT IS RESET MOVEM TA,LITNXT## ; JUST LIKE THAT ;SET UP RPGLIB ARGUMENTS SELARG: TSWF REENT; ; REENTRANT? JRST BLDRES ; YES - NO RPGLIB CALL MOVE TA,[SIXLIT##,,1] ; A SIXBIT LITERAL! PUSHJ PP,STASHL## ; GO STASH IT MOVE TA,[SIXBIT 'RPGII'] ; THAT'S US! PUSHJ PP,STASHL AOS ELITPC## ; BUMP LITERAL PC MOVE TA,[OCTLIT##,,1] ; ARG 2 IS COMPILER VERSION NUMBER PUSHJ PP,STASHL MOVE TA,.JBVER## ; GET VERSION PUSHJ PP,STASHL ; STASH AOS ELITPC MOVE TA,[OCTLIT,,1] ; PUT OUT ARG COUNT PRIOR TO LIST PUSHJ PP,STASHL MOVSI TA,-2 PUSHJ PP,STASHL AOS TA,ELITPC ; SAVE ADDR OF FIRST WORD OF LIST MOVEM TA,RPGVER## MOVE TA,[XWDLIT##,,4] ; MAKE ARG LIST ENTRIES PUSHJ PP,STASHL MOVEI TA,0 ; ENTRY1 = 0,,ARG1-PTR PUSHJ PP,STASHL MOVE TA,RPGVER HRLZI TA,-3(TA) TLO TA,AS.LIT## HRRI TA,AS.MSC## PUSHJ PP,STASHL AOS ELITPC MOVEI TA,0 ; ENTRY2 = 0,,ARG2-PTR PUSHJ PP,STASHL MOVE TA,RPGVER HRLZI TA,-2(TA) TLO TA,AS.LIT HRRI TA,AS.MSC PUSHJ PP,STASHL AOS ELITPC ;BLDRES BUILD UP RESERVED WORD ENTRIES ; ; ; BLDRES: SETZM NAMWRD+1 ; HOUSEKEEPING SETZB DT,LN ; ZAP THE INDEX RES.0: MOVE TC,RESTAB(DT) ; GET A NAME JUMPE TC,BLDCH ; WHEN WE GOT A ZERO, WE'RE DONE MOVEM TC,NAMWRD ; ELSE PUT IT WHERE IT BELONGS PUSHJ PP,TRYNAM ; LOOK IT UP JRST RES.6 ; NOT FOUND. TRY ANOTHER. MOVEI TB,CD.DAT ; LOOK IN DATAB MOVSS TA ; GET RELATIVE LINK PUSHJ PP,FNDLNK ; LOOK ME UP SOMETIME HONEY JRST RES.6 ; NOT FOUND IN DATAB MOVE TA,TB ; GET LINK INTO GOOD AC PUSH PP,TA ; SAVE IT FOR AWHILE RES.1: LDB TC,DA.SIZ ; GET SIZE OF FIELD JUMPE TC,RES.2 ; ZERO - NOT DEFINED CAME TC,LN ; IS IT THE SAME AS LAST TIME? JRST RES.3 ; NO - COULD BE BAD RES.2: LDB TA,DA.SNM ; GET LINK JUMPE TA,RES.4 ; END OF CHAIN PUSHJ PP,LNKSET ; ELSE SET UP LINK JRST RES.1 ; AND LOOP RES.3: SKIPE LN ; FIRST TIME? JRST RES.7 ; NOPE - ERROR TIME MOVE LN,TC ; YES - GET NEW VALUE LDB CH,DA.DEC ; AND GET DECIMAL POSITS JRST RES.2 ; AND LOOP RES.4: SKIPE LN ; ZERO AFTER ALL THAT? JRST RES.5 ; NO - GOOD USE VALUE WE FOUND MOVE LN,RESSIZ(DT) ; ELSE WE MUST DEFAULT SIZE SETZ CH, ; AND DECIMAL POSITIONS RES.5: POP PP,TA ; RECOVER POINTER DPB LN,DA.SIZ ; STASH SIZE DPB CH,DA.DEC ; LIKEWISE WITH DEC POS MOVEI TB,3 ; UNPACKED NUMERIC DPB TB,DA.FLD ; STORE AS TYPE MOVEI TB,1(DT) ; GET WORD ID DPB TB,DA.RSV ; FLAG AS SUCH LDB TA,DA.SNM ; GET LINK JUMPE TA,RES.6 ; DONE THIS LOOP TOO PUSHJ PP,LNKSET ; SET UP LINK JRST RES.5+1 ; LOOP RES.6: SETZ LN, ; START ALL OVER AOJA DT,RES.0 ; WAY BACK THERE ;BLDRES (CONT'D) ; RES.7: LDB TB,DA.LIN## ; GET DEFINING LINE NUMBER MOVEM TB,SAVELN ; STASH WARN 122; ; HE REDEFINED SAME FIELD JRST RES.2 ; SO IGNORE THE TRY ;TABLE OF DEFAULT FIELD SIZES RESSIZ: OCT 6 ; UDATE OCT 2 ; UDAY OCT 2 ; UMONTH OCT 2 ; UYEAR OCT 4 ; PAGE OCT 4 ; PAGE1 OCT 4 ; PAGE2 RESTAB: SIXBIT /UDATE/ SIXBIT /UDAY/ SIXBIT /UMONTH/ SIXBIT /UYEAR/ SIXBIT /PAGE/ SIXBIT /PAGE1/ SIXBIT /PAGE2/ SIXBIT / / ;BLDCH BUILD UP INPUT AND OUTPUT CHAINS ; ;THIS ROUTINE WILL RESERVE SPACE IN AS1FIL FOR ALL DATA ITEMS, ;AND BUILD OTFTAB, OCHTAB, ICHTAB. ; BLDCH: HRRZ TA,DATLOC ; GET START OF DATTAB MOVEI TD,^D30 ; START AT THE BEGINNING SETZM LDCIND## ; zap the pointer to compile time array table BLD.00: SWOFF FBINRY; ; START FRESH MOVEM TA,CURDAT ; STORE FOR LATER SETZM HISIZ ; ZAP SIZE COUNTER SETZM OP1DEC ; zap decimal counter SETZM OPFLDX## ; and field type register SETZM OP1SIZ ; zappe' BLD.01: LDB TB,DA.DUN ; GET DONE FLAG JUMPN TB,BLD.3A ; IF ALREADY DONE, BYPASS LDB TB,DA.LTF## ; GET LITERAL FLAG JUMPN TB,BLD.3A ; IF A LITERAL, BYPASS IFN BINARY,< LDB TC,DA.FLD ; GET FIELD TYPE CAIN TC,2 ; GODAMN BINARY? SWON FBINRY; ; YES - TELL THE GENTRY > MOVEI TC,1 ; get a flag DPB TC,DA.DUN ; say we've been here LDB TB,DA.OCC ; GET NUMBER OF OCCURS JUMPN TB,BLD.03 ; ARRAY OF SOME SORTS LDB TB,DA.SIZ ; GET SIZE OF FIELD SKIPE TB ; [275] did we get a size? MOVEM TB,OP1SIZ ; [275] yes - store it BLD.05: SKIPN HISIZ ; first time? JUMPN TB,BLD.5A ; yes - jump if found a size JUMPN TB,BLD.04 ; jump if size found this time MOVE TB,OP1SIZ ; get the size DPB TB,DA.SIZ ; store it MOVE TB,OP1DEC ; get decimal count DPB TB,DA.DEC ; store that too MOVE TB,OPFLDX ; get field type DPB TB,DA.FLD ; store it BLD.04: IFN BINARY,< TSWT FBINRY; ; BINARY FIELD? JRST .+3 ; NO - SKIP OVER JUNK CAIE TD,^D30 ; YES - ARE WE ON WORD BOUNDARY? AOS EAS1PC ; NO - BUMP PC > MOVE TC,EAS1PC ; GET CURRENT PC HRRM TC,2(TA) ; store core pointer (DA.COR) DPB TD,DA.RES ; store byte residue LDB TB,DA.FLS ; defined in file section? JUMPE TB,BLD.2A ; no - treat special BLD.4B: HRRZ TC,7(TA) ; get array load pointer (DA.LDP) SKIPE TC ; is it set? PUSHJ PP,BLDARR ; yes - go build an ARRTAB entry for it HLRZ TC,10(TA) ; get array dump pointer (DA.DPP) SKIPE TC ; is that set? PUSHJ PP,BLDARD ; yes - build ARRTAB entry ;BLDCH (cont'd) ; BLD.02: HRRZ TA,10(TA) ; get same name link (DA.SNM) JUMPN TA,BLD.1A ; GOT ONE - LOOP MOVE TB,HISIZ ; GET CHARACTER COUNTER JUMPE TB,BLD.E1 ; [342] undefined field if zero.... IFN BINARY,< TSWF FBINRY; ; BINARY? JRST BLD.B1 ; YES - TREAT A TAD SPECIAL > BLD.2D: ADDB TB,PCREM ; ADD NEW CHARACTER SIZE IDIVI TB,6 ; GET WORD (RELATIVE) MOVEM TB,EAS1PC ; STORE AS NEW ASYFIL PC ADDI TA,1 ; BYTES ARE ORGIN 1 IMULI TA,6 ; CONVERT FROM BYTES TO BITS MOVEI TD,^D36 ; ASHES TO ASHES SUB TD,TA ; DUST TO DUST BLD.3A: MOVE TA,CURDAT ; REGET POINTER ADDI TA,SZ.DAT ; INCREMENT HRRZ TE,DATNXT ; [033] GET END OF DATAB CAME TA,TE ; AT END? JRST BLD.00 ; NO - LOOP JRST BLD.06 ; YES - GO BUILD SOME TABLES BLD.3D: LDB TC,DA.ALT ; alternating table? JUMPN TC,CPOPJ ; exit if yes MOVE TC,TA ; else get link where we can play with it SUB TC,DATLOC ; make relative TRO TC,TC.DAT## ; identify it AOS TE,LDCIND ; get next table index MOVEM TC,LDCTAB##(TE) ; stash in table POPJ PP, ; and exit BLD.E1: MOVE TA,CURDAT ; [342] get first field BLD.E2: LDB TB,DA.LIN ; [342] get defining line number MOVEM TB,SAVELN ; [342] save for error routines LDB TB,DA.FLS ; [342] defined on I or O specs? JUMPE TB,BLD.E3 ; [342] (others will catch other errors) LDB TB,DA.INF ; [351] defined on I specs? JUMPN TB,BLD.E3 ; [351] yes - we don't want it LDB TB,DA.LTF ; [342] output literal? JUMPN TB,BLD.E3 ; [342] yes - no definition necessary LDB TB,DA.NAM ; [342] a real field? JUMPE TB,BLD.E3 ; [342] no error if not WARN 148; ; [342] [351] yes - error BLD.E3: LDB TA,DA.SNM ; [342] get pointer to next field JUMPE TA,BLD.3A ; [342] exit if none PUSHJ PP,LNKSET ; [342] else set it up JRST BLD.E2 ; [342] and loop ;BLDCH (CONT'D) ; BLD.03: LDB TC,DA.ARE ; GET ARRAY ENTRY FLAG JUMPN TC,BLD.3F ; IF IS, DON'T RESERVE SPACE SKIPE HISIZ ; [254] already defined once? JRST BLD.3F ; [254] yes - go set up linkers LDB TC,DA.SIZ ; IF NOT, IS REGULAR ARRAY, GET SIZE IMUL TB,TC ; MULTIPLY BY NUMBER OF OCCURANCES MOVEM TB,HISIZ ; stash size MOVEM TC,OP1SIZ ; save element size LDB TC,DA.DEC ; get decimal count MOVEM TC,OP1DEC ; stash LDB TC,DA.FLD ; get field type MOVEM TC,OPFLDX ; save LDB TC,DA.LDC## ; load at compile time? SKIPE TC ; well? PUSHJ PP,BLD.3D ; yes - set up table entry MOVE TD,PCREM ; get PC counter IDIVI TD,6 ; get words SKIPE TC ; remainder? ADDI TD,1 ; round to nearest word ADDI TD,1 ; allow extra header word MOVEM TD,EAS1PC ; use as new PC IMULI TD,6 ; return to characters MOVEM TD,PCREM ; store new value MOVEI TD,^D36 ; get new residue PUSH PP,TA ; save a pointer MOVE TA,CURDAT ; get the original DATAB pointer BLD.3B: LDB TC,DA.DUN ; already been here? JUMPE TC,BLD.3C ; no - no need to visit this time either MOVE TC,EAS1PC ; get PC HRRM TC,2(TA) ; replace core pointer (DA.COR) DPB TD,DA.RES ; and byte residue MOVE TC,OP1SIZ ; get size of field DPB TC,DA.SIZ ; store in this item MOVE TC,OP1DEC ; get decimal count DPB TC,DA.DEC ; store that too MOVE TC,OPFLDX ; ge field type DPB TC,DA.FLD ; stash it LDB TC,DA.ICH ; get ICHTAB link JUMPE TC,BLD.3E ; leap if none ADD TC,ICHLOC ; turn into real pointer MOVE TE,EAS1PC ; get core location ADDI TE,1 ; don't know why we need this but we do HRLI TE,440600 ; make into byte pointer MOVEM TE,(TC) ; store as IC.DES MOVE TE,OP1SIZ ; get size of field DPB TE,[POINT 12,5(TC),32] ; stash as IC.SIZ MOVE TE,OPFLDX ; get field type DPB TE,[POINT 2,4(TC),35] ; save as IC.FLD BLD.3E: HRRZ TA,10(TA) ; get next item with same name (DA.SNM) JUMPE TA,BLD.3C ; exit if no link PUSHJ PP,LNKSET ; set it up JRST BLD.3B ; and loop BLD.3C: POP PP,TA ; restore the pointer JRST BLD.05 ; GO RESERVE SPACE BLD.1A: PUSHJ PP,LNKSET ; SET UP LINK JRST BLD.01 ; BACK WE GO BLD.2A: MOVEI CH,SAVAC2## ; set up to save the AC's BLT CH,SAVAC2+16 ; save 'em ; LDB TB,DA.NDF ; GET "NOT DEFINED" ; JUMPE TB,BLD.2B ; IS DEFINED - OK ; LDB TA,DA.SNM ; GET SAME NAME LINK ; JUMPE TA,BLD.2C ; error if none ; PUSHJ PP,LNKSET ; SET IT UP ; JRST BLD.2A+2 ; loop ;BLDCH (cont'd) ; BLD.2B: MOVEM TA,CURDAT ; STASH SWON FLAG; ; ON GOES THE FLAG PUSHJ PP,BLD11C ; A BIT OF MAGIC, DICK MOVSI CH,SAVAC2 ; SAVE A WORD OF CORE BLT CH,16 ; RESTORE AC'S JRST BLD.4B ; AND BACK TO MAINLINE TYPE STUFF BLD.3F: SKIPN HISIZ ; size defined yet? JRST BLD.04 ; no - continue MOVE TC,OP1SIZ ; yes - get size DPB TC,DA.SIZ ; yes - stash into DATAB entry MOVE TB,OP1DEC ; get decimal count DPB TB,DA.DEC ; stash that too MOVE TB,OPFLDX ; get field type DPB TB,DA.FLD ; that too may be needed LDB TE,DA.ICH ; get ICHTAB link JUMPE TE,BLD.04 ; exit if none ADD TE,ICHLOC ; make into real pointer MOVE TC,OP1SIZ ; get size of field DPB TC,[POINT 12,5(TE),32] ; save as IC.SIZ MOVE TC,OPFLDX ; get field type DPB TC,[POINT 2,4(TE),35] ; save as IC.FLD JRST BLD.04 ; continue BLD.5A: MOVEM TB,HISIZ ; store the size ;[275] MOVEM TB,OP1SIZ ; store again LDB TB,DA.DEC ; get the decimal count MOVEM TB,OP1DEC ; stash it LDB TB,DA.FLD ; get the field MOVEM TB,OPFLDX ; stash PUSH PP,TA ; stash the current DATAB pointer MOVE TA,CURDAT ; get the original one BLD.5B: CAMN TA,(PP) ; are we back where we started? JRST BLD.5C ; yes - exit MOVE TB,OP1SIZ ; get the size DPB TB,DA.SIZ ; store MOVE TB,OP1DEC ; get the decimal count DPB TB,DA.DEC ; store MOVE TB,OPFLDX ; get the field type DPB TB,DA.FLD ; store that too LDB TC,DA.ICH ; get ICHTAB link JUMPE TC,BLD.5D ; skip over this code if none ADD TC,ICHLOC ; else turn into real pointer MOVE TB,OP1SIZ ; get size DPB TB,[POINT 12,5(TC),32] ; store as IC.SIZ MOVE TB,OPFLDX ; get field type DPB TB,[POINT 2,4(TC),35] ; store as IC.FLD BLD.5D: HRRZ TA,10(TA) ; get DA.SNM JUMPE TA,BLD.5C ; exit if we hit the end (????) PUSHJ PP,LNKSET ; set those linkers fred JRST BLD.5B ; loop the loop BLD.5C: POP PP,TA ; restore old DATAB pointer JRST BLD.04 ; back to the grind ;BLDCH (cont'd) ; BLD.2C: OUTSTR [ASCIZ / ?Not defined field with no same name link found in BLD.2A /] JRST KILL ; OOPS! DIDN'T KNOW IT WAS LOADED BLD.B1: MOVE TD,PCREM ; GET THAT PC IDIVI TD,6 ; IS MAGIC SKIPE TC ; IF WE HAD REMAINDER ADDI TD,1 ; BUMP UP BY ONE IMULI TD,6 ; MAKE REAL MOVEM TD,PCREM ; REPLACE MOVEI TC,6 ; TRY SIX TO START WITH CAILE TB,^D10 ; DOUBLE PRECISION? MOVEI TC,^D12 ; YES - MOVE TB,TC ; GET INTO PROPER AC JRST BLD.2D ; CONTINUE WITH WHAT WE WERE DOING BEFORE ; ;START BUILDING OTFTAB ; BLD.06: MOVE TB,LDCIND ; get LDCTAB index SETZM LDCTAB+1(TB) ; and stash a zero entry HRRZ TA,FILLOC ; GET START OF FILTAB MOVEM TA,CURFIL ; STORE FOR OTHERS ;[312] CAIE TD,0 ; [115] [243] even word? AOS EAS1PC ; NO - ROUND TO IT MOVEI TB,1 ; [152] get an initial value MOVEM TB,FTBNUM## ; [152] and use it to initialize FTBNUM PUSHJ PP,BLDLHL ; set up limits literal BLD.07: MOVE TA,[XWD CD.OTF,SZ.OTF] ; SET UP TO GET ENTRY PUSHJ PP,GETENT ; GET IT MOVEM TA,CUROTF ; STASH POINTER MOVE TB,CURFIL ; GET CURFILE POINTER MOVEI TD,TBCNT-1 ; get index BLD.08: EXCH TB,TA ; PLAY FOOTSIES WITH POINTERS LDB TC,@FTB(TD) ; GET A BYTE EXCH TB,TA ; ONE MORE TIME DPB TC,@OTB(TD) ; STORE BYTE SOJGE TD,BLD.08 ; loop until done MOVEI TC,1 ; get output flag TSWF FLAG; ; magic call? DPB TC,OT.TYP ; yes - say is output file regardless EXCH TB,TA ; YES - MOVE TB,CUROTF ; get OTFTAB pointer SUB TB,OTFLOC ; make into relative pointer DPB TB,FI.OTF## ; stash in FILTAB as pointer to corresponding item LDB TB,FI.BKL## ; GET BLOCK LENGTH LDB TD,FI.RCL## ; GET RECORD LENGTH MOVE TE,TD ; STORE FOR LATER LDB TC,FI.ADF## ; GET LINK TO RAF FILE ANDI TC,77777 ; DROP TABLE ID MOVE TA,CUROTF ; GET BACK POINTER SUBI TC,1 ; decrement address DPB TC,OT.ADP## ; STASH IN OTFTAB ;[345] Blocking Factor optimization put under REPEAT 0 REPEAT 0,< ; [345] LDB TC,OT.DEV## ; GET DEVICE CAIL TC,.FIDSK ; DISK? CAIG TC,.FIMTA ; TAPE? JRST BLD.09 ; NO - DON'T FIGURE BLOCKING CAME TB,TD ; WE GOTTA FIGURE BLOCKING? JRST BLD.09 ; NO - ADDI TD,6 ; YES - ADD WC WORD IDIVI TD,6 ; TAKE TO MOD 6 SKIPE TC ; REMAINDER? ADDI TD,1 ; yes - round up MOVEI TB,^D256 ; start with standard length BLD.8A: CAMLE TD,TB ; will we fit in this size block? JRST BLD.8B ; no - try another size MOVE TC,TB ; stash IDIV TB,TD ; get blocking factor MOVE TD,TB ; get into proper AC MOVE TB,TC ; get back number of words IMULI TB,6 ; convert to characters JRST BLD.10 ; and go finish up BLD.8B: ADDI TB,^D256 ; try a bit larger JRST BLD.8A ; like this > ; [345] JRST BLD.09 ; [345] just get straight blocking factor ;BLD.06 (CONT'D) CONTINUE BUILDING OTFTAB ; BLD.10: MOVE TA,CUROTF ; GET OTF POINTER DPB TD,OT.BLK ; STORE BLOCKING FACTOR MOVE TC,TB ; TRICKY IDIVI TC,6 ; GET WORDS IN REC SKIPE TB ; REMAINDER? AOS TC ; YES - ROUND UP DPB TC,OT.BSZ ; STORE AS BUFFER SIZE (WORDS) DPB TE,OT.BSC ; STORE BUFFER SIZE (CHARS) MOVE TB,EAS1PC ; GET CURRENT PC DPB TB,OT.BFP ; STORE AS BUFFER POINTER CAIGE TC,^D14 ; enough room for labels? MOVEI TC,^D14 ; no - make some ADDM TC,EAS1PC ; UPDATE PC JRST BLD.11 ; ON TO BIGER AND BETTER BLD.09: EXCH TB,TD ; get stuff into proper AC IDIV TD,TB ; get blocking factor JRST BLD.10 ; go and store BLDLHL: MOVE CH,[XWD OCTLIT,2] ; get LITAB header PUSHJ PP,STASHC ; output it SETZ CH, ; get a zero PUSHJ PP,STASHC ; output it MOVE CH,[EXP .INFIN] ; get the big one PUSHJ PP,STASHC ; output that too HRLZ CH,ELITPC ; get LITtab PC AOS ELITPC ; bump PC HRR CH,ELITPC ; get next half AOS ELITPC ; bump PC once more MOVEM CH,LHLLIT## ; stash as limits literal POPJ PP, ; jump ;BLD.06 (CONT'D) TABLES USED TO BUILD OTFTAB ; FTB: EXP FI.PHY## EXP FI.TYP## EXP FI.DES## EXP FI.PRO## EXP FI.ORG## EXP FI.RAF## EXP FI.DEV## EXP FI.EOF## EXP FI.KYP## EXP FI.SEQ## EXP FI.BUF## EXP FI.AST## EXP FI.REW## EXP FI.EXT## EXP FI.ADD## EXP FI.OVI## EXP FI.OVL## EXP FI.LPP## EXP FI.EXI## EXP FI.COR## EXP FI.KYL## TBCNT==.-FTB OTB: EXP OT.NAM## EXP OT.TYP## EXP OT.DES## EXP OT.PRO## EXP OT.ORG## EXP OT.RAF## EXP OT.DEV## EXP OT.EOF## EXP OT.KYP## EXP OT.SEQ## EXP OT.BUF## EXP OT.AST## EXP OT.REW## EXP OT.EXT## EXP OT.ADD## EXP OT.OVI## EXP OT.OVL## EXP OT.LPP## EXP OT.EXI## EXP OT.CRS## EXP OT.KYL## ;BLD.11 ; ;BUILD UP ICHTAB & OCHTAB ENTRIES FOR FILE IN CUROTF, CURFIL. ; ; BLD.11: PUSHJ PP,BLDFTB ; GO BUILD FTBTAB FOR THIS FILTAB ENTRY TSWF FLAG; ; MFCU call? POPJ PP, ; yes - exit MOVE TA,CURFIL ; GET THE FILE LDB TB,FI.TYP ; get file type CAIN TB,3 ; combined? PUSHJ PP,BLDSTK ; yes - output stacker entries LDB TA,FI.DAT ; GET POINTER TO DATAB ITEM JUMPE TA,BLD.18 ; NO DATA ITEMS (?) PUSHJ PP,LNKSET ; SET UP LINKERS MOVEM TA,CURDAT ; STASH FOR LATER MOVEM TA,CURMAJ ; STORE AS MAJOR POINTER LDB TB,DA.INF## ; GET INPUT SECTION FLAG JUMPE TB,BLD.19 ; OUTPUT RECORD - GO PROCESS BLD11C: MOVE TA,[XWD CD.ICH,SZ.ICH] ; SET UP TO GET ITEM PUSHJ PP,GETENT ; GET AN ICHTAB ENTRY HRRZM TA,CURICH ; STORE hrrz tb,ta ; get pointer into tb SUB TB,ICHLOC ; MAKE A POINTER hrrzm tb,currec ; save current record pointer MOVE TA,CUROTF ; GET OTFTAB POINTER TRNN TB,777777 ; [021] TREAT SPECIAL IF RH ZERO MOVEI TB,777777 ; [021] OUR SPECIAL FLAG DPB TB,OT.IPC ; STORE AS INPUT CHAIN POINTER BLD.14: MOVE TA,CURICH ; GET POINTER TO ICHTAB ITEM MOVE TB,CURDAT ; GET POINTER TO DATAB ITEM MOVEI TD,TB2CNT-1 ; get index BLD11B: EXCH TA,TB ; ZWAP! LDB TC,@DTB(TD) ; GET A BYTE EXCH TA,TB ; SWAP POINTERS DPB TC,@ITB(TD) ; STASH IN ICHTAB SOJGE TD,BLD11B ; Loop until done EXCH TA,TB ; RESTORE POINTERS HRRZ TC,2(TA) ; get core location (DA.COR) LDB TD,DA.RES ; GET BYTE RESIDUE ROT TD,-6 ; AIIIII! THE ROT! ADD TD,TC ; COMBINE TLO TD,(6B11) ; SIX BIT BYTES. HRRZ TC,1(TA) ; get INDTAB chain pointer (DA.IND) EXCH TA,TB ; swap the pointers MOVEM TD,(TA) ; store destination byte pointer (IC.DES) ;[352] TSWT FLAG; ; [272] flagged items never have entries JUMPE TC,BLD11A ; [272] skip over code if no IDTTAB entry MOVE CH,ELITPC ; GET POINTER HRLM CH,1(TA) ; store pointer to IDTTAB chain (IC.RII) PUSHJ PP,INDOUT ; GO DUMP INDTAB ENTRY BLD11A: EXCH TA,TB ; [272] restore pointers ;BLD.11 (CONT'D) CONTINUE BUILDING ICHTAB & OCHTAB ENTRIES ; BLD11D: TSWF FLAG; ; special flag set? JRST BLD.12 ; yes - skip over array entry stuff HRRZ TA,13(TA) ; get array pointer (DA.ARP) JUMPE TA,BLD.12 ; NOT AN ARRAY - PUSHJ PP,LNKSET ; SET UP LINKS HLRZ TC,13(TA) ; get pointer to ICHTAB (DA.ICH) MOVE TA,CURICH ; RESTORE POINTER JUMPN TC,.+2 ; [324] special case - flag as HRRZI TC,777777 ; [324] relocatable zero entry. HRRM TC,2(TA) ; store as array pointer to ICH (IC.ARP) MOVE TA,CURDAT ; GET BACK TO DATAB LDB TD,DA.IMD ; GET IMMEDIATE LDB TA,DA.INP ; GET POINTER TO INDEX JUMPE TA,BLD.12 ; NO INDEX (BUT AN ARRAY??) MOVE TC,TA ; GET INTO RIGHT AC IN CASE OF JUMP JUMPN TD,.+3 ; IMMEDIATE? PUSHJ PP,LNKSET ; NO - SET LINKS HLRZ TC,13(TA) ; get ICHTAB pointer (DA.ICH) MOVE TA,CURICH ; YES - GET ICHTAB POINTER DPB TC,IC.INP ; STORE INDEX POINTER BLD.12: MOVE TC,CURICH ; GET ICHTAB POINTER SUB TC,ICHLOC ; MAKE A POINT MOVE TA,CURDAT ; GET DATAB POINTER HRLM TC,13(TA) ; store as ICHTAB pointer (DA.ICH) MOVE TA,CURICH ; RESTORE POINTER TSWFZ FLAG; ; MAGIC? POPJ PP, ; YES - EXIT MOVEM TA,CURFLD ; STORE AS CURRENT FIELD MOVE TA,CURDAT ; GET CURRENT DATAB HLRZ TA,1(TA) ; get brother link (DA.BRO) JUMPE TA,BLD.15 ; THIS IS THE END PUSHJ PP,LNKSET ; SET UP LINKS MOVEM TA,CURDAT ; STORE AS NEW DATAB ITEM MOVE TA,[XWD CD.ICH,SZ.ICH] ; SET UP TO GET ICHTAB ENTRY PUSHJ PP,GETENT ; GO FOR IT HRRZM TA,CURICH ; STASH POINTER FOR POSTERIOR HRRZ TB,TA ; BACHINO! BACHINO! SUB TB,ICHLOC ; MAKE A POINTER MOVE TA,CURFLD ; GET CURRENT FIELD HRRM TB,1(TA) ; store as pointer to next field (IC.NXF) JRST BLD.14 ; LOOP ON BACK ;BLD.11 (CONT'D) TABLES USED TO BUILD ICHTAB ENTRIES ; ; ;TABLE OF DATAB ITEMS TO BE TRANSFERRED TO ICHTAB DTB: EXP DA.NPS## EXP DA.FMN## EXP DA.FBZ## EXP DA.FPL## EXP DA.CLI## EXP DA.FRR## EXP DA.MAT## EXP DA.RTR## EXP DA.LHI## EXP DA.STS## EXP DA.FLD## EXP DA.ISZ## ; [317] EXP DA.SEQ## EXP DA.FRP## EXP DA.OCC## EXP DA.IMD## EXP DA.FMT## TB2CNT==.-DTB ;TABLE OF ITEMS TO BE TRANSFERRED TO ICHTAB ITB: EXP IC.NPS## EXP IC.FMN## EXP IC.FBZ## EXP IC.FPL## EXP IC.CLI## EXP IC.FRR## EXP IC.MAT## EXP IC.RTR## EXP IC.LHI## EXP IC.STS## EXP IC.FLD## EXP IC.SIZ## EXP IC.SEQ## EXP IC.SRC## EXP IC.OCC## EXP IC.IMD## EXP IC.FMT## ;BLD.11 (CONT'D) CONTINUE BUILDING ICHTAB & OCHTAB ENTRIES ; BLD.15: MOVE TA,CURMAJ ; GET MAJOR POINTER LDB TA,DA.MAJ ; GET MAJOR LINK JUMPE TA,BLD.18 ; GET ANOTHER FILE IF LINK IS EMPTY PUSHJ PP,LNKSET ; SET UP LINK MOVEM TA,CURDAT ; STORE MOVEM TA,CURMAJ## ; STORE NEW MAJOR POINTER MOVE TA,CURFLD ; GET PREVIOUS FIELD HLLZS 1(TA) ; make sure IC.NXF is zero MOVE TA,CURDAT ; GET BACK DATAB POINTER LDB TB,DA.INF ; INPUT RECORD? JUMPE TB,BLD.19 ; NO - OUTPUT RECORD MOVE TA,[XWD CD.ICH,SZ.ICH] ; SET UP TO GET ICHTAB ENTRY PUSHJ PP,GETENT ; GET IT HRRZM TA,CURICH ; STASH IT HRRZ TB,TA ; SET UP TO MAKE A POINTER SUB TB,ICHLOC ; MAKE IT MOVE TA,CURREC ; AND STORE FOR LATER add ta,ichloc ; offset BLD.16: HRLM TB,2(TA) ; store as next record link (IC.NXR) HRRZ TA,1(TA) ; get next field link (IC.NXF) JUMPE TA,BLD.17 ; ALL DONE IF ZED ADD TA,ICHLOC ; INDEX JRST BLD.16 ; LOOP BLD.17: MOVE TA,CURICH ; GET ICHTAB POINTER BACK sub ta,ichloc ; make table relative MOVEM TA,CURREC ; STORE AS CURRENT RECORD JRST BLD.14 ; AND TAKE THE BIG LOOP BLD.18: MOVE TA,CURFIL ; GET FILTAB POINTER ADDI TA,SZ.FIL ; BUMP HRRZ TB,FILNXT ; GET FILNXT MOVEM TA,CURFIL ; STORE NEW FILTAB POINTER CAME TA,TB ; ALL DONE? JRST BLD.07 ; NO - LOOP MOVE TA,CUROTF ; YES - GET OTFTAB POINTER MOVEI TB,1 ; SET "LAST" DPB TB,OT.LAS ; SO WE KNOW WHERE TO STOP JRST OUT.00 ;BLD.11 (CONT'D) ROUTINE BLD.19 PROCESSES OCHTAB ENTRIES ; BLD.19: MOVE TA,[XWD CD.OCH,SZ.OCH] ; SET UP TO GET TABLE ENTRY PUSHJ PP,GETENT ; GET IT HRRZM TA,CUROCH ; STORE HRRZM TA,CURREC ; STORE AS CURRENT RECORD HRRZ TB,TA ; MOVE 'ER SUB TB,OCHLOC ; MAKE A POINTER MOVE TA,CUROTF ; GET A POINTER TRNN TB,777777 ; [021] ANYTHING BUT ZERO RH, OK MOVEI TB,777777 ; [021] FAKE OUT OTF.02 DPB TB,OT.OPC ; STORE A POINTER JRST BLD.20 ; BYPASS SOME JUNK BLD20A: MOVE TA,CURDAT ; GET DATAB POINTER LDB TB,DA.SIZ ; GET THIS SIZE JUMPN TB,BLD.20 ; ALL OK IF WE FIND ONE LDB TB,DA.LTF## ; CHECK LITERAL FLAG JUMPN TB,BLD.20 ; ALL ALSO OK IF WE FIND ONE LDB TA,DA.NAM## ; ELSE GET NAMTAB LINK MOVEI TB,CD.DAT ; GET PLACE TO LOOK PUSHJ PP,FNDLNK ; AND LOOK JFCL ; ALWAYS FIND IT MOVE TA,TB ; GET LINK INTO PROPER AC BLD19A: LDB TB,DA.SIZ ; GET THIS SIZE ENTRY JUMPN TB,BLD19B ; ALL DONE WHEN WE FIND ONE HRRZ TB,10(TA) ; get a same name link (DA.SNM) JUMPE TB,BLD.20 ; didn't find one - complain to Him MOVE TA,TB ; GOT ONE SO SWAP LINKS PUSHJ PP,LNKSET ; SET UP THOSE LINKS JRST BLD19A ; AND TRY ONE MORE TIME BLD19B: LDB TC,DA.FLD ; GET FIELD TYPE TOO LDB TD,DA.DEC ; AND DECIMAL POSITIONS MOVE TA,CURDAT ; GET OLD TIME DATAB POINTER DPB TB,DA.SIZ ; AND STORE SIZE DPB TC,DA.FLD ; FIELD TYPE, DPB TD,DA.DEC ; AND DECIMAL POSITIONS BLD.20: MOVE TA,CUROCH ; GET OCHTAB POINTER MOVE TB,CURDAT ; GET DATAB POINTER MOVEI TD,TB3CNT-1 ; get index ;BLD.11 (CONT'D) CONTINUE PROCESSING ICHTAB & OCHTAB ENTRIES ;BLD.19 (CONT'D) CONTINUE OUTPUTTING OCHTAB ENTRIES ; BLD.21: EXCH TA,TB ; ZWAP! LDB TC,@DTB2(TD) ; GET A DATAB ITEM EXCH TA,TB ; SWAP POINTERS DPB TC,@OCB(TD) ; STORE AS OCHTAB ITEM SOJGE TD,BLD.21 ; Loop until done EXCH TA,TB ; GET EVERYTHING WHERE IT BELONGS HRRZ TC,2(TA) ; get assigned core location (DA.COR) LDB TD,DA.RES ; GET BYTE RESIDUE ROT TD,-6 ; MAKE A BYTE POINTER ADD TD,TC ; MIX THE TWO TLO TD,(6B11) ; SIX BIT BYTES HRRZ TC,1(TA) ; get INDTAB pointer (DA.IND) MOVEM TD,2(TB) ; store as source byte pointer (OC.SRC) JUMPE TC,BLD21A ; DON'T GENERATE ANYTHING IF ZERO MOVE CH,ELITPC ; GET POINTER INTO LITAB HRRM CH,1(TB) ; store OC.IND MOVE TA,TB ; get link into proper AC for LNKSET PUSHJ PP,INDOUT ; DUMP INDTAB BLD21A: MOVE TA,CURDAT ; GET DATAB POINTER LDB TC,DA.IMD ; get immediate flag HLRZ TA,14(TA) ; get index pointer (DA.INP) JUMPE TA,BLD.22 ; NONE - GO JUMP MOVE TB,TA ; get into proper AC in case of jump JUMPN TC,.+4 ; jump if immediate PUSHJ PP,LNKSET ; SET UP LINKS HLRZ TB,13(TA) ; get pointer to ICHTAB item (DA.ICH) ANDI TB,TM.DAT## ; get only the juicy parts MOVE TA,CUROCH ; GET OUR OCHTAB POINTER HRLM TB,(TA) ; store as index pointer (OC.IDX) BLD.22: MOVE TA,CURDAT ; RECOVER POINTER HRRZ TA,13(TA) ; get array pointer (DA.ARP) JUMPE TA,BLD22A ; NONE - PUSHJ PP,LNKSET ; SET UP LINKAGE HLRZ TB,13(TA) ; get ICHTAB pointer (DA.ICH) SKIPN TB ; is it zero? SETO TB, ; yes - use special flag MOVE TA,CUROCH ; GET CURRENT OCHTAB ITEM HRLM TB,6(TA) ; store as array pointer (OC.ARP) BLD22A: MOVE TA,CUROCH ; make sure we have OCHTAB pointer SETZ TB, ; and a zero DPB TB,OC.LTF ; zap the literal flag DPB TB,OC.LSZ ; likewise the size MOVE TA,CURDAT ; RECOVER POINTER HLRZ TB,2(TA) ; get VALTAB link (DA.VAL) JUMPE TB,BLD.23 ; JUST LEAVE IF NO LINK PUSHJ PP,PREDIT## ; ELSE GO SET UP FOR EDIT. SWOFF FLAG; ; turn off flag to be sure JUMPE TE,BLD.23 ; MUST BE EDIT WORD MOVE TA,CUROCH ; MUST BE LITERAL DPB TE,OC.LTF## ; FLAG AS SUCH SUBI TD,1 ; ADJUST FOR BACK ARROW DPB TD,OC.LSZ## ; AND STORE LITERAL SIZE ;BLD.11 (CONT'D) CONTINUE PROCESSING ICHTAB & OCHTAB ENTRIES ;BLD.19 (CONT'D) CONTINUE OUTPUTTING OCHTAB ENTRIES ; BLD.23: MOVE TA,CUROCH ; RECOVER OCHTAB POINTER MOVEM TA,CURFLD ; STORE AS CURRENT FIELD MOVE TA,CURDAT ; RECOVER DATAB POINTER HLRZ TA,1(TA) ; get brother link (DA.BRO) JUMPE TA,BLD.24 ; NO MORE BROTHERS, GET MAJOR PUSHJ PP,LNKSET ; SET UP LINK MOVEM TA,CURDAT ; STORE AS CURRENT DATAB ITEM MOVE TA,[XWD CD.OCH,SZ.OCH] ; SET UP TO GET OCHTAB ENTRY PUSHJ PP,GETENT ; GET IT HRRZM TA,CUROCH ; STASH POINTER HRRZ TB,TA ; MOVE POINTER SUB TB,OCHLOC ; MAKE A POINTER MOVE TA,CURFLD ; GET CURRENT FIELD HRLM TB,1(TA) ; store as next field (OC.NXF) JRST BLD20A ; AND LOOP BLD23A: MOVE TA,CURDAT ; GET ORIGINAL POINTER LDB TB,DA.LIN## ; GET LINE NUMBER MOVEM TB,SAVELN ; SAVE IT FOR WARNW WARN 700; ; OUTPUT A WARNING JRST BLD.23 ; AND TRY AGAIN ;BLD.11 (CONT'D) CONTINUE PROCESSING ICHTAB & OCHTAB ENTRIES ;BLD.19 (CONT'D) TABLES USED FOR PROCESSING OCHTAB ENTRIES ; ; ;ITEMS TO GET FROM DATAB DTB2: EXP DA.FLD## EXP DA.SIZ## EXP DA.DEC## EXP DA.PRI## EXP DA.PRO## EXP DA.STR## EXP DA.STP## EXP DA.ORT## EXP DA.ARC## EXP DA.FOV## EXP DA.SKB## EXP DA.SKA## EXP DA.SPB## EXP DA.SPA## EXP DA.END## EXP DA.EDT## EXP DA.IMD## EXP DA.STS## EXP DA.BLA## EXP DA.RSV## EXP DA.OCC## EXP DA.TAB## TB3CNT==.-DTB2 ;PLACES TO PUT THEM IN OCHTAB OCB: EXP OC.FLD## EXP OC.SIZ## EXP OC.DEC## EXP OC.PRI## EXP OC.PRO## EXP OC.STR## EXP OC.STP## EXP OC.ORT## EXP OC.ADD## EXP OC.FOV## EXP OC.SKB## EXP OC.SKA## EXP OC.SPB## EXP OC.SPA## EXP OC.END## EXP OC.EDT## EXP OC.IMD## EXP OC.STS## EXP OC.BLA## EXP OC.RSV## EXP OC.OCC## EXP OC.TAB## ;BLD.11 (CONT'D) CONTINUE PROCESSING ICHTAB & OCHTAB ENTRIES ;BLD.19 (CONT'D) GET NEXT OCHTAB ENTRY, OR LOOP AND GET NEXT FILTAB ENTRY ; BLD.24: MOVE TA,CURMAJ ; GET MAJOR RECORD POINTER HRRZ TA,(TA) ; get major link (DA.MAJ) JUMPE TA,BLD.18 ; NO MORE PUSHJ PP,LNKSET ; SET LINKER'S MOVEM TA,CURDAT ; STASH MOVEM TA,CURMAJ ; STORE AS NEW MAJOR RECORD MOVE TA,CURFLD ; GET FIELD POINTER HRRZS 1(TA) ; zap OC.NXF MOVE TA,[XWD CD.OCH,SZ.OCH] ; SET UP TO GET TABLE ENTRY PUSHJ PP,GETENT ; AND GET IT HRRZM TA,CUROCH ; STASH HRRZ TB,TA ; IDAHO TRANSFER SUB TB,OCHLOC ; MAKE A LINK MOVE TA,CURREC ; GET RECORD POINTER BLD.25: HRRM TB,(TA) ; stash link to next record (OC.NXR) HLRZ TA,1(TA) ; get link to next field (OC.NXF) JUMPE TA,BLD.26 ; OUT - ADD TA,OCHLOC ; CONVERT LINK TO REAL WORLD JRST BLD.25 ; AND LOOP - BLD.26: MOVE TA,CUROCH ; GET CURRENT OCHTAB POINTER MOVEM TA,CURREC ; STORE AS NEXT RECORD JRST BLD.20 ; and loop on around ;BLDFTB ROUTINE TO BUILD AN FTBTAB ENTRY FOR THE CURRENT FILTAB ENTRY ; ; ; BLDFTB: PUSHJ PP,GETFTB## ; GET AN FTBTAB ENTRY HRRZM TA,CURFTB## ; STASH FOR LATER MOVE TB,TA ; get pointer to where we can use it SUB TB,FTBLOC ; make into relative pointer ANDI TB,777777 ; get only the good parts MOVE TC,FTBNUM ; get number of FTBTAB entries we've made IMULI TC,32 ; multiply by size of device table ADD TB,TC ; increase pointer MOVE TA,CUROTF ; GET CURRENT OTFTAB POINTER DPB TB,OT.FTB ; and store pointer to FTBTAB entry LDB TC,OT.BFP ; get the buffer pointer LDB TD,OT.BSC ; GET THE BUFFER SIZE LDB TE,OT.BLK ; GET THE BLOCKING FACTOR MOVE TA,CURFTB ; GET BACK THE FTBTAB POINTER DPB TC,FT.REC## ; STASH BUFFER POINTER DPB TD,FT.MRS## ; STASH BUFFER SIZE (RECORD SIZE) DPB TE,FT.BKF## ; STASH BLOCKING FACTOR MOVE TA,CURFIL ; GET FILTAB POINTER LDB TB,FI.NAM## ; GET NAMTAB POINTER FOR THIS FILE MOVE TA,CURFTB ; GET FTBTAB POINTER BACK ADD TB,NAMLOC## ; MAKE NAMTAB POINTER REAL MOVE TC,1(TB) ; GET FIRST SIX CHARS MOVE TD,2(TB) ; GET THE NEXT SIX (MY KINGDOM FOR DMOVE) MOVEM TC,(TA) ; STASH IN FT.FNM MOVEM TD,1(TA) ; STASH AS NEXT WORD MOVEI TB,1 ; GET THE INFAMOUS FLAG DPB TB,FT.NOD## ; SET NUMBER OF DEVICES TO 1 DPB TB,FT.NFL## ; ALSO NUMBER OF FILE LIMIT CLAUSES DPB TB,FT.STL## ; LIKEWISE WITH STANDARD LABELS FLAG MOVE CH,ELITPC ; get LITAB PC DPB CH,FT.DNM## ; stash as address of device name literal MOVE TA,CURFIL ; GET FILTAB POINTER LDB TB,FI.DEV ; GET THE DEVICE MOVE CH,[XWD SIXLIT,1] ; GET LITAB HEADER PUSHJ PP,STASHC ; OUTPUT TO LITAB MOVE CH,DVTAB1(TB) ; GET DEVICE NAME CAIN TB,.FIMTA ; is it a mag-tape? JRST [ LDB TC,FI.UNT## ; yes - get unit number ADDI TC,'0' ; make into sixbit ASH TC,6 ; get into line ADD CH,TC ; add in the unit JRST .+1 ] ; exit PUSHJ PP,STASHC ; OUTPUT IT TO LITAB AOS ELITPC ; bump that PC LDB TC,FI.ORG ; GET FILE ORGANIZATION CAIN TC,2 ; indexed file? PUSHJ PP,BLDFT2 ; yes - output second device name LDB CH,FI.AST## ; get ASCII option ;BLDFTB (cont'd) ; ; ; MOVE TA,CURFTB ; get FTBTAB pointer SETZ TE, ; get a special constant ready MOVEI TD,2 ; default to ASCII JUMPN CH,.+3 ; all set if this is ASCII option CAILE TB,5 ; DISK or TAPE? SETZ TD, ; yes - use sixbit I/O DPB TD,FT.DDM## ; stash device data mode SKIPE TD ; was that ASCII mode? DPB TE,FT.BKF ; yes - set to unblocked SETZ TD, ; 0 = SEQUENTIAL MOVE TA,CUROTF ; get OTFTAB pointer back LDB TE,OT.PRO## ; [276] get file description MOVE TA,CURFTB ; restore FTBTAB pointer MOVE TD,MODTAB(TE) ; [276] get I/O mode CAIN TC,2 ; [276] was that ISAM? MOVEI TD,2 ; [276] yes - set to ISAM mode BLDFT3: DPB TD,FT.MOD## ; STASH AS I/O MODE CAIE TD,1 ; RANDOM? JRST BLDFT0 ; NO - MOVE CH,ELITPC ; YES - GET LITAB PC DPB CH,FT.ACK## ; STASH AS ADDR OF ACTUAL KEY TABLE MOVE CH,[XWD OCTLIT,1] ; GET HEADER PUSHJ PP,STASHC ; OUTPUT SETZ CH, ; START WITH ZERO PUSHJ PP,STASHC ; OUTPUT THAT TOO AOS ELITPC ; [276] bump litab pc JRST BLDFT1 ; [276] continue elsewhere MODTAB: EXP 0 ; consecutive => sequential EXP 1 ; ADDRout => random EXP 1 ; seq by key => random EXP 0 ; not supported EXP 1 ; random by rec num => random EXP 2 ; indexed => ISAM ;BLDFTB (CONT'D) COME HERE ON SEQUENTIAL OR INDEXED FILE ; ; ; BLDFT0: CAIE TD,2 ; INDEXED? JRST BLDFT1 ; NO - JUMP OUT MOVEI TB,17 ; GET ALL ACCESS PRIVLEDGES DPB TB,FT.OWA## ; STASH AS ISAM ACCESS RIGHTS MOVEI TB,10 ; GET READ ONLY PRIVLEDGES DPB TB,FT.OTA## ; STASH AS OTHERS ACCESS RIGHTS MOVE TA,CURFIL ; GET FILTAB POINTER LDB TC,FI.KYP ; GET KEY POINTER SUBI TC,1 ; make key position orgin 0 LDB TD,FI.KYL ; GET KEY LENGTH IDIVI TC,6 ; GET WORD COUNT FROM POINTER HRL TC,BYTAB1(TB) ; GET BYTE RESIDUE MOVE TA,CUROTF ; get OTFTAB pointer LDB TB,OT.BFP ; get pointer to buffer ADD TC,TB ; add in as base address MOVE TA,CURFTB ; GET FTBTAB POINTER DPB TC,FT.BRK## ; STORE AS BPTR TO RECORD KEY HRRZ TC,ELITPC ; GET LITAB PC HRL TC,BYTAB1 ; GET STANDARD BYTE POINTER DPB TC,FT.BSK## ; STORE AS BPTR TO SYMBOLIC KEY DPB TD,FT.KLB## ; STASH LENGTH OF ISAM KEY IDIVI TD,6 ; TAKE MODULO 6 SKIPE TC ; IF REMAINDER ADDI TD,1 ; THEN ROUND UP MOVE CH,TD ; GET INTO PROPER AC HRLI CH,SIXLIT ; MAKE INTO HEADER WORD PUSHJ PP,STASHC ; OUTPUT ADDM TD,ELITPC ; BUMP ELITPC SETZ CH, ; GET A ZERO PUSHJ PP,STASHC ; OUTPUT IT SOJG TD,.-1 ; AND LOOP ON JRST BLDFT1 ; continue BLDFT2: MOVE CH,[XWD SIXLIT,1] ; get LITAB header PUSHJ PP,STASHC ; output MOVE CH,DVTAB1(TB) ; get device name for data file AOS ELITPC ; bump the pc PJRST STASHC ; output and exit ;BLDFTB (CONT'D) OUTPUT REMAINDER OF FTBTAB DATA ; ; ; BLDFT1: HRRZ TC,ELITPC ; GET THAT PC HRL TC,BYTAB1 ; GET BYTE POINTER DATA DPB TC,FT.VID## ; STASH AS VALUE OF ID BYTE POINTER MOVE CH,[XWD SIXLIT,2] ; ONE FOR FILENAME, ONE FOR EXTENSION PUSHJ PP,STASHC ; OUTPUT MOVE TA,CUROTF ; GET OTFTAB POINTER LDB CH,OT.NAM ; GET PHYSICAL NAME PUSHJ PP,STASHC ; OUTPUT IT HRLZI CH,'RGD' ; GET DEFAULT EXTENSION LDB TC,OT.DES ; GET DESCRIPTION CAIN TC,3 ; RECORD ADDRESS? HRLZI CH,'RGL' ; YES - LIMITS FILE LDB TC,OT.ORG ; GET ORGANIZATION CAIN TC,3 ; ADDRout? HRLZI CH,'RGA' ; yes - CAIN TC,2 ; indexed? HRLZI CH,'IDX' ; YES LDB TC,OT.DEV ; GET DEVICE CAIN TC,.FIMF1 ; MFCU1? HRLZI CH,'MF1' ; YES - CAIN TC,.FIMF2 ; MFCU2? HRLZI CH,'MF2' ; YES - TSWF FLAG; ; outputing stacker entries? MOVS CH,.STEXT ; yes - use stacker extension PUSHJ PP,STASHC ; OUTPUT AOS ELITPC ; BUMP AOS ELITPC ; BUMP MOVE TA,CURFTB ; GET THAT POINTER MOVE CH,LHLLIT## ; get limits literal DPB CH,FT.LHL## ; stash in FTBTAB MOVE TB,FTBNXT## ; GET NEXT FTBTAB ADDRESS SUB TB,FTBLOC ; GET RELATIVE LOC AOS TC,FTBNUM ; get number of entries and increment at same time IMULI TC,32 ; multiply by number of words in device table ADD TB,TC ; and add in DPB TB,FT.NFT## ; STASH POPJ PP, ; EXIT ;DEVICE TABLE DVTAB1: SIXBIT /DSK/ ; MFCU1 SIXBIT /DSK/ ; MFCU2 SIXBIT /CDR/ ; READ01 SIXBIT /LPT/ ; PRINTER SIXBIT /LPT/ ; PRINTR2 SIXBIT /TTY/ ; CONSOLE SIXBIT /DSK/ ; DISK SIXBIT /TAPE/ ; TAPE ;BYTE POINTER TABLE BYTAB1: XWD 0,440600 XWD 0,360600 XWD 0,300600 XWD 0,220600 XWD 0,140600 XWD 0,060600 XWD 0,000600 ;BLDARR Build an ARRTAB entry for array load/dump ; ; ; BLDARR: TDCA LN,LN ; say from whence we came BLDARD: MOVEI LN,1 ; likewise I'm sure LDB TB,DA.ALT## ; is it first half of alternating table? JUMPN TB,CPOPJ## ; must be if we jumped PUSH PP,TD ; save some AC's PUSH PP,TA ; and another PUSHJ PP,GETARR ; get an ARRTAB entry MOVE TA,(PP) ; get DATAB pointer back LDB TB,DA.COR ; get core pointer LDB TC,DA.RES ; and byte pointer residue DPB TC,[POINT 6,TB,5] ; each in it's proper place LDB TC,DA.SIZ ; get size of field LDB TD,DA.OCC ; and occurs of array MOVE TA,CURARR## ; get ARRTAB pointer TLO TB,600 ; set byte size DPB TB,AR.PNT## ; store as pointer DPB TC,AR.SIZ## ; store size DPB TD,AR.OCC## ; and occurs MOVE TA,(PP) ; get pointer to DATAB item LDB TB,DA.EPR## ; get entries/record LDB TC,DA.LDP## ; get load pointer LDB TD,DA.DPP## ; and dump pointer CAIN TC,777777 ; [250] special flag? SETZ TC, ; [250] yes - reset to zero CAIN TD,777777 ; [250] another special flag? SETZ TD, ; [250] yes - likewise reset MOVE TA,CURARR ; get back ARRTAB pointer DPB TB,AR.EPR## ; stash entries per record DPB LN,AR.LDM## ; stash load/dump flag DPB TC,AR.FIL## ; default to load SKIPE LN ; but was it dump? DPB TD,AR.FIL ; yes - so stash correct pointer MOVE TA,(PP) ; get back DATAB pointer LDB TA,DA.ALL## ; get alternating link JUMPE TA,BLDAR1 ; exit if none CAIN TA,TC.DAT##+77777 ; [252] special valid zero? TRZ TA,77777 ; [252] yes - make into real zero PUSHJ PP,LNKSET ; else set up link LDB TB,DA.COR ; get assigned core location LDB TC,DA.RES ; and byte residue DPB TC,[POINT 6,TB,5] ; combine TLO TB,600 ; turn into real byte pointer LDB TC,DA.SIZ ; get size of entry MOVE TA,CURARR ; get pointer into ARRtab DPB TB,AR.ALT## ; save alternating table pointer DPB TC,AR.ASZ## ; and field size BLDAR1: POP PP,TA ; restore pointer POP PP,TD ; again POPJ PP, ; and exit ;GETARR Get an ARRTAB entry ; ; ; GETARR: MOVE TA,ARRNXT## ; get pointer to next item MOVE TB,TA ; get into working AC ADD TB,[XWD SZ.ARR,SZ.ARR] ; increment by size of entry JUMPGE TB,GETAR1 ; jump if all out of room MOVEM TB,ARRNXT ; else store new pointer MOVEM TA,CURARR ; save current one for others POPJ PP, ; and leave GETAR1: PUSHJ PP,XPNARR## ; expand the table JRST GETARR ; and try again ;BLDSTK Output table entries for MFCU stackers ; ; ; BLDSTK: SKIPE .STLST## ; already done it once? POPJ PP, ; yes - exit PUSH PP,CUROTF ; save pointer SWON FLAG; ; no - turn on magic flag MOVEI TB,'ST1' ; get stacker 1 extension MOVEM TB,.STEXT## ; save it PUSHJ PP,BLD.07 ; go output OTFTAB and FTBTAB entries MOVE TB,CUROTF ; get the OTFTAB entry we just output SUB TB,OTFLOC ; make table relative HRRM TB,.STLST ; save AOS .STEXT ; get next extension PUSHJ PP,BLD.07 ; output stacker 2 entries AOS .STEXT ; get .ST3 PUSHJ PP,BLD.07 ; output that entry AOS .STEXT ; get .ST4 PUSHJ PP,BLD.07 ; output that too SWOFF FLAG; ; turn off the flag MOVE TA,CURFIL ; restore the AC POP PP,CUROTF ; restore pointer POPJ PP, ; exit ;OUT.00 Final setup before outputing tables ; ; ; OUT.00: MOVE CH,[XWD AS.REL+1B35,AS.MSC] ; [356] PUSHJ PP,PUTAS1 ; [356] output a RELOC MOVEI CH,AS.DAT ; [356] to start of DATAB so that PUSHJ PP,PUTAS1 ; [356] correct value of %DAT is output by G. AOS EAS1PC ; bump the PC one more time MOVE CH,[XWD AS.REL+1B35,AS.MSC] PUSHJ PP,PUTAS1## ; PUT OUT TYPE WORD MOVE CH,EAS1PC ; OUR INCREMENT TRO CH,AS.DOT## ; .+ PUSHJ PP,PUTAS1 ; OUTPUT IT MOVE TA,CURFTB ; GET THE CURRENT FTBTAB POINTER SETZ TB, ; GET A ZERO DPB TB,FT.NFT ; ZERO OUT POINTER MOVE TA,ARRLOC ; get start of ARRTAB CAMN TA,ARRNXT ; anything in it? JRST OUT.01 ; no - MOVE TA,CURARR ; yes - get last item MOVEI TB,1 ; get a flag DPB TB,AR.LAS## ; flag as last item OUT.01: PUSHJ PP,ARR.00 ; output ARRTAB ;OTF.00 OTFTAB OUTPUT ROUTINE ; ;THIS ROUTINE OUTPUTS OTFTAB TO AS1FIL. ; OTF.00: MOVE TA,EAS1PC ; GET CURRENT PC MOVEM TA,OTFBAS## ; STORE AS BASE OF OTFTAB SETZM EAS1PC ; ZAPETH THE PC HRRZ TA,OTFLOC ; START AT THE BEGINNING MOVEM TA,CUROTF ; STORE FOR LATER HRLZI CH,AS.REL+1B35 HRRI CH,AS.MSC PUSHJ PP,PUTAS1 HRRZI CH,AS.OTB## PUSHJ PP,PUTAS1 ; RELOC %OTF OTF.01: HRRZ TB,OTFNXT ; GET END O' LINE CAML TA,TB ; ARE WE THERE YET? JRST ICH.00 ; YES - GO DUMP ICHTAB MOVEI CH,3 ; GONNA PUT OUT 3 XWD'S TLO CH,AS.XWD## ; TELL THE ASSEMBLER PUSHJ PP,PUTAS1 ; OUTPUT THE WORD MOVSI TB,-5 ; SET UP AOBJ POINTER OTF.02: LDB CH,@PTAB1(TB) ; GET OTFTAB ITEM CAIN CH,777777 ; [021] IS SPECIAL?? AOJA CH,.+4 ; [021] YES - CHANGE TO RELOCATED ZERO JUMPN CH,.+3 ; ZERO? SKIPGE PTAB1(TB) ; YES - DO WE WANT NON-RELOCATABLE ZERO? SKIPA CH,[XWD AS.CNB,0] ; YES - GIVE IT TO 'EM ADD CH,ATAB1(TB) ; NO - ADD IN RELOCATION MOVSS CH ; GET EVERYTHING WHERE IT BELONGS PUSHJ PP,PUTAS1 ; OUTPUT IT AOBJN TB,OTF.02 ; LOOP UNTIL DONE LDB CH,OT.FTB## ; GET FTBTAB POINTER ADDI CH,AS.FTB## ; FLAG IT PUSHJ PP,PUTAS1 ; OUTPUT IT MOVE CH,[XWD AS.SIX##,1] ; WRITE OUT SIXBIT CONSTANT PUSHJ PP,PUTAS1 ; LDB CH,OT.NAM## ; PHYSICAL NAME OF FILE PUSHJ PP,PUTAS1 ; OUTPUT MOVE CH,[XWD AS.OCT,5] ; GONNA WRITE 6 MORE WORDS PUSHJ PP,PUTAS1 ; SAY SO MOVE TB,[XWD -5,4] ; ANOTHER AOBJ POINTER ;OTF.00 (CONT'D) CONTINUE OUTPUTING OTFTAB ENTRIES ; OTF.03: MOVE TD,CUROTF ; GET BASE ADD TD,TB ; INCREMENT MOVE CH,(TD) ; GET THE WORD WE WANT PUSHJ PP,PUTAS1 ; OUTPUT IT AOBJN TB,OTF.03 ; LOOP 'TIL DONE ADDI TA,SZ.OTF ; BUMP POINTER MOVEM TA,CUROTF ; RESTORE MOVEI TB,SZ.OTF ; GET SIZE OF THAT ENTRY ADDM TB,EAS1PC ; BUMP EAS1PC JRST OTF.01 ; LOOP ;TABLE FOR RELOCATABLE ENTRIES IN OTFTAB ATAB1: XWD AS.MSC,AS.DAT XWD AS.MSC,AS.OTB XWD AS.MSC,AS.DAT XWD AS.MSC,AS.OCB XWD AS.MSC,AS.ICB PTAB1: EXP OT.COR##+1B0 EXP OT.ADP## EXP OT.BFP## EXP OT.OPC##+1B0 EXP OT.IPC##+1B0 EXTERNAL AS.MSC, AS.DAT, AS.OTB, AS.OCB, AS.ICB, AS.CNS ;ICH.00 ICHTAB OUTPUT ROUTINE ; ;THIS ROUTINE OUTPUTS ICHTAB TO AS1FIL. ; ICH.00: MOVE TA,EAS1PC ; GET PC MOVEM TA,ICHBAS## ; STORE AS BASE OF ICHTAB SETZM EAS1PC ; ZAP PC HRRZ TA,ICHLOC ; GET START OF ICHTAB HRLZI CH,AS.REL+1B35 HRRI CH,AS.MSC PUSHJ PP,PUTAS1 HRRZI CH,AS.ICB## PUSHJ PP,PUTAS1 ; RELOC %ICH ICH.01: HRRZ TB,ICHNXT ; GET LAST LOC CAML TA,TB ; ARE WE THERE? JRST OCH.00 ; YES - GO DUMP OCHTAB MOVE CH,[XWD AS.BYT,AS.MSC] ; OUTPUT A BYTE POINTER PUSHJ PP,PUTAS1 ; TELL G THAT MOVE CH,(TA) ; GET FIRST WORD TRO CH,AS.DAT ; RELATIVE TO %DAT PUSHJ PP,PUTAS1 ; OUTPUT THAT TOO MOVE CH,[XWD AS.XWD,3] ; SETUP TO DUMP 3 XWD's PUSHJ PP,PUTAS1 ; DUMP MOVSI TB,-4 ; MAKE AN AOBJ POINTER ICH.02: LDB CH,@PTAB2(TB) ; GET A WORD JUMPN CH,ICH.2A ; [324] zero? MOVE CH,[XWD AS.CNB##,0] ; [324] yes - put a zero in ASYFIL JRST ICH.2B ; [324] ICH.2A: CAIN CH,777777 ; [324] relocatable zero entry? MOVEI CH,0 ; [324] yes - set to zero ADD CH,ATAB2(TB) ; [324] add relocation to increment ICH.2B: MOVSS CH ; [324] swap! PUSHJ PP,PUTAS1 ; OUTPUT IT AOBJN TB,ICH.02 ; LOOP 'TIL DONE HLRZ CH,3(TA) ; get index pointer (IC.INP) ADD CH,[XWD AS.MSC,AS.DAT] ; RELOCATE WITH RESPECT TO DATAB LDB TC,IC.IMD ; GET IMMEDIATE FLAG JUMPE TC,ICH.04 ; IF NOT IMMEDIATE, LEAVE AS IS HLRZ CH,3(TA) ; else make it non-relocatable HRLI CH,AS.CNB ; MARK AS CONSTANT CAIA ; NO REASON TO SWAP HALVES ICH.04: MOVSS CH ; OF COURSE PUSHJ PP,PUTAS1 ; OUTPUT IT MOVE CH,[XWD AS.CNB,0] ; ROUND OUT ODD HALF PUSHJ PP,PUTAS1 MOVE CH,[XWD AS.OCT,3] ; 3 OCTAL CONSTANTS PUSHJ PP,PUTAS1 ; MOVE TB,[XWD -3,4] ; AOBJ POINTER ;ICH.00 (CONT'D) CONTINUE OUTPUTING ICHTAB ENTRIES ; ICH.03: MOVE TC,TA ; GET BASE ADD TC,TB ; GET APPROPRIATE WORD MOVE CH,(TC) ; LOAD IT PUSHJ PP,PUTAS1 ; DUMP IT AOBJN TB,ICH.03 ; LOOP IT ADDI TA,SZ.ICH ; BUMP IT MOVEI TB,SZ.ICH ; GET SIZE OF ICHTAB ENTRY ADDM TB,EAS1PC ; BUMP PC ACCORDINGLY JRST ICH.01 ; LOOP IT ATAB2: XWD AS.MSC,AS.LIT XWD AS.MSC,AS.ICB XWD AS.MSC,AS.ICB XWD AS.MSC,AS.ICB ; [324] PTAB2: EXP IC.RII EXP IC.NXF EXP IC.NXR EXP IC.ARP## ;OCH.00 OUTPUT OCHTAB TO AS1FIL ; ;THIS ROUTINE WILL DUMP OCHTAB TO AS1FIL, DOING APPROPRIATE TRANSLATIONS ; OCH.00: MOVE TA,EAS1PC ; GET PC MOVEM TA,OCHBAS## ; IS START OF OCHTAB SETZM EAS1PC ; START OVER AGAIN HRRZ TA,OCHLOC ; GET START OF TABLE HRLZI CH,AS.REL+1B35 HRRI CH,AS.MSC PUSHJ PP,PUTAS1 HRRZI CH,AS.OCB## PUSHJ PP,PUTAS1 ; RELOC %OCH OCH.01: HRRZ TB,OCHNXT ; GET END CAML TA,TB ; ARE WE THERE? JRST FTB.00 ; YES - ALL DONE MOVE CH,[XWD AS.XWD,2] ; TWO XWD's PUSHJ PP,PUTAS1 ; MOVSI TB,-4 ; AOBJ POINTER LDB TC,OC.IMD ; IMMEDIATE INDEX? JUMPE TC,OCH.02 ; NO - HLRZ CH,(TA) ; yes - get index (OC.IDX) PUSHJ PP,PUTAS1 ; OUTPUT WORD AOBJP TB, ; BUMP POINTER OCH.02: LDB CH,@PTAB3(TB) ; GET A BYTE JUMPN CH,.+2 ; IS IT ZERO? SKIPA CH,[XWD AS.CNB,0] ; YES - STUFF ZERO IN ASYFIL ADD CH,ATAB3(TB) ; ELSE SET UP RELOCATE MOVSS CH ; THE RITUAL PUSHJ PP,PUTAS1 ; OUTPUT AOBJN TB,OCH.02 ; LOOP IF NOT DONE MOVE CH,[XWD AS.BYT,AS.MSC] ; SET UP FOR A BYTE POINTER PUSHJ PP,PUTAS1 ; OUTPUT DESCRIPTOR MOVE CH,2(TA) ; GET BYTE POINTER TRO CH,AS.DAT ; RELOCATE RELATIVE TO DATBAS PUSHJ PP,PUTAS1 ; AND OUTPUT MOVE CH,[XWD AS.OCT,3] ; THREE OCTAL CONSTANTS PUSHJ PP,PUTAS1 ; MOVE TB,[XWD -3,3] ; A POINTER ;OCH.00 (CONT'D) CONTINUE OUTPUTING OCHTAB ENTRIES ; OCH.03: MOVE TC,TA ; GET CURRENT TABLE ENTRY ADD TC,TB ; ADD IN INDEX MOVE CH,(TC) ; GET ENTRY PUSHJ PP,PUTAS1 ; OUTPUT IT AOBJN TB,OCH.03 ; KEEP ON LOOPIN' MOVE CH,[XWD AS.XWD,1] ; ANOTHER XWD PUSHJ PP,PUTAS1 ; HLRZ CH,6(TA) ; this one is array pointer (OC.ARP) CAIE CH,777777 ; special flag? JRST .+3 ; no - treat normally SETZ CH, ; yes - make a zero JRST .+3 ; and relocate against ICHTAB JUMPN CH,.+2 ; NOT ZERO SO SKIP SKIPA CH,[XWD AS.CNB,0] ; IS ZERO SO PUT ZERO ADD CH,[XWD AS.MSC,AS.ICB] ; RELOCATE AGAINST %ICH MOVSS CH ; PUSHJ PP,PUTAS1 ; HRRZ CH,6(TA) ; get edit word pointer (OC.EDP) JUMPN CH,.+2 ; IF IS ZERO SKIPA CH,[XWD AS.CNB,0] ; SUBSTITUTE A NON-RELOCATABLE ZERO ADD CH,[XWD AS.MSC,AS.LIT] ; ELSE ADD IN RELOCATION TO EXISITING POINTER MOVSS CH ; GET EVERYTHING WHERE IT BELONGS PUSHJ PP,PUTAS1 ; LIKE THIS MOVEI TB,SZ.OCH ; GET SIZE ADDM TB,EAS1PC ; BUMP PC ADDI TA,SZ.OCH ; GET NEXT ENTRY JRST OCH.01 ; LOOP - ATAB3: XWD AS.MSC,AS.ICB XWD AS.MSC,AS.OCB XWD AS.MSC,AS.OCB XWD AS.MSC,AS.LIT PTAB3: EXP OC.IDX EXP OC.NXR EXP OC.NXF EXP OC.IND ;FTB.00 ROUTINE TO OUTPUT FTBTAB TO AS1FIL ; ; FTB.00: MOVE TA,EAS1PC ; GET PC MOVEM TA,FTBBAS## ; SAVE IT SETZM EAS1PC ; ZAP PC MOVE CH,[XWD AS.REL,AS.FTB] ; GET THE RELOC PUSHJ PP,PUTAS1 ; OUTPUT RELOC %FTB HRRZ TA,FTBLOC## ; START AT THE BEGINNING FTB.01: HRRZ TB,FTBNXT ; GET END OF TABLE CAML TA,TB ; ARE WE THERE YET? JRST LDC.00 ; YES - EXIT HRRZM TA,CURFTB ; NO - STASH POINTER MOVE CH,[XWD AS.OCT,SZ.DEV] ; Device table is 32 words long PUSHJ PP,PUTAS1 ; Output header MOVNI TB,SZ.DEV ; Get counter SETZ CH, ; Get a constant of zero PUSHJ PP,PUTAS1 ; Output a zero AOJL TB,.-1 ; Loop until we've put out 32 of 'em MOVE CH,[XWD AS.SIX,5] ; SET UP TO OUTPUT FT.FNM PUSHJ PP,PUTAS1 ; OUTPUT HEADER MOVNI TB,5 ; GET COUNT FTB.02: MOVE CH,(TA) ; GET A WORD PUSHJ PP,PUTAS1 ; OUTPUT IT ADDI TA,1 ; BUMP POINTER AOJN TB,FTB.02 ; LOOP UNTIL DONE MOVE CH,[XWD AS.XWD,SZ.FTB-5]; get monster header PUSHJ PP,PUTAS1 ; OUTPUT HLLZ CH,(TA) ; GET LH OF WORD HRRI CH,AS.CNB ; GET CONTROL INFO PUSHJ PP,PUTAS1 ; OUTPUT HRLZ CH,(TA) ; GET RIGHT HALF IOR CH,[XWD AS.LIT,AS.MSC] ; GET CONTROL DATA PUSHJ PP,PUTAS1 ; OUTPUT ADDI TA,1 ; INCREMENT POINTER HLLZ CH,(TA) ; GET LH HRRI CH,AS.CNB ; THE USUAL PUSHJ PP,PUTAS1 ; LIKEWISE HRRZ CH,(TA) ; ALL BECAUSE FT.NFT IS WEIRD SKIPN CH ; ZERO? SKIPA CH,[XWD 0,AS.CNB] ; YES - USE REAL ZERO ADDI CH,AS.FTB ; NO - RELOCATE PUSHJ PP,PUTAS1 ; OUTPUT ADDI TA,1 ; BUMP POINTER MOVSI TB,- ; make IOWD ;FTB.00 (CONT'D) ; ; FTB.03: HLLZ CH,(TA) ; GET LH OF TABLE WORD HLLZ TC,ASTAB(TB) ; GET RELOCATION CODE IOR CH,TC ; COMBINE HRRI CH,AS.MSC ; GET OTHER ASYFIL DATA SKIPN TC ; RELOCATED? HRRI CH,AS.CNB ; NO - USE CONSTANT FLAG PUSHJ PP,PUTAS1 ; OUTPUT HRLZ CH,(TA) ; GET RH OF TABLE WORD HRLZ TC,ASTAB(TB) ; GET CORRESPONDING RELOCATION IOR CH,TC ; COMBINE HRRI CH,AS.MSC ; GET RH OF DATA WORD SKIPN TC ; RELOCATED? HRRI CH,AS.CNB ; NO - SET UP AS CONSTANT PUSHJ PP,PUTAS1 ; OUTPUT ADDI TA,1 ; BUMP POINTER AOBJN TB,FTB.03 ; LOOP UNTIL DONE MOVEI TB,SZ.FTB+SZ.DEV ; get total table size ADDM TB,EAS1PC ; AND BUMP PC JRST FTB.01 ; AND TAKE THE BIG LOOP ;FTB.00 (CONT'D) DEFINE RELOCATION TABLES ; ; ; TABLE IS FORMATTED AS FOLLOWS: ; ; LH CONTAINS RELOCATION FOR LEFT HALF OF DATA WORD. IF THE RELOCATION ; IS ZERO, THEN THE DATA IS TREATED AS NON-RELOCATABLE. ; ; RH CONTAINS RELOCATION FOR RIGHT HALF OF DATA WORD FORMMATTED THE ; SAME AS THE LH. ; ; ASTAB: XWD 0,0 XWD 0,AS.DAT XWD 0,0 XWD 0,AS.LIT XWD 0,AS.LIT XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,AS.LIT XWD 0,AS.DAT XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD 0,0 XWD AS.LIT,AS.LIT XWD 0,0 XWD 0,0 ASTBLN==.-ASTAB IFN >, ;LDC.00 Output compile time arrays to AS1FIL ; ;Note special register definition. ; ; OPTR==2 IPTR==3 EPR==5 OCC==6 SIZ==7 LDC.00: SKIPN LDCIND ; any compile time arrays? JRST GENIE ; no - MOVE LN,ARRLIN## ; get saved line number MOVEM LN,SAVELN## ; and restore it TSWF FEOF; ; yes - but are we at end of source? JRST LDC.06 ; yes - minor error LDB TB,[POINT 14,CRDBUF,13] ; get first 2 characters CAIE TB,"**" ; hmmmmm? JRST LDC.10 ; error of sorts LDC.11: SETZM LDCIND ; reset index LDC.03: SETZM TEMCNT## ; [355] and PC counter SETZM TM2CNT## ; Likewise for alternate SWOFF FLALT!FLUALT; ; [346] [355] zap some flags PUSHJ PP,RDCRD ; [340] get a card JRST LDC.06 ; E-O-F JRST LDC.07 ; ** AOS TA,LDCIND ; get an index SKIPN TA,LDCTAB(TA) ; anything there? JRST GENIE ; no - PUSHJ PP,LNKSET ; yes - set up the link LDB TB,DA.ALL ; get alternating link SKIPE TB ; alternating arrays/tables? SWON FLALT; ; yes - MOVE CH,[XWD AS.REL+1,AS.MSC]; get RELOC PUSHJ PP,PUTAS1 ; output it LDB CH,DA.COR ; get core address ADDI CH,AS.DAT ; [340] make DATAB relative PUSHJ PP,PUTAS1 ; output LDB EPR,DA.EPR ; get entries/record LDB OCC,DA.OCC ; get number of occurs TSWF FLALT; ; alternating? IMULI OCC,2 ; yes - double occurs MOVE IPTR,[POINT 7,CRDBUF] ; get pointer into buffer MOVE OPTR,[POINT 6,TEMBUF] ; get pointer into storage TSWT FLALT; ; alternating arrays? JRST LDC.08 ; no - MOVEM OPTR,CURARP## ; yes - stash pointer MOVE OPTR,[POINT 6,TM2BUF] ; get new pointer EXCH OPTR,CURARP ; [355] get pointers into correct places MOVEM TA,CURARR ; stash pointer LDB TA,DA.ALL ; get new link CAIN TA,TC.DAT+77777 ; [346] is it relocatable zero? ANDI TA,-TM.DAT-1 ; [346] yes - make it so PUSHJ PP,LNKSET ; set it up EXCH TA,CURARR ; [346] get pointers in correct order IMULI EPR,2 ; [346] alternating tables get twice ;LDC.00 (cont'd) ; ; ; LDC.08: TSWT FLALT; ; alternating? JRST LDC.09 ; no - TSWC FLUALT; ; switch items EXCH OPTR,CURARP ; swap EXCH TA,CURARR ; pointers LDC.09: LDB SIZ,DA.SIZ ; get size of field LDC.01: ILDB CH,IPTR ; get a character SUBI CH,40 ; convert to sixbit IDPB CH,OPTR ; store TLNN OPTR,770000 ; word full? PUSHJ PP,TEMOUT ; yes - output it SOJG SIZ,LDC.01 ; loop until whole field is out SOJLE OCC,LDC.02 ; exit if whole array is done SOJG EPR,LDC.08 ; loop if any record left PUSHJ PP,RDCRD ; else read in a card JRST LDC.06 ; E-O-F JRST LDC.07 ; ** MOVE IPTR,[POINT 7,CRDBUF] ; get new pointer LDB EPR,DA.EPR ; and get entries/record again TSWF FLALT; ; [346] using alternating tables? IMULI EPR,2 ; [346] yes - double it JRST LDC.08 ; loop LDC.02: TLNE OPTR,770000 ; anything left in word? PUSHJ PP,TEMOUT ; yes - output it TSWT FLALT; ; [355] alternating tables? JRST LDC.04 ; [355] no - MOVE OPTR,CURARP ; [355] yes - get alternate pointer MOVE TA,CURARR ; [355] get array pointer TSWC FLUALT; ; [355] complement user flag TLNE OPTR,770000 ; [355] anything left in buffer? PUSHJ PP,TEMOUT ; [355] yes - output it LDC.04: PUSHJ PP,RDCRD ; read a card JRST LDC.05 ; E-O-F JRST LDC.03 ; ** WARN 333; ; too much data JRST LDC.04 ; try again LDC.05: AOS TA,LDCIND ; get another entry SKIPN LDCTAB(TA) ; anything left? JRST GENIE ; No ok LDC.06: WARN 334; ; not enough data JRST GENIE ; exit LDC.07: WARN 334; ; not enough data JRST GENIE ; loop LDC.10: WARN 22; ; bad card PUSHJ PP,RDCRD ; get another JRST LDC.06 ; E-O-F JRST LDC.07 ; ** JRST LDC.11 ; loop ;TEMOUT Output a word to AS1FIL ; ; ; TEMOUT: TSWF FLALT; ; alternating? JRST TEM.00 ; yes - handle special MOVE CH,[XWD AS.SIX,1] ; one word of sixbit PUSHJ PP,PUTAS1 ; coming up MOVE CH,(OPTR) ; get the word PUSHJ PP,PUTAS1 ; output MOVE OPTR,[POINT 6,TEMBUF] ; get new pointer TSWF FLUALT; ; using alternate? MOVE OPTR,[POINT 6,TM2BUF] ; yes - use pointer to that POPJ PP, ; and exit TEM.00: MOVE CH,[XWD AS.REL+1,AS.MSC]; get a RELOC PUSHJ PP,PUTAS1 ; output it LDB CH,DA.COR ; get core address ADDI CH,AS.DAT ; [340] %DAT is base address TSWT FLUALT; ; using alternate? JRST TEM.01 ; no - ADD CH,TM2CNT ; yes - add in how many words we've already put AOS TM2CNT ; bump the count PUSHJ PP,PUTAS1 ; output the RELOC address JRST TEMOUT+2 ; then output the sixbit word TEM.01: ADD CH,TEMCNT ; increment it AOS TEMCNT ; bump PUSHJ PP,PUTAS1 ; output address JRST TEMOUT+2 ; loop ;RDCRD Read in a card image for LDC.00 ; ; ; RDCRD: PUSHJ PP,GETSRC## ; get a character TSWF FEOF; ; at E-O-F? POPJ PP, ; yes - SWON FREGCH; ; no - set to reget the character PUSHJ PP,GETCRD## ; get a cards worth LDB TB,[POINT 14,CRDBUF,13] ; get first 2 chars CAIN TB,"/*" ; [340] eof card? POPJ PP, ; [340] yes - take eof return AOS (PP) ; [340] no - increment return CAIN TB,"**" ; double star? POPJ PP, ; yes - AOS (PP) ; No - bump PC once more POPJ PP, ; then return ;ARR.00 Output ARRTAB to AS1FIL ; ; ; ARR.00: MOVE TA,EAS1PC ; get where we left of after data MOVEM TA,ARRBAS## ; save for later SETZM EAS1PC ; and zap count HRRZ TA,ARRLOC## ; get start of table ARR.01: HRRZ TB,ARRNXT ; get end of table CAMN TA,TB ; are we there yet? POPJ PP, ; yes - exit MOVEM TA,CURARR ; save pointer MOVE CH,[XWD AS.BYT,AS.MSC] ; no - set up to output byte pointer PUSHJ PP,PUTAS1 ; output MOVE CH,(TA) ; get AR.PNT TRO CH,AS.DAT ; add in relocation PUSHJ PP,PUTAS1 ; output it MOVE CH,[XWD AS.OCT,1] ; set up for octal constant PUSHJ PP,PUTAS1 ; output header MOVE CH,1(TA) ; get ARR flags PUSHJ PP,PUTAS1 ; output those too MOVE CH,[XWD AS.XWD,1] ; next output an XWD PUSHJ PP,PUTAS1 ; output the header word HLRZ TA,2(TA) ; get FILTAB pointer PUSHJ PP,LNKSET ; set it up LDB CH,FI.OTF ; get OTFTAB pointer MOVSS CH ; get into proper half IOR CH,[XWD AS.OTB,AS.MSC] ; get relocation word PUSHJ PP,PUTAS1 ; output the LH MOVE TA,CURARR ; [253] restore ARRTAB pointer HRLZ CH,2(TA) ; get RH flags HRRI CH,AS.CNB ; identify as constant PUSHJ PP,PUTAS1 ; so output it SKIPN 3(TA) ; all zero? JRST ARR.02 ; yes - go output a zero MOVE CH,[XWD AS.BYT,AS.MSC] ; get ready for byte pointer PUSHJ PP,PUTAS1 ; output it MOVE CH,3(TA) ; get the pointer TRO CH,AS.DAT ; DATBAS relative otherwise ARR.03: PUSHJ PP,PUTAS1 ; output it MOVEI TB,SZ.ARR ; get size of ARRTAB entry ADDM TB,EAS1PC ; bump the ASYfil PC HRRZ TA,CURARR ; get ARRTAB pointer ADDI TA,SZ.ARR ; increment it JRST ARR.01 ; and keep on looping ARR.02: MOVE CH,[XWD AS.OCT,1] ; get constant header PUSHJ PP,PUTAS1 ; output SETZ CH, ; get zero constant JRST ARR.03 ; output ;ROUTINE TO DUMP LITAB ENTRIES WHOSE POINTER IS IN TC ; ;THIS ROUTINE MUST NOT DISTURB AC'S TA OR TB ; ; ; INDOUT: EXCH TA,TC ; GET POINTER AND STORE TA PUSHJ PP,LNKSET ; GET REAL INDTAB LINK MOVE CH,[XWD OCTLIT,1] ; GONNA OUTPUT A WORD PUSHJ PP,STASHC## ; OUTPUT HEADER MOVE CH,(TA) ; GET INDTAB WORD PUSHJ PP,STASHC ; OUTPUT IT AOS ELITPC ; BUMP LITAB PC LDB CH,ID.END## ; GET END FLAG JUMPN CH,.+2 ; IS IT END? AOJA TA,INDOUT+2 ; NO - LOOP EXCH TA,TC ; YES - RESTORE TA POPJ PP, ; AND EXIT ; ; GENIE ; ; THIS IS THE HEART OF THE CODE GENERATOR. IT IS THIS ROUTINE ; THAT READS THE OP'S OUT OF GENFIL, STASHES THEM IN ; APPROPRIATE SPOTS, THEN DISPATCHES TO THE CORRECT ROUTINE. ; ; ; GENIE: HRLZI CH,(B8) ; FLAG END OF GENFIL PUSHJ PP,PUTGEN## ; AND OUTPUT IT CLOSE GEN, ; CLOSE OUT FILE MOVE CH,PRGID## ; OUR VERY FIRST TAG MOVEM CH,NAMWRD## ; STASH SETZM NAMWRD+1 ; AND ZAP THE GARBO PUSHJ PP,TRYNAM## ; LOOKUP PUSHJ PP,BLDNAM## ; NOT THERE- PUT IT THERE MOVEM TA,CURNAM## ; STASH MOVE TA,[XWD CD.PRO,SZ.PRO] ; GET PRAMAETERS PUSHJ PP,GETENT## ; GET A PROTAB ENTRY HRRZM TA,CURPRO ; STASH FOR LATER MOVS TB,CURNAM ; REGET NAMTAB LINK DPB TB,PR.NAM## ; STORE IN PROTAB ENTRY MOVEI TB,CD.PRO ; GET OUR SECRET CODE DPB TB,PR.ID## ; STICK IN TABLE MOVE TB,EAS2PC ; GET CURRENT PC DPB TB,PR.LNK## ; STASH AS PC BASE MOVE CH,CURPRO ; GET BACK OUR CURRENT ENTRY SUB CH,PROLOC ; MAKE A TYPE OF POINTER HRRZS CH ; DUMP THE GARBAGE ADD CH,[XWD AS.PN,AS.PRO] ; MAKE AN INSTRUCTION PUSHJ PP,PUTASN ; DEFINE TAG PUSHJ PP,SETGEN## ; OPEN IT UP FOR INPUT PUSHJ PP,GETGEN## ; GET A WORD MOVEM CH,OPHLD## ; STASH IT PUSH PP,[[ OUTSTR [ASCIZ "?Too many POPJ's "] JRST KILL ]] ; PROVIDE A SAFETY VALVE SWOFF FINDON; ; TURN OFF "INDCHK GENERATED" GEN.00: MOVE TA,OPHLD ; GET LAST TIMES OP TLNE TA,400000 ; IS IT REALLY AN OP? JRST NOTOP ; NO - ERROR LDB TB,[POINT 8,TA,8] ; YES - GET OP-CODE CAILE TB,HIOP ; IS IT < HIOP? JRST BIGOP ; NO - SHOULD BE = HIOP SETZM OPRTR## ; ZAP THE AREA MOVE TC,[XWD OPRTR,OPRTR+1] ; SET UP TO ZAP ALL BLT TC,OPRTR+5 ; AND DO IT MOVEM TA,OPRTR ; STASH OP PUSHJ PP,GETGEN ; GET SECOND WORD MOVEM CH,OPRTR+1 ; AND STORE PUSHJ PP,GETGEN ; GET ANOTHER TLNN CH,400000 ; IS OPERAND? JRST GEN.01 ; NO - SHOULD BE OPERATOR MOVEM CH,OPRTR+2 ; YES - STASH PUSHJ PP,GETGEN ; AND ANOTHER TLNN CH,400000 ; ??? JRST GEN.01 ; OPERATOR MOVEM CH,OPRTR+3 ; STASH PUSHJ PP,GETGEN ; AND STILL ANOTHER TLNN CH,400000 ; OP? JRST GEN.01 ; OPERATOR MOVEM CH,OPRTR+4 ; STORE PUSHJ PP,GETGEN ; [315] get another genfil entry TLNN CH,1B18 ; [315] operand? JRST GEN.01 ; [315] no - operator MOVEM CH,OPRTR+5 ; [315] yes - store PUSHJ PP,GETGEN ; AND STILL ANOTHER GEN.01: MOVEM CH,OPHLD ; STORE FOR NEXT TIME SWOFF FROUND!FOP1AR!FOP1TB!FOP2AR!FOP2TB!FWHOLE!FOP1WL; MOVE TC,[XWD 377777,777777] ; CAN'T HELP BUT GET SMALLER MOVEM TC,WHOSIZ## ; START SIZE FOR WHOLE ARRAYS PUSHJ PP,@OPTAB(TB) ; OFF TO THE ROUTINE JRST GEN.00 ; AND LOOP ON AROUND BIGOP: CAIN TB,ENDOP ; VALID ENDOP? JRST CLSUP ; YEP - GO FINISH .BADOP: OUTSTR [ASCIZ "?Bad GENFIL operator "] JRST KILL## NOTOP: OUTSTR [ASCIZ "?Operator not found when expected "] JRST KILL NOTIMP: LDB TB,[POINT 13,OPRTR,28] ; GET LINE NUMBER MOVEM TB,SAVELN## ; STASH WARN 706; ; OPERATOR NOT IMPLEMENTED POPJ PP, ; RETURN ; ;DISPATCH TABLE FOR OPERATORS ; ; ; ; OPTAB: EXP .BADOP ; ZERO ALWAYS INVALID 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 .DET ; DETAIL CALC ESCAPE LINKAGE EXP .CAL ; CONTROL CALC ESCAPE LINKAGE EXP .MOVEA ; MOVEA EXP .TIME ; TIME HIOP==.-OPTAB ENDOP==377 ;GENERATE CODE FOR ADD ; ; .ADD: PUSHJ PP,CHK3## ; CHECK FOR WHOLE ARRAYS PUSHJ PP,INDCHK## ; GENERATE INDICATOR CHECK CODE TSWF FWHOLE; ; WHOLE ARRAY? PUSHJ PP,WHLGN1## ; YES - GENERATE SOME CODE PUSHJ PP,GT1AC1## ; GET OP1 INTO AC1 PUSHJ PP,GT2AC3## ; GET OP2 INTO AC3 HRRZ TA,OPRTR##+4 ; GET RESULT LINK PUSHJ PP,LNKSET## ; SET UP DATAB LINK LDB TB,DA.FLD## ; GET FIELD TYPE SKIPN TB ; ALPHA NO GOOD PUSHJ PP,FNDFLD## ; TELL THE TURKEY LDB TC,DA.DEC## ; GET DECIMAL POSITION COUNT LDB TB,DA.RND## ; GET ROUNDING FLAG SKIPE TB ; DO WE NEED TO ROUND? SWON FROUND; ; YEP PUSHJ PP,SH1AC1## ; SHIFT AC1 INTO LINE PUSHJ PP,SH2AC3## ; SHIFT AC3 INTO LINE SETZ LN, ; THE MAGIC INDEX PUSHJ PP,CH.12## ; CHOOSE 1 OR 2 MOVE TB,OP1SIZ ; [354] get a size CAILE TB,^D10 ; [354] double precision? MOVEM TB,OP2SIZ ; [354] yes - make sure we store double precision PUSHJ PP,PTRAC3## ; STORE RESULT FROM AC3 TSWF FWHOLE; ; WHOLE ARRAYS? PJRST WHLGN2## ; YES - POPJ PP, ; EXIT ;GENERATE CODE FOR SUBTRACT ; ; .SUB: PUSHJ PP,CHK3 ; CHECK FOR WHOLE ARRAYS PUSHJ PP,INDCHK ; CHECK FOR INDICATORS TSWF FWHOLE; ; IF WHOLE ARRAYS PUSHJ PP,WHLGN1 ; GENERATE SOME CODE PUSHJ PP,GT2AC1 ; GET OP1 PUSHJ PP,GT1AC3 ; GET OP2 HRRZ TA,OPRTR+4 ; GET DATAB LINK PUSHJ PP,LNKSET ; SET IT UP LDB TB,DA.FLD ; GET FIELD TYPE SKIPN TB ; WE ONLY WANT NUMERIC PUSHJ PP,FNDFLD ; SAY SO LDB TC,DA.DEC ; GET DECIMALS LDB TB,DA.RND ; GET HALF ADJUST FLAG SKIPE TB ; ON? SWON FROUND; ; YES - TURN THIS ONE ON TOO PUSHJ PP,SH2AC1## ; SHIFT AC1 PUSHJ PP,SH1AC3## ; SHIFT AC3 MOVEI LN,1 ; SUB=1 PUSHJ PP,CH.12 ; MAKE A CHOICE MOVE TB,OP1SIZ ; [354] get size CAILE TB,^D10 ; [354] double precision? MOVEM TB,OP2SIZ ; [354] yes - store PUSHJ PP,PTRAC3 ; SHIFT RESULT TSWF FWHOLE; ; WHOLE? PJRST WHLGN2 ; YES - POPJ PP, ; EXIT ;GENERATE CODE FOR MULTIPLY ; ; .MULT: PUSHJ PP,CHK3 ; CHECK OUT ARRAYS PUSHJ PP,INDCHK## ; GENERATE INDICATOR CHECK CODE TSWF FWHOLE; ; WHOLE ARRAYS? PUSHJ PP,WHLGN1 ; YES - PUSHJ PP,GT1AC1## ; GET OP1 INTO AC1 PUSHJ PP,GT2AC3## ; GET OP2 INTO AC3 HRRZ TA,OPRTR##+4 ; GET RESULT LINK PUSHJ PP,LNKSET## ; SET UP DATAB LINK LDB TB,DA.FLD## ; GET FIELD TYPE SKIPN TB ; ALPHA NO GOOD PUSHJ PP,FNDFLD## ; TELL THE TURKEY MOVE TB,OP1SIZ ; [361] GET SIZE OF OP1 ADD TB,OP2SIZ ; [361] PLUS SIZE OF OP2 CAILE TB,^D19 ; [361] WILL IT FIT AS FIXED POINT? JRST FLTMUL ; [361] NO - USE FLOATING LDB TB,DA.RND## ; GET ROUNDING FLAG SKIPE TB ; DO WE NEED TO ROUND? SWON FROUND; ; YEP MOVEI LN,2 ; THE MAGIC INDEX PUSHJ PP,CH.12## ; CHOOSE 1 OR 2 MOVE TB,OP1SIZ## ; GET SIZE OF A ADD TB,OP2SIZ## ; ADD IN SIZE OF B MOVEM TB,OP2SIZ ; FUDGE MOVE TB,OP1DEC## ; GET A'S DEC POSITS ADDM TB,OP2DEC## ; UPDATE B LDB TC,DA.DEC ; GET RESULT DEC POSITS PUSHJ PP,SH2AC3 ; SHIFT RESULT PUSHJ PP,PTRAC3 ; STORE RESULT FROM AC3 TSWF FWHOLE; ; WHOLE ARRAYS? PJRST WHLGN2 ; YES - POPJ PP, ; EXIT ;FLTMUL Generate floating multiply code ; ; ; FLTMUL: MOVE TB,OP1SIZ ; GET SIZE OF FIRST OP MOVE CH,[XWD FLOT1.+AC1,AS.CNS+1] CAILE TB,^D10 ; DOUBLE PRECISION? MOVE CH,[XWD FLOT2.+AC1,AS.CNS+1] PUSHJ PP,PUTASY ; OUTPUT ONE OR THE OTHER MOVE TB,OP2SIZ ; DO THE SAME FOR OP 2 MOVE CH,[XWD FLOT1.+AC3,AS.CNS+3] CAILE TB,^D10 ; DOUBLE? MOVE CH,[XWD FLOT2.+AC3,AS.CNS+3] PUSHJ PP,PUTASY ; OUTPUT IT MOVE CH,[XWD FMP.+AC3,AS.CNS+1] PUSHJ PP,PUTASY ; OUTPUT THE MULTIPLY MOVE TB,OP1DEC ; GET OP 1 DECIMALS ADD TB,OP2DEC ; PLUS OP 2 LDB TD,DA.DEC ; GET RESULT DECIMALS SUB TD,TB ; GET AMOUNT TO SHIFT FLTML0: JUMPE TD,FLTML1 ; MAYBE NONE? MOVE CH,[XWD FDV.+ASINC+AC3,AS.MSC] SKIPL TD ; SKIP IF RIGHT SHIFT MOVE CH,[XWD FMP.+ASINC+AC3,AS.MSC] PUSHJ PP,PUTASY ; OUTPUT IT MOVMS TD ; GET SIZE OF SHIFT HRRZ CH,ELITPC ; GET LITAB PC IORI CH,AS.LIT ; SAY WHAT IT IS PUSHJ PP,PUTASN ; AND OUTPUT IT MOVE CH,[XWD FLTLIT,2] ; SAY WHAT WE'RE GOING TO OUTPUT PUSHJ PP,STASHC ; OUTPUT EADER MOVEI CH,1(TD) ; GET EXPONENT PUSHJ PP,STASHC ; OUTPUT THAT MOVSI CH,(1B7) ; GET MANTISSA OF .1 PUSHJ PP,STASHC ; OUTPUT THAT TOO AOS ELITPC ; BUMP PC FLTML1: MOVE CH,[XWD FIX.+AC3,AS.CNS+3] PUSHJ PP,PUTASY ; OUTPUT FIX INSTRUCTION ;[365] The following code is designed to truncate the recently fixed number to ;[365] eight digits. This is not a very intelligent way of doing it, but it ;[365] should work OK, and it needs to be done NOW! LDB TD,DA.SIZ ; [365] get result size SUBI TD,^D8 ; [365] floating point only has 8 digit precision JUMPLE TD,FLTML2 ; [365] thats all we need... PUSH PP,TA ; [365] save TA PUSH PP,TD ; [365] save shift count MOVNS TD ; [365] negate for right shift LDB TB,DA.SIZ ; [365] get result precision again MOVEM TB,ESIZ ; [365] save for shifter PUSH PP,ESIZ ; [365] save ESIZ for later LDB TB,DA.DEC ; [365] get decimals MOVEM TB,EDEC ; [365] stash PUSH PP,EDEC ; [365] save it HRLZI CH,AC3 ; [365] work with AC3 PUSHJ PP,SHFTAC## ; [365] right shift - POP PP,EDEC ; [365] get parameters back POP PP,ESIZ ; [365] POP PP,TD ; [365] HRLZI CH,AC3 ; [365] use ac3 again PUSHJ PP,SHFTAC ; [365] and shift left again POP PP,TA ; [365] restore TA FLTML2: MOVEI TB,^D15 ; SET SIZE UP TO MAX SINCE MOVEM TB,OP2SIZ ; FIX ALWAYS RETURNS DOUBLE LDB TC,DA.DEC ; GET DECIMALS FOR PUTAC PUSHJ PP,PTRAC3 ; AND PUT THAT AC TSWF FWHOLE; ; WHOLE ARRAYS? PJRST WHLGN2 ; YES - POPJ PP, ; NO - ;GENERATE CODE FOR DIVIDE ; ; .DIV: PUSHJ PP,CHK3 ; CHECK FOR WHOLE ARRAYS PUSHJ PP,INDCHK ; CHECK FOR INDICATORS TSWF FWHOLE; ; IS THERE A WHOLE ARRAY? PUSHJ PP,WHLGN1 ; YES - PUSHJ PP,GT1AC3## ; GET OP1 PUSHJ PP,GT2AC1## ; GET OP2 HRRZ TA,OPRTR+4 ; GET DATAB LINK PUSHJ PP,LNKSET ; SET IT UP MOVEM TA,CURDAT ; SAVE POINTER LDB TB,DA.FLD ; GET FIELD TYPE SKIPN TB ; WE ONLY WANT NUMERIC PUSHJ PP,FNDFLD ; SAY SO MOVE TB,OP1DEC ; GET A DECIMALS SUB TB,OP2DEC ; SUBTRACT B DECIMALS LDB TD,DA.DEC ; GET R DECIMALS SUB TD,TB ; TD_R-(A-B) LDB TB,DA.RND ; [364] get rounding flag SKIPE TB ; [364] is it set? ADDI TD,1 ; [364] yes - allow extra precision for round MOVE TC,TD ; [366] get into working AC ADD TC,OP1SIZ ; [366] plus size of OP CAILE TC,^D15 ; [366] must we float it? JRST FLTDIV ; [366] yes - go do so JUMPLE TD,.+2 ; SKIP IF WE DON'T NEED TO SHIFT PUSHJ PP,SH13.1## ; [353] SHIFT A TO MAKE SURE WE HAVE SUFFICIENT ; PRECISION FOR RESULT MOVE TA,CURDAT ; GET DATAB POINTER LDB TB,DA.RND ; GET HALF ADJUST FLAG SKIPE TB ; ON? SWON FROUND; ; YES - TURN THIS ONE ON TOO MOVE TB,OP2DEC ; GET B DECIMALS MOVEM TB,REMDEC## ; SAVE IN CASE OF MVR MOVE TB,OP2SIZ ; GET B SIZE MOVEM TB,REMSIZ## ; ALSO SAVE FOR SAME REASON MOVEI LN,3 ; DIV=3 PUSHJ PP,CH.12 ; MAKE A CHOICE SKIPN TB,OP1DEC ; [353] get A SKIPA TB,OP2DEC ; [353] if A=0 then TB_B, else TB_A-B SUB TB,OP2DEC ; [353] -B LDB TD,DA.DEC ; GET R SUB TD,TB ; TD_R-(A-B) JUMPE TD,.+2 ; SHIFT IF NECESSARY PUSHJ PP,SH23.1## ; LIKE RIGHT HERE MOVE TB,OP1SIZ ; [353] get size of number in the AC's MOVEM TB,OP2SIZ ; [353] store for PTRAC3 PUSHJ PP,PTRAC3 ; SHIFT RESULT TSWF FWHOLE; ; WHOLE ARRAY? PJRST WHLGN2 ; YES - POPJ PP, ; NO - ;FLTDIV Generate code for floating point divide operation ; ;[366] ; FLTDIV: MOVE TB,OP1SIZ ; get size of OP1 MOVE CH,[XWD FLOT1.+AC3,AS.CNS+3] CAILE TB,^D10 ; double precision in AC3? MOVE CH,[XWD FLOT2.+AC3,AS.CNS+3] PUSHJ PP,PUTASY ; output one or the other MOVE TB,OP2SIZ ; get size of OP2 MOVE CH,[XWD FLOT1.+AC1,AS.CNS+1] CAILE TB,^D10 ; double? MOVE CH,[XWD FLOT2.+AC1,AS.CNS+1] PUSHJ PP,PUTASY ; output it MOVE CH,[XWD FDV.+AC3,AS.CNS+1] PUSHJ PP,PUTASY ; output the divide operation MOVE TB,OP2DEC ; get decimals for remainder operation MOVEM TB,REMDEC ; store them MOVE TB,OP2SIZ ; get size MOVEM TB,REMSIZ ; and store that too SKIPN TB,OP1DEC ; get A SKIPA TB,OP2DEC ; if A=0 then TB_B, else TB_A-B SUB TB,OP2DEC ; -B LDB TD,DA.DEC ; get R SUB TD,TB ; TD_R-ABS(A-B) JRST FLTML0 ; do the rest elsewhere ;GENERATE CODE FOR MVR ; ; ; .MVR: PUSHJ PP,INDCHK ; GENERATE INDICATOR CHECK HRRZ TA,OPRTR+2 ; GET LINK HRRZM TA,OPRTR+4 ; [113] STASH THERE IN CASE WE DON'T CALL FNDFLD PUSHJ PP,LNKSET ; SET IT UP LDB TB,DA.FLD ; GET FIELD TYPE SKIPN TB ; ONLY NUMERIC IS OK PUSHJ PP,FNDFLD ; FIND A NUMERIC FIELD HRLZI CH,AC0 ; DO IT WITH AC0 MOVE TB,REMDEC ; GET LEFT OVER DECIMALS MOVEM TB,EDEC## ; SAVE MOVE TB,REMSIZ ; GET SIZE MOVEM TB,ESIZ## ; SAVE MOVEM TB,OP2SIZ ; STASH SO SHFT3B WORKS RIGHT LDB TD,DA.DEC ; GET RESULT DECIMALS SUB TD,REMDEC ; GET SHIFT PJUMPE TD,PTRAC5 ; MAYBE WE DON'T HAVE TO SHIFT PUSHJ PP,SHFTAC## ; NOPE- WE HAVE TO PJRST PTRAC5## ; GO STASH RESULT ;GENERATE CODE FOR ZADD ; ; .ZADD: PUSHJ PP,WH.OP1## ; CHECK OUT WHOLE ARRAYS PUSHJ PP,INDCHK ; GENERATE INDICATOR CODE MOVE TA,OPRTR+3 ; GET FACTOR 2 LINK MOVEM TA,OPRTR+4 ; STASH AS RESULT LINK PUSHJ PP,WH.OP3## ; DOES RESULT AGREE? POPJ PP, ; NOPE - JUST FORGET THIS ONE TSWF FWHOLE; ; YES - IS IT WHOLE ARRAY? PUSHJ PP,WHLGN1 ; YES - OUTPUT SOME CODE PUSHJ PP,GT1AC3 ; GET FACTOR 1 INTO AC3 HRRZ TA,OPRTR+4 ; GET DATAB LINK PUSHJ PP,LNKSET ; SET UP THAT LINK LDB TB,DA.FLD ; GET FIELD TYPE SKIPN TB ; MUST BE NUMERIC PUSHJ PP,FNDFLD ; IS NOT - GO FIND ONE LDB TC,DA.DEC ; GET DECIMAL POSITIONS PUSHJ PP,SH1AC3 ; ALLIGN THE AC'S MOVE TB,OP1SIZ ; GET SIZE OF FIELD MOVEM TB,OP2SIZ ; STASH SO SHFT3B WORKS OK PUSHJ PP,PTRAC3 ; GO STORE RESULT TSWF FWHOLE; ; WHOLE ARRAY? PJRST WHLGN2; ; YES - POPJ PP, ; NO ;GENERATE CODE FOR ZSUB ; ; .ZSUB: PUSHJ PP,WH.OP1 ; CHECK FOR WHOLE ARRAYS PUSHJ PP,INDCHK ; GEN INDICATOR CODE MOVE TA,OPRTR+3 ; GET FACTOR 2 LINK MOVEM TA,OPRTR+4 ; STASH AS RESULT LINK PUSHJ PP,WH.OP3 ; CHECK RESULT POPJ PP, ; WAS ERROR TSWF FWHOLE; ; WAS IT WHOLE ARRAY? PUSHJ PP,WHLGN1 ; YES PUSHJ PP,GT1AC3 ; GET FACTOR 1 MOVEI LN,5 ; THE MAGIC NUMBER SETZM OP2SIZ ; ZAP ANY LEFTOVERS PUSHJ PP,CH.12 ; CHOOSE SOME CODE JRST .ZADD+11 ; GO DO THE REST ;Generate code for XFOOT ; ; ; .XFOOT: PUSHJ PP,WH.OP1 ; make sure our factor 2 is whole array TSWTZ FWHOLE; ; was it? JRST .XFOO1 ; no - error PUSHJ PP,WH.OP2 ; how about result? TSWF FWHOLE; ; [350] we don't want it, but did we get it? JRST .XFOO2 ; yes - error MOVE TB,OPRTR+3 ; get result entry MOVEM TB,OPRTR+4 ; stick it where it should be PUSHJ PP,INDCHK ; generate indicator code MOVE CH,[XWD SETZB.##+AC3,AS.CNS+4] ; [350] PUSHJ PP,PUTASY ; [350] get some zeroes MOVEI TB,^D12 ; [350] say that they are double precision MOVEM TB,OP2SIZ ; [350] store for PTRAC3 PUSHJ PP,PTRAC3 ; [350] and store that result field full of 0's SWON FWHOLE; ; [350] turn the flag back on PUSHJ PP,WHLGN1 ; generate whole array set up code PUSHJ PP,GT1AC1 ; get op1 into AC1 PUSHJ PP,GT2AC3 ; get op2 into AC3 HRRZ TA,OPRTR+4 ; get result link PUSHJ PP,LNKSET ; set up link LDB TB,DA.FLD ; get field type SKIPN TB ; alpha no good PUSHJ PP,FNDFLD ; find a good one LDB TC,DA.DEC ; get decimal count LDB TB,DA.RND ; get rounding flag SKIPE TB ; is it set? SWON FROUND; ; yes - turn on SW flag PUSHJ PP,SH1AC1 ; allign op1 PUSHJ PP,SH2AC3 ; allign op2 SETZ LN, ; ADD index PUSHJ PP,CH.12 ; choose an operator SWOFF FWHOLE; ; result never whole array PUSHJ PP,PTRAC3 ; store result SWON FWHOLE; ; turn whole array flag back on PJRST WHLGN2 ; output whole array ending code .XFOO1: GETLN; ; get line number WARN 716; ; factor 2 must be whole array POPJ PP, ; exit .XFOO2: GETLN; ; recover line number WARN 646; ; result cannot be whole array POPJ PP, ; ;Generate code for SQRT ; ; ; .SQRT: PUSHJ PP,WH.OP1 ; check for whole array PUSHJ PP,INDCHK ; output indicators MOVE TA,OPRTR+3 ; get result MOVEM TA,OPRTR+4 ; put in it's place PUSHJ PP,WH.OP3 ; check result for whole array POPJ PP, ; some sort of error TSWF FWHOLE; ; whole array? PUSHJ PP,WHLGN1 ; yes - generate some code SETZM FLTCN.## ; zap temp storage PUSHJ PP,GT1AC1 ; get argument into AC1 MOVE TB,OP1SIZ ; get it's size MOVE CH,[XWD FLOT1.+AC1,AS.CNS+1] CAILE TB,^D10 ; double precision? MOVE CH,[XWD FLOT2.+AC1,AS.CNS+1] PUSHJ PP,PUTASY ; put out call to float routine MOVE TB,OP1DEC ; get the decimal places JUMPE TB,.SQRT1 ; none - no need to shift MOVE CH,[XWD FDV.+ASINC+AC1,AS.MSC] PUSHJ PP,PUTASY ; put out floating divide MOVE CH,ELITPC ; get LITAB PC IORI CH,AS.LIT ; identify as such MOVEM CH,FLTCN.## ; save for later PUSHJ PP,PUTASN ; output address MOVE CH,[XWD FLTLIT,2] ; get LITAB header PUSHJ PP,STASHC ; output MOVEI CH,1(TB) ; get exponent PUSHJ PP,STASHC ; output MOVSI CH,(1B7) ; get mantissa PUSHJ PP,STASHC ; output AOS ELITPC ; bump LITAB PC .SQRT1: MOVE CH,[XWD SQRT.,AS.CNS+1] ; get UUO call to square root routine PUSHJ PP,PUTASY ; output it HRRZ TA,OPRTR+4 ; get link to result PUSHJ PP,LNKSET ; set it up LDB TB,DA.FLD ; get field SKIPN TB ; numeric? PUSHJ PP,FNDFLD ; no - find one that is LDB TC,DA.DEC ; get decimal positions JUMPE TC,.SQRT2 ; is zero - no need to shift MOVEM TC,OP2DEC ; save for PUTAC MOVE CH,[XWD FLTLIT,2] ; get LITAB header PUSHJ PP,STASHC ; output MOVEI CH,1(TC) ; get exponent PUSHJ PP,STASHC ; output MOVSI CH,(1B7) ; get a .1 PUSHJ PP,STASHC ; output it MOVE CH,[XWD FMP.+ASINC+AC1,AS.MSC] PUSHJ PP,PUTASY ; output floating multiply HRRZ CH,ELITPC ; get LITAB PC IORI CH,AS.LIT ; identify as such PUSHJ PP,PUTASN ; output it AOS ELITPC ; bump the PC ;.SQRT (cont'd) ; ; ; .SQRT2: MOVE CH,[XWD FIX.+AC1,AS.CNS+1] PUSHJ PP,PUTASY ; output call to fix routine MOVEI TB,^D15 ; get full 15 digit count MOVEM TB,OP1SIZ ; stash as op1 size since FIX returns double precision MOVEM TB,OP2SIZ ; store special for PUTAC HRRZ TA,OPRTR+4 ; get result link PUSHJ PP,LNKSET ; set it up LDB TB,DA.FLD ; get field type SKIPN TB ; only numeric valid PUSHJ PP,FNDFLD ; find one LDB TC,DA.DEC ; get decimal count SWON FROUND; ; square root is always rounded PUSHJ PP,PTRAC1## ; stash result TSWF FWHOLE; ; was all this a whole array? PJRST WHLGN2 ; yes - output rest of code POPJ PP, ; No - exit ;GENERATE CODE FOR COMP ; ; ; .COMP: PUSHJ PP,INDCHK ; GENERATE INDICATOR CHECK MOVE TB,OPRTR+3 ; GET F1 ENTRY TLNE TB,1B20 ; NUMERIC LITERAL? JRST .COMP0 ; YEP - TLNE TB,1B19 ; ALPHA LITERAL? JRST .COMP3 ; YES - MOVE TB,OPRTR+4 ; GET F2 ENTRY TLNE TB,1B20 ; NUMERIC LIT? JRST .COMP2 ; YES - TLNE TB,1B19 ; ALPHA LIT? JRST .COMP4 ; YES - MOVEI TB,3 ; GET F1 INDEX PUSHJ PP,GTFLD## ; GET TYPE JUMPE TC,.COMP3 ; F1 NOT NUMERIC .COMP0: MOVEI TB,4 ; GET F2 INDEX PUSHJ PP,GTFLD ; GET TYPE JUMPE TC,.COMP7 ; F2 NOT NUMERIC - ERROR .COMP1: MOVE TB,OPRTR+3 ; REARRANGE THE STACK EXCH TB,OPRTR+2 EXCH TB,OPRTR+4 MOVEM TB,OPRTR+3 ; ALL DONE PUSHJ PP,GT1AC1 ; GET FACTOR 1 PUSHJ PP,GT2AC3 ; GET FACTOR 3 MOVE TC,OP2DEC ; GET FACTOR 2 DECIMALS PUSHJ PP,SH1AC1 ; ALLIGN FACTOR 1 MOVEI LN,4 ; COMP = 4 PUSHJ PP,CH.12 ; CHOOSE OP HLRZ TA,OPRTR+4 ; GET INDTAB LINK .CMP1A: PUSHJ PP,LNKSET ; SET IT UP MOVE CH,[XWD AS.OCT,1] ; OUTPUT OCTAL CONSTANT PUSHJ PP,PUTASY ; LIKE THIS MOVE CH,(TA) ; GET THE CONSTANT JRST PUTASN ; OUTPUT IT AND EXIT .COMP2: MOVEI TB,3 ; FACTOR 1 INDEX PUSHJ PP,GTFLD ; GET TYPE JUMPE TC,.COMP6 ; F1 NOT NUMERIC - ERROR JRST .COMP1 ; ALL OK .COMP3: MOVEI TB,4 ; FACTOR 2 INDEX PUSHJ PP,GTFLD ; GET TYPE JUMPN TC,.COMP9 ; F2 NOT ALPHA - ERROR JRST .COMP5 ;.COMP (CONT'D) .COMP4: MOVEI TB,3 ; F1 INDEX PUSHJ PP,GTFLD ; IS SHE MY TYPE? JUMPN TC,.COMP8 ; NO - F1 NOT ALPHA - ERROR JRST .COMP5 ; YES - ALLS WELL .COMP6: GETLN; ; GET ERROR CAUSING LINE NUMBER WARN 700; ; F1 NOT NUMERIC POPJ PP, .COMP7: GETLN; WARN 701; ; F2 NOT NUMERIC POPJ PP, .COMP8: GETLN; WARN 702; ; F1 NOT ALPHA POPJ PP, .COMP9: GETLN; WARN 703; ; F2 NOT ALPHA POPJ PP, ;.COMP (CONT'D) ; ;.COMP5 HANDLE ALPHA COMPARE ; ; .COMP5: PUSHJ PP,STBYT1## ; SET UP POINTER TO OP1 PUSHJ PP,STBYT2## ; SET UP POINTER TO OP2 MOVE TB,OP1BSZ## ; GET OP1 BYTE SIZE CAMGE TB,OP2BSZ## ; SHOULD GO HIGH-LOW OR EQUAL PUSHJ PP,SWPOP## ; NO - HAVE TO SWAP OPERANDS MOVE TB,OP1SIZ ; GET SIZE CAMLE TB,OP2SIZ ; GET SMALLER SIZE MOVE TB,OP2SIZ ; HAVE TO USE OP2 PUSHJ PP,BPTRSZ ; OUTPUT BYTE POINTERS WITH IMBEDDED SIZE MOVE TB,OP1BSZ ; GET BYTE SIZE CAMN TB,OP2BSZ ; ARE THEY EQUAL? JRST .CMP11 ; YES - USE COMP. CAIN TB,7 ; NO - IS OP1 ASCII? JRST .CMP12 ; YES - USE CMP.76 MOVE TB,OP2BSZ ; MUST BE EBCDIC MOVE CH,[XWD CMP.97+ASINC,AS.MSC] CAIE TB,7 ; IS OP2 ASCII? MOVE CH,[XWD CMP.96+ASINC,AS.MSC] .CMP10: PUSHJ PP,PUTASY ; OUTPUT COMPARE MOVE CH,OP1LIT ; GET INCREMENT TRO CH,AS.LIT ; IDENTIFY IT PUSHJ PP,PUTASN ; OUTPUT INCREMENT HLRZ TA,OPRTR+2 ; GET INDICATOR POINTER PUSHJ PP,.CMP1A ; OUTPUT INDICATOR WORD MOVE TB,OP1SIZ ; GET SIZE OF OP1 CAME TB,OP2SIZ ; ALL OK IF EQUAL JRST .CMP14 ; NOT EQUAL - DO SPACE CHECK POPJ PP, ; EXIT .CMP11: SKIPA CH,[XWD COMP.+ASINC,AS.MSC] .CMP12: MOVE CH,[XWD CMP.76+ASINC,AS.MSC] JRST .CMP10 EXTERNAL COMP.,CMP.76,CMP.96,CMP.97,AS.BYT,BYTLIT ;.COMP (CONT'D) ; ;.CMP14 HANDLE COMPARE WHEN FIELD LENGTH UNEQUAL ; ; ; .CMP14: CAMG TB,OP2SIZ ; WHICH IS LONGER? JRST .CMP15 ; OP2 > OP1 SUB TB,OP2SIZ ; OP1 > OP2: GET DIFFERANCE MOVE TC,OP2SIZ ; GET AMOUNT TO INCREMENT POINTER MOVE CH,OP1BYT## ; GET POINTER PUSHJ PP,.CMP17 ; SET UP BYTE INCREMENT MOVE TC,OP1BSZ ; GET BYTE SIZE .CMP16: MOVE CH,BTB2-6(TC) ; GET INSTRUCTION PUSHJ PP,PUTASY ; OUTPUT MOVE CH,OP1LIT ; GET LITAB PC TRO CH,AS.LIT ; IDENTIFY AS SUCH PUSHJ PP,PUTASN ; OUTPUT INCREMENT AOS ELITPC ; BUMP PC HLRZ TA,OPRTR+2 ; GET INDICATOR LINK JRST .CMP1A ; OUTPUT INDICATOR WORD .CMP15: PUSHJ PP,SWPIND## ; SWAP INDICATORS MOVE TB,OP2SIZ ; GET OP2 SIZE SUB TB,OP1SIZ ; GET DIFFERANCE MOVE TC,OP1SIZ ; GET AMOUNT TO INCREMENT MOVE CH,OP2BYT## ; GET POINTER PUSHJ PP,.CMP19 ; INCREMENT POINTER MOVE TC,OP2BSZ ; GET BYTE SIZE JRST .CMP16 ; GO OUTPUT COMPARE BTB2: XWD SPAC.6##+ASINC,AS.MSC XWD SPAC.7##+ASINC,AS.MSC XWD 0,0 XWD SPAC.9##+ASINC,AS.MSC ;.COMP (CONT'D) ; ; ; .CMP17: TSWF FOP1AR!FOP1TB; ; TABLE OR ARRAY? JRST .CMP18 ; YES - PUSHJ PP,BINC ; NO - BUMP POINTER MOVEM CH,OP2BYT ; STASH NEW POINTER PJRST BPTRSZ ; OUTPUT POINTERS THEN EXIT .CMP18: PUSH PP,TC ; SAVE SIZE PUSHJ PP,BPTRSZ ; OUTPUT POINTERS POP PP,TC ; GET BACK INCREMENT COUNT PJRST BNCGN3## ; GENERATE INCREMENT CODE .CMP19: TSWF FOP2AR!FOP2TB; ; TABLE/ARRAY? JRST .CMP20 ; YES - PUSHJ PP,BINC## ; NO - BUMP POINTER MOVEM CH,OP2BYT ; STASH PJRST BPTRSZ ; OUTPUT POINTER .CMP20: MOVEM TC,OP2CNT## ; stash count SWON FINC; ; set increment flag for BPTRSZ PJRST BPTRSZ ; go output pointers with increment code ;GENERATE CODE FOR SETOF AND SETON ; ; ; .SETOF: SKIPA CH,[XWD SETOF.##+ASINC,AS.MSC] .SETON: MOVE CH,[XWD SETON.##+ASINC,AS.MSC] PUSH PP,CH ; SAVE CH PUSHJ PP,INDCHK ; CHECK INDICATORS POP PP,CH ; REGET HEADER PUSHJ PP,PUTASY ; PUT OUT HEADER MOVE CH,ELITPC ; GET LITAB ENTRY TRO CH,AS.LIT ; FLAG AS SUCH PUSHJ PP,PUTASN ; OUTPUT INCREMENT MOVE CH,[XWD OCTLIT,1] ; SETUP FOR OCTAL LITERAL PUSHJ PP,STASHC ; TELL LITAB ABOUT IT HLRZ TA,OPRTR+2 ; GET VALUE PUSHJ PP,LNKSET ; SET UP LINKS MOVE CH,(TA) ; GET INDICATORS PUSHJ PP,STASHC ; PUT THEM INTO LITAB AOS ELITPC ; BUMP LITAB PC POPJ PP, ; EXIT ;GENERATE CODE FOR GOTO ; ; ; .GOTO: PUSHJ PP,INDCHK ; CHECK OUT SOME INDICATORS HRRZ TA,OPRTR+2 ; GET A NAMTAB LINK MOVEI TB,CD.PRO ; LOOK IN PROTAB PUSHJ PP,FNDLNK ; LIKE THIS JRST .GOTO1 ; NOT FOUND - ERROR MOVE TA,TB ; REARRANGE THE LINK LDB TC,PR.BSR## ; GET BEGSR FLAG JUMPN TC,.GOTO2 ; CAN'T GOTO A BEGSR TAG SUB TB,PROLOC## ; MAKE A RELATIVE LINK HRRZ CH,TB ; PUT IN CORRECT AC ADD CH,[XWD JRST.,AS.PRO] ; MAKE INTO AN INSTRUCTION PJRST PUTASY ; OUTPUT IT .GOTO1: GETLN; ; GET LINE NUMBER WARN 231; ; NOT DEFINED POPJ PP, ; EXIT .GOTO2: GETLN; WARN 214; ; GOTO TO BEGSR NOT ALLOWED POPJ PP, ; EXIT ;GENERATE CODE FOR TAG ; ; ; .TAG: HRRZ TA,OPRTR+2 ; GET A PROTAB LINK PUSHJ PP,LNKSET ; MAKE INTO REAL LINK TSWT FAS3; ; ARE WE IN AS3FIL? SKIPA TC,EAS2PC ; NO - USE EAS2PC MOVE TC,EAS3PC ; YES - USE EAS3PC DPB TC,PR.LNK## ; STASH AS CORE LOC MOVEI TC,1 ; GET A FLAG TSWF FAS3; ; ARE WE IN AS3FIL? DPB TC,PR.SEG## ; YES - SAY SO IN PROTAB ENTRY HRRZ CH,OPRTR+2 ; GET BACK PROTAB LINK ANDI CH,TM.PRO## ; DROP OFF THE TABLE ID ADD CH,[XWD AS.PN##,AS.PRO##] PJRST PUTASN ; OUTPUT THE TAG DEFINITION ;GENERATE CODE FOR BEGSR TAG ; ; ; .BEGSR: JRST .TAG ; USE IDENTICAL CODE ;GENERATE CODE FOR ENDSR ; ; ; .ENDSR: MOVE CH,[XWD POPJ.+AC17,AS.CNS+0] PJRST PUTASY ; OUTPUT A POPJ 17, ;GENERATE CODE FOR EXSR ; ; ; .EXSR: PUSHJ PP,INDCHK ; GENERATE INDICATOR CHECK CODE HRRZ TA,OPRTR+2 ; GET PROTAB LINK MOVEI TB,CD.PRO ; SAY THAT IS WHAT IT IS PUSHJ PP,FNDLNK ; TRY IT JRST .GOTO1 ; BEGSR TAG NOT DEFINED MOVE TA,TB ; GET INTO PROPER AC LDB TC,PR.BSR ; GET BEGSR FLAG JUMPE TC,.EXSR1 ; MUST BE SET TO BE LEGAL SUB TB,PROLOC ; GET RELATIVE LINK HRRZ CH,TB ; GET INTO PROPER AC ADD CH,[XWD PUSHJ.+AC17,AS.PRO] PJRST PUTASY ; OUTPUT THE PUSHJ 17,TAG .EXSR1: GETLN; ; recover line number WARN 213; ; EXSR OF NON-BEGSR TAG POPJ PP, ; EXIT ;Generate code for the EXIT op ; ; ; .EXIT: PUSHJ PP,INDCHK ; generate indicator check HRRZ CH,OPRTR+2 ; get EXTAB link ANDI CH,TM.EXT## ; clear out ID ADD CH,[XWD PUSHJ.+AC17,AS.EXT##] PJRST PUTASY ; output the PUSHJ and exit ;Generate code for the RLABL op ; ; ; .RLABL: MOVE TA,OPRTR+2 ; get a factor MOVEM TA,OPRTR+3 ; put it where others can get to it MOVEM TA,OPRTR+4 ; and again SETZM OP2DEC ; start fresh PUSHJ PP,STBYT2 ; make byte pointer to factor PUSHJ PP,.BPTRB ; output that pointer MOVE CH,[XWD ARG.+ASINC+AC10,AS.MSC] PUSHJ PP,PUTASY ; output the ARGument MOVE CH,OP2LIT ; get location of byte pointer IORI CH,AS.LIT ; identify as LITAB item PUSHJ PP,PUTASN ; output as address field MOVE CH,[XWD OCTLIT,1] ; follow pointer with constant PUSHJ PP,STASHC ; output SETZ CH, ; start fresh PUSHJ PP,CHKNUM ; numeric? CAIA ; no - TLO CH,(3B1) ; yes - set some flags MOVE TB,OPRTR+4 ; get link TLNE TB,(1B1) ; literal? TLO CH,(1B3) ; yes - flag it MOVE TB,OP2DEC ; get decimal places DPB TB,[POINT 5,CH,17] ; stash HRR CH,OP2SIZ ; get size of field AOS ELITPC ; bump pointer PJRST STASHC ; output and exit ; ********** NOTE ********** ; ; ; IF FWHOLE IS SET THEN FOP2AR MUST ALSO BE SET SINCE THE RESULT ; FIELD MUST ALWAYS BE A WHOLE ARRAY, IF ANYTHING IS. THIS IS NOT ; TRUE OF FOP1AR SINCE OP1 MAY BE ANYTHING EVEN IF THE RESULT ; IS A WHOLE ARRAY. WE MUST THEREFORE KEEP THREE FLAGS FOR OP1; ; ONE (FOP1AR) TO FLAG AN ARRAY ENTRY; ANOTHER (FOP1TB) TO FLAG AS ; TABLE ENTRY; AND A THIRD (FOP1WL) TO FLAG OP1 AS A WHOLE ARRAY. ; ALL THREE MUST BE CHECKED TO DETERMINE IF OP1 IS SUBSCRIPTED. ; ;GENERATE CODE FOR MOVE ; ; ; .MOVE: PUSHJ PP,INDCHK ; OUTPUT THOSE INDICATORS MOVE TB,OPRTR+2 ; GET F2 MOVEM TB,OPRTR+4 ; STASH FOR OTHERS IFN BINARY,< TLNE TB,3B19 ; A LITERAL? JRST .MOVE0 ; YES - MOVEI TB,2 ; GET FACTOR 2 INDEX PUSHJ PP,GTFLD ; SET IT UP CAIN TC,2 ; BINARY? JRST .ZADD+1 ; YES - USE Z-ADD .MOVE0: HRRZ TA,OPRTR+3 ; GET RESULT FIELD PUSHJ PP,LNKSET ; SET UP THOSE LINKERS LDB TB,DA.SIZ ; GET SIZE SKIPN TB ; IF FIELD DEFINED? PUSHJ PP,FNDFLD ; NO - SET IT UP NOW LDB TB,DA.FLD ; GET FIELD TYPE CAIN TC,2 ; BINARY? JRST .ZADD+1 ; YES - USE Z-ADD > .MOVE1: SETZM OP2CNT ; reset increment count MOVE TB,OPRTR+4 ; SWAP SOME POINTERS AROUND EXCH TB,OPRTR+3 ; SO THAT F2 IS IN OPRTR+3 MOVEM TB,OPRTR+4 ; AND RESULT IS IN OPRTR+4 PUSHJ PP,WH.OP2 ; CHECK OUT OP2 PUSHJ PP,WH.OP3 ; DOES OP3 AGREE? POPJ PP, ; NO - TSWF FWHOLE; ; WAS IT WHOLE ARRAY? PUSHJ PP,WHLGN1 ; YES - GENERATE CODE PUSHJ PP,STBYT1 ; SO THAT THIS WORKS RIGHT PUSHJ PP,STBYT2 ; AND THIS MOVE TB,OP1SIZ ; GET SIZE OF F2 CAMN TB,OP2SIZ ; TWO FIELDS EQUAL? JRST .MOVE2 ; YES - 1 = 2 CAML TB,OP2SIZ ; WELL? JRST .MOVE3 ; 1 > 2 MOVE TC,OP2SIZ ; 1 < 2 SUB TC,TB ; GET DIFFERENCE MOVEM TC,OP2CNT ; save for later TSWF FOP2AR!FOP2TB; ; SUBSCRIPTED OP2? JRST .MOVE2 ; YES - SPECIAL CASE MOVE CH,OP2BYT ; GET BYTE POINTER TO RESULT PUSHJ PP,BINC ; INCREMENT IT TC TIMES MOVEM CH,OP2BYT ; RESTORE POINTER .MOVE2: TSWF FOP2AR!FOP2TB; ; op2 subscripted? SWON FINC; ; yes - set increment flag PUSHJ PP,BPTRSZ## ; OUTPUT POINTERS TSWT FOP1AR!FOP1TB!FOP1WL; ; op1 subscripted? JRST .MOVE6 ; NO SPECIAL CARE NEEDED MOVE TB,OP1SIZ ; GET SIZE OF 1 CAMN TB,OP2SIZ ; WELL? JRST .MOVE6 ; TWO FIELDS ARE EQUAL IN SIZE CAML TB,OP2SIZ ; JRST .MOVE4 ; 1 > 2 .MOVE6: PUSH PP,ELITPC ; SAVE CURRENT LITAB PC MOVE TB,OP1LIT## ; GET LOC OF OP1 POINTER MOVEM TB,ELITPC ; MOVE INTO CURRENT PC PUSHJ PP,CHCONV## ; CHOOSE A MOVE UUO POP PP,ELITPC ; RESTORE LITAB PC TSWF FWHOLE; ; ARE WE DEALING WITH WHOLE ARRAYS? PJRST WHLGN2 ; YES - GENERATE END CODE POPJ PP, ; AND EXIT ;.MOVE (CONT'D) ; .MOVE3: TSWF FOP1AR!FOP1TB!FOP1WL; ; OP1 SUBSCRIPTED? JRST .MOVE5 ; YES - WILL GENERATE IBP CODE SUB TB,OP2SIZ ; GET DIFFERENCE IN SIZE MOVE TC,TB ; GET INTO PROPER AC MOVE CH,OP1BYT ; GET BYTE POINTER PUSHJ PP,BINC ; INCREMENT MOVEM CH,OP1BYT ; REPLACE POINTER .MOVE5: MOVE TB,OP2SIZ ; GET SIZE JRST .MOVE2 ; GO FINISH UP .MOVE4: TSWT FOP1AR!FOP1TB!FOP1WL; ; IS OP1 SUBSCRIPTED? JRST .MOVE6 ; NO - ALREADY MODIFIED SUB TB,OP2SIZ ; GET IBP COUNT MOVE TC,TB ; GET INTO PROPER AC PUSHJ PP,BNCGN1## ; GENERATE IBP CODE JRST .MOVE6 ; CONTINUE WITH UUO GENERATION ;GENERATE CODE FOR MOVEL ; ; ; .MOVEL: PUSHJ PP,INDCHK ; GENERATE INDICATOR CHECK MOVE TB,OPRTR+2 ; GET FACTOR 2 MOVEM TB,OPRTR+4 ; STASH FOR LATER SWAP IFN BINARY,< TLNE TB,3B19 ; LITERAL? JRST .MOVL0 ; YES - MOVEI TB,2 ; GET FACTOR 2 INDEX PUSHJ PP,GTFLD ; GET FIELD TYPE CAIN TC,2 ; BINARY? JRST .ZADD+1 ; YES - USE Z-ADD .MOVL0: HRRZ TA,OPRTR+3 ; GET RESULT FIELD PUSHJ PP,LNKSET ; SET UP LINKS LDB TB,DA.SIZ ; GET SIZE OF FIELD SKIPN TB ; DEFINED? PUSHJ PP,FNDFLD ; NO - FIND OUT IF IT IS LDB TB,DA.FLD ; GET FIELD TYPE CAIN TC,2 ; BINARY? JRST .ZADD+1 ; YES - USE Z-ADD > .MOVL1: MOVE TB,OPRTR+4 ; REARRANGE DATA EXCH TB,OPRTR+3 ; CONTINUE (SEE .MOVE1 FOR DETAILS) MOVEM TB,OPRTR+4 ; FINISH PUSHJ PP,WH.OP2## ; CHECK OP2 PUSHJ PP,WH.OP3## ; CHECK OP3 POPJ PP, ; SOMETHING DIDN'T WORK TSWF FWHOLE; ; DID WE FIND A WHOLE ARRAY? PUSHJ PP,WHLGN1 ; YES - PUSHJ PP,STBYT1 ; GET BYTE POINTER TO FACTOR 2 PUSHJ PP,STBYT2 ; GET BYTE POINTER TO RESULT MOVE TB,OP1SIZ ; GET F2 SIZE CAMN TB,OP2SIZ ; EQUAL TO RESULT LENGTH? JRST .MOVL8 ; OUTPUT BYTE POINTERS AND EXIT CAML TB,OP2SIZ ; ? JRST .MOVL2 ; 1 > 2 PUSHJ PP,.MOVL3 ; 1 < 2 - OUTPUT BYTE POINTERS PUSHJ PP,CHKNUM## ; IS RESULT NUMERIC? POPJ PP, ; NO - JUST EXIT TSWF FOP1AR!FOP1TB!FOP1WL; ; TABLE/ARRAY? JRST .MOVL4 ; YES - MOVE CH,OP2BYT ; NO - GET BYTE POINTER MOVE TC,OP1SIZ ; GET INCREMENT COUNT SUBI TC,1 ; WE WANT ILDB NOT LDB POINTER PUSHJ PP,BINC ; INCREMENT MOVEM CH,OP1BYT ; STASH .MOVL4: MOVE CH,OP2BYT ; GET BYTE POINER MOVE TC,OP2SIZ ; GET INCREMENT COUNT SUBI TC,1 ; GO FORTH AND BE DIMINISHED PUSHJ PP,.MINC2 ; OUPUT INCREMENT AND POINTERS TSWF FOP1AR!FOP1TB!FOP1WL; ; DID WE DEFER OP1 INCREMENT? PUSHJ PP,.MOVL5 ; YES - DO IT NOW THEN MOVE CH,[XWD MVSGNR##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; OUTPUT MOVE CH,OP1LIT ; GET OP1 BYTE ADDRESS TRO CH,AS.LIT ; IDENTIFY PUSHJ PP,PUTASN ; OUTPUT IT TSWF FWHOLE; ; DO WE HAVE WHOLE ARRAY? PJRST WHLGN2 ; OUTPUT END CODE POPJ PP, ; EXIT ;.MOVEL (CONT'D) ; ; .MOVL3: PUSHJ PP,BPTRSZ ; OUTPUT POINTERS WITH SIZE PUSH PP,ELITPC ; SAVE LITAB PC MOVE CH,OP1LIT ; GET OP1 BYTE ADDRESS MOVEM CH,ELITPC ; TEMPORARY PUSHJ PP,CHCONV ; CHOOSE A CONVERSION POP PP,ELITPC ; GET BACK REAL PC POPJ PP, ; AND EXIT .MOVL5: MOVE TC,OP1SIZ ; GET INCREMENT COUNT SUBI TC,1 ; DECREMENT PJRST BNCGN1 ; OUTPUT INCREMENT CODE AND EXIT .MOVL8: PUSHJ PP,.MOVL3 ; OUTPUT SOME POINTERS TSWF FWHOLE; ; ARE WE DEALING WITH WHOLES? PJRST WHLGN2 ; YES - POPJ PP, ; NO - ;.MOVEL (CONT'D) ; .MOVL2: MOVE TB,OP2SIZ ; GET THE SMALLER ONE PUSHJ PP,.MOVL3 ; OUTPUT SOME BYTE POINTERS PUSHJ PP,CHKNUM ; IS IT NUMERIC (THE RESULT)? POPJ PP, ; NO - EXIT TSWF FOP1AR!FOP1TB!FOP1WL; ; TABLE OR ARRAY? JRST .MOVL6 ; YES - DEFER OUTPUTING POINTERS MOVE CH,OP1BYT ; GET FIRST BYTE POINTER MOVE TC,OP1SIZ ; GET SIZE OF FIRST FIELD SUBI TC,1 ; MAKE IXXB POINTER PUSHJ PP,BINC ; GET POINTER TO SIGN IN F2 MOVEM CH,OP1BYT ; STASH AS FIRST BYTE POINTER .MOVL6: MOVE CH,OP2BYT ; GET POINTER TO RESULT MOVE TC,OP2SIZ ; GET SIZE SUBI TC,1 ; PUSHJ PP,.MINC2 ; MAKE POINTER TO PLACE TO PUT SIGN TSWF FOP1AR!FOP1TB!FOP1WL; ; DID WE DEFER OUTPUT? PUSHJ PP,.MOVL5 ; YES - WELL DO IT NOW THEN MOVE CH,[XWD MVSGN##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; OUTPUT UUO MOVE CH,OP1LIT ; GET LITAV ADDRESS TRO CH,AS.LIT ; MARK AS SUCH PUSHJ PP,PUTASN ; OUTPUT TSWF FWHOLE; ; DID WE HAVE WHOLE ARRAY? PJRST WHLGN2 ; YES - POPJ PP, ; NO - ;Generate code for MOVEA ; ; ; .MOVEA: PUSHJ PP,INDCHK ; generate indicator check MOVE TB,OPRTR+2 ; get factor 2 MOVEM TB,OPRTR+4 ; save as result IFN BINARY,< TLNE TB,3B19 ; literal? JRST .MOVA0 ; yes - MOVEI TB,2 ; no - get factor 2 index PUSHJ PP,GTFLD ; get the field CAIN TC,2 ; binary? JRST .ZADD+1 ; yes - .MOVA0: HRRZ TA,OPRTR+3 ; get result field PUSHJ PP,LNKSET ; set up links LDB TB,DA.SIZ ; get size of field SKIPN TB ; defined here? PUSHJ PP,FNDFLD ; no - go find it LDB TB,DA.FLD ; get field type CAIN TC,2 ; binary ? JRST .ZADD+1 ; yes - > ; end of IFN BINARY .MOVA1: MOVE TB,OPRTR+4 ; do the old swap EXCH TB,OPRTR+3 ; MOVEM TB,OPRTR+4 ; presto! PUSHJ PP,WH.OP2 ; check for whole array PUSHJ PP,WH.OP3 ; ok? POPJ PP, ; obviously not TSWF FWHOLE; ; any whole arrays? PUSHJ PP,WHLGN1 ; yes - go generate some setup code PUSHJ PP,STBYT1 ; get byte pointer to factor 2 PUSHJ PP,STBYT2 ; get byte pointer to result TSWT FOP1AR!FOP2AR; ; at least one of them an array? WARN 559; ; no - error MOVE TB,OP1SIZ ; get size of factor 2 MOVE TC,OP2SIZ ; get size of result CAMGE TB,TC ; f2 < result ? MOVEM TB,OP2SIZ ; yes - use smaller CAMGE TC,TB ; no - result < f2 ? MOVEM TB,OP1SIZ ; yes - use that JRST .MOVL8 ; go generate some code ;GENERATE CODE FOR MHHZO ; ; ; .MHHZO: PUSHJ PP,INDCHK ; GENERATE INDCHK CODE PUSHJ PP,MVITMS ; MOVE SOME THINGS AROUND PUSHJ PP,CHKNM2## ; IS F2 NUMERIC? CAIA ; NO JRST .MYYZO ; YES - ERROR PUSHJ PP,CHKNUM ; IS RESULT NUMERIC? CAIA ; NO - JRST .MYYZO ; YES - ERROR PUSHJ PP,STBYT1 ; SET UP POINTER PUSHJ PP,STBYT2 ; AND ANOTHER PUSHJ PP,BPTR## ; OUTPUT BYTE POINTERS PJRST .MXXZO ; OUTPUT THE MOVSGN CODE ;GENERATE CODE FOR MHLZO ; ; ; .MHLZO: PUSHJ PP,INDCHK ; CHECK THOSE INDICATORS PUSHJ PP,MVITMS ; MOVE THOSE ITEMS PUSHJ PP,CHKNM2 ; CHECK THAT FACTOR 2 CAIA ; OK JRST .MYYZO ; ERROR - IS NUMERIC PUSHJ PP,STBYT1 ; SET UP ONE POINTER PUSHJ PP,STBYT2 ; AND ANOTHER MOVE CH,OP2BYT ; GET RESULT POINTER MOVE TC,OP2SIZ ; GET LENGTH SUBI TC,1 ; WE WANT IDPB POINTER, NOT DPB SKIPE TC ; don't do it 6.871947674*10^10 times PUSHJ PP,.MINC2 ; INCREMENT POINTER PJRST .MXXZO ;GENERATE CODE FOR MLLZO ; ; ; .MLLZO: PUSHJ PP,INDCHK ; OUTPUT INDICATOR CODE PUSHJ PP,MVITMS ; MOVE THAT STUFF AROUND PUSHJ PP,STBYT1 ; SET UP FACTOR 2 POINTER PUSHJ PP,STBYT2 ; SET UP RESULT POINTER TSWF FOP1AR!FOP1TB!FOP1WL; ; IS IT TABLE/ARRAY? JRST .MLLZ1 ; YES - DEFER POINTER OUTPUT MOVE CH,OP1BYT ; GET BYTE POINTER MOVE TC,OP1SIZ ; GET INCREMENT COUNT SUBI TC,1 ; THE USUAL SKIPE TC ; don't try it with zero PUSHJ PP,BINC ; INCREMENT IT MOVEM CH,OP1BYT ; STASH .MLLZ1: MOVE CH,OP2BYT ; GET THAT POINTER MOVE TC,OP2SIZ ; GET INCREMENT SUBI TC,1 ; OH HUM SKIPE TC ; watch out for zero PUSHJ PP,.MINC2 ; USE A COMMON ROUTINE TSWT FOP1AR!FOP1TB!FOP1WL; ; DID WE DEFER? PJRST .MXXZO ; NO - GO OUTPUT CODE MOVE TC,OP1SIZ ; YES - GET INCREMENT COUNT SUBI TC,1 ; DIMINISH BY 1 SKIPE TC ; don't use zero PUSHJ PP,BNCGN1 ; OUTPUT INCREMENT CODE PJRST .MXXZO ; OUTPUT MOVSGN CODE AND EXIT ;GENERATE CODE FOR MLHZO ; ; ; .MLHZO: PUSHJ PP,INDCHK ; GENERATE INDICATOR CHECK PUSHJ PP,MVITMS ; SWAP! PUSHJ PP,CHKNUM ; IS RESULT NUMERIC? CAIA ; NO - OK JRST .MYYZO ; APPARENTLY SO PUSHJ PP,STBYT1 ; GET ONE POINTER PUSHJ PP,STBYT2 ; GET ANOTHER MOVE CH,OP1BYT ; GET FACTOR 2 BYTE POINTER MOVE TC,OP1SIZ ; GET FACTOR 2 SIZE SUBI TC,1 ; OF COURSE SKIPE TC ; don't try it with zero PUSHJ PP,.MINC1 ; INCCCCCCCCREMENT PJRST .MXXZO ; GO OUTPUT POINTERS AND EXIT ;SUPPORT ROUTINES FOR THE MOVE ZONE VERBS ; ; ; ;ROUTINE TO OUTPUT MVSGN UUO .MXXZO: MOVE CH,[XWD MVSGN+ASINC,AS.MSC] PUSHJ PP,PUTASY ; OUTPUT IT MOVE CH,OP1LIT ; GET LITAB PC TRO CH,AS.LIT ; SAY WHAT IT IS PUSHJ PP,PUTASN ; OUTPUT ADDRESS AND EXIT TSWF FWHOLE; ; WAS IT WHOLE ARRAY? PJRST WHLGN2 ; YES - POPJ PP, ; NO - ;ROUTINE TO OUTPUT ERROR MESSAGE FOR ILLEGAL NUMERIC FIELD .MYYZO: GETLN; ; get line number for error WARN 590; ; "WHEREVER HIGH USED, MUST BE ALPHA" POPJ PP, ; EXIT ;ROUTINE TO SWAP SOME POINTERS AROUND MVITMS: MOVE TB,OPRTR+2 ; GET FACTOR 2 POINTER EXCH TB,OPRTR+3 ; PUT IN OPRTR+3 MOVEM TB,OPRTR+4 ; PUT RESULT POINTER INTO OPRTR+4 PUSHJ PP,WH.OP2 ; CHECK OUT OP2 PUSHJ PP,WH.OP3 ; CHECK OUT OP3 JRST MVITM1 ; OP3 DIDN'T CHECK OUT TOO GOOD TSWF FWHOLE; ; ALL OK - WHOLE ARRAY? PJRST WHLGN1 ; YES - GENERATE CODE POPJ PP, ; EXIT MVITM1: POP PP,TB ; POP OFF EXTRA RETURN ADDRESS POPJ PP, ; EXIT ;ROUTINE TO INCREMENT OP1 IN SOME FASHION .MINC1: TSWF FOP1AR!FOP1TB!FOP1WL; ; TABLE/ARRAY? JRST .MNC1A ; YES - PUSHJ PP,BINC ; NO - INCREMENT MOVEM CH,OP1BYT ; SAVE POINTER PJRST BPTR ; OUTPUT POINTERS .MNC1A: PUSH PP,TC ; SAVE COUNT PUSHJ PP,BPTR ; OUTPUT POINTERS POP PP,TC ; RESTORE COUNT PJRST BNCGN1 ; OUTPUT INCREMENT CODE AND EXIT ;Support routines for move zone (cont'd) ; ;ROUTINE TO INCREMENT OP2 IN SOME FASHION ; .MINC2: TSWF FOP2AR!FOP2TB; ; TABLE/ARRAY? JRST .MNC2A ; YES - PUSHJ PP,BINC ; INCREMENT MOVEM CH,OP2BYT ; SAVE PJRST BPTR ; OUTPUT POINTERS .MNC2A: PUSH PP,TC ; SAVE COUNT PUSHJ PP,BPTR ; OUTPUT SOME POINTERS POP PP,TC ; RESTORE COUNT PJRST BNCGN2## ; OUTPUT INCREMENT CODE ;Generate code for TESTZ ; ; ; .TESTZ: PUSHJ PP,INDCHK ; generate indicator check MOVE TB,OPRTR+2 ; get our only link MOVEM TB,OPRTR+3 ; and spread it around a bit MOVEM TB,OPRTR+4 ; and a bit more PUSHJ PP,CHKNM2 ; is it numeric? CAIA ; no - OK JRST .TSTZ1 ; yes - error PUSHJ PP,WH.OP2 ; better check out a stupid programmer TSWF FWHOLE; ; was he? JRST .TSTZ2 ; yes - PUSHJ PP,STBYT2 ; no - try some more TSWF FOP2AR; ; another attempt at an array? JRST .TSTZ2 ; yes - still wrong PUSHJ PP,.BPTRB ; output a pointer MOVE CH,[XWD OCTLIT,1] ; get litab header for one word PUSHJ PP,STASHC ; output it HRRZ TA,OPRTR+1 ; get indicators PUSHJ PP,LNKSET ; set 'em up MOVE CH,(TA) ; get those indicators PUSHJ PP,STASHC ; and output them AOS ELITPC ; bump the LITAB PC MOVE CH,[XWD TESTZ##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output the UUO MOVE CH,OP2LIT ; get litab address of op pointer IORI CH,AS.LIT ; mark it PJRST PUTASN ; output and exit .TSTZ1: GETLN; ; get line number with error WARN 207; ; must be alpha POPJ PP, .TSTZ2: GETLN; ; get offending line number WARN 205; ; arrays invalid POPJ PP, ;Generate code for BITON ; ; ; .BITON: PUSHJ PP,.BITST ; output common code MOVE CH,[XWD TDO.+AC1,AS.CNS+2] PUSHJ PP,PUTASY ; output code to turn on bits PJRST .BITFN ; generate common finish code and exit ;Generate code for BITOF ; ; ; .BITOF: PUSHJ PP,.BITST ; output common code MOVE CH,[XWD TDZ.+AC1,AS.CNS+2] PUSHJ PP,PUTASY ; output code to clear bits PJRST .BITFN ; generate end code ;Generate code for TESTB ; ; ; .TESTB: PUSHJ PP,.BITST ; output common code MOVE CH,[XWD TESTB.##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output TESTB. UUO MOVE CH,ELITPC ; get LITAB PC IORI CH,AS.LIT ; id PUSHJ PP,PUTASN ; Output address MOVE CH,[XWD OCTLIT,1] ; one octal constant to LITAB PUSHJ PP,STASHC ; Output LITAB word HRRZ TA,OPRTR+1 ; get link to resulting indicators PUSHJ PP,LNKSET ; set up links MOVE CH,(TA) ; get resulting indicators AOS ELITPC ; bump PC PJRST STASHC ; output as address field ;Support Routines for the Bit Verbs ; ; ;Routine to generate common start code ; .BITST: PUSHJ PP,INDCHK ; generate indicator check MOVE CH,OPRTR+2 ; move some links around EXCH CH,OPRTR+3 ; stick 2 in 3 MOVEM CH,OPRTR+4 ; and 3 in 4 PUSHJ PP,WH.OP2 ; whole array? TSWFZ FWHOLE; ; ? JRST .BIT5 ; yes - error PUSHJ PP,CHKNM2 ; factor 2 numeric? CAIA ; no - ok JRST .BIT7 ; yes - error PUSHJ PP,CHKNUM ; how about result field CAIA ; no - ok JRST .BIT7 ; yes - error MOVE TB,OPRTR+3 ; get factor 2 link TLNE TB,(1B1) ; literal? JRST .BITS1 ; yes - convert to binary mask PUSHJ PP,STBYT1 ; set up byte pointer for op 1 MOVE TB,OP1SIZ ; get size CAIE TB,1 ; is one? JRST .BIT6 ; no - error PUSHJ PP,GTBP15## ; yes - get pointer into AC0 MOVE CH,[XWD ILDB.+AC1,AS.CNS+5] PUSHJ PP,PUTASY ; generate .BITS0: PUSHJ PP,STBYT2 ; generate pointer to result field MOVE TB,OP2SIZ ; get size CAIE TB,1 ; one? JRST .BIT6 ; no - error PUSHJ PP,GTBP25## ; get pointer into AC0 MOVE CH,[XWD ILDB.+AC2,AS.CNS+5] PJRST PUTASY ; output .BITS1: HRRZ TA,OPRTR+3 ; get VALTAB link PUSHJ PP,LNKSET ; set it HRLI TA,440700 ; make into byte pointer ILDB TB,TA ; get WC SUBI TB,1 ; allow for psuedo back-arrow SETZ TC, ; start with mask of zero .BITS2: ILDB CH,TA ; get character (ASCII) CAIL CH,"0" ; valid character? CAILE CH,"5" ; sorry! only six bits JRST .BIT4 ; No - error IOR TC,BITAB-"0"(CH) ; add in that bit to the mask SOJG TB,.BITS2 ; loop until WC = 0 .BITS3: HRLZI CH, ; generate HRR CH,TC ; get the mask PUSHJ PP,PUTASY ; output JRST .BITS0 ; generate rest of code ;.BITST (cont'd) ; ; ; .BIT4: GETLN; ; get line number WARN 557; ; mask other than 0-5 SOJG TB,.BITS2 ; ignore if any left JRST .BITS3 ; else just finish up .BIT5: GETLN; ; get number WARN 588; ; no whole arrays allowed POP PP,TB ; pop off garbage return POPJ PP, ; then return .BIT6: GETLN; ; get line number with error WARN 589; ; size must be = 1 POP PP,TB ; POPJ PP, ; .BIT7: GETLN; ; get bad line WARN 207; ; must be alpha POP PP,TB ; POPJ PP, ; BITAB: EXP 1B30 EXP 1B31 EXP 1B32 EXP 1B33 EXP 1B34 EXP 1B35 ;.BITFN Generate final code for the bit verbs ; ; ; .BITFN: MOVE CH,[XWD DPB.+AC1,AS.CNS+5] PJRST PUTASY ; generate and exit ;Generate code for EXCPT ; ; ; .EXCPT: PUSHJ PP,INDCHK ; generate that indicator check MOVE CH,[XWD EXCPT.##,AS.CNS]; get the UUO PJRST PUTASY ; output code, then exit ;Generate code for FORCE ; ; ; .FORCE: PUSHJ PP,INDCHK ; check for indicators MOVE CH,[XWD MOVEI.+AC1+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output it HRRZ TA,OPRTR+2 ; get the FILTAB link PUSHJ PP,LNKSET ; set it up LDB CH,FI.OTF ; get the pointer to the OTFTAB item IORI CH,AS.OTB## ; add in relocation PUSHJ PP,PUTASN ; output OTFTAB address MOVE CH,[XWD MOVEM.+AC1,AS.CNS+146] PJRST PUTASY ; output it then exit ;Generate code for READ ; ; ; .READ: PUSHJ PP,INDCHK ; generate indicator code MOVE CH,[XWD READ.##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output the UUO MOVE CH,ELITPC ; get a pointer into LITAB IORI CH,AS.LIT ; mark it as such PUSHJ PP,PUTASN ; output as UUO address MOVE CH,[XWD XWDLIT,2] ; get LITAB header PUSHJ PP,STASHC ; output SETZ CH, ; default to zero HRRZ TA,OPRTR+1 ; get resulting indicators pointer JUMPE TA,.+3 ; if none - use that zero PUSHJ PP,LNKSET ; set up the link LDB CH,[POINT 8,(TA),23] ; get indicator from col 58-59 PUSHJ PP,STASHC ; output it as LH HRRZ TA,OPRTR+2 ; get FILTAB link PUSHJ PP,LNKSET ; set it up LDB CH,FI.OTF ; get OTFTAB link MOVSS CH ; get into proper half IOR CH,[XWD AS.OTB,AS.MSC] ; mark as to what it is AOS ELITPC ; bump the LITAB PC now so PJRST STASHC ; we can PJRST the hell out of here ;.CHAIN Generate code for CHAIN ; ; ; .CHAIN: PUSHJ PP,INDCHK ; generate indicator code HRRZ TA,OPRTR+2 ; get FILTAB link PUSHJ PP,LNKSET ; set it up LDB TB,FI.PRO ; get file processing mode CAIN TB,5 ; random by key? JRST .CHAN2 ; yep - CAIE TB,4 ; no - random by relative key? JRST .CHAN3 ; no - error PUSHJ PP,CHKNM2 ; is key numeric? JRST .CHAN5 ; no - error PUSHJ PP,GT2AC1 ; yes - get key into AC1 & AC2 MOVE TB,OP2DEC ; get decimal position count JUMPN TB,.CHAN5 ; error if any TSWF FWHOLE; ; any whole arrays? JRST .CHAN4 ; yes - error MOVE CH,[XWD CHAIN.##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output the UUO MOVE CH,ELITPC ; get a LITAB entry IORI CH,AS.LIT ; mark as such PUSHJ PP,PUTASN ; output that too MOVE CH,[XWD XWDLIT,4] ; get LITAB header word PUSHJ PP,STASHC ; output SETZ CH, ; get a zero PUSHJ PP,STASHC ; output LH PUSHJ PP,STASHC ; and RH AOS ELITPC ; and bump LITAB PC .CHAN1: HRRZ TA,OPRTR+1 ; get indicator link SETZ CH, ; start fresh JUMPE TA,.+3 ; do we have any resulting indicators? PUSHJ PP,LNKSET ; yes - set up link LDB CH,[POINT 8,(TA),7] ; and get that indicator MOVE TB,OP2SIZ ; now get size DPB TB,[POINT 10,CH,27] ; stash in LH word too MOVSS CH ; XWD literal is increment,,address IORI CH,AS.CNB ; say it's a constant PUSHJ PP,STASHC ; and output HRRZ TA,OPRTR+2 ; get FILTAB link PUSHJ PP,LNKSET ; set it up LDB CH,FI.OTF ; get OTFTAB pointer MOVSS CH ; get into proper half IOR CH,[XWD AS.OTB,AS.MSC] ; add in flags AOS ELITPC ; bump the PC PJRST STASHC ; and output and exit ;.CHAIN (cont'd) ; ; ; .CHAN2: MOVE TB,OPRTR+3 ; get the data item link MOVEM TB,OPRTR+4 ; put it where STBYT2 can find it PUSHJ PP,STBYT2 ; get byte pointer to key TSWF FWHOLE; ; any whole arrays? JRST .CHAN4 ; yes - no good HRRZ TA,OPRTR+2 ; get FILTAB link PUSHJ PP,LNKSET ; set it up LDB TB,FI.KYL ; get supposed length of key field CAME TB,OP2SIZ ; same size as key the guy gave us? JRST .CHAN6 ; no - error PUSHJ PP,.BPTRB## ; output byte pointer to LITAB MOVE CH,[XWD CHAIN.+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output the UUO MOVE CH,OP2LIT## ; get LITAB location of byte pointer IORI CH,AS.LIT ; add in address PUSHJ PP,PUTASN ; output address MOVE CH,[XWD XWDLIT,2] ; get LITAB header PUSHJ PP,STASHC ; output JRST .CHAN1 ; and output the rest .CHAN3: GETLN; ; get offending line number WARN 525; ; file is of incorrect type for CHAIN POPJ PP, ; exit .CHAN4: GETLN; ; get bad line number WARN 524; ; no whole arrays allowed POPJ PP, .CHAN5: GETLN; ; get line number WARN 582; ; key must be numeric and no decimals POPJ PP, .CHAN6: GETLN; ; get the line WARN 591; ; key lengthes must be equal POPJ PP, ;Generate code for DSPLY ; ; ; .DSPLY: PUSHJ PP,INDCHK ; generate indicator check HRRZ TB,OPRTR+3 ; [322] factor 1 optional SKIPE TB ; [322] PUSHJ PP,WH.OP2 ; whole arrays? TSWFZ FWHOLE; ; ? JRST .DSPL1 ; yes - error SETZM OP1BYT ; reset to zero in case none SETZM OP2BYT ; likewise HRRZ TB,OPRTR+3 ; get factor 1 SKIPE TB ; anything there? PUSHJ PP,STBYT1 ; yes - set it up HRRZ TB,OPRTR+4 ; get result SKIPE TB ; anything there? PUSHJ PP,STBYT2 ; yes - set that up too PUSHJ PP,BPTR ; output the byte pointers MOVE CH,[XWD XWDLIT,2] ; followed by an XWD PUSHJ PP,STASHC ; tell LITAB SETZ CH, ; start anew MOVE TB,OP1SIZ ; get size of field DPB TB,[POINT 7,CH,10] ; stash MOVE TB,OP2SIZ ; get size of next field DPB TB,[POINT 7,CH,17] ; stash that too HRRZ TB,OPRTR+3 ; [322] factor 1 optional SKIPE TB ; [322] PUSHJ PP,CHKNM2 ; factor 1 numeric? CAIA ; no - TLO CH,(1B0) ; yes - flag as such HRRZ TB,OPRTR+4 ; [322] result is optional SKIPE TB ; [322] PUSHJ PP,CHKNUM ; what about result CAIA ; not numeric TLO CH,(1B1) ; numeric - flag it HRRI CH,AS.CNB ; LH is constant PUSHJ PP,STASHC ; output to LITAB HRRZ TA,OPRTR+2 ; get FILTAB pointer PUSHJ PP,LNKSET ; set it up LDB CH,FI.OTF ; get pointer to OTFTAB entry IORI CH,AS.OTB ; flag as %OTF relative HRLZS CH ; get into LH HRRI CH,AS.MSC ; get other flag PUSHJ PP,STASHC ; output to LITAB ;.DSPLY (cont'd) ; ; ; MOVE CH,[XWD OCTLIT,1] ; and now an octal constant PUSHJ PP,STASHC ; output header SETZ CH, ; start fresh MOVE TB,OP1DEC ; get decimal places DPB TB,[POINT 4,CH,3] ; stash in output word MOVE TB,OP2DEC ; get decimal places of other field DPB TB,[POINT 4,CH,7] ; and stash those too PUSHJ PP,STASHC ; output word to LITAB MOVE CH,[XWD DSPLY.##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output UUO call to ASYfil HRRZ CH,OP1LIT ; get address of first byte pointer IORI CH,AS.LIT ; identify it AOS ELITPC ; bump the LITAB PC once AOS ELITPC ; and twice PJRST PUTASN ; output increment and exit .DSPL1: GETLN; ; get line number for error WARN 524; ; can't use whole arrays POPJ PP, ; exit ;.TIME Generate code for TIME verb ; ; ; .TIME: PUSHJ PP,INDCHK ; generate indicator check PUSHJ PP,WH.OP1 ; check out the field TSWF FWHOLE; ; whole array? JRST .TIME4 ; yes - no good HRRZ TA,OPRTR+2 ; get the link MOVEM TA,OPRTR+4 ; and stash in case we don't call FNDFLD PUSHJ PP,LNKSET ; set the links LDB TB,DA.FLD ; get the field type SKIPN TB ; we want numeric PUSHJ PP,FNDFLD ; see if we can find one LDB TB,DA.DEC ; apparently did - get decimal positions JUMPN TB,.TIME1 ; must be zero to be OK LDB TB,DA.SIZ ; now get size of field CAIN TB,6 ; just time of day wanted? JRST .TIME2 ; yes - CAIN TB,^D12 ; or does he want time of day and date? JRST .TIME3 ; that's it - GETLN; ; get line number for error message WARN 713; ; doesn't want either - must be error POPJ PP, ; exit .TIME1: GETLN; ; get line number WARN 714; ; must be 0 decimal positions POPJ PP, ; .TIME2: SKIPA CH,[XWD TIME.##,AS.CNS] ; get the UUO .TIME3: MOVE CH,[XWD TIMED.##,AS.CNS]; likewise PUSHJ PP,PUTASY ; output it PJRST PTRAC3 ; and store result .TIME4: GETLN; ; get line number WARN 715; ; no whole arrays allowed POPJ PP, ;Generate code for the DEBUG op ; ; ; .DEBUG: PUSHJ PP,INDCHK ; generate indicator check MOVE TA,OPRTR+3 ; get a link EXCH TA,OPRTR+4 ; swap it for another MOVEM TA,OPRTR+3 ; and replace HRRZ TB,OPRTR+3 ; get the link SKIPE TB ; make sure we have one PUSHJ PP,WH.OP2 ; check for good ol' whole arrays SETZM OP1BYT ; start fresh SETZM OP2BYT ; likewise I'm sure HRRZ TB,OPRTR+3 ; get result link SKIPE TB ; is there one? PUSHJ PP,STBYT1 ; yes set it up HRRZ TB,OPRTR+4 ; get factor 1 link SKIPE TB ; is there one? PUSHJ PP,STBYT2 ; yes - set it PUSHJ PP,BPTR ; output two byte pointers MOVE CH,[XWD XWDLIT,2] ; get LITAB link PUSHJ PP,STASHC ; output it HRRZI CH,AS.CNB ; get non-relocatable zero PUSHJ PP,STASHC ; output it HRRZ TA,OPRTR+2 ; get FILTAB link PUSHJ PP,LNKSET ; set it up LDB CH,FI.OTF ; get OTFTAB link MOVSS CH ; get into correct half IOR CH,[XWD AS.OTB,AS.MSC] ; identify halves PUSHJ PP,STASHC ; output it MOVE CH,[XWD OCTLIT,1] ; now comes an octal constant PUSHJ PP,STASHC ; tell LITAB SETZ CH, ; start with nothing MOVE TB,OP2SIZ ; get size of factor 1 DPB TB,[POINT 4,CH,6] ; stash MOVE TB,OP1SIZ ; get result field size DPB TB,[POINT 10,CH,16] ; stash that too MOVE TB,WHOSIZ ; get whole array size TSWT FWHOLE; ; is it set up SETZ TB, ; no - DPB TB,[POINT 10,CH,26] ; save it HRRZ TB,OPRTR+3 ; get result link SKIPE TB ; make sure it exists PUSHJ PP,CHKNM2 ; is result numeric? CAIA ; no TRO CH,1B27 ; yes - say so HRRZ TB,OPRTR+4 ; does factor 1 exist? SKIPE TB ; don't do anything if it doesn't PUSHJ PP,CHKNUM ; factor 1 numeric? CAIA ; no - TLO CH,(1B2) ; yes - SETZ TB, ; default to field TSWF FOP1TB; ; table? MOVEI TB,1 ; yes - TSWF FOP1AR; ; array? MOVEI TB,2 ; yes - TSWF FOP1WL; ; whole array? MOVEI TB,3 ; yes - DPB TB,[POINT 2,CH,1] ; save whatever it is PUSHJ PP,STASHC ; output the flags MOVE CH,[XWD DEBUG.##+ASINC,AS.MSC] PUSHJ PP,PUTASY ; output UUO call HRRZ CH,OP1LIT ; get address of first pointer IORI CH,AS.LIT ; identify it AOS ELITPC ; bump the PC AOS ELITPC ; again PJRST PUTASN ; and exit ;GENERATE ESCAPE LINKAGE FOR CONTROL CALCULATIONS ; ;GENERATE: PUSHJ PP,400012 ; JRST PRGID ; ; .CAL: TSWFZ FINDON; ; STILL GOT A TAG LEFT? PUSHJ PP,FNDTAG## ; YES - TIE UP LOOSE ENDS MOVE CH,[XWD PUSHJ.+AC17+ASINC,AS.CNB] PUSHJ PP,PUTASY## ; OUTPUT IT HRRZI CH,400012 ; ADDRESS OF D.00 PUSHJ PP,PUTASN ; OUTPUT INCREMENT MOVE CH,PRGID ; PLACE TO JRST TO MOVEM CH,NAMWRD ; STASH FOR LOOKUP SETZM NAMWRD+1 ; CLEAN HOUSE PUSHJ PP,TRYNAM ; LOOKUP JRST .CAL1 ; ERROR - MOVEI TB,CD.PRO ; GET TABLE ID MOVSS TA ; GET RELATIVE LINK INTO RH PUSHJ PP,FNDLNK## ; LOOKUP LINK JRST .CAL1 ; ERROR - SUB TB,PROLOC## ; MAKE A POINTER HRRZ CH,TB ; MOVE AND CLEAR ADD CH,[XWD JRST.,AS.PRO] ; MAKE INTO INSTRUCTION PUSHJ PP,PUTASY ; OUTPUT IT POPJ PP, ; EXIT .CAL1: OUTSTR [ASCIZ /?PROTAB entry not found when expected in phase E /] JRST KILL## ; GO CROAK, FROGGY ;OUTPUT DETAIL CALCULATION ESCAPE CODE ; ;OUTPUT: PUSHJ PP,400011 ; %TOT: ; ; .DET: TSWFZ FINDON; ; CHECK FOR LEFTOVER TAG PUSHJ PP,FNDTAG ; GOT ONE - GO PROCESS MOVE CH,[XWD PUSHJ.+AC17+ASINC,AS.CNB] PUSHJ PP,PUTASY HRRZI CH,400011 ; GET ADRESS INCREMENT PUSHJ PP,PUTASN ; OUTPUT IT TSWC FAS3; ; SWITCH SEGMENTS MOVE CH,[SIXBIT /%TOT/] ; GET TAG NAME MOVEM CH,NAMWRD ; STASH FOR LOOKUP/BUILD SETZM NAMWRD+1 ; CALL DEWEY'S PUSHJ PP,TRYNAM ; SEE IF IT'S THERE PUSHJ PP,BLDNAM ; IT'S NOT - PUT IT THERE MOVEM TA,CURNAM ; STASH NAMTAB LINK FOR LATER MOVE TA,[XWD CD.PRO,SZ.PRO] ; GET VITAL STATISTICS PUSHJ PP,GETENT## ; GET A PROTAB ENTRY HRRZM TA,CURPRO## ; STASH THIS LINK TOO MOVS TB,CURNAM ; GET BACK NAMTAB LINK DPB TB,PR.NAM ; STORE LINK IN TABLE MOVE TB,CD.PRO ; GET TABLE ID DPB TB,PR.ID ; STORE AS SUCH MOVE TB,EAS3PC## ; GET CURRENT PC (SHOULD BE ZERO) DPB TB,PR.LNK ; STASH AS LOC OF TAG MOVEI TB,1 ; GET A FLAG DPB TB,PR.SEG## ; STASH AS SEGMENT FLAG MOVE CH,CURPRO ; GET PROTAB LINK SUB CH,PROLOC ; MAKE INTO POINTER HRRZS CH ; CLEAR OUT THE GARBAGE ADD CH,[XWD AS.PN,AS.PRO] ; MAKE INTO TAG DEF OP PUSHJ PP,PUTASN ; WRITE IT OUT POPJ PP, ; EXIT CLSUP: PUSHJ PP,LITSET## ; GO SET UP LITERALS MOVE TB,EAS3PC ; [260] get AS3 PC MOVEM TB,TEMBAS ; [260] store as start of %TEMP HRRZ CH,ETEMAX## ; [246] get max count of temporaries JUMPE CH,CLS.1 ; [246] just continue if none required HRLI CH,AS.OCT ; [246] else get ready to output PUSHJ PP,PUTASN ; [246] output header MOVE TB,ETEMAX ; [246] get count SETZ CH, ; [246] output zeroes PUSHJ PP,PUTASY ; [246] output at least one SOJN TB,.-1 ; [246] as many as necessary CLS.1: SETOI DW, ; ALL ONES ON ERA FILE = EOF PUSHJ PP,PUTERA## CLOSE ERA, ; CLOSE OUT ERROR FILE MOVEI CH,0 ; EOF FOR AS1 = A HEADER WORD OF ZERO PUSHJ PP,PUTAS1 ; OUTPUT IT CLOSE AS1, ; CLOSE FILE MOVEI CH,0 ; PUT OUT PUSHJ PP,PUTAS2## ; END-OF-DATA ON AS2 MOVEI CH,0 ; PUT OUT PUSHJ PP,PUTAS3## ; END-OF-DATA ON AS3 MOVSI CH,177740 ; PUT OUT PUSHJ PP,PUTASN## ; 'END-FILE' ON CURRENT FILE CLOSE AS2, ; AS2 CLOSED OUT..... CLOSE AS3, ; AS3 CLOSED OUT..... FINE: MOVEI TA,FIXNUM ; [246] get number of fixed items MOVEM TA,DATBAS## ; DATBAS = number of fixed items ADDB TA,ARRBAS ; ARRBAS = ARRBAS + DATBAS ADDB TA,OTFBAS ; OTFBAS = OTFBAS + ARRBAS ADDB TA,ICHBAS ; ICHBAS = OTFBAS + ICHBAS ADDB TA,OCHBAS ; OCHBAS = ICHBAS + OCHBAS ADDB TA,FTBBAS ; FTBBAS = OCHBAS + FTBBAS ADD TA,EAS1PC ; RESDNT = FTBBAS + EAS1PC MOVEM TA,RESDNT## MOVEM TA,PROGST## ; STORE AS PROGRAM ENTRY POINT ADD TA,EAS2PC## ; NONRES = RESDNT + EAS2PC MOVEM TA,NONRES## ADDB TA,LITBAS## ; LITBAS = NONRES + LITBAS ADDB TA,TEMBAS## ; [260] TEMBAS = LITBAS + TEMBAS ENDFAZ E; ;DEFINE ALL EXTERNAL CALLS SO WE AVOID SOME ERROR MESSAGES EXTERNAL DATLOC,DATNXT,CURDAT,FILLOC,FILNXT,CURFIL,OTFLOC,OTFNXT,CUROTF EXTERNAL ICHLOC,ICHNXT,CURICH,OCHLOC,OCHNXT,CUROCH,OTFBAS EXTERNAL .FIMF1,.FIMF2,.FICDR,.FILPT,.FILP2,.FITTY,.FIDSK,.FIMTA EXTERNAL CURFLD,CURREC EXTERNAL HISIZ,EAS1PC,PCREM,SAVEAC,TEMBUF,TM2BUF,CRDBUF EXTERNAL LNKSET,GETENT,GENCOM,.LOKUP EXTERNAL AS.REL,AS.MSC,AS.OCT,AS.DAT,AS.OCB,AS.ICB,AS.CNB EXTERNAL AS.ABS,AS.BYT,AS.PRO,AS.PN EXTERNAL DA.DUN,DA.FLS,DA.COR,DA.RES,DA.SNM,DA.VAL,DA.ARE,DA.NDF,DA.IND EXTERNAL DA.ARP,DA.ICH,DA.BRO,DA.MAJ,DA.INP EXTERNAL OT.BLK,OT.BSZ,OT.BSC,OT.BFP,OT.IPC,OT.LAS,OT.OPC EXTERNAL IC.DES,IC.RII,IC.INP,IC.NXF,IC.NXR EXTERNAL OC.NXR,OC.NXF,OC.IND,OC.IDX,OC.ARP,OC.SRC EXTERNAL FI.DAT EXTERNAL AD,SUBM.,MOVEI.,MOVEM.,JRST.,PUSHJ.,POPJ.,ILDB.,TDO.,TDZ.,DPB. EXTERNAL FDV., FMP., FLTLIT, SQRT., FIX., FLOT1., FLOT2., ARG. END RPGIIE