Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50517/gencom.mac
There is 1 other file named gencom.mac in the archive. Click here to see a list.
TITLE GENCOM FOR RPGII %1
SUBTTL COMMON ROUTINES TO BE USED BY CODE GENERATORS BOB CURRIER
;
; GENCOM %1
;
; HEREIN FIND VARIOUS ROUTINES USED BY THE CODE GENERATORS.
; THESE ROUTINES ARE COLLECTED HERE FOR SAKE OF EASIER
; EDITING.
;
; BOB CURRIER SEPTEMBER 6, 1975 16:02:53
;
; Copyright (C) 1975, 1976 by Cerritos College and Robert Currier
; All rights reserved
;
TWOSEG
RELOC 400000
ENTRY GENCOM
GENCOM:
;ROUTINES FOUND HEREIN:
INTERNAL PUTASY, PUTASN, STASHL, LITSET, SH1AC1, SH2AC3, PTRAC3, GT1AC1, GT2AC3
INTERNAL SHFTAC, ROUND, STASHC, INDCHK, MAKTAG, FNDTAG, BLDTAG, NOTNUM, FNDFLD
INTERNAL CH.12, SH11.2, SH23.1, PTRAC5, GTFLD, GT1AC3, GT2AC1, SH1AC3, SH2AC1
INTERNAL SWPOP, SWPIND, BINC, STBYT1, STBYT2, PUTPTR, CHCONV, CHKNUM, CHKNM2
INTERNAL BPTRSZ, BPTR, GTBYTA, BNCGN1, BNCGN2, BNCGN3, WH.OP1, WH.OP2, WH.OP3
INTERNAL CHK3, WHLGN1, WHLGN2, .BPTRB, PUTPT2, GTBP15, GTBP25, PTRAC1
INTERNAL SH13.1, SH23.1 ; [353]
SALL
;PUTASY
;
;PUT A WORD ONTO THE CURRENT ASYFIL AND BUMP APPROPRIATE PC
;
;
PUTASY: TSWT FAS3; ; ARE WE CURRENTLY IN SECOND SEGMENT
AOSA EAS2PC## ; NO - BUMP PRIMARY PC
AOSA EAS3PC## ; YES - BUMP SECONDARY PC
JRST PUTAS2 ; WRITE ONTO AS2FIL
JRST PUTAS3 ; WRITE ONTO AS3FIL
;PUTASN
;
;PUT A WORD ONTO THE CURRENT ASYFIL, DON'T BUMP PC
;
;
PUTASN: TSWT FAS3; ; CURRENTLY IN SECONDAY SECTION?
JRST PUTAS2## ; NO - USE AS2FIL
JRST PUTAS3## ; YES - USE AS3FIL
;
;PUT A WORD INTO AS.LIT
;
;IF LITAB IS FULL AND < FULLIT WORDS, EXPAND AS.LIT
;IF LITAB IS FULL AND > FULLIT WORDS, WRITE OUT SOME WORDS
; ONTO LITFIL, AND MOVE REMAINDER TO TOP OF AS.LIT
FULLIT==10*200 ;NUMBER OF WORDS WRITTEN OUT EACH TIME.
;THIS MUST BE > ^D768 YET SMALL ENOUGH SO
;THAT CURRENT LITERAL GROUP BEING STASHED
;WILL NOT BE WRITTEN OUT.
;LARGEST LITERAL GROUP IS ASCII, SIZE 120.
STASHC: EXCH TA,CH ; SAVE TA AND GET CH
PUSHJ PP,STASHL ; GO STASH
EXCH TA,CH ; RESTORE
POPJ PP, ; EXIT
STASHL: MOVE TE,LITNXT## ; GET NEXT HOLE ADDRESS
AOBJP TE,STSHL0 ; IF NO ROOM, JUMP
MOVEM TA,(TE) ; STORE WORD
MOVEM TE,LITNXT ; RESTORE LITNXT
POPJ PP, ; AND EXIT
;TABLE IS FULL
STSHL0: HLRE TE,LITLOC## ; IS
MOVMS TE ; LITAB
CAILE TE,FULLIT ; AS BIG AS IT GETS?
JRST STSHL2 ; YES -
STSHL1: PUSHJ PP,XPNLIT## ; NO - EXPAND LITAB
JRST STASHL ; AND TRY AGAIN
;LITAB IS FULL, AND AS BIG AS IT SHOULD GET
STSHL2: MOVEM TA,SAVEAC## ; SAVE
MOVE TA,[XWD TD,SAVEAC+1] ; AC'S
BLT TA,SAVEAC+3 ; TD THRU TA
SKIPLE LITBLK## ; IS LITFIL ALREADY OPEN?
JRST STSHL3 ; YES -
SKIPL LITBLK ; WAS ANYTHING EVER WRITTEN?
CLOSE LIT, ; YES - CLOSE INPUT
MOVE TE,LITHDR## ; GET FILE NAME
HLLZ TD,LITHDR+1 ; AND EXTENSION
SETZB TC,TB ; CLEAR PROTECTION, PROJ-PROG
ENTER LIT,TE ; OPEN FILE FOR OUTPUT
JRST STSHL5 ; CANNOT - ERROR
SETZM LITBLK ; CLEAR WORD COUNT
;PUT WORD INTO LITAB (CONT'D)
;LITFIL IS NOW OPEN FOR OUTPUT
STSHL3: MOVEI TE,FULLIT ; BUMP WORD COUNT
ADDM TE,LITBLK ; LIKE THIS
MOVSI TE,-FULLIT ; CREATE
HRR TE,LITLOC ; IOWD LIST FOR
SETZ TD, ; OUTPUT
OUT LIT,TE ; WRITE IT
JRST STSHL4 ; OK -
MOVEI CH,LITDEV## ; ERROR - DIE
JRST DEVDED## ; AGGGGGHH!
STSHL4: MOVE TD,LITLOC ; MOVE
MOVSI TE,FULLIT+1(TD) ; WORDS
HRRI TE,1(TD) ; UP
MOVN TD,[XWD FULLIT,FULLIT] ; FROM
ADDB TD,LITNXT ; BOTTOM
BLT TE,(TD) ; OF TABLE
MOVNI TE,FULLIT ; UPDATE
SKIPE CURLIT ; ANY NON-ZERO
ADDM TE,CURLIT## ; CURLIT
MOVE TA,[SAVEAC+1,,TD] ; RESTORE
BLT TA,TB ; THE AC'S
MOVE TA,SAVEAC ; WE SAVED
JRST STASHL ; AND TRY AGAIN
;ENTER FAILURE
STSHL5: OUTSTR [ASCIZ "?Cannot ENTER "]
MOVEI DA,LITDEV ; GET DEVICE
HRRZ I2,TD ; GET ERROR CODE
JRST ERATYP## ; GO CROAK
;LITSET OUTPUT LITAB TO AS3FIL (LITS-O-MANIA)
;
;CALLED VIA THE INFAMOUS PUSHJ
;
;
LITSET: TSWT FAS3; ; ARE WE USING AS3FIL ALREADY?
SWON FAS3; ; NO - START NOW
MOVE TE,EAS3PC ; GET CURRENT ASY PC
MOVEM TE,LITBAS## ; STASH
SETZM EAS3PC## ; RESET
HRRZ TC,LITLOC ; WE MUST SET UP AC TE
HRRZ TE,LITNXT ; IN CASE WE DON'T READ ANYTHING
SUB TE,TC ; OFF DISK, AND IT DOESN'T GET SET UP THAT WAY
SKIPLE LITBLK ; LITFIL OPEN?
PUSHJ PP,LITS03 ; YES -
HRRZ TA,LITLOC ; NO - GET BASE ADDRESS
AOS TA ; BUMP BY ONE
HRLZI CH,AS.REL##+1B35 ; RELOC
HRRI CH,AS.MSC## ; MISC ADDRESS
PUSHJ PP,PUTASN ; PUT ON ASYFIL
HRRZI CH,AS.LIT## ; RELOC %LIT+0
PUSHJ PP,PUTASN
LITS00: MOVS TB,(TA) ; GET A LITAB WORD
MOVS CH,LITSTB(TB) ; GET ASY OP-CODE
MOVE TC,TB ; SAVE FOR LATER
HLRZS TB ; GET WORD COUNT (LITTAB STYLE)
MOVE TD,TB ; GET INTO AC WE CAN PLAY WITH
IDIV TD,LITST2(TC) ; CONVERT TO NUMBER OF GENERATED WORDS
ADDM TD,EAS3PC ; BUMP ASYFIL PC
CAMN CH,[XWD AS.BYT,0] ; IS BYTE POINTER?
JRST .+3 ; YES - TREAT A BIT SPECIAL
HRRM TD,CH ; STICK WC IN ASYFIL WORD
PUSHJ PP,PUTASN ; OUTPUT THE WORD
AOS TA ; INCREMENT INDEX
SOJG TE,.+2 ; ANY LEFT?
PUSHJ PP,LITS10 ; NO - GO GET ANOTHER HELPING
LITS01: MOVE CH,(TA) ; GET ANOTHER WORD
PUSHJ PP,PUTASN ; OUTPUT IT
SOJE TB,LITS02 ; JUMP OUT IF DONE
AOS TA ; ELSE BUMP INDEX
SOJG TE,.+2 ; NO MORE ROOM?
PUSHJ PP,LITS10 ; YES - GET SOME MORE
JRST LITS01 ; LOOP
LITS02: AOS TA ; BUMP INDEX
SOJG TE,.+2 ; ANY ROOM LEFT?
PUSHJ PP,LITS12 ; NO
JRST LITS00 ; LOOP
;LITSET (CONT'D)
;
LITS03: HRRZ TA,LITLOC ; GET BASE OF LITTAB
HRRZ TE,LITNXT ; GET TOP
CAMN TA,TE ; IS TABLE ZERO SIZE?
JRST LITS04 ; YES - NOTHING TO WRITE
SUB TE,TA ; TE NOW HAS WORD COUNT
ADDM TE,LITBLK ; UPDATE WORD COUNT
MOVNS TE ; CREATE IOWD
HRLZS TE ; LIST FOR
HRR TE,LITLOC ; WRITING LITFIL
SETZ TD, ; MARK END OF LIST
OUT LIT,TE ; OUTPUT
JRST LITS04 ; ALL OK
MOVEI CH,LITDEV ; BAD
JRST DEVDED ; GO TO THE DEVICES GRAVEYARD
LITS04: CLOSE LIT, ; CLOSE OUTPUT
MOVE TE,LITHDR ; GET FILE NAME
HLLZ TD,LITHDR+1 ; AND EXTENSION
SETZB TC,TB ; ZERO PROT AND PPN
LOOKUP LIT,TE ; OPEN FOR INPUT
JRST STSHL5 ; BUMMER - GO ELSEWHERE TO DIE
LITS05: MOVE TB,LITBLK ; GET WORD COUNT
CAIGE TB,FULLIT ; COMPARE TO MAX BUFFER
JRST LITS09 ; NOT FULL BUFFER LEFT
LITS06: HLRE TE,LITLOC ;
MOVMS TE
CAILE TE,FULLIT ; ?
JRST LITS07 ; YES - OK
PUSHJ PP,XPNLIT ; NO - EXPAND IT
JRST LITS06 ; LOOP AND CHECK AGAIN
LITS07: MOVNI TE,FULLIT ; GET WORD COUNT
ADDM TE,LITBLK ; SUBTRACT FROM MASTER WORD COUNT
MOVSI TE,-FULLIT ; CREATE IOWD
PUSH PP,[FULLIT] ; STASH WORD COUNT
LITS08: HRR TE,LITLOC ; GET ADDR HALF OF IOWD
SETZ TD, ; MARK END
IN LIT,TE ; GRAB SOME WORDS
JRST LITS8A ; ALL OK
MOVEI CH,LITDEV ; SAY WHO DIED
JRST DEVDED ; AND PLACE TO DO IT
;LITSET (CONT'D)
;
LITS8A: POP PP,TE ; RECOVER WORD COUNT
POPJ PP, ; EXIT
LITS09: SETZM LITBLK ; ZAP WORD COUNT
PUSH PP,TB ; SAVE WORD COUNT
MOVNS TB ; GET READY FOR IOWD
HRLZ TE,TB ; TRANSFER
JRST LITS08 ; GO DO REST
LITS10: SKIPG LITBLK ; ANY LEFT?
JRST LITS14 ; NO - ERROR
LITS11: PUSH PP,TB ; SAVE AC
PUSHJ PP,LITS05 ; GO GET SOME
POP PP,TB ; RESTORE AC
HRRZ TA,LITLOC ; GET NEW LITLOC
AOS TA ; AND BUMP LITLOC
POPJ PP, ; AND TRY AGAIN
LITS12: SKIPLE LITBLK ; ANY LEFT?
JRST LITS11 ; YES -
POP PP,TB ; POP OFF A ADDRESS SO WE RETURN TO RIGHT PLACE
POPJ PP, ; NO - EXIT
LITS14: OUTSTR [ASCIZ "?Short LITTAB in phase E
"]
JRST KILLF## ; GO DIE AND DUMP
;LITSET (CONT'D) TABLES USED BY LITSET
;
LITSTB: EXP 0 ; DUMMY WORD
EXP AS.XWD## ; XWD
EXP AS.BYT## ; BYTE POINTER
EXP AS.ASC## ; ASCII CONSTANT
EXP AS.SIX## ; SIXBIT CONSTANT
EXP AS.D1## ; 1-WORD DECIMAL CONSTANT
EXP AS.D2## ; 2-WORD DECIMAL CONSTANT
EXP AS.FLT## ; FLOATING POINT CONSTANT
EXP AS.OCT## ; OCTAL CONSTANT
LITST2: OCT 0 ; DUMMY WORD
OCT 2 ; XWD
OCT 2 ; BYTE POINTER
OCT 1 ; ASCII
OCT 1 ; SIXBIT
OCT 1 ; 1-WORD DECIMAL
OCT 1 ; 2-WORD DECIMAL
OCT 2 ; FLOATING POINT
OCT 1 ; OCTAL
;
;SH1AC1 ROUTINE TO ALLIGN AC1 WITH RESULT FIELD
;
;
;
SH1AC1: MOVE TD,TC ; GET RESULT FIELD DECIMAL COUNT
SUB TD,OP1DEC## ; TD = R - F1
JUMPE TD,SH11.1 ; NO NEED TO SHIFT IF THEY'RE THE SAME
SH11.2: HRLZI CH,AC1 ; GET AC1 CODE
MOVE TB,OP1DEC ; GET DECIMAL PLACES
MOVEM TB,EDEC## ; STORE FOR UPDATE
MOVE TB,OP1SIZ## ; GET SIZE
MOVEM TB,ESIZ## ; STASH THAT TOO
PUSHJ PP,SHFTAC ; SHIFT THAT AC
MOVE TB,EDEC ; GET BACK NEW DEC POSITS
MOVEM TB,OP1DEC ; STASH
MOVE TB,ESIZ ; GET BACK SIZE
MOVEM TB,OP1SIZ ; STORE
SH11.1: POPJ PP, ; EXIT
;
;SH2AC3 ROUTINE TO ALLIGN AC3 WITH RESULT FIELD
;
;
;
SH2AC3: MOVE TD,TC ; GET RESULT FIELD COUNT
SUB TD,OP2DEC## ; TD = R - F2
JUMPE TD,SH11.1 ; DON'T SHIFT IF EQUAL
SH23.1: HRLZI CH,AC3 ; PUT IT IN AC3
MOVE TB,OP2DEC ; GET DECIMAL PLACES
MOVEM TB,EDEC ; STASH
MOVE TB,OP2SIZ## ; GET SIZE
MOVEM TB,ESIZ ; STASH THAT TOO
PUSHJ PP,SHFTAC ; <<<<<<<<SHIFT<<<<<<<
MOVE TB,EDEC ; GET BACK DEC PLACES
MOVEM TB,OP2DEC ; STORE
MOVE TB,ESIZ ; GET
MOVEM TB,OP2SIZ ; STORE
POPJ PP, ; EXIT
;
;SH2AC1 ROUTINE TO ALLIGN AC1 WITH RESULT FIELD
;
;
;
SH2AC1: MOVE TD,TC ; GET R DECIMAL COUNT
SUB TD,OP2DEC ; GET AMOUNT TO SHIFT
JUMPE TD,SH11.1 ; DON'T SHIFT IF WE DON'T NEED TOO
SH21.1: HRLZI CH,AC1 ; [353] SHIFT AC1 DUMMY
JRST SH23.1+1 ; GO DO THE REST
;
;SH1AC3 ROUTINE TO ALLIGN AC3 WITH RESULT FIELD
;
;
;
SH1AC3: MOVE TD,TC ; GET RESULT DECIMAL COUNT
SUB TD,OP1DEC ; GET SHIFT COUNT
JUMPE TD,SH11.1 ; NO NEED TO SHIFT
SH13.1: HRLZI CH,AC3 ; [353] AC3 TURKEY!
JRST SH11.2+1 ; GO DO IT TO IT
;SHFTAC ROUTINE TO SHIFT AC
;
;
;
SHFTAC: JUMPL TD,SHFT4 ; MUST DIVIDE (RIGHTWARD SHIFT)
ADDM TD,EDEC ; UPDATE
ADDM TD,ESIZ ; LIKEWISE
MOVE TB,ESIZ ; GET SIZE
CAILE TB,^D10 ; > 10?
JRST SHFT2 ; YES -
ADD CH,[XWD IMUL.+ASINC,AS.MSC]
PUSHJ PP,PUTASY
SKIPN CH,PWR10-1(TD) ; POWER DEFINED?
PUSHJ PP,SHFT1 ; NO - STASH IN LITERAL POOL
PUSHJ PP,PUTASN ; OUTPUT AS OPERAND
POPJ PP, ; EXIT
;GET POWER OF TEN AND STASH IN LITERAL POOL
SHFT1: MOVE CH,ELITPC ; GET LITAB PC
TRO CH,AS.LIT ; FLAG AS LINK
MOVEM CH,PWR10-1(TD) ; STORE ADDRESS FOR LATER
MOVE TA,[XWD D1LIT,1] ; GET HEADER
PUSHJ PP,STASHL ; OUTPUT IT
MOVE TA,POWR10(TD) ; GET VALUE
PUSHJ PP,STASHL ; OUTPUT IT
AOS ELITPC ; BUMP PC
POPJ PP, ; EXIT
;MUST WORK WITH DOUBLE PRECISION
SHFT2: CAIG TD,^D10 ; A BIGGY?
JRST SHFT3B ; NO -
PUSH PP,CH ; YES - SAVE SOME STUFF
PUSH PP,TD ; ON THE STACK
ADD CH,[XWD MUL.+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; PUT OUT THE MUL
MOVEI TD,^D10 ; MULTIPLY BY 10**10
SKIPN CH,PWR10-1(TD) ; DEFINED YET?
PUSHJ PP,SHFT1 ; NO - GO DEFINE IT
PUSHJ PP,PUTASN ; OUTPUT THE ADDRESS
POP PP,TD ; DO SOME RESTORATION
POP PP,CH ;
SUBI TD,^D10 ; DECREMENT SHIFT COUNT
SHFT3: ADD CH,[XWD MUL.21+ASINC,AS.MSC]
SHFTX: MOVMS TD ; [360] take magnitude
PUSHJ PP,PUTASY ; OUTPUT THE INSTR.
SKIPN CH,PWR10-1(TD) ; DEFINED?
PUSHJ PP,SHFT1 ; NO -
PUSHJ PP,PUTASN ; OUTPUT ADDRESS
POPJ PP, ; EXIT -
;SHFTAC (CONT'D) SEE IF WE MUST CONVERT TO DOUBLE PRECISION
;
SHFT3B: SUB TB,TD ; GET THE ORIGINAL SIZE
CAILE TB,^D10 ; WAS IT SINGLE PRECISION
JRST SHFT3 ; NO - IS ALREADY DOUBLE
PUSH PP,CH ; YES - CONVERT TO DOUBLE
ADD CH,[XWD MULI.,AS.CNS+1] ; GENERATE A <MULI AC,1>
PUSHJ PP,PUTASY ; OUTPUT IT
POP PP,CH ; RESTORE THE AC
JRST SHFT3 ; CONTINUE
;SHFTAC (CONT'D) MUST DO A RIGHT SHIFT. USE DIVIDE
;
;
;
SHFT4: ADDM TD,EDEC ; [360] update decimal coount
MOVE TC,ESIZ ; GET SIZE OF FIELD
CAILE TC,^D10 ; > 10?
JRST SHFT5 ; YES -
TSWF FROUND; ; DO WE NEED TO HALF-ADJUST?
PUSHJ PP,ROUND ; YES -
ADD CH,[XWD IDIV.+ASINC,AS.MSC]
ADDM TD,ESIZ ; [360] DECREMENT SIZE
JRST SHFTX ; GO OUTPUT POWER OF TEN
SHFT5: TSWF FROUND; ; must we round?
PUSHJ PP,ROUND ; yes - do so then
MOVE TC,ESIZ ; GET SIZE
ADDM TD,ESIZ ; [360] decrement size
CAIG TC,^D10 ; > 10 ?
JRST SHFT6 ; NO -
ADD CH,[XWD DIV.21+ASINC,AS.MSC]
JRST SHFTX ; GET OUTPUT 10**TD
SHFT6: MOVMS TD ; [360] take magnitude
CAILE TD,^D10 ; TD > 10?
JRST SHFT7 ; YES -
ADD CH,[XWD DIV.+ASINC,AS.MSC]
JRST SHFTX ; GO FINISH IN LAPLAND OF COURSE
SHFT7: PUSH PP,CH
PUSH PP,TD ; SAVE SOME TIDBITS
ADD CH,[XWD DIV.+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT DIVIDE
MOVEI TD,^D10 ; DIVIDE BY 10**10
SKIPN CH,PWR10##-1 ; DEFINED?
PUSHJ PP,SHFT1 ; NO - GO DO IT
PUSHJ PP,PUTASN ; MUST BE BY NOW
POP PP,TD ; POP TIDBITS OFF STACK
POP PP,CH ;
SUBI TD,^D10 ; DECREMENT SHIFT COUNT
TSWF FROUND; ; DO WE NEED TO ROUND ALSO?
PUSHJ PP,ROUND ; YES -
ADD CH,[XWD IDIV.+ASINC,AS.MSC]
JRST SHFTX ; GO OFF INTO THE SUNSET
;
;ROUND GENERATE CODE TO ROUND THE AC'S
;
; ENTER WITH AC IN CH, SHIFT COUNT IN TD; THESE AC'S ARE
; PRESERVED THRUOUT THE ROUTINE.
;
;
;
ROUND: PUSH PP,CH ; STASH THESE
PUSH PP,TD ; ON THE STACK
MOVMS TD ; [360] take magnitude of dec pos
MOVEM CH,EAC## ; STORE AC
LSH CH,-5 ; GET AC INTO FAR RIGHT HALF
HRRI CH,SKIPL. ; GENERATE <SKIPL AC>
MOVSS CH ; GET DATA INTO PROPER HALVES
PUSHJ PP,PUTASY ; OUTPUT IT
SKIPN CH,RPWR10##-1(TD) ; IS FACTOR DEFINED?
PUSHJ PP,ROUND4 ; NO - GO PUT IN LITERAL POOL
MOVEM CH,ESAVAC## ; STORE FOR LATER USE
MOVEM CH,RPWR10-1(TD) ; STORE ADDRESS
MOVE CH,[XWD SKIPA.+AC5,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <SKIPA 5,[LIT]>
MOVE CH,ESAVAC ; GET LITERAL
PUSHJ PP,PUTASN ; OUTPUT IT
MOVE CH,[XWD MOVN.+AC5,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <MOVN 5,[LIT]>
MOVE CH,ESAVAC ; GET LITERAL
PUSHJ PP,PUTASN ; OUTPUT IT
MOVE TB,ESIZ ; GET SIZE
CAILE TB,^D10 ; DOUBLE PRECISION?
JRST ROUND3 ; NO -
;AC'S CONTAIN SINGLE PRECISION
ROUND1: MOVE CH,EAC ; GET AC
ADD CH,[XWD AD,5] ; GENERATE <ADD AC,5>
PUSHJ PP,PUTASY ; OUTPUT IT
ROUND2: POP PP,TD ; RESTORE DATA
POP PP,CH ;
POPJ PP, ; EXIT
;AC'S CONTAIN DOUBLE PRECISION
ROUND3: MOVE CH,EAC ; GET AC
ADD CH,[XWD ADD.21,5] ; GENERATE <ADD.21 AC,5>
PUSHJ PP,PUTASY ; OUTPUT IT
JRST ROUND2 ; OGO POP OFF
;ROUND (CONT'D) ADD A ROUNDING FACTOR TO THE LITERAL POOL
;
ROUND4: MOVE TA,[XWD D1LIT,1] ; GET HEADER
PUSHJ PP,STASHL ; OUTPUT IT
MOVE TA,ROUNDR-1(TD) ; GET ROUNDING FACTOR
PUSHJ PP,STASHL ; OUTPUT IT AS DATA
HRRZ CH,ELITPC ; GET ADDRESS (LITAB RELATIVE)
TRO CH,AS.LIT ; FLAG IT
AOS ELITPC ; BUMP PC
POPJ PP, ; EXIT
;GT1AC1 GET OPERAND 1 INTO AC1
;
;
GT1AC1: HRLZI TB,AC1 ; STICK IT IN AC1
MOVEM TB,EAC ; TEMP STASH
MOVEI TB,2 ; OP1 IS OPRTR+2
PUSHJ PP,GTFACX ; GO FOR IT
MOVEM TC,OP1DEC ; STORE DECIMAL POSITIONS
MOVEM TD,OP1SIZ ; STASH SIZE
POPJ PP, ; EXIT
;GT2AC3 GET OPERAND 2 INTO AC3
;
;
GT2AC3: HRLZI TB,AC3 ; STICK IT IN AC3
MOVEM TB,EAC ; PUT HERE FOR NOW
MOVEI TB,3 ; OP2 IS OPRTR+3
PUSHJ PP,GTFACX ; GO GET IT
MOVEM TC,OP2DEC ; STASH DEC POSITIONS
MOVEM TD,OP2SIZ ; STORE FIELD SIZE
POPJ PP, ; EXIT
;GT1AC3 GET OPERAND 1 INTO AC3
;
;
GT1AC3: HRLZI TB,AC3 ; PUT IT IN AC3
JRST GT1AC1+1 ; GO DO THE REST
;GT2AC1 GET OPERAND 2 INTO AC1
;
;
GT2AC1: HRLZI TB,AC1 ; AC1 IS THE ONE FOR ME
JRST GT2AC3+1 ; ME TOO
;GTFACX GET AN OPERAND INTO AN AC
;
;
;
GTFACX: SWOFF FPUT; ; TURN ME OFF
HRRZ TA,OPRTR(TB) ; GET LINK TO ITEM
PUSHJ PP,LNKSET## ; SET THOSE LINKERS!
LDB TC,[POINT 1,OPRTR(TB),1]; GET LITERAL FLAG
JUMPN TC,GTF.03 ; ONE O' THOSE LITTLE BASTARDS
LDB TC,DA.ARE## ; GET ARRAY ENTRY FLAG
JUMPN TC,GTF.09 ; LEAP IF ARRAY ENTRY
LDB TC,DA.SIZ ; GET SIZE
JUMPE TC,GTF.1B ; NOT DEFINED -
GTF.00: LDB TC,DA.OCC## ; GET NUMBER OF OCCURS
JUMPN TC,GTF.10 ; LEAP IF WHOLE ARRAY OR TABLE
LDB TC,DA.RSV## ; get reserved word flag
JUMPN TC,GTF.12 ; it is if we jump
LDB TC,DA.FLD## ; GET FIELD TYPE (MUST BE DATAB ITEM)
JUMPE TC,GTF.1A ; CAN'T BE ALPHA
CAIE TC,2 ; BINARY?
JRST GTF.02 ; NO - TREAT AS GODDAMN SIXBIT
GTF.0A: MOVE CH,[XWD MOV+ASINC,AS.MSC##]
ADD CH,EAC ; AND IN THE AC OF OUR CHOICE
PUSHJ PP,PUTASY ; OUTPUT IT
LDB CH,DA.COR## ; GET CORE ADDRESS
TRO CH,AS.DAT## ; FLAG AS DATAB RELATIVE
PUSHJ PP,PUTASN ; OUTPUT THAT TOO
GTF.01: LDB TC,DA.DEC## ; GET DECIMAL POSITIONS TO PLEASE OTHERS
LDB TD,DA.SIZ## ; GET FIELD SIZE TOO
POPJ PP, ; EXIT
GTF.1A: PUSHJ PP,NOTNUM ; ITEM NOT NUMERIC
JRST GTF.02 ; FAKE IT LIKE IT WAS
GTF.1B: PUSH PP,TB ; STASH OPRTR INDEX
LDB TA,DA.NAM ; GET NAMTAB LINK
MOVEI TB,CD.DAT ; GET DATAB ID
PUSHJ PP,FNDLNK ; LOOK FOR LINK
JRST GTF.1D ; NOT FOUND (??)
MOVE TA,TB ; GET LINK INTO PROPER AC
POP PP,TB ; RESTORE OPRTR INDEX
GTF.1C: LDB TC,DA.SIZ ; GET SIZE
JUMPN TC,GTF.00 ; IF WE GOT IT, JUMP OUT AND CONTINUE
LDB TA,DA.SNM## ; GET SAME NAME LINK
JUMPE TA,GTF.1D ; ERROR IF NOT ONE
PUSHJ PP,LNKSET ; SET IT UP
JRST GTF.1C ; LOOP
;GTFACX (cont'd)
;
GTF.1D: LDB TC,[POINT 13,OPRTR,28] ; ELSE GET LINE NUMBER
MOVEM TC,SAVELN ; STASH
CAIE TB,2 ; FACTOR 1?
JRST .+3 ; NO - MUST BE TWO
WARN 704; ; FACTOR 1 NOT DEFINED
JRST GTF.02 ; LET'S PRETEND
WARN 705; ; FACTOR 2 NOT DEFINED
JRST GTF.02
;Get a sixbit operand into an AC
GTF.02: LDB CH,DA.FMT ; GET FORMAT
MOVE CH,GTAB2(CH) ; GET PROPER INSTRUCTION
ADD CH,EAC ; SET UP THE AC
PUSHJ PP,PUTASY ; PUT OUT ONE OR THE OTHER
MOVE CH,ELITPC## ; GET LITTAB PC
TRO CH,AS.LIT## ; FLAG AS LITAB RELATIVE
PUSHJ PP,PUTASN ; PUT OUT INCREMENT WORD
PUSHJ PP,PUTPTR ; OUTPUT PROPER POINTER
JRST GTF.01 ; AND GO FINISH UP
;GTFACX (CONT'D) MOVE A LITERAL TO AN AC
;
GTF.03: SWOFF FMINUS!FDECPT; ; TURN OFF SOME FLAGS
SETZB TC,TD ; CLEAR SUMMER AND DEC COUNTER
SETZ TE, ; AND POSITION COUNTER
HRRZS TA ; CLEAR UP POINTER
ADD TA,[POINT 7,0,6] ; MAKE INTO A BYTE POINTER
ILDB CH,TA ; GET A CHARACTER
CAIN CH,"+" ; [304] unary plus?
JRST GTF.04 ; [304] yes - ignore
CAIE CH,"-" ; IS IT A UNARY MINUS?
JRST GTF.04+1 ; NO -
SWON FMINUS; ; YES - TURN ON NEGATE FLAG
GTF.04: ILDB CH,TA ; GET ANOTHER CHARACTER
CAIN CH,"." ; A DECIMAL?
JRST GTF.4B ; YES - GO TURN ON FLAG
CAIN CH,"_" ; NO - A EOL?
JRST GTF.05 ; YES - ALL DONE HERE
IMULI TC,12 ; NO - SHIFT SUM
ADDI TC,-"0"(CH) ; ADD IN NEW DIGIT
TSWF FDECPT; ; IS DECIMAL COUNTER ON?
ADDI TD,1 ; YES - BUMP COUNTER
ADDI TE,1 ; BUMP ALL COUNTER
JRST GTF.04 ; NO - LOOP
GTF.4B: SWON FDECPT; ; TURN ON COUNTER FLAG
JRST GTF.04 ; AND GET ANOTHER CHARACTER
GTF.05: TSWF FMINUS; ; UNARY MINUS SEEN?
MOVNS TC ; YES - NEGATE
GTF.06: TLNE TC,777777 ; ARE WE ONLY USING LOW ORDER 18 BITS?
JRST GTF.07 ; YES - CANNOT USE MOVEI
MOVE CH,[XWD MOVEI.+ASINC,AS.CNB]
ADD CH,EAC ; SETUP AC
PUSHJ PP,PUTASY ; OUTPUT THE MOVEI
HRRZ CH,TC ; GET CONSTANT
PUSHJ PP,PUTASN ; PUT IT IN ADDRESS FIELD
JRST GTF.08 ; GO FINISH UP
;GTFACX (CONT'D) COME HERE WHEN WE MUST USE A MOVE OF A LITAB CONSTANT
;
;
;
GTF.07: MOVE CH,[XWD MOV+ASINC,AS.MSC]
ADD CH,EAC ; SET UP AC ENTRY
PUSHJ PP,PUTASY ; OUTPUT IT
MOVE CH,ELITPC ; GET A LITAB ENTRY
TRO CH,AS.LIT ; MARK AS LITAB RELATIVE
PUSHJ PP,PUTASN ; OUTPUT AS ADDRESS
PUSH PP,TE ; [353] save counter
MOVE CH,[XWD D1LIT,1] ; ONE DECIMAL CONSTANT
PUSHJ PP,STASHC ; STICK IT IN LITAB
MOVE CH,TC ; GET CONSTANT
PUSHJ PP,STASHC ; OUTPUT IT
AOS ELITPC ; BUMP LITAB PC
POP PP,TE ; [353] restore digit count
GTF.08: MOVE TC,TD ; TO EACH HIS OWN
MOVE TD,TE ; PLACE IN FOURSPACE
POPJ PP, ; OFF WE GO, INTO THE WILD BLUE YONDER.....
;GTFACX (CONT'D) HANDLE ARRAY ENTRY
;
GTF.09: PUSH PP,TA ; SAVE DATAB POINTER
LDB TA,DA.ARP## ; GET ARRAY POINTER
PUSHJ PP,LNKSET ; SET IT UP
LDB TC,DA.FLD ; GET FIELD TYPE
JUMPE TC,NOTNUM ; ERROR IF NOT NUMERIC
GTF.9E: LDB TD,DA.OCC ; GET NUMBER OF OCCURS
MOVEM TA,CURDAT## ; STASH POINTER
POP PP,TA ; RESTORE DATAB POINTER
LDB TC,DA.IMD## ; GET IMMEDIATE FLAG
JUMPE TC,GTF.9B ; IS NOT IMMEDIATE
LDB TC,DA.INP## ; IS IMMEDIATE - GET INDEX
CAMLE TC,TD ; IS INDEX IN BOUNDS?
JRST GTF.9D ; NO - ERROR
HRRZ CH,TC ; GET INDEX INTO PROPER AC
HRLI CH,<MOVEI.+AC0> ; GENERATE <MOVEI 0,INDEX>
PUSHJ PP,PUTASY ; OUTPUT IT
GTF.9A: EXCH TA,CURDAT ; GET ARRAY POINTER
MOVE CH,[XWD SUBSCR+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE SUBSCRIPT CALL
MOVE CH,ELITPC ; GET LITAB PC
TRO CH,AS.LIT ; MARK AS LITAB ITEM
PUSHJ PP,PUTASN ; OUTPUT IT
PUSHJ PP,PUTPT2 ; OUTPUT BYTE POINTER TO LITAB
MOVE CH,[XWD XWDLIT,2] ; GET READY TO OUTPUT 2 BYTES
PUSHJ PP,STASHC ; OUTPUT HEADER TO SAY ITS COMING
LDB CH,DA.OCC ; GET NUMBER OF OCCURS
TSWF FWHOLE; ; whole array?
MOVE CH,WHOSIZ ; yes - use preset size
PUSHJ PP,STASHC ; OUTPUT AS RH
LDB CH,DA.SIZ ; GET SIZE OF ENTRY
PUSHJ PP,STASHC ; OUTPUT AS LH
AOS ELITPC ; BUMP THE PC
TSWF FWZARD; ; IS IT SORCEROUS?
POPJ PP, ; YES - GET THEE HENCE FOUL THAUMATURGIST
MOVE CH,[XWD TLZ.+AC0,AS.CNS+3777]
PUSHJ PP,PUTASY ; OUTPUT CODE TO CLEAR PART OF POINTER
LDB CH,DA.SIZ ; GET SIZE OF FIELD
HRLI CH,<TLO.+AC0> ; GENERATE <TLO 0,SIZE-OF-FIELD>
PUSHJ PP,PUTASY ; OUTPUT INSTRUCTION
LDB CH,DA.FMT ; GET FORMAT OF FIELD
TSWF FPUT; ; ARE WE PUTTING OR GETTING
SKIPA CH,PTAB1(CH) ; PUTTING
MOVE CH,GTAB1(CH) ; GETTING
ADD CH,EAC ; ADD IN AC WE ARE USING
PUSHJ PP,PUTASY ; OUTPUT IT
LDB TD,DA.SIZ ; get the size for others
LDB TC,DA.DEC ; likewise with decimals
POPJ PP, ; EXIT
;GTFACX (CONT'D) CONTINUE HANDLEING OF ARRAY ENTRY
;
GTF.9B: PUSH PP,TA ; SAVE AC
PUSH PP,EAC ; SAVE THE AC WE'RE USING
MOVSI TC,AC0 ; USE AC0 FOR NOW
MOVEM TC,EAC ;
LDB TA,DA.INP ; GET POINTER TO INDEX
PUSHJ PP,GTFLD+1 ; GET THAT FIELD
JUMPE TC,GTF.9D ; IS BAD
CAIN TC,2 ; BINARY?
JRST GTF.9C ; YES -
PUSHJ PP,GTF.02 ; NO - BORROW A ROUTINE
POP PP,EAC ; RESTORE
POP PP,TA ; RESTORE
JRST GTF.9A ; GO FINISH UP
GTF.9C: PUSHJ PP,GTF.0A ; STEAL ANOTHER ROUTINE
POP PP,EAC ; RESTORE
POP PP,TA ; RESTORE
JRST GTF.9A ; CONTINUE
GTF.9D: WARN 228; ; INVALID INDEX
POPJ PP,
GTAB1: XWD GD6.,AS.CNS+0
XWD GD7.,AS.CNS+0
XWD 0,0
GTAB2: XWD GD6.+ASINC,AS.MSC
XWD GD7.+ASINC,AS.MSC
XWD 0,0
;GTFACX (CONT'D) HANDLE WHOLE ARRAY OR TABLE
;
GTF.10: LDB TC,DA.FLD ; GET FIELD TYPE
JUMPE TC,NOTNUM ; MUST BE NUMERIC
LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC## ; MAKE INTO REAL POINTER
HLRZ TC,1(TC) ; GET FIRST 3 CHARACTERS
CAIE TC,'TAB' ; IS IT A TABLE?
JRST GTF.11 ; NO - IS WHOLE ARRAY
MOVE CH,[XWD MOV+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT <MOVE 0,143>
LDB CH,DA.COR## ; get assigned core location
MOVEI CH,AS.DAT-1(CH) ; identify and decrement
PUSHJ PP,PUTASN ; output address field
JRST GTF.9A+1 ; GO FINISH
;HANDLE WHOLE ARRAY
GTF.11: MOVE CH,[XWD MOV+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <MOVE 0,INDEX>
MOVE CH,WHOLOC## ; GET LITAB ADDRESS OF INDEX
TRO CH,AS.LIT ; SAY WHERE IT CAME FROM
PUSHJ PP,PUTASN ; OUTPUT IT
JRST GTF.9A+1 ; GO OUTPUT REST OF CODE
;Handle reserved word
GTF.12: MOVE CH,[XWD RSVWD.+ASINC,AS.CNB]
PUSHJ PP,PUTASY ; output the UUO call
SETZ CH, ; zap our ASYFIL word
LDB TD,DA.SIZ ; get size of field
DPB TD,[POINT 4,CH,25] ; stash
SUBI TC,1 ; decrement the reserved word id
DPB TC,[POINT 4,CH,29] ; stash that too
LDB TC,[POINT 4,EAC,12] ; get the AC
DPB TC,[POINT 4,CH,21] ; stash in output word
PUSHJ PP,PUTASN ; output
JRST GTF.01 ; and exit
;PTRAC3 ROUTINE TO MOVE RESULT FROM AC3 TO CORE
;
;
;
PTRAC3: HRLZI TB,AC3 ; GET AC3
PUTAC: MOVEM TB,EAC## ; STASH AS AC TO USE
HRRZ TA,OPRTR##+4 ; GET RESULT LINK
PUSHJ PP,LNKSET ; SET UP LINK
LDB TC,DA.RSV ; get reserved word flag
JUMPN TC,PUTAC2 ; is reserved word - check it out
LDB TC,DA.LHI## ; get look-ahead flag
JUMPN TC,PUTAC1 ; thats a no-no too
HRRZ TC,OPRTR+1 ; GET RESULTING INDICATORS
JUMPE TC,PTR2.2 ; SKIP OVER CODE IF NONE
LDB TD,DA.SIZ ; GET SIZE OF FIELD
MOVE CH,[XWD SETZM.,1] ; GENERATE <SETZM 1>
PUSHJ PP,PUTASY ; THUSLY
ADDI CH,1 ; MAKE IT INTO A <SETZM 2>
CAIG TD,^D10 ; IS IT DOUBLE PRECISION?
PUSHJ PP,PUTASY ; YES - PUT OUT SECOND SETZM
CAIG TD,^D10 ; DOUBLE AGAIN?
SKIPA CH,[XWD CMP.11,0] ; NO - GENERATE <CMP.11>
MOVE CH,[XWD CMP.22,0] ; YES - GENERATE <CMP.22>
MOVE TD,EAC ; GET AC FIELD
LSH TD,-5 ; SHIFT IT AROUND
HLR CH,TD ; STICK IN OUTPUT WORD
PUSHJ PP,PUTASY ; OUTPUT APPROPRIATE INSTRUCTION
PUSH PP,TA ; SAVE DATAB POINTER
MOVE TA,TC ; GET INDTAB POINTER
PUSHJ PP,LNKSET ; SET IT UP
MOVE CH,[XWD AS.OCT,1] ; SET UP FOR OCTAL CONSTANT
PUSHJ PP,PUTASY ; OUTPUT HEADER
LDB TC,[POINT 8,(TA),7] ; SWAP > AND < BECAUSE WE MUST
LDB TD,[POINT 8,(TA),15] ; DO THE COMPARISON IN REVERSE
DPB TC,[POINT 8,(TA),15] ; ORDER DUE TO THE FACT THAT
DPB TD,[POINT 8,(TA),7] ; CMP DOES NOT ACCEPT AN AC FIELD
MOVE CH,(TA) ; GET INDTAB WORD
PUSHJ PP,PUTASN ; OUTPUT TO ASYFIL
POP PP,TA ; RESTORE DATAB POINTER
JRST PTR2.2 ; continue further on
PUTAC1: GETLN; ; get the line number
WARN 227; ; reserved word is literal or look-ahead
POPJ PP, ; exit
PUTAC2: CAILE TC,4 ; is it one of the PAGE's?
JRST PUTAC3 ; no - error
MOVE CH,[XWD RSVWD.+ASINC,AS.CNB]
PUSHJ PP,PUTASY ; output it
SETZ CH, ; zap an AC
TRO CH,1B30 ; say we are storing
JRST GTF.12+3 ; finish up
PUTAC3: GETLN; ; get the line number
WARN 226; ; reserved word other than PAGE invalid
POPJ PP, ; exit
;PTRAC3 (CONT'D)
;DECIDE WHICH TYPE OF MOVE WE MUST DO
PTR2.2: LDB TC,DA.ARE ; IS IT AN ARRAY ENTRY?
JUMPN TC,PTR2.3 ; MUST BE IF WE JUMPED
PUSHJ PP,GTFPT ; GET RESULT FIELD
LDB TD,DA.OCC ; GET NUMBER OF OCCURS
JUMPN TD,PTR2.4 ; MUST BE WHOLE ARRAY OR TABLE
TSWF FWHOLE; ; whole array?
JRST PTR2.4 ; yes -
CAIE TC,2 ; BINARY?
JRST PTR2.1 ; NO -
MOVE CH,[XWD MOVEM.+ASINC,AS.MSC]
ADD CH,EAC ; GET AC
PUSHJ PP,PUTASY ; YES - CAN USE STRAIGHT MOVE
LDB CH,DA.COR ; GET CORE POINTER
TRO CH,AS.DAT ; FLAG AS DATAB RELATIVE
PUSHJ PP,PUTASN ; PUT OUT ADDRESS FIELD
LDB TC,DA.SIZ ; GET SIZE OF FIELD
CAIGE TC,^D10 ; SINGLE PRECISION?
POPJ PP, ; YES - EXIT
PUSH PP,CH ; NO - SAVE ADDRESS FIELD
MOVE CH,[XWD MOVEM.+ASINC,AS.MSC]
ADD CH,EAC ; ADD IN THE AC
ADDI CH,1 ; BUT WE WANT AC+1
PUSHJ PP,PUTASY ; WE MUST DO DOUBLE MOVE
POP PP,CH ; GET BACK ADDRESS
ADDI CH,1 ; INCREMENT ADDRESS BY 1
PUSHJ PP,PUTASN ; OUTPUT THE ADDRESS
POPJ PP, ; EXIT
GTFPT: HRRZ TA,OPRTR+4 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET IT UP
LDB TC,DA.FLD ; GET FIELD TYPE
LDB TD,DA.SIZ ; GET SIZE
JUMPN TD,CPOPJ## ; EXIT IF FOUND
PUSH PP,TB ; SAVE TB
LDB TA,DA.NAM ; GET NAMTAB LINK
MOVEI TB,CD.DAT ; GET PLACE TO LOOK
PUSHJ PP,FNDLNK ; LOOK
JRST GTFPT2 ; NOT FOUND
MOVE TA,TB ; GET PROPER LINK
POP PP,TB ; RESTORE TB
GTFPT1: LDB TD,DA.SIZ ; GET SIZE
LDB TC,DA.FLD ; GET FIELD TYPE
PJUMPN TD,CPOPJ ; EXIT IF FOUND
LDB TA,DA.SNM ; GET LINK
PJUMPE TA,FNDFL1 ; ERROR IF NONE
PUSHJ PP,LNKSET ; ELSE SET UP LINK
JRST GTFPT1 ; AND LOOP
GTFPT2: POP PP,TB ; RESTORE TB
PJRST FNDFL1 ; GO TYPE ERROR
;PTRAC3 (CONT'D)
;COME HERE IF WE MUST CONVERT FROM SIXBIT TO COMP
;
PTR2.1: LDB CH,DA.FMT ; GET FORMAT
MOVE CH,PTAB2(CH) ; GET THAT INSTRUCTION
ADD CH,EAC ; ADD IN PROPER AC
MOVE TA,OPRTR+4 ; GET RESULT FIELD POINTER
PUSHJ PP,LNKSET ; SET IT UP
LDB TB,DA.SIZ ; GET SIZE OF RESULT
CAILE TB,^D10 ; DOUBLE PRECISION?
JRST PTR2.6 ; [353] yes - make sure value in AC is
MOVE TB,OP2SIZ ; NO - IS NUMBER IN AC'S DOUBLE?
CAILE TB,^D10 ; ?
ADD CH,[XWD AC1,0] ; YES - USE LOW ORDER AC ONLY
PTR2.7: PUSHJ PP,PUTASY ; [353] output a PD6.
MOVE CH,ELITPC ; GET A LITAB POINTER
TRO CH,AS.LIT ; LITAB RELATIVE
PUSHJ PP,PUTASN ; OUTPUT
PJRST PUTPTR ; OUTPUT BYTE POINTER
PTR2.3: SWON FPUT; ; SAY WE'RE PUTTING
PUSHJ PP,PTR2.5 ; CHECK FOR GODAMN AC0
JRST GTF.09 ; GO DO IT
PTR2.4: SWON FPUT; ; PUT-PUT
PUSHJ PP,PTR2.5 ; UGH
JRST GTF.10 ; GO
PTR2.5: MOVE TC,EAC ; GET OUR AC
CAIE TC,AC5 ; IS IT GODAMN AC5?
POPJ PP, ; NO - HURRAH
MOVE CH,[XWD MOV+AC3,5] ; MOVE AC3_AC5
PUSHJ PP,PUTASY
MOVE CH,[XWD MOV+AC4,6] ; MOVE AC4_AC6
PUSHJ PP,PUTASY ; OUTPUT IT
MOVE TC,AC3 ; GET AC3
MOVEM TC,EAC ; USE AAS NEW AC
POPJ PP, ; EXIT
PTR2.6: MOVE TB,OP2SIZ ; [353] get size of value in AC
CAILE TB,^D10 ; [353] double precision?
JRST PTR2.7 ; [353] yes -
PUSH PP,CH ; [353] no - must make it so: stash old value
MOVE CH,[XWD MULI.,AS.CNS+1] ; [353] get a <MULI AC,1>
ADD CH,EAC ; [353] load proper AC
PUSHJ PP,PUTASY ; [353] output instruction
POP PP,CH ; [353] restore current partial instruction
JRST PTR2.7 ; [353] and continue...
PTAB1: XWD PD6.,AS.CNS+0
XWD PD7.,AS.CNS+0
XWD 0,0
PTAB2: XWD PD6.+ASINC,AS.MSC
XWD PD7.+ASINC,AS.MSC
XWD 0,0
;PTRAC5 ROUTINE TO MOVE RESULT FROM AC5 TO CORE
;
;
;
PTRAC5: HRLZI TB,AC5 ; GET THAT AC
MOVEM TB,EAC ; STASH
HRRZ TA,OPRTR+2 ; GET THIS
JRST PUTAC+2
;PTRAC1 Routine to move result from AC1 to core
;
;
;
PTRAC1: HRLZI TB,AC1 ; get the AC
JRST PUTAC ; go do the rest elsewhere
;PUTPTR OUTPUT BYTE POINTER TO ITEM IN TA
; (With size imbedded in ptr)
;
;
PUTPTR: MOVE CH,[XWDLIT,,2] ; JUST 1 XWD
PUSHJ PP,STASHC ; AND PUT IT IN LITAB
SETZ CH, ; START ANEW
LDB TC,DA.RES## ; GET BYTE RESIDUE
DPB TC,[POINT 6,CH,5] ; STASH IN WORD
LDB TC,DA.SIZ ; GET SIZE
DPB TC,[POINT 11,CH,17] ; STASH THAT TOO
PUTP: HRRI CH,AS.CNB ; MARK IT
PUSHJ PP,STASHC ; OUTPUT IT
LDB TC,DA.COR ; GET CORE ADDRESS
HRLZ CH,TC ; GET INTO PROPER AC
TLO CH,AS.DAT ; MARK AS DATAB RELATIVE
HRRI CH,AS.MSC ; GOOD OLD MARKER
PUSHJ PP,STASHC ; OUTPUT
AOS ELITPC ; BUMP COUNTER
POPJ PP, ; EXIT
;PUTPT2 Output byte pointer to item in TA with no size imbedded
;
;
;
PUTPT2: MOVE CH,[XWD XWDLIT,2] ; get LITAB header word
PUSHJ PP,STASHC ; output it
SETZ CH, ; zap word
LDB TC,DA.RES ; get byte residue
DPB TC,[POINT 6,CH,5] ; stash in pointer word
LDB TC,DA.FMT ; get format of field
MOVE TC,BYTAB(TC) ; get byte size
DPB TC,[POINT 6,CH,11] ; stash in pointer word
JRST PUTP ; and go finish up
;INDCHK GENERATE CODE TO CHECK FOR PROPER INDICATORS
;
;
;
INDCHK: TSWFZ FINDON; ; DO WE NEED TO PUT OUT A TAG?
PUSHJ PP,FNDTAG ; YES - WELL DO SO TURKEY
HLRZ TA,OPRTR+1 ; GET INDTAB LINK
SKIPN TA ; GOT ONE?
POPJ PP, ; NO - NO NEED FOR CHECK OR TAG NEXT TIME
PUSHJ PP,LNKSET## ; YES - SET UP LINK
MOVE CH,[XWD MOVEI.+AC16+ASINC,AS.MSC##]
PUSHJ PP,PUTASY ; OUTPUT THE UUO
MOVE CH,ELITPC## ; GET LITAB PC
TRO CH,AS.LIT## ; FLAG AS LITAB RELATIVE
PUSHJ PP,PUTASN ; OUTPUT THE ADDRESS FIELD
INDCK1: MOVE CH,[XWD OCTLIT,1] ; INDTAB WORDS ARE OCTAL CONSTANTS
PUSHJ PP,STASHC ; OUTPUT HEADER WORD
MOVE CH,(TA) ; GET INDTAB ENTRY
PUSHJ PP,STASHC ; OUTPUT THAT TOO
AOS ELITPC ; BUMP LITAB PC
LDB TB,ID.END## ; GET END FLAG
ADDI TA,1 ; ALWAYS BUMP TA
JUMPE TB,INDCK1 ; LOOP UNTIL WE FIND FLAG
MOVE CH,[XWD PUSHJ.+AC17+ASINC,AS.CNB]
PUSHJ PP,PUTASY ; OUTPUT PUSHJ
MOVEI CH,400013 ; GET ADDRESS OF INDC. DISPATCH
PUSHJ PP,PUTASN ; OUTPUT THAT TOO
PUSHJ PP,BLDTAG ; GET A TAG
MOVE CH,CURPRO ; GET TABLE ADDRESS
SUB CH,PROLOC ; GET RELATIVE ADDRESS
HRRZS CH ; GET ONLY THE GOOD PARTS
ADD CH,[XWD JRST.,AS.PRO##]
PUSHJ PP,PUTASY ; JRST TO NEXT TAG IF CHECK FAILS
SWON FINDON; ; SWITCH ON TO REMEMBER
POPJ PP, ; EXIT
;CH.12 CHOOSE WHICH OPERAND TO USE FOR ARITHMETIC OP
;
;
;
CH.12: MOVE TB,OP1SIZ ; GET SIZE OF OPERAND 1
MOVE TC,OP2SIZ ; GET SIZE OF OPERAND 2
CAILE TB,^D10 ; TEN DIGITS/WORD
JRST CH.12B ; IS A .2X
CAILE TC,^D10 ; ANOTHER CHECK
JRST CH.12C ; IS A .12
XCT TAB.11(LN) ; IS A .11
CH.12A: PUSHJ PP,PUTASY ; OUTPUT IT
POPJ PP, ; AND EXIT
CH.12B: CAILE TC,^D10 ; CHECK OP2
JRST CH.12D ; IS A .22
XCT TAB.21(LN) ; IS A .21
JRST CH.12A
CH.12C: XCT TAB.12(LN) ; GET INSTRUCTION
JRST CH.12A ; GO STASH IT
CH.12D: XCT TAB.22(LN) ; GET A .22
JRST CH.12A ; GO HUNTING
TAB.11: MOVE CH,[XWD AD+AC3,1]
MOVE CH,[XWD SUB.+AC3,1]
PUSHJ PP,MLC1C1
MOVE CH,[XWD DIV.11+AC3,1]
MOVE CH,[XWD CMP.11,3]
MOVE CH,[XWD MOVN.+AC3,3]
MOVE CH,[XWD CMP%11,3]
TAB.12: MOVE CH,[XWD ADD.21+AC3,1]
MOVE CH,[XWD SUB.21+AC3,1]
MOVE CH,[XWD MUL.21+AC3,1]
MOVE CH,[XWD DIV.12+AC3,1] ; [353]
MOVE CH,[XWD CMP.12,3]
POPJ PP,
MOVE CH,[XWD CMP%12,3]
TAB.21: MOVE CH,[XWD ADD.12+AC3,1]
MOVE CH,[XWD SUB.12+AC3,1]
MOVE CH,[XWD MUL.12+AC3,1]
MOVE CH,[XWD DIV.21+AC3,1] ; [353]
MOVE CH,[XWD CMP.21,3]
PUSHJ PP,ZSC2
MOVE CH,[XWD CMP%21,3]
TAB.22: MOVE CH,[XWD ADD.22+AC3,1]
MOVE CH,[XWD SUB.22+AC3,1]
MOVE CH,[XWD MUL.22+AC3,1]
MOVE CH,[XWD DIV.22+AC3,1]
MOVE CH,[XWD CMP.22,3]
POPJ PP,
MOVE CH,[XWD CMP%22,3]
;HANDLE MULTIPLICATION OF 1-WORD BY 1-WORD
MLC1C1: ADD TB,TC ; GET RESULT SIZE
CAILE TB,^D10 ; FIT IN ONE WORD?
SKIPA CH,[XWD MUL.+AC3,1] ; NO - PUT IT IN TWO
MOVE CH,[XWD IMUL.+AC3,1] ; YES - LEAVE IT AS ONE
POPJ PP, ; POP BACK TO CA.12A
;HANDLE ZSUB OF DOUBLE PRECISION
;
;GENERATES THE FOLLOWING CODE:
;
; SETCM 3,3 ; TAKE ONES COMPLEMENT OF HIGH WORD
; MOVN 4,4 ; TAKE TWOS COMPLEMENT OF LOW WORD
; HRLOI 5,377777 ; GET TEST MASK
; TDNN 4,5 ; IF LOW PART IS ZERO.....
; ADDI 3,1 ; CHANGE HIGH PART TO TWO'S COMPLEMENT
;
ZSC2: MOVE CH,[XWD SETCM.+AC3,3]
PUSHJ PP,PUTASY ; OUT TO ASYFIL
MOVE CH,[XWD MOVN.+AC4,4]
PUSHJ PP,PUTASY ; ME TOO
MOVE CH,[XWD HRLOI.+AC0+ASINC,AS.CNB]
PUSHJ PP,PUTASY
MOVEI CH,377777 ; MAGIC CONSTANT
PUSHJ PP,PUTASN ; STUFF IT
MOVE CH,[XWD TDNN.+AC4,5]
PUSHJ PP,PUTASY
MOVE CH,[XWD ADDI.+AC3,1]
POPJ PP, ; EXIT AND THEN STASH
;CHCONV ROUTINE TO CHOOSE WHAT CONVERSION ROUTINE TO UTILIZE FOR MOVE
;
;
;
CHCONV: MOVE TB,OP1BSZ ; GET BYTE SIZE OF F1
CAMN TB,OP2BSZ ; SAME AS F2?
JRST CHCNV1 ; YES - USE REGULAR MOVE
MOVE TC,OP2BSZ ; GET BYTE SIZE OF F2
XCT CONTB1-6(TB) ; GET AN INSTRUCTION
CHCNV0: PUSHJ PP,PUTASY ; OUTPUT IT
MOVE CH,ELITPC ; GET LITAB PC
TRO CH,AS.LIT ; MARK WHO IT CAME FROM
PJRST PUTASN ; OUTPUT THAT TOO
CHCNV1: MOVE CH,[XWD MOVE.+ASINC,AS.MSC]
JRST CHCNV0 ; OUTPUT STANDARD MOVE UUO
;DEFINE TABLES
CONTB1: MOVE CH,CONTB6-6(TC) ; F1 SIXBIT
MOVE CH,CONTB7-6(TC) ; F1 ASCII
Z
MOVE CH,CONTB9-6(TC) ; F1 EBCDIC
CONTB6: XWD 0,0
XWD CD6D7.+ASINC,AS.MSC ; F2 ASCII
XWD 0,0
XWD CD6D9.+ASINC,AS.MSC ; F2 EBCDIC
CONTB7: XWD CD7D6.+ASINC,AS.MSC ; F2 SIXBIT
XWD 0,0
XWD 0,0
XWD CD7D9.+ASINC,AS.MSC ; F2 EBCDIC
CONTB9: XWD CD9D6.+ASINC,AS.MSC ; F2 EBCDIC
XWD CD9D7.+ASINC,AS.MSC ; F2 EBCDIC
XWD 0,0
XWD 0,0
;CHKNUM ROUTINE TO SEE IF FACTOR IN OPRTR+4 IS NUMERIC
;
;CALL: PUSHJ PP,CHKNUM
; RET+1 IF NOT NUMERIC
; RET+2 IF NUMERIC
;
;
CHKNUM: MOVE TB,OPRTR+4 ; GET POINTER
TLNE TB,1B20 ; NUMERIC LITERAL?
AOSA (PP) ; YES - TAKE SKIP RETURN
TLNE TB,1B19 ; NO - IS IT ALPHA LIT?
POPJ PP, ; YES - TAKE NON-SKIP RETURN
MOVEI TB,4 ; GET INDEX
PUSHJ PP,GTFLD ; GET FIELD TYPE
SKIPE TC ; NUMERIC?
AOS (PP) ; YES -
POPJ PP, ; NO - EXIT
;CHKNM2 ROUTINE TO SEE IF FACTOR IN OPRTR+3 IS NUMERIC
;
;CALL: PUSHJ PP,CHKNM2
; RET+1 IF NOT NUMERIC
; RET+2 IF NUMERIC
;
;
CHKNM2: MOVE TB,OPRTR+3 ; GET INDEX
TLNE TB,1B20 ; NUMERIC LITERAL?
AOSA (PP) ; YES -
TLNE TB,1B19 ; NO - IS IT ALPHA LIT?
POPJ PP, ; YES - TAKE NON-SKIP RETURN
MOVEI TB,3 ; GET INDEX
PUSHJ PP,GTFLD ; GET FIELD
SKIPE TC ; NUMERIC
AOS (PP) ; YES -
POPJ PP, ; NO - EXIT
;GTFLD GET FIELD TYPE
;
;
;
GTFLD: HRRZ TA,OPRTR(TB) ; GET LINK
PUSHJ PP,LNKSET ; SET IT
LDB TC,DA.SIZ ; GET SIZE
JUMPE TC,GTFLD1 ; NOT DEFINED
LDB TC,DA.FLD ; GET FIELD TYPE
POPJ PP, ; EXIT
GTFLD1: PUSH PP,TB ; [064] STASH OPRTR INDEX IN CASE OF ERROR
LDB TA,DA.NAM## ; GET NAMTAB LINK
MOVEI TB,CD.DAT ; GET TABLE ID
PUSHJ PP,FNDLNK ; LOOK UP LINK
JRST GTFLD4 ; NOT FOUND - HUH?????
MOVE TA,TB ; [064] GET LINK INTO PROPER AC
POP PP,TB ; [064] RESTORE OPRTR INDEX
GTFLD2: LDB TC,DA.SIZ ; GET SIZE OF FIELD
JUMPE TC,GTFLD3 ; NOT DEFINED
LDB TC,DA.FLD ; GET FIELD TYPE
POPJ PP, ; EXIT
GTFLD3: HRRZ TA,10(TA) ; get same name link (DA.SNM)
JUMPE TA,GTFLD4 ; ERROR IF NOT ONE
PUSHJ PP,LNKSET ; SET LINK
JRST GTFLD2 ; LOOP
GTFLD4: GETLN; ; GET LINE NUMBER
CAIN TB,3 ; WHICH ONE?
JRST .+3 ; F2
WARN 704; ; FACTOR 1 NOT DEFINED
CAIA ; FAST SKIP
WARN 705; ; FACTOR 2 NOT DEFINED
POP PP,TA ; POP OFF ONE ADDRESS
POPJ PP, ; THE LONG EXIT
;MAKTAG SET UP A TAG NAME IN NAMWRD
;
;
MAKTAG: MOVE TB,[POINT 3,TAGNUM##,26]; POINTER TO TAG NUMBER
SETZ TC, ; ZAP SUMMER
ILDB CH,TB ; GET A DIGIT
LSH TC,6 ; MAKE ROOM FOR DADDY
ADDI TC,'0'(CH) ; ADD IN NEW DIGIT
TLNE TB,770000 ; ALL DONE?
JRST MAKTAG+2 ; NOPE - LOOP
MAKTG1: HRLI TC,'%' ; YES - GIVE HIM A PERCENTAGE
LSH TC,^D12 ; LEFT JUSTIFY
MOVEM TC,NAMWRD## ; STASH
SETZM NAMWRD+1 ; ZAP
POPJ PP, ; EXIT
;FNDTAG LOOKUP AND GENERATE TAG
;
;
;
FNDTAG: PUSHJ PP,MAKTAG ; MAKE A TAG
PUSHJ PP,TRYNAM## ; LOOK IT UP
JRST TAGX ; WHAT THE HELL???
MOVEI TB,CD.PRO ; FOR FEW KNOW THEIR TRUE NAME
MOVSS TA ; GET RELATIVE POINTER INTO RH
PUSHJ PP,FNDLNK## ; GET THAT LINK
JRST TAGX ; BOMBO AGAIN....
MOVE TA,TB ; GET INTO USUAL AC
TSWT FAS3; ; ARE WE USING AS3FIL YET?
SKIPA TC,EAS2PC ; NO - USE EAS2PC
MOVE TC,EAS3PC ; YES - USE IT THEN
DPB TC,PR.LNK## ; STASH AS CORE LINK
HRRZ CH,PROLOC## ; GET THE GOOD STUFF
SUB TB,CH ; MAKE INTO RELATIVE POINTER
MOVE CH,TB ; AND BACK TO CORRECT AC
ADD CH,[XWD AS.PN##,AS.PRO] ; MAKE INTO TAG DEFINITION
PUSHJ PP,PUTASN ; OUTPUT IT
MOVEI TB,1 ; GET A BUMPER
ADDB TB,TAGNUM ; AND BUMP WITH IT
CAIG TB,777 ; ALL OK??
POPJ PP, ; YEP ---
MSG <?RPGTMT Too many tags generated internally, max. of 1024 exceeded.
>
JRST KILL## ; GO DIE GRACEFULLY
TAGX: OUTSTR [ASCIZ "?Tag created then lost, God doesn't like us
"]
JRST KILL ; MOST DECIDEDLY FATAL I'M AFRAID
;BLDTAG BUILD A PROTAB ENTRY FOR A TAG
;
;
;
BLDTAG: PUSHJ PP,MAKTAG ; MAKE A TAG
PUSHJ PP,TRYNAM ; IS IT IN NAMTAB?
PUSHJ PP,BLDNAM## ; NO - WELL PUT IT THERE
MOVEM TA,CURNAM## ; STASH NAMTAB POINTER
MOVE TA,[XWD CD.PRO,SZ.PRO] ; SHOW HIM THE PRETTY MARKS, BROTHERS
PUSHJ PP,GETENT## ; OL' CHARLTON WILL NEVER LEARN
HRRZM TA,CURPRO## ; STASH PROTAB LINK TOO
MOVS TB,CURNAM ; GET BACK NAMTAB LINK
DPB TB,PR.NAM## ; STASH IN PROTAB
MOVEI TB,CD.PRO ; GET THE MARK
DPB TB,PR.ID## ; AND MARK HIM FOR LIFE
SETZ TB, ; ASSUME EAS2PC RELATIVE
TSWF FAS3; ; CORRECT ASSUMPTION?
MOVEI TB,1 ; NOPE - EAS3PC RELATIVE
DPB TB,PR.SEG## ; FLAG SEGMENT TYPE
POPJ PP, ; AND GET THE HELL OUT OF HERE
;NOTNUM OUTPUT "ITEM NOT NUMERIC" ERROR MESSAGE
;
;
;
NOTNUM: LDB TC,[POINT 13,OPRTR,28] ; GET LINE NUMBER
MOVEM TC,SAVELN## ; STASH IT FOR WARN
WARN 207; ; AND WARN 'EM
POPJ PP, ; THE CARRY ON AS USUAL
;FNDFLD LOOKUP FIELD
;
;
;
FNDFLD: LDB TB,DA.SIZ ; GET SIZE
JUMPN TB,NOTNUM ; IF WE HAVE ONE, FIELD IS WRONG TYPE
HRRZ TA,10(TA) ; else get same name link (DA.SNM)
JUMPE TA,FNDFL1 ; RESULT NOT DEFINED
PUSHJ PP,LNKSET ; SET UP LINKS
LDB TB,DA.FLD ; GET FIELD TYPE
JUMPE TB,FNDFLD ; IF ZERO, KEEP ON TRYING
MOVE TB,TA ; GET LINK
SUB TB,DATLOC## ; MAKE INTO REAL
IORI TB,<CD.DAT>B20 ; IN CASE OTHERS NEED
HRRZM TB,OPRTR+4 ; THE SAME LINK
POPJ PP, ; AND EXIT
FNDFL1: GETLN; ; get the line number
WARN 707; ; RESULT FIELD NOT DEFINED
HRRZ TA,OPRTR+4 ; GET BACK ORIGINAL LINK
PUSHJ PP,LNKSET ; SET IT UP
POPJ PP, ; AND EXIT
;BINC INCREMENT BYTE POINTER IN CH, TC TIMES
;
;
;
BINC: IBP CH ; BUMP POINTER
SOJN TC,.-1 ; LOOP UNTIL DONE
POPJ PP, ; EXIT WHEN WE ARE DONE
;SWPOP SWAP OPERAND INFORMATION
;SWPIND SWAP HIGH AND LOW INDICATORS
;
;
;
SWPOP: SETZ TB, ; START AT THE END
MOVE TC,@SWP1(TB) ; GET A OP1 ITEM
MOVE TD,@SWP2(TB) ; GET A OP2 ITEM
MOVEM TC,@SWP2(TB) ; STASH OP1 ITEM AS OP2 ITEM
MOVEM TD,@SWP1(TB) ; DO THE SAME FOR OP2 ITEM
ADDI TB,1 ; BUMP POINTER
SKIPE (TB) ; END OF TABLE?
JRST SWPOP+1 ; NO - LOOP
SWPIND: HLRZ TA,OPRTR+2 ; GET INDICATORS LINK
PUSHJ PP,LNKSET ; SET UP LINK
LDB TB,[POINT 8,(TA),7] ; GET HIGH INDICATOR
LDB TC,[POINT 8,(TA),15] ; GET LOW INDICATOR
DPB TC,[POINT 8,(TA),7] ; STASH LOW AS HIGH
DPB TB,[POINT 8,(TA),15] ; STASH HIGH AS LOW
POPJ PP, ; EXIT
SWP1: EXP OPRTR+3
EXP OP1SIZ
EXP OP1BYT
EXP OP1BSZ
EXP 0
SWP2: EXP OPRTR+4
EXP OP2SIZ
EXP OP2BYT
EXP OP2BSZ
;STBYT1 SET UP BYTE POINTER TO OPERAND 1
;
;NOTE SPECIAL REGISTER DEFINITION
;
;
TF==TE-1
TG==TF-1
STBYT1: MOVE TF,OPRTR+3 ; GET OP1 INFO
MOVE TG,OPRTR+4 ; LIKEWISE
TLNE TF,1B19 ; IS OP1 A LITERAL?
JRST SBYT1A ; YEP -
HRRZ TA,OPRTR+3 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET UP THAT LINK
LDB TB,DA.ARE ; GET ARRAY ENTRY FLAG
JUMPN TB,SBYT1G ; IS ARRAY IF WE JUMP
PUSHJ PP,FNDRES ; find real field
LDB TB,DA.RSV ; get reserved word flag
JUMPN TB,SBYTRS ; it is reserved word - error
LDB TB,DA.OCC ; GET NUMBER OF OCCURANCES
JUMPN TB,SBYT1F ; IF WE JUMP MUST BE TABLE OR WHOLE ARRAY
SBYT1: LDB TB,DA.FMT## ; GET FORMAT
MOVE TC,BYTAB(TB) ; GET BYTE SIZE
MOVEM TC,OP1BSZ## ; STASH
LDB CH,DA.COR ; GET CORE POINTER
TRO CH,AS.DAT ; DATAB RELATIVE
LDB TD,DA.RES ; GET BYTE RESIDUE
DPB TD,[POINT 6,CH,5] ; STASH RESIDUE
DPB TC,[POINT 5,CH,11] ; STASH BYTE SIZE
MOVEM CH,OP1BYT## ; STASH BYTE POINTER
LDB TC,DA.SIZ ; GET SIZE OF FIELD
MOVEM TC,OP1SIZ ; STASH
LDB TC,DA.DEC ; get decimal positions
MOVEM TC,OP1DEC ; save
POPJ PP, ; EXIT
BYTAB: DEC 6 ; SIXBIT
DEC 7 ; ASCII
DEC 9 ; EBCDIC
SBYT1F: LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC ; MAKE INTO REAL POINTER
HLRZ TC,1(TC) ; GET FIRST THREE CHARACTERS
CAIE TC,'TAB' ; IS IT A TABLE?
SWONS FOP1WL; ; NO FLAG AS WHOLE ARRAY
SWON FOP1TB; ; YES - FLAG AS SUCH
JRST SBYT1 ; CONTINUE
SBYT1G: SWON FOP1AR; ; FLAG AS ARRAY
MOVEI TB,3 ; GET INDEX
PUSHJ PP,GTFLD ; GET FIELD INFORMATION
JRST SBYT1 ; CONTINUE
;STBYT1 (CONT'D) HANDLE LITERAL BYTE POINTER
SBYT1A: TLNE TG,1B19 ; OP2 A LITERAL TOO?
JRST SBYT1B ; YES - USE SIXBIT
; MOVEI TB,4 ; NO - GET OP2 INDEX
; PUSHJ PP,GTFLD ; GET FIELD POINTER
; LDB TB,DA.FMT ; GET FORMAT
; MOVE TC,BYTAB(TB) ; GET BYTE SIZE
; CAIN TC,^D9 ; IS EBCDIC?
SBYT1B: MOVEI TC,6 ; YES - USE SIXBIT
MOVEM TC,OP1BSZ ; NO - STASH BYTE SIZE
MOVE CH,ELITPC ; GET LITAB PC
TRO CH,AS.LIT ; LITAB RELATIVE
MOVEI TD,^D42 ; THE MAGIC NUMBER
SUB TD,TC ; GET BYTE OFFSET
DPB TD,[POINT 6,CH,5] ; STASH OFFSET
DPB TC,[POINT 5,CH,11] ; STASH SIZE
MOVEM CH,OP1BYT ; STASH BYTE POINTER
HRRZ TA,TF ; GET POINTER TO OP1
PUSHJ PP,LNKSET ; SET UP VALTAB LINK
HRRZ TB,TA ; GET ADDRESS
ADD TB,[POINT 7,0] ; MAKE INTO BYTE POINTER
ILDB CH,TB ; GET CHARACTER COUNT
SUBI CH,1 ; account for the back-arrow terminator
MOVEM CH,OP1SIZ ; STASH
HLLO LN,OPRTR+3 ; get flags
PUSHJ PP,SBYT1E ; output literal
TLNN LN,1B20 ; was that numeric literal?
POPJ PP, ; no -exit
HRRZS LN ; yes - get count
SETZM OP1DEC ; clear it
CAIN LN,777777 ; did we see a point?
POPJ PP, ; no -
SOS TB,OP1SIZ ; decrement to allow for decimal point
SUB TB,LN ; get decimal count
MOVEM TB,OP1DEC ; save
POPJ PP, ; and exit
;STBYT1 (CONT'D) COMMON PORTION OF LITERAL SETUP
SBYT1E: MOVE TD,CH ; GET COUNT INTO TD
IDIV CH,TC ; GET NUMBER OF WORDS
JUMPE CH+1,.+2 ; REMAINDER?
ADDI CH,1 ; YES - ROUND UP
HRLZI TA,SIXLIT ; DEFAULT TO SIXBIT
CAIE TC,6 ; DO WE WANT ASCII?
HRLZI TA,ASCLIT ; YES - GET IT
HRR TA,CH ; STASH WORD COUNT
PUSHJ PP,STASHL ; STASH WHOLE THING IN LITAB
ADDM CH,ELITPC ; BUMP LITAB PC
MOVE TE,[POINT 6,TA] ; GET A POINTER
CAIE TC,6 ; IS SIXBIT?
MOVE TE,[POINT 7,TA] ; NO - GET ASCII POINTER
SETZ TA, ; START FRESH
SBYT1C: ILDB CH,TB ; GET A CHAR
TLNN LN,1B20 ; numeric literal?
JRST SBYT1H ; no
CAIE CH,"." ; yes - is this a decimal point?
JRST SBYT1H ; no -
HRRM TD,LN ; yes save the count
SOJE TD,SBYT1D ; see if any left
JRST SBYT1C ; ignore the decimal point
SBYT1H: CAIN TC,6 ; IS ASCII OK?
SUBI CH,40 ; NO - CONVERT TO SIXBIT
IDPB CH,TE ; STASH
SOJE TD,SBYT1D ; EXIT IF ALL DONE
TLNE TE,760000 ; HAVE WE FILLED TA YET?
JRST SBYT1C ; NO - LOOP
PUSHJ PP,STASHL ; YES - OUTPUT TO LITAB
JRST SBYT1C-4 ; TAKE THE BIG LOOP
SBYT1D: PUSHJ PP,STASHL ; DON'T FORGET THE LAST WORD
POPJ PP, ; EXIT
SBYTRS: GETLN; ; get the line number
WARN 207; ; all reserved words are numeric
POPJ PP, ; exit
;STBYT2 ROUTINE TO SET UP BYTE POINTER FOR OPERAND 2
;
;
;
STBYT2: MOVE TF,OPRTR+4 ; GET OP2 LINKS
MOVE TG,OPRTR+3 ; GET OP1 LINKS
TLNE TF,1B19 ; OP2 A LITERAL?
JRST SBYT2A ; YES - GO PROCESS
HRRZ TA,OPRTR+4 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET IT UP
LDB TB,DA.ARE ; GET ARRAY ENTRY FLAG
JUMPN TB,SBYT2C ; IS ARRAY ENTRY
PUSHJ PP,FNDRES ; find real data item
LDB TB,DA.RSV ; get reserved word flag
JUMPN TB,SBYTRS ; error if it is
LDB TB,DA.OCC ; GET NUMBER OF OCCURANCES
JUMPN TB,SBYT2D ; IS EITHER TABLE OR WHOLE ARRAY
SBYT2: LDB TB,DA.FMT ; GET FORMAT
MOVE TC,BYTAB(TB) ; GET BYTE SIZE
MOVEM TC,OP2BSZ ; STASH
LDB CH,DA.COR ; GET CORE POINTER
TRO CH,AS.DAT ; RELATIVE TO DATAB
LDB TD,DA.RES ; GET BYTE RESIDUE
DPB TD,[POINT 6,CH,5] ; STASH IN POINTER
DPB TC,[POINT 5,CH,11] ; STASH SIZE TOO
MOVEM CH,OP2BYT## ; STASH POINTER
LDB TC,DA.SIZ ; GET SIZE
MOVEM TC,OP2SIZ ; STORE
LDB TC,DA.DEC ; get decimal positions
MOVEM TC,OP2DEC ; save it
POPJ PP, ; EXIT
SBYT2C: SWON FOP2AR; ; SET ARRAY FLAG
MOVEI TB,4 ; GET ENTRY INDEX
PUSHJ PP,GTFLD ; GET THAT FIELD
JRST SBYT2 ; CONTINUE
SBYT2D: LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC ; MAKE REAL
HLRZ TC,1(TC) ; GET FIRST 3
CAIE TC,'TAB' ; IS IT A TABLE?
SWONS FOP2AR; ; FLAG WHOLE ARRAY AS ARRAY
SWON FOP2TB; ; YES - SET FLAG
JRST SBYT2
;STBYT2 (CONT'D) SET UP LITERAL BYTE POINTER
SBYT2A: TLNE TG,1B19 ; IS OP1 A LITERAL ALSO?
JRST SBYT2B ; YES - ASSUME 6IXBIT
; MOVEI TB,3 ; GET OP1 INDEX
; PUSHJ PP,GTFLD ; GET FIELD POINTER
; LDB TB,DA.FMT ; GET FORMAT
; MOVE TC,BYTAB(TB) ; GET BYTE SIZE
; CAIN TC,^D9 ; EBCDIC?
SBYT2B: MOVEI TC,6 ; YES - ASSUME SIXBIT
MOVEM TC,OP2BSZ## ; STASH AS BYTE SIZE
MOVE CH,ELITPC ; GET LITAB PC
TRO CH,AS.LIT ; MEN CALL ME LITAB
MOVEI TD,^D42 ; LET'S HEAR IT FOR 36 BIT MACHINES
SUB TD,TC ; GET BYTE OFFSET
DPB TD,[POINT 6,CH,5] ; STASH OFFSET IN POINTER
DPB TC,[POINT 5,CH,11] ; STASH BYTE SIZE
MOVEM CH,OP2BYT## ; STASH POINTER WHERE WE CAN FIND IT LATER
MOVE TA,TF ; GET OP2 LINK
PUSHJ PP,LNKSET ; SET UP LINK
HRRZ TB,TA ; GET ADDRESS FIELD
ADD TB,[POINT 7,0] ; MAKE INTO BYTE POINTER
ILDB CH,TB ; GET SIZE
SUBI CH,1 ; remember the back-arrow
MOVEM CH,OP2SIZ ; STASH SIZE
HLLO LN,OPRTR+3 ; get flags
PUSHJ PP,SBYT1E ; use common routine
TLNN LN,1B20 ; numeric?
POPJ PP, ; No - exit
HRRZS LN ; yes - get count
SETZM OP2DEC ; zap
CAIN LN,777777 ; did we see a decimal point?
POPJ PP, ; no
SOS TB,OP2SIZ ; decrement size to account for decimal point
SUB TB,LN ; get decimal positions
MOVEM TB,OP2DEC ; save
POPJ PP, ; and exit
;BPTRSZ ROUTINE TO OUTPUT DUAL BYTE POINTERS WITH SIZE IN SECOND
;
;ENTER WITH SIZE IN TB
;
;
BPTRSZ: TSWT FOP1WL; ; IF OP1 A WHOLE ARRAY?
TSWF FOP1AR; ; IS OP1 AN ARRAY?
JRST .BPTG ; LOOKS THAT WAY
TSWF FOP1TB; ; A TABLE?
JRST .BPTH ; YEP
SKIPN OP1BYT ; do we have one?
PUSHJ PP,BYTZ ; no - returns +4
MOVE CH,[XWD BYTLIT,2] ; NO - OUTPUT REGULAR POINTER TO LITAB
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,[XWD AS.BYT,AS.MSC] ; GET ASYFIL HEADER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,OP1BYT ; GET POINTER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,ELITPC ; GET LITAB PC
MOVEM CH,OP1LIT ; SAVE FOR OTHERS
AOS ELITPC ; UPDATE LITAB PC
.BPTA: TSWT FWHOLE; ; IS OP2 WHOLE ARRAY?
TSWF FOP2AR; ; OP2 AN ARRAY?
PJRST .BPTE ; YES -
TSWF FOP2TB; ; NO - TABLE?
PJRST .BPTF ; YES -
SKIPN OP2BYT ; got one?
PUSHJ PP,BYTZ ; no -
MOVE CH,[XWD BYTLIT,2] ; GET LITAB HEADER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,[XWD AS.BYT,AS.MSC] ; GET ASYFIL HEADER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,OP2BYT ; GET BYTE POINTER
DPB TB,[POINT 11,CH,17] ; STASH SIZE IN POINTER
PUSHJ PP,STASHC ; OUTPUT IT
MOVE CH,ELITPC ; GET PC
MOVEM CH,OP2LIT ; SAVE
AOS ELITPC ; BUMP PC
POPJ PP, ; EXIT
.BPTG: PUSHJ PP,.BPTB ; SET UP OP1 POINTER
JRST .BPTA ; CONTINUE WITH OP2
.BPTH: PUSHJ PP,.BPTD ; SET UP OP1 POINTER TO TABLE
JRST .BPTA ; CONTINUE
;BPTRSZ (CONT'D)
;
;.BPTB OUTPUT ARRAY POINTER TO OP1
;
;
.BPTB: HRRZ TA,OPRTR+3 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET UP THE LINKS
PUSH PP,TB ; SAVE SIZE FIELD
TSWF FOP1WL; ; OP1 WHOLE ARRAY?
PUSHJ PP,GTBYTB ; YES - THIS CALL RETURNS +2
PUSHJ PP,GTBYTA ; GENERATE CODE TO GET POINTER INTO AC0
MOVE TB,ELITPC ; GET LITAB PC
MOVEM TB,OP1LIT## ; SAVE FOR OTHERS
.BPTC: SWOFF FWZARD; ; MAKE SURE
MOVE CH,[XWD MOVEM.+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <MOVEM 0,%LIT>
MOVE CH,TB ; GET PC
TRO CH,AS.LIT ; MARK MY WORDS WELL
PUSHJ PP,PUTASN ; OUTPUT ADDRESS
MOVE CH,[XWD OCTLIT,1] ; GET LITAB HEADER
PUSHJ PP,STASHC ; OUTPUT
SETZ CH, ; CONSTANT OF ZERO
PUSHJ PP,STASHC ; OUTPUT
AOS ELITPC ; BUMP PC
POP PP,TB ; RESTORE COUNT
POPJ PP, ; EXIT
;.BPTD ROUTINE TO OUTPUT TABLE POINTER TO OP1
;
.BPTD: HRRZ TA,OPRTR+3 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET IT UP
PUSH PP,TB ; SAVE TB
SWON FWZARD; ; REASONS FOR THIS MAY BE FOUND IN
; "OF EVILL SORCERIES DONE IN NEW-ENGLAND OF
; ; DAEMONS IN NO HUMANE SHAPE"
PUSHJ PP,GTF.10+2 ; CHEAT!
MOVE TB,ELITPC ; GET LITAB PC
MOVEM TB,OP1LIT ; STORE FOR OTHERS
PJRST .BPTC ; CONTINUE
;BPTRSZ (CONT'D)
;
;.BPTE ROUTINE TO OUTPUT ARRAY POINTER TO OP2
;
;
.BPTE: PUSHJ PP,.BPTJ ; SET UP LOCATION
HRRZ TA,OPRTR+4 ; GET POINTER
PUSHJ PP,LNKSET ; SET IT
PUSH PP,TB ; STASH SIZE
PUSHJ PP,GTBYTA ; OUTPUT POINTER
.BPTI: TSWFZ FINC; ; must we generate increment code?
PUSHJ PP,BNCGN4 ; yes - go do it
MOVE CH,[XWD TLZ.+AC0,AS.CNS+3777]
PUSHJ PP,PUTASY ; GENERATE <TLZ 0,3777> TO CLEAR SIZE AREA
POP PP,CH ; GET SIZE OFF STACK
HRLI CH,<TLO.+AC0> ; MAKE A <TLO 0,SIZE>
PUSHJ PP,PUTASY ; OUTPUT IT
.BPTK: SWOFF FWZARD; ; OFF
MOVE CH,[XWD MOVEM.+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT IT
MOVE CH,OP2LIT ; GET OP2 BYTE POINTER LOC
TRO CH,AS.LIT ; IS IN LITAB
PJRST PUTASN ; OUTPUT AND EXIT
.BPTJ: MOVE TC,ELITPC ; GET LITAB PC
MOVEM TC,OP2LIT## ; STORE FOR OTHERS
MOVE CH,[XWD OCTLIT,1] ; ONE OCTAL LITERAL COMING UP
PUSHJ PP,STASHC ; OUTPUT
SETZ CH, ; LITERAL IS ZERO
AOS ELITPC ; BUMP PC
PJRST STASHC ; OUTPUT AND EXIT
;.BPTF OUTPUT TABLE POINTER TO OP2
;
;
.BPTF: PUSHJ PP,.BPTJ ; SET UP POINTER IN LITAB
HRRZ TA,OPRTR+4 ; GET DATAB POINTER
PUSHJ PP,LNKSET ; SET IT UP
PUSH PP,TB ; SAVE COUNT
SWON FWZARD; ; ABRACADABRA
PUSHJ PP,GTF.10+2 ; GO CHEAT A BIT
PJRST .BPTI ; GO FINISH UP CODE
;BPTR ROUTINE TO OUTPUT TWO BYTE POINTERS
;
;
;
BPTR: TSWT FOP1WL; ; OP1 WHOLE ARRAY?
TSWF FOP1AR; ; OP1 ARRAY?
JRST .BPTRA ; YES -
TSWF FOP1TB; ; NO - TABLE?
JRST .BPTRC ; YES -
SKIPN OP1BYT ; got one?
PUSHJ PP,BYTZ ; no -
MOVE CH,[XWD BYTLIT,2] ; NO - GET LITAB HEADER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,[XWD AS.BYT,AS.MSC] ; GET ASYFIL HEADER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,OP1BYT ; GET BYTE POINTER
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,ELITPC ; GET PC
MOVEM CH,OP1LIT ; SAVE FOR OTHER ROUTINES
AOSA ELITPC ; BUMP LITAB PC
.BPTRA: PUSHJ PP,.BPTB ; GO OUTPUT ARRAY POINTER
.BPTRB: TSWT FWHOLE; ; OP2 WHOLE ARRAY?
TSWF FOP2AR; ; OP2 ARRAY?
PJRST .BPTRD ; YES -
TSWF FOP2TB; ; NO - TABLE?
PJRST .BPTRE ; YES -
SKIPN OP2BYT ; got one?
PUSHJ PP,BYTZ ; no -
MOVE CH,[XWD BYTLIT,2] ; NO - GET STANDARD LITAB HEADER
PUSHJ PP,STASHC ; OUTPUT IT
MOVE CH,[XWD AS.BYT,AS.MSC] ; GET ASYFIL HEADER
PUSHJ PP,STASHC ; OUTPUT IT
MOVE CH,OP2BYT ; GET BYTE POINTER
PUSHJ PP,STASHC ; OUTPUT IT
MOVE CH,ELITPC ; GET PC
MOVEM CH,OP2LIT ; SAVE
AOS ELITPC ; BUMP PC
POPJ PP, ; EXIT
.BPTRC: PUSHJ PP,.BPTD ; GO OUTPUT TABLE POINTER
JRST .BPTRB ; CONTINUE WITH OP2
.BPTRD: PUSHJ PP,.BPTJ ; output LITAB header
HRRZ TA,OPRTR+4 ; get link
PUSHJ PP,LNKSET ; set the links
PUSHJ PP,GTBYTA ; get pointer in AC0
PJRST .BPTK ; and move to byte pointer
.BPTRE: PUSHJ PP,.BPTJ ; setup LITAB location
HRRZ TA,OPRTR+4 ; get link
PUSHJ PP,LNKSET ; set up those linkers
SWON FWZARD; ; invoke
PUSHJ PP,GTF.10+2 ; cheat and steal a routine
PJRST .BPTK ; output pointer and exit
;GTBP15 Routine to get byte pointer to OP1 into AC0
;
;
;
GTBP15: TSWT FOP1WL; ; whole array?
TSWF FOP1AR; ; array?
PJRST GT15.1 ; yes - one or the other
TSWF FOP1TB; ; table?
PJRST GT15.2 ; yes -
SKIPN OP1BYT ; have one?
PUSHJ PP,BYTZ ; no -
MOVE CH,[XWD BYTLIT,2] ; get LITAB header
PUSHJ PP,STASHC ; output it
MOVE CH,[XWD AS.BYT,AS.MSC] ; get secondary header
PUSHJ PP,STASHC ; output
MOVE CH,OP1BYT ; get that byte pointer
PUSHJ PP,STASHC ; output it to litab
MOVE CH,ELITPC ; get tha PC
MOVEM CH,OP1LIT ; save for others
AOS ELITPC ; bump the PC
MOVE CH,[XWD MOV+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; generate code to move it to AC0
MOVE CH,OP1LIT ; get that litab loc
IORI CH,AS.LIT ; identify
PJRST PUTASN ; output and exit
GT15.1: HRRZ OPRTR+3 ; get link
PUSHJ PP,LNKSET ; set it up
TSWF FOP1WL; ; whole array?
PUSHJ PP,GTBYTB ; yes - this returns +2
PJRST GTBYTA ; no -
POPJ PP, ; needed for GTBYTB return
GT15.2: HRRZ TA,OPRTR+3 ; get that link
PUSHJ PP,LNKSET ; set it up
SWON FWZARD; ; invoke
PUSHJ PP,GTF.10+2 ; steal the routine
SWOFF FWZARD; ; de-invoke
POPJ PP, ; and exit
;GTBP25 Routine to get byte pointer to OP2 into AC0
;
;
;
GTBP25: TSWT FWHOLE; ; whole array?
TSWF FOP2AR; ; array?
PJRST GT25.1 ; yes -
TSWF FOP2TB; ; table?
PJRST GT25.2 ; yes -
SKIPN OP2BYT ; got one
PUSHJ PP,BYTZ ; no -
MOVE CH,[XWD BYTLIT,2] ; get LITAB header
PUSHJ PP,STASHC ; output
MOVE CH,[XWD AS.BYT,AS.MSC] ; get secondary header
PUSHJ PP,STASHC ; output
MOVE CH,OP2BYT ; and get the byte pointer
PUSHJ PP,STASHC ; output it
MOVE CH,[XWD MOV+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; output MOVE
MOVE CH,ELITPC ; get literal location
MOVEM CH,OP2BYT ; save for other
IORI CH,AS.LIT ; identify
AOS ELITPC ; must do this
PJRST PUTASN ; output it
GT25.1: HRRZ TA,OPRTR+3 ; get the link
PUSHJ PP,LNKSET ; set it up
PJRST GTBYTA ; get the pointer and exit
GT25.2: HRRZ TA,OPRTR+3 ; get the link
PJRST GT15.2+1 ; go do rest elsewhere
;GTBYTA ROUTINE TO GENERATE CODE TO GET POINTER INTO AC0
;
;
;
GTBYTA: SWON FWZARD; ; INVOKE THE ISHTARI
TSWF FWHOLE; ; WHOLE ARRAY?
JRST GTBYTB+2 ; SET UP AND DISPATCH
PUSH PP,TA ; SAVE DATAB POINTER
LDB TA,DA.ARP ; GET ARRAY POINTER
PUSHJ PP,LNKSET ; SET UP LINKS
PJRST GTF.9E ; GO CHEAT AND STEAL A ROUTINE
GTBYTB: SWON FWZARD; ; INVOKE
AOS (PP) ; TAKE SKIP RETURN
LDB TA,DA.ARP ; GET ARRAY POINTER
PUSHJ PP,LNKSET ; SET IT UP
PJRST GTF.11 ; DO IT
BYTZ: MOVE CH,[XWD OCTLIT,1] ; non-relocatable header
MOVEI TC,3 ; return increment
ADDM TC,(PP) ; bump return
POPJ PP, ; and exit
;BNCGN1 GENERATE INCREMENT CODE FOR OP1
;
;ENTER WITH INCREMENT COUNT IN TC
;
;
BNCGN1: CAIG TC,1 ; is it worth generating a loop for?
JRST .+4 ; no - just generate the IBP
HRRZ CH,TC ; GET COUNT INTO PROPER AC
HRLI CH,<MOVEI.+AC0> ; MAKE A <MOVEI 0,COUNT>
PUSHJ PP,PUTASY ; OUTPUT IT
MOVE CH,[XWD IBP.+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT <IBP POINTER>
MOVE CH,OP1LIT ; GET OP1 POINTER ADDRESS
TRO CH,AS.LIT ; IS IN LITAB
PUSHJ PP,PUTASN ; OUTPUT ADDRESS
CAIG TC,1 ; are we generating a loop?
POPJ PP, ; no - exit
MOVE CH,[XWD SOJG.+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <SOJG 0,.-1>
MOVEI CH,AS.DOT+77777 ; = .-1
PJRST PUTASN ; OUTPUT IT
;BNCGN2 GENERATE INCREMENT CODE FOR OP2
;
;
;
BNCGN2: CAIG TC,1 ; must we generate a loop
JRST .+4 ; no
HRRZ CH,TC ; GET COUNT
HRLI CH,<MOVEI.+AC0> ; MAKE AN INSTRUCTION
PUSHJ PP,PUTASY ; OUTPUT ONE TOO
MOVE CH,[XWD IBP.+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT IBP
MOVE CH,OP2LIT ; GET POINTER ADDRESS
TRO CH,AS.LIT ; I COME FROM LITAB
PUSHJ PP,PUTASN ; OUTPUT ADDRESS
BNCG2A: CAIG TC,1 ; are we generating a loop?
POPJ PP, ; nope -
MOVE CH,[XWD SOJG.+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT <SOJG 0,.-1>
MOVEI CH,AS.DOT+77777 ; GET A .-1
PJRST PUTASN ; OUTPUT IT AND EXIT
;BNCGN3 GENERATE INCREMENT CODE FOR OP1
;
;THIS ROUTINE GENERATES CODE TO INCREMENT OP1 BYTE POINTER TC TIMES
;AND STASH THE RESULTING POINTER INTO OP2.
;
;
;
BNCGN3: HRRZ CH,TC ; GET INTO PROPER AC
HRLI CH,<MOVEI.+AC0> ; MAKE INTO INSTRUCTION
PUSHJ PP,PUTASY ; OUTPUT
MOVE CH,[XWD MOV+AC6+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <MOVE 6,OP1>
MOVE CH,OP1LIT ; GET OP1 LITAB LOC
TRO CH,AS.LIT ; IDENTIFY
PUSHJ PP,PUTASN ; OUTPUT
MOVE CH,[XWD IBP.,6] ; GET <IBP 6>
PUSHJ PP,PUTASY ; OUTPUT
MOVE CH,[XWD SOJG.+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <SOJG 0,.-1>
MOVEI CH,AS.DOT+77777 ; = .-1
PUSHJ PP,PUTASN ; OUTPUT AS ADDRESS
MOVE CH,[XWD MOVEM.+AC6+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; GENERATE <MOVEM 6,OP2>
MOVE CH,OP2LIT ; GET OP2 LITAB ADDRESS
TRO CH,AS.LIT ; SAY "I'M FROM LITAB"
PJRST PUTASN ; OUTPUT ADDRESS AND EXIT
;BNCGN4 This routine generates special code to increment AC0
;
;Increments the byte pointer in AC0, OP2CNT times. Uses AC6 for count rather
;then the customary AC0.
;
;
;
BNCGN4: SKIPN TC,OP2CNT## ; get count - is it non-zero?
POPJ PP, ; nope - no code needed
CAIG TC,1 ; must we loop?
JRST .+4 ; no -
HRRZ CH,TC ; get into proper AC
HRLI CH,<MOVEI.+AC6> ; get the count into AC6
PUSHJ PP,PUTASY ; output it
MOVE CH,[XWD IBP.,AS.CNS+0] ; get IBP
PUSHJ PP,PUTASY ; output it
CAIG TC,1 ; are we looping?
POPJ PP, ; no - exit
MOVE CH,[XWD SOJG.+AC6+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; yes - output loop instruction
MOVEI CH,AS.DOT+77777 ; address = .-1
PJRST PUTASN ; output the address and exit
;WH.OP1 ROUTINE TO CHECK IF OP1 IS A WHOLE ARRAY
;
;
;
WH.OP1: LDB TC,[POINT 1,OPRTR+2,1] ; GET LITERAL FLAG
JUMPN TC,CPOPJ ; IF LITERAL, OBVIOUSLY NOT ARRAY
HRRZ TA,OPRTR+2 ; GET DATAB POINTER
PUSHJ PP,LNKSET ; SET IT UP
LDB TB,DA.ARE ; IS IT ARRAY ENTRY?
JUMPN TB,CPOPJ ; MUST BE IF WE JUMPED
MOVEI TB,2 ; GET INDEX
PUSHJ PP,GTFLD ; GET FIELD TYPE
LDB TD,DA.OCC ; GET OCCURENCES
JUMPE TD,CPOPJ ; IF ZERO, EXIT
LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC ; ADD IN BASE ADDRESS
HLRZ TC,1(TC) ; GET FIRST THREE CHARACTERS
CAIN TC,'TAB' ; IS IT A TABLE?
POPJ PP, ; YES -
SWON FWHOLE; ; NO - MUST BE WHOLE ARRAY, SAY SO
CAMGE TD,WHOSIZ ; IS THIS NEW SIZE SMALLER?
MOVEM TD,WHOSIZ ; YES - REPLACE
POPJ PP, ; EXIT
AOS (PP) ; INCREMENT RETURN ADDRESS
POPJ PP, ; EXIT+1
;WH.OP2 ROUTINE TO CHECK IF OP2 IS WHOLE ARRAY
;
;
;
WH.OP2: LDB TC,[POINT 1,OPRTR+3,1] ; GET LITERAL FLAG
JUMPN TC,CPOPJ ; IS LITERAL IF JUMP
HRRZ TA,OPRTR+3 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET IT UP
LDB TB,DA.ARE ; IS IT ARRAY ENTRY
JUMPN TB,CPOPJ ; IGNORE IF IT IS
MOVEI TB,3 ; GET INDEX FOR OP2
PUSHJ PP,GTFLD ; GET FIELD TYPE
LDB TD,DA.OCC ; GET NUMBER OF OCCURENCES
JUMPE TD,CPOPJ ; IF 0 EXIT
LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC ; ADD IN BASE
HLRZ TC,1(TC) ; GET FIRST 3 CHARS
CAIN TC,'TAB' ; IS IT A TABLE?
POPJ PP, ; YES - EXIT
SWON FWHOLE; ; NO - TURN ON FLAG
CAMGE TD,WHOSIZ## ; IS NEW SIZE SMALLER?
MOVEM TD,WHOSIZ ; YES - RESET IT
POPJ PP, ; EXIT
;WH.OP3 ROUTINE TO SEE IF OP3 IS A WHOLE ARRAY
;
;IF OP3 IS WHOLE ARRAY, EITHER OP1 OR OP2 MUST BE WHOLE ARRAY.
;IF OP3 IS NOT WHOLE ARRAY, NEITHER OP1 NOR OP2 CAN BE WHOLE ARRAY.
;
;CALL: PUSHJ PP,WH.OP3 ; NO ARGUMENTS
; RETURN+1 ; ERROR RETURN
; RETURN+2 ; OK RETURN
;
;
;
WH.OP3: HRRZ TA,OPRTR+4 ; GET DATAB LINK
PUSHJ PP,LNKSET ; SET UP LINK
LDB TB,DA.ARE ; GET ARRAY ENTRY FLAG
JUMPN TB,WHOP3N ; JUMP IF ARRAY ENTRY
PUSHJ PP,FNDRES ; GET REAL DATAB ENTRY
LDB TD,DA.OCC ; GET NUMBER OF OCCURS
JUMPE TD,WHOP3N ; JUMP IF ZERO
LDB TC,DA.NAM ; GET NAMTAB LINK
ADD TC,NAMLOC ; ADD IN BASE
HLRZ TC,1(TC) ; GET FIRTS 3 CHARS
CAIN TC,'TAB' ; IS IT A TABLE?
JRST WHOP3N ; YES -
CAMGE TD,WHOSIZ ; NEW SIZE SMALLER?
MOVEM TD,WHOSIZ ; YES - REPLACE
SWON FWHOLE; ; MAKE SURE THIS IS ON
AOS (PP) ; SKIP
POPJ PP, ; TAKE ERROR RETURN
WHOP3N: TSWT FWHOLE; ; WE'RE NOT WHOLE ARRAY, WAS ANYONE ELSE?
JRST CPOPJ1## ; NO - OK
GETLN; ; GET ERRONEOUS LINE NUMBER
WARN 587; ; YES - ERROR
POPJ PP, ; TAKE ERROR RETURN
FNDRES: LDB TA,DA.NAM ; GET NAMTAB LINK
MOVEI TB,CD.DAT ; GET THAT ID
PUSHJ PP,FNDLNK ; FIND FIRST DATAB ITEM
JRST FNDFL1 ; EROR!
MOVE TA,TB ; GET PROPER AC
FNDRS1: LDB TB,DA.SIZ ; GET SIZE FIELD
JUMPN TB,CPOPJ ; EXIT WHEN FOUND
HRRZ TA,10(TA) ; else get same name link (DA.SNM)
JUMPE TA,FNDFL1 ; IF NONE THEN ERROR
PUSHJ PP,LNKSET ; SET IT UP
JRST FNDRS1 ; AND TRY AGAIN
;CHK3 COMMON ROUTINE TO CHECK FOR OP1,2,3 BEING WHOLE ARRAYS
;
;
;
CHK3: PUSHJ PP,WH.OP1 ; CHECK OUT OP1
PUSHJ PP,WH.OP2 ; CHECK OUT OP2
PUSHJ PP,WH.OP3 ; IS OP3 COMPATIBLE?
POP PP,TB ; NO - POP OFF EXTRA RETURN ADDRESS
POPJ PP, ; YES - EXIT
;WHLGN1 ROUTINE TO OUTPUT START CODE FOR HANDLING WHOLE ARRAY
;
;GENERATES THE FOLLOWING CODE:
;
; %TAG: SETZM %LIT
; MOVEI 0,1
; ADDB 0,%LIT
; CAILE 0,ARRAY-SIZE
; JRST %TAG2
;
;SEE WHLGN2 FOR END CODE
;
;
WHLGN1: HLRZ TB,OPRTR+1 ; GET INDICATORS
SKIPN TB ; DID WE GENERATE INDC. CODE?
PUSHJ PP,BLDTAG ; NO - OUTPUT TAG OURSELVES
MOVE TB,TAGNUM ; GET THAT NUMBER
MOVEM TB,WL%AE## ; STASH AS %TAG2
AOS TB,TAGNUM ; GET ANOTHER TAG
MOVEM TB,WL%L## ; STORE AS %TAG
PUSHJ PP,BLDTAG ; BUILD A TAG
PUSHJ PP,FNDTAG ; OUTPUT IT TO ASYFIL
MOVE CH,[XWD SETZM.+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT A SETZM
SKIPN CH,WHOLOC## ; DO WE HAVE A %LIT DEFINED YET?
PUSHJ PP,WLGN1A ; NO - DEFINE IT NOW
TRO CH,AS.LIT ; IDENTIFY AS LITAB ITEM
PUSHJ PP,PUTASN ; OUTPUT AS ADDRESS FOR SETZM
MOVE CH,[XWD MOVEI.+AC0,AS.CNS+1]
PUSHJ PP,PUTASY ; output a <MOVEI 0,1>
MOVE CH,[XWD ADDB.+AC0+ASINC,AS.MSC]
PUSHJ PP,PUTASY ; OUTPUT <AOS 0,%LIT>
MOVE CH,WHOLOC ; GET %LIT
TRO CH,AS.LIT ; IS LITAB ITEM
PUSHJ PP,PUTASN ; OUTPUT ADDRESS
HRLZI CH,<CAILE.+AC0> ; GET <CAILE 0,ARRAY-SIZE>
HRR CH,WHOSIZ ; ADD IN SIZE
PUSHJ PP,PUTASY ; OUTPUT INSTRUCTION
MOVE CH,WL%AE ; GET %TAG2
PUSHJ PP,LKTAG## ; LOOK UP IN PROTAB
ADD CH,[XWD JRST.,AS.PRO] ; MAKE INTO INSTRUCTION
PJRST PUTASY ; OUTPUT AND EXIT
WLGN1A: MOVE TB,ELITPC ; GET LITAB PC
MOVEM TB,WHOLOC ; SAVE FOR OTHERS
AOS ELITPC ; BUMP
MOVE CH,[XWD OCTLIT,1] ; GET LITAB HEADER
PUSHJ PP,STASHC ; OUTPUT
SETZ CH, ; MAKE <OCT 0>
PUSHJ PP,STASHC ; OUTPUT
MOVE CH,WHOLOC ; GET LOC
POPJ PP, ; RETURN
;WHLGN2 ROUTINE TO OUTPUT END CODE FOR HANDLING WHOLE ARRAYS
;
;GENERATES THE FOLLOWING CODE:
;
; JRST %TAG+1
; %TAG2:
;
;
;
WHLGN2: MOVE CH,WL%L ; GET %TAG
PUSHJ PP,LKTAG ; LOOK UP IN PROTAB
ADD CH,[XWD JRST.+ASINC,AS.PRO]
PUSHJ PP,PUTASY ; OUTPUT JRST+
MOVEI CH,AS.ABS+1 ; GET INCREMENT
PUSHJ PP,PUTASN ; OUTPUT
PUSH PP,TAGNUM ; SAVE TAGNUM
MOVE TB,WL%AE ; GET %TAG2
MOVEM TB,TAGNUM ; STICK INTO TAGNUM
PUSHJ PP,FNDTAG ; OUTPUT TO ASYFIL
POP PP,TAGNUM ; RESTORE TAGNUM
SWOFF FINDON; ; MAKE SURE IT'S OFF
POPJ PP, ; AND EXIT
;TABLE OF ONE-WORD POWERS OF TEN
POWR10: DEC 1 ; 0
DEC 10 ; 1
DEC 100 ; 2
DEC 1000 ; 3
DEC 10000 ; 4
DEC 100000 ; 5
DEC 1000000 ; 6
DEC 10000000 ; 7
DEC 100000000 ; 8
DEC 1000000000 ; 9
DEC 10000000000 ; 10
;TABLE OF ROUNDING FACTORS
ROUNDR: DEC 5 ; 1
DEC 50 ; 2
DEC 500 ; 3
DEC 5000 ; 4
DEC 50000 ; 5
DEC 500000 ; 6
DEC 5000000 ; 7
DEC 50000000 ; 8
DEC 500000000 ; 9
DEC 5000000000 ; 10
;DEFINITION OF ASYFIL CODES
DEFINE SETVAL (X,Y),<
X=Y'B26
INTERNAL X
>
SETVAL MOV,000
SETVAL MOVEI.,001
SETVAL MOVEM.,002
SETVAL MOVM.,003
SETVAL MOVMM.,004
SETVAL MOVN.,005
SETVAL MOVNI.,006
SETVAL MOVSI.,011
SETVAL AD,012
SETVAL ADDI.,013
SETVAL ADDM.,014
SETVAL ADDB.,015
SETVAL SUB.,016
SETVAL SUBI.,017
SETVAL SUBM.,020
SETVAL MUL.,021
SETVAL MULI.,022
SETVAL IMUL.,023
SETVAL ASH.,025
SETVAL DIV.,026
SETVAL TDO.,027
SETVAL TDZ.,030
SETVAL IDIV.,031
SETVAL IDIVI.,032
SETVAL FAD.,034
SETVAL FADM.,035
SETVAL FSB.,036
SETVAL FSBM.,037
SETVAL FMP.,040
SETVAL FMPM.,041
SETVAL FDV.,042
SETVAL FDVM.,043
SETVAL DPB.,044
SETVAL LDB.,045
SETVAL IDPB.,046
SETVAL ILDB.,047
SETVAL AOS.,050
SETVAL SOS.,051
SETVAL SOSGE.,052
SETVAL SOSLE.,053
SETVAL CAM.,052
SETVAL CAI.,053
SETVAL CAME.,054
SETVAL CAIE.,055
SETVAL CAMG.,056
SETVAL CAIG.,057
SETVAL CAMGE.,060
SETVAL CAIGE.,061
SETVAL CAML.,062
SETVAL CAIL.,063
SETVAL CAMLE.,064
SETVAL CAILE.,065
SETVAL CAMN.,066
SETVAL CAIN.,067
SETVAL JUMP.,067
SETVAL JUMPE.,070
SETVAL JUMPG.,071
SETVAL JMPGE.,072
SETVAL JUMPL.,073
SETVAL JMPLE.,074
SETVAL JUMPN.,075
SETVAL JRST.,076
SETVAL SKIP.,076
SETVAL SKIPE.,077
SETVAL SKIPG.,100
SETVAL SKPGE.,101
SETVAL SKIPL.,102
SETVAL SKPLE.,103
SETVAL SKIPN.,104
SETVAL SKIPA.,105
SETVAL TRNE.,106
SETVAL TRNN.,107
SETVAL TLNE.,110
SETVAL TLNN.,111
SETVAL IBP.,112
SETVAL PUSHJ.,113
SETVAL BLT.,114
SETVAL SETZM.,115
SETVAL SETOM.,116
SETVAL TDCA.,117
SETVAL ANDM.,120
SETVAL TDNN.,121
SETVAL HRLOI.,122
SETVAL HRROI.,123
SETVAL HRLZI.,124
SETVAL HRRZI.,125
SETVAL SETZB.,126
SETVAL ARG.,127
SETVAL SOJG.,130
SETVAL EXCH.,131
SETVAL CALLI.,132
SETVAL TLZ.,133
SETVAL TLO.,134
SETVAL SETCA.,135
SETVAL SETCM.,136
SETVAL POPJ.,137
;DEFINITION OF UUO CALLS
DEFINE SETVAL (X,Y,Z),<
X=Y'B26+Z'B30
INTERNAL X
>
SETVAL COMP.,174,0
SETVAL CMP.11,174,1
SETVAL CMP.12,174,2
SETVAL CMP.21,174,3
SETVAL CMP.22,174,4
SETVAL CMP.76,174,5
SETVAL CMP.96,174,6
SETVAL CMP.97,174,7
SETVAL SPAC.6,174,10
SETVAL SPAC.7,174,11
SETVAL SPAC.9,174,12
SETVAL COMP%,174,13
SETVAL CMP%11,174,14
SETVAL CMP%12,174,15
SETVAL CMP%21,174,16
SETVAL CMP%22,174,17
SETVAL MOVE.,175,0
SETVAL CD6D7.,175,1
SETVAL CD6D9.,175,2
SETVAL CD7D6.,175,3
SETVAL CD7D9.,175,4
SETVAL CD9D6.,175,5
SETVAL CD9D7.,175,6
SETVAL MVSGNR,175,7
SETVAL MVSGN,175,10
SETVAL TESTZ,175,11
SETVAL TIME.,175,12
SETVAL TIMED.,175,13
SETVAL RSVWD.,175,14
SETVAL TESTB.,175,15
SETVAL SQRT.,175,16
SETVAL DEBUG.,175,17
SETVAL SETOF.,176,0
SETVAL SETON.,176,1
SETVAL INDC.,176,2
SETVAL FORCE.,176,3
SETVAL EXCPT.,176,4
SETVAL READ.,176,5
SETVAL CHAIN.,176,6
SETVAL DSPLY.,176,7
;DEFINE UUO CALLS
DEFINE SETVAL (X,Y),<
X=Y'B26
INTERNAL X
>
SETVAL SUBSCR,140;
SETVAL FIX.,142
SETVAL FLOT1.,145
SETVAL FLOT2.,146
SETVAL PD6.,147;
SETVAL PD7.,150;
SETVAL GD6.,151;
SETVAL GD7.,152;
SETVAL NEG.,153;
SETVAL MAG.,154;
SETVAL ADD.12,155;
SETVAL ADD.21,156;
SETVAL ADD.22,157;
SETVAL SUB.12,160;
SETVAL SUB.21,161;
SETVAL SUB.22,162;
SETVAL MUL.12,163;
SETVAL MUL.21,164;
SETVAL MUL.22,165;
SETVAL DIV.11,166;
SETVAL DIV.12,167;
SETVAL DIV.21,170;
SETVAL DIV.22,171;
DEFINE SETVAL (X,Y),<
X=Y
INTERNAL X
>
;DEFINE LITFIL ITEMS
SETVAL XWDLIT,1 ; LITAB CODE FOR XWD GROUP
SETVAL BYTLIT,2 ; LITAB CODE FOR BYTE POINTER GROUP
SETVAL ASCLIT,3 ; LITAB CODE FOR ASCII CONSTANT
SETVAL SIXLIT,4 ; LITAB CODE FOR SIXBIT CONSTANT
SETVAL D1LIT,5 ; LITAB CODE FOR 1-WORD DECIMAL CONSTANT
SETVAL D2LIT,6 ; LITAB CODE FOR 2-WORD DECIMAL CONATANT
SETVAL FLTLIT,7 ; LITAB CODE FOR FLOATING-POINT CONSTANT
SETVAL OCTLIT,10 ; LITAB CODE FOR OCTAL CONSTANT
;DEFINE EXTERNALS AND SUCH ROT
EXTERNAL AS.CNB, AS.CNS, AS.ABS, AS.DOT
END