Trailing-Edge
-
PDP-10 Archives
-
decuslib20-06
-
decus/20-153/rpgiie.mac
There is 1 other file named rpgiie.mac in the archive. Click here to see a list.
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,-<SZ.FTB-7> ; 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 <ASTBLN-<SZ.FTB-7>>,<PRINTX ?ASTAB is incorrect length for SZ.FTB>
;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,(<ENDOP>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 <ILDB 1,5>
.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 <ILDB 2,5>
.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,<MOVEI.+AC1> ; generate <MOVEI 1,bit.mask>
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 <DPB 1,5> 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