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 ; <<<<<<< 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 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 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 MOVE CH,ESAVAC ; GET LITERAL PUSHJ PP,PUTASN ; OUTPUT IT MOVE CH,[XWD MOVN.+AC5,AS.MSC] PUSHJ PP,PUTASY ; GENERATE 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 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 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, ; GENERATE 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, ; GENERATE 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 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 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 PUSHJ PP,PUTASY ; THUSLY ADDI CH,1 ; MAKE IT INTO A 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 MOVE CH,[XWD CMP.22,0] ; YES - GENERATE 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 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 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,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 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 TO CLEAR SIZE AREA POP PP,CH ; GET SIZE OFF STACK HRLI CH, ; MAKE A 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, ; MAKE A PUSHJ PP,PUTASY ; OUTPUT IT MOVE CH,[XWD IBP.+ASINC,AS.MSC] PUSHJ PP,PUTASY ; OUTPUT 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 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, ; 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 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, ; MAKE INTO INSTRUCTION PUSHJ PP,PUTASY ; OUTPUT MOVE CH,[XWD MOV+AC6+ASINC,AS.MSC] PUSHJ PP,PUTASY ; GENERATE MOVE CH,OP1LIT ; GET OP1 LITAB LOC TRO CH,AS.LIT ; IDENTIFY PUSHJ PP,PUTASN ; OUTPUT MOVE CH,[XWD IBP.,6] ; GET PUSHJ PP,PUTASY ; OUTPUT MOVE CH,[XWD SOJG.+AC0+ASINC,AS.MSC] PUSHJ PP,PUTASY ; GENERATE MOVEI CH,AS.DOT+77777 ; = .-1 PUSHJ PP,PUTASN ; OUTPUT AS ADDRESS MOVE CH,[XWD MOVEM.+AC6+ASINC,AS.MSC] PUSHJ PP,PUTASY ; GENERATE 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, ; 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 MOVE CH,[XWD ADDB.+AC0+ASINC,AS.MSC] PUSHJ PP,PUTASY ; OUTPUT MOVE CH,WHOLOC ; GET %LIT TRO CH,AS.LIT ; IS LITAB ITEM PUSHJ PP,PUTASN ; OUTPUT ADDRESS HRLZI CH, ; GET 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 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