Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/cmngen.mac
There are 20 other files named cmngen.mac in the archive. Click here to see a list.
; UPD ID= 1956 on 3/3/89 at 8:38 AM by KSTEVENS
TITLE CMNGEN FOR COBOL V13
SUBTTL COMMON ROUTINES USED BY CODE GENERATORS AL BLACKINGTON/CAM
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984, 1985 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
SEARCH OPCTAB
%%P==:%%P
IFN TOPS20,<SEARCH MONSYM,MACSYM>
;EDITS
;NAME DATE COMMENTS
;V13****************
;KWS 22-FEB-89 [1652] Add definition of SORT here to be used in SRTGEN
;RLF 26-OCT-86 [1633] Get correct internal size for comp items with
; depending on clause
;MEM 16-OCT-86 [1631] DON'T PUT OUT E.215 IF WE'VE HAD FATAL ERRORS
;V12B****************
;MJC 18-JUL-85 [1604] Make XPNLIT fixup CURIRG for INSPECT
;MJC 25-MAR-85 [1565] Remove OCCURS 1 TIMES optimization from
; subscripting.
;KWS 26-OCT-84 [1550] Clear flags in SETOPN.
;MJC 21-AUG-84 [1543] Fix 1411 to give no warning if ON SIZE ERROR
; is used.
;JEH 10-OCT-83 [1477] Adjust the correction factor added to floating
; point numbers (epsilon) to consider nbr of
; decimal places in source
;DMN 24-Feb-83 [1453] Fix 1411 to point to correct line on truncation error.
;JEH 30-Sep-82 [1411] Test for leading truncation warning in the rounding
; routine if conversion from floating point to binary
; before operand sizes adjusted.
;JEH 5-May-82 [1353] Eliminate HALT if literal is too large, give error.
;RJD 9-Mar-82 [1344] Bad code generated for literal compare.
;JSM 18-Sep-81 [1307] COMP-3 literal 0 is always generated unsigned.
; Make it signed if receiving operand is signed.
;DMN 19-Jun-81 [1300] Subroutine arg passing fails if REDEFINED item is specified
; in USING clause but original item is referenced.
;V12A****************
;JSM 19-Mar-81 [1123] Bad table link, catastrophe in phase E with
; subscript assoc with linkage item with no occurs clause.
;DMN 31-Dec-80 [1110] Allow ON SIZE ERROR code to catch divide by zero for COMP-1 result.
;DAW 29-Dec-80 [1107] Prevent "Ill mem ref"
;DAW 15-Dec-80 [1103] Bug in literal pooler caused bad code to
; be generated in rare cases.
;DAW 18-Nov-80 [1077] Prevent "ILL MEM REF" in PHASE E
;DAW 14-Nov-80 [1073] Bad code gen when depending item is at a level
; two or more down from the item being looked at
;DMN 1-APR-80 [1004] MAKE ASCII & EBCDIC COLLATING SEQUENCES WORK.
;DMN 30-JAN-80 [762] ADD SMALL CONSTANT TO COMP-2 COMPUTE CALCULATIONS.
; IMPLEMENT AND USE D. P. FLOATING POINT LITERALS.
;DAW 25-OCT-79 [753] MAKE 745 WORK FOR ANS68 TOO
;DAW 15-OCT-79 [745] MULTIPLE SUBSCRIPTS WITH NON-COMP DEPENDING VAR.
; COBOL-74 ONLY
;V12*****************
;DMN 6-OCT-79 [743] COBOL-74 MORE OF EDIT 721
;DMN 7-SEP-79 [730] FIX MULTIPLY A BY B ON SIZE ERROR FOR QUAD WORD.
;DMN 26-JUL-79 [722] COBOL-74 FIX MOVE HIGH/LOW-VALUES WITH PROGRAM COL. SEQ.
;DMN 24-JUL-79 [721] COBOL-74 FIX SUBSCRIPTED IF WITH PROGRAM COL. SEQ.
;DAW 22-JUN-79 [716] FIX BAD CHECK FOR EBCDIC MODE IN SUBSCRIPTING
;DMN 2-APR-79 [673] FIX QUAD WORD ROUNDING PROBLEM
;DAW 28-MAR-79 [671] FIX PROBLEM WITH LINKAGE SECTION SUBSCRIPTS
;DAW 12-MAR-79 [661] GIVE ERROR MESSAGE AND DISALLOW COMP-1 SUBSCRIPTS
;DAW 12-MAR-79 [660] FIX ERROR MESSAGE POINTS TO WRONG PLACE
;DAW 27-FEB-79 [643] FIX "?SIZTE RETURNED 0" IF PROGRAM ERRORS
;DMN 26-FEB-79 [636] FIX BAD LITERAL GENERATION IF PROGRAM HAS FATAL SUBSCRIPT ERRORS
;DAW 20-FEB-79 [634] FIX SIZE ERROR CHECKING FOR FOUR-WORD RESULTS
;DMN 16-JAN-79 [625] FIX BAD TEST FOR TWO WORD TEMP IN PUTEMP
;DMN 4-JAN-79 [621] MAKE BADALL A GLOBAL FOR MOVGEN
;DMN 11-DEC-78 [610] FIX INCORRECT CODE GENERATED IN ARRAY WHERE TOP LEVEL IS COMP IS REFERENCED VIA CONSTANT SUBSCRIPT
;DAW 7-DEC-78 [606] FIX ?INTERNAL COMPILER ERROR IF 01 ITEM OCCURS USAGE IS NON-DISPLAY
;DMN 31-OCT-78 [577] FIX SET DOWN BY 262144 (I.E. <-1,,0>)
;DMN 6-OCT-78 [570] ADD QUAD-WORD ROUNDING FUNCTION
;EHM 16-SEP-78 [551] FIX CATASTROPHE IN PHASE E
;EHM 14-SEP-78 [543] FIX ACCEPT INTO A DISPLAY-6 ITEM
;V10*****************
;EHM 6-JAN-78 [525] FIX SUBSCRIPT EXPRESSION AND NON COMP
;EHM 7-NOV-77 [522] FIX ROUNDING FOR LARGE DIFFERENCES IN NUMBER OF DECIMAL PLACES.
;DPL 23-JUN-76 [431] ADD PUTAYY AS INTERNAL FOR SORT GIVING
; 6-APR-76 [424] DONT ATTEMPT TO MAKE LITERAL IF NO SIZE
; 17-FEB-76 [406] SET ERROR RETURN FROM SETOPN IF DATA ITEM HAS ERROR BIT (DA.ERR) SET
; 28-JAN-76 [402] ALLOW INDEX REG AND INDIRECT ADDRESSING FOR ARGUMENT TO LIBOL
;JEC 21-JAN-76 [374] FIX CONVERSION FROM ASCII TO SIXBIT LITERALS
;DBT 23-JUN-75 REMOVE LAST OF UUOS - SETUUO:
;ACK 20-APR-75 ADD ABILITY TO MOVE DISPLAY-9 TO/FROM OTHER FLAVORS OF DISPLAY.
;ACK 22-APR-75 SAME AS ABOVE FOR FIGURATIVE CONSTANTS.
;********************
; EDIT 365 FIX MULTIPLE CALLS TO SETOPN FOR TALLY.
; EDIT 333 ALLOW TALLY AS A SUBSCRIPT TO BE ADDED TO SUBTRACTED FROM
; EDIT 330 MAINTAIN FFATAL ERROR BIT ON
; EDIT 306 JEC FIX SUBSCRIPTING OF COMP ITEMS IN AN ASCII RECORD.
; EDIT 274 RECOVER IF LITERAL SUBCRIPT IS TOO LARGE
; EDIT 262 HANDLE DUMMY SUBSCRIPT CORRECTLY [262]
; EDIT 251 RECOVER IF SUBSCRIPT IS SUBSCRIPTED
; EDIT 250 ALLOW TALLY AS A SUBSCRIPT
; EDIT 173 PUT BACK SOME CODE TAKEN OUT BY LITTAB FIX 167
; CODE MOVES CURLIT WHICH CONTAINS HEADER WORD LOCATION.
; EDIT 167 FIXES LITTAB OVERFLOW
; EDIT 161 DON'T ASSIGN FATHER'S USAGE TO THE SON IF SON'S IS NOT BINARY
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
ENTRY CMNGEN
CMNGEN:
;ROUTINES INCLUDED HERE
INTERNAL SZERO.,SQUOT.,ASRJ.,AZRJ.,AQRJ.,AHRJ.,ALRJ.,FPLOV.
INTERN SHVAL.,SLVAL. ;[722]
INTERN TSTARO,GDEBV,GDEBA,GDEBB,GDEBAB,CDEBA,CDEBB,CDEBAB
INTERNAL M.IA,M.IB,GETEMP,SETEMP,PUTEMP,PUTTAG,SETOPA,SETOPB,SETOPN
INTERN STASHI,STASHL,STASHP,STASHQ,MBYTPA,MBYTPB,PVALIT,PVLIT2
INTERNAL VALLIT,VLIT2,CONVNL,CONVFP,CONVF2,SCANL,MBYTEA,MBYTEB,DPDIV.
INTERNAL PUTASY,PUTASN,FORCX0,BMPEOP,GENFPL,GENF2L,PUSEOP,PUSH12,PUTAYY ;[431]
INTERNAL NEGATL,CREATL,MAKEL,MAKEL2,MAKEL4,ROUND,SIZERA,B1PAR,B2PAR
INTERNAL SWAPAB,ADJSL.,ADJSL1,ADJBL.,JOUT,SUBSCR,BYTE.A,BYTE.B,BYTE.C
INTERNAL SUBSCA,SUBSCB,SUBSCC,SUBSCD,SUBSCE
INTERNAL PUT.A,PUT.AA,PUT.B,PUT.BA,PUT.L,PUT.LA,PUT.LB,PUT.LC,PUT.LD
INTERNAL PUT.P,PUT.PA,PUT.PC,PUT.XA,PUT.XB,PUT.EX,PUT.16,PUT.SX,PUT.AO,PUT.BO,PUT.PJ
INTERNAL SUBSIZ
INTERNAL SZDPVA,SZDPVB
INTERNAL DEPCKK,DEPTSA,DEPTSB,DPBDEP
INTERNAL EPSLON ;[762]
;****************************************************************
;CONSTANTS INCLUDED HERE
INTERNAL BYTE.S,BYTE.W,CHAC,CHOP,W1LN,W1CP,TCLN,TCCP,POWR10,DPWR10
INTERNAL ACMODE,ACSIZE,TESUBC,W2SUBC,TASUBC
;****************************************************************
;ERROR ROUTINES INCLUDED HERE
INTERNAL OPNWRN, OPWRN, OPNFAT, OPFAT
INTERNAL BADEOP, NOTNUM, NOTDAT, NOTDEF
;EXTERNAL ROUTINES AND DATA
IFE TOPS20,<
EXTERN DEVDED,ERATYP,LITDEV,LITHDR
>
EXTERNAL XPNLIT,XPNTAG,XPNEOP,FATAL,WARN,KILL
EXTERNAL LNKSET,GETTAG,PUTAS1,PUTAS2,PUTAS3,ADJDP.,FNDBRO
EXTERNAL MXAC.,MACX.,MXX.,CFPCX.,CC1C2.
EXTERN CPOPJ1,CPOPJ
EXTERN MSERA. ;[1453]
EXTERNAL LITBLK,LITNXT,LITLOC,CURLIT
EXTERNAL ESZERO,ESQUOT,EAZRJ,EASRJ,EAQRJ,ELOVAL,EHIVAL,EFPLOV,EFPCNV,EF2CNV
EXTERNAL ELITPC,ELITHI,ESIZEZ,ETEMPC,ETEMAX,TEMBAS,OPERND,LITHLD,EPWR10,RPWR10
EXTERNAL EBASEA,EMODEA,ERESA,EINCRA,ESIZEA,EDPLA,EFLAGA,EBYTEA,ETABLA
EXTERNAL EBASEB,EMODEB,ERESB,EINCRB,ESIZEB,EDPLB,EFLAGB,EBYTEB,ETABLB
EXTERNAL EBASEX,EMODEX,ERESX,EINCRX,ESIZEX,EDPLX,EFLAGX,EBYTEX,ETABLX
EXTERNAL ESAVEA,ESAVAX,ESAVEB,ESAVBX,EBASAX,EBASBX,ESAVES,ESAVSB,ESAVSX
EXTERNAL EXTLOC,DATLOC
EXTERNAL TAGLOC,TAGCNT,EAC,EOPLOC,EOPNXT,CUREOP,EAS1PC,EAS2PC,EAS3PC,OPLINE
EXTERNAL ESAVAC,ESZERA,ESAVOP,ENOCC1,ENOCC2,SUBCON
EXTERNAL ESMAX, EREMAN,EWORDB,EMULSZ,ESAVDT,ESAVSW,SAVEAC
EXTERNAL SUBINP,CUROPP
EXTERNAL DA.USG,DA.NDP,DA.DPR,DA.INS,DA.EXS,DA.RES,DA.CLA,CURDAT
EXTERNAL DA.EDT,DA.SYR,DA.SYL,DA.SLL,DA.SGN,DA.DEF,DA.SUB
EXTERNAL DA.OCC,DA.NOC,DA.OCH,DA.DEP,DA.SON,DA.DCR
EXTERNAL AS.DAT,AS.TAG,AS.CNB,AS.MSC,AS.PAR,AS.LIT,AS.TMP
EXTERNAL AS.BYT,AS.XWD,AS.OCT,AS.DOT,AS.MS2
EXTERNAL TB.DAT,TM.DAT
EXTERNAL LNKCOD,LMASKB,LMASKS
EXTERNAL DPITM,DPLNK,DPVAR,DEPVB
EXTERNAL SIZE.4,SIZE.5 ;[634] SIZE CHECK ROUTINES IN LIBOL
;PUT A WORD ONTO THE CURRENT ASYFIL AND BUMP APPROPRIATE PC
PUTASY:
TLC CH,UUOMSK ;COMPLIMENT SO WE CAN CHECK FOR UUO'S
TLCN CH,UUOMSK ;POSSIBLE UUO??
JRST CNVUUO ;YES
PUTAYY:
TSWT FAS3 ;ARE WE CURRENTLY IN A NON-RESIDENT SEGMENT?
AOSA EAS2PC ;NO--BUMP RESIDENT PC
AOSA EAS3PC ;YES--BUMP NON-RESIDENT PC
JRST PUTAS2 ;WRITE ONTO AS2FIL
JRST PUTAS3 ;WRITE ONTO AS3FIL
;PUT ALTERNATE CODE SET MARKER INTO ASYFIL
PUTASA::MOVSI CH,ASMACS
;PUT A WORD ONTO THE CURRENT ASYFIL, BUT DON'T BUMP PC
PUTASN:
TSWFZ FUUOIC ;DO WE HAVE A UUO INCREMENT TO TRAP?
JRST CNVUUI ;YES - GO DO IT
TSWT FAS3 ;CURRENTLY IN NON-RESIDENT SEGMENT?
JRST PUTAS2 ;NO--USE AS2FIL
JRST PUTAS3 ;YES--USE AS3FIL
;PUT OUT REFERENCE TO A CONSTANT
;ENTER WITH INST IN CH, AND CONSTANT IN TE
;IF RHS OF CH = AS.CNB
;AND TE .LT. 77777
;GENERATE SMALL CONSTANT, ELSE GENERATE LARGE CONSTANT
PUTASC: CAILE TE,77777 ;IS IT A SMALL CONSTANT?
JRST PTASC2 ;NO, SO GIVE UP NOW
PUSH PP,CH
HRRZ CH,CH ;GET RHS ONLY
CAIE CH,AS.CNB+ASINC ;CONSTANT?
JRST PTASC1 ;NO
POP PP,CH
HRR CH,TE ;JUST USE CONST
JRST PUTASY ;AND OUTPUT IT
PTASC1: POP PP,CH
PTASC2: PUSH PP,TE ;SAVE CONST.
PUSHJ PP,PUTASY
POP PP,CH ;GET BACK CONST.
JRST PUTASN
;CALL PUTASY OR PUT.EX IF ADDRESS IS AN EXTERNAL SYMBOL
PUTAXY: LDB TE,[POINT 3,CH,20] ;LOOK AT ADDRESS
CAIN TE,AC.EXT## ;IS IT AN EXTERNAL SYMBOL?
JRST PUT.EX ;YES, CALL "PUT AN EXTERNAL"
JRST PUTASY ;NO, CALL REGULAR OUTPUT ROUTINE
;THIS ROUTINE IS CALLED FROM PUTASY AND PUTASN WITH JRST'S
; TO CNVUUO AND CNVUUI RESPECTIVELY
;
;THIS ROUTINE IS CALLED WHEN THERE IS A UUO TO BE CONVERTED TO
; A PUSHJ. WHEN IT RECIEVES A UUO ( IN CH ) FROM PUTASY IT CHECKS
; TO SEE IF THERE IS AN INCREMENT TO FOLLOW AND IF SO IT SETS THE
; SW FLAG FUUOIC AND RETURNS DIRECTLY TO THE PUTASY CALLER.
; FUUOIC WILL THEN CAUSE PUTASN TO JRST TO CNVUUI WITH THE INCREMENT.
; IF THERE IS NO INCREMENT IT WILL GENERATE THE PUSHJ IMMEDIATELY.
; THERE ARE 4 POSSIBLE CASES TO BE HANDLED DEPENDING UPON 1. IF THERE
; IS AN INCREMENT TO FOLLOW AND 2. IF THE UUO ROUTINE NEEDS TO SEE
; THE AC NUMBER IN THE UUO.
; NO INCREMENT - NO AC
; MOVEI 16,UUO.ADRESS.FIELD
; PUSHJ 17,UUO.ROUTINE
; INCREMENT - NO AC
; MOVEI 16,UUO.ADRESS.FIELD
; INCREMENT WORD TO ASY
; PUSHJ 17,UUO.ROUTINE
; NO INCREMENT - AC NEEDED
; MOVE 16,LIT00%
; LIT00% INCREMENT TO ASY
; PUSHJ 17,UUO.ROUTINE
; ...
; LIT00%+N:
; UUO INSTRUCTION
; INCREMENT - AC
; MOVE 16,LIT00%
; LIT00% INCREMENT TO ASY
; PUSHJ 17,UUO.ROUTINE
; ...
; LIT00%+N:
; UUO
; UUO ADDRESS INCREMENT
; NOTE THAT IF SOMEONE GENERATES A UUO WHICH MAKES
; USE OF THE INDEX FIELD AND/OR THE INDIRECT BIT IT WILL BE
; IMPROPERLY HANDLED IN THE LATTER 2 CASES SINCE THE ADDRESS WILL
; NOT BE EVALUATED A'LA A UUO CALL. INTERNAL COMPILER ERRORS
; WILL BE GENERATED FOR THIS CASE AND IF IT OCCURS THE UUO GENERATING
; ROUTINE WILL BE FIXED TO GENERATE THE PUSHJ DIRECTLY
; NOTE ALSO THE RUSSIAN ROUTLETTE WHICH IS BEING PLAYED BY PLACING
; THINGS INTO THE LIT00% TABLE - WE COULD BE SPLITTING A BLOCK WHICH
; THE CALLER IS GENERATING. IT IS HOPED THAT THIS WILL NOT OCCUR.
; IT WOULD BE A STRANGE THING TO DO BUT WHO KNOWS.
; FIRST A FEW SYMBOLIC DEFINITIONS OF FIELDS
ENDIT==177 ;END OF ASY FILES CODE
; ASY INSTRUCTION FIELD MASKS
IM.CD==600000 ;CODE FIELD OF INSTRUCTION
IM.IC==400000 ;INSTRUCTION CODE BIT
IM.OP==177000 ;OP CODE CODE FIELD
IM.AC==000740 ;AC FIELD
IM.ACL==000040 ;LOW ORDER AC BIT
IM.IN==000017 ;INDEX FIELD
IM.IX==000020 ;INDIRECT BIT
IM.ADH==600000 ;HIGH ORDER TWO BITS OF ADDRESS CODE
; ASY INSTRUCTION FIELD BYTE POINTERS
IP.OP==<POINT 7,CH,8> ;ASY OPERATOR FIELD
IP.AC==<POINT 4,CH,12> ;AC FIELD
IP.ACH==<POINT 3,CH,11> ;HIGH 3 AC BITS
EXTERNAL UUOSV% ;SAVE UUO TO BE CONVERTED
EXTERNAL UUINC% ;SAVE INCREMENT OF UUO TO BE CONVERTED
CNVUUO:: ;PUTASY ENTRY POINT
;IS THERE ANY POINT IN LOOKING AT ALL??
SKIPE LITASY## ;IF NOT = 0 THEN
JRST PUTAYY ;LITERALS, NOT INSTRUCTIONS ARE BEING
;SHOVED INTO THE ASY FILES
; FIRST DO AN INTERNAL CHECK OF THE INCREMENT FLAG
; IT SHOULD NEVER BE ON AT THIS POINT
TSWFZ FUUOIC
PUSHJ PP,CNVER ;BAD NEWS
;NOW DO WE HAVE A VALID UUO???
PUSH PP,TE ;SAVE SOME REGS
PUSH PP,TD
TLNE CH,IM.IC ;IS THIS REALLY AN INSTRUCTION OR
; JUST A REVERSED ASY ASN CALL???
JRST CNVUNO ;BAD CALL - IF A UUO SLIPED THROUGH
; COBOLG WILL LET US KNOW
LDB TE,[IP.OP] ;OPERATOR
CAIGE TE,FSTUUO ;IS IT IN THE LOWER BOUND?
;THIS IS DONE BECAUSE THE CHECK IN PUTASY
; IS NOT COMPLETELY ACCURATE
JRST CNVUNO ;NOT A UUO
LDB TD,[IP.AC] ;GET AC FOR LATER
CAIE TE,ENDIT ;END OF ASY FILE???
JRST CNVU11 ;ITS A UUO
;MAYBE - CHECK AC FOR 17
CAIN TD,17
JRST CNVUNO ;YES IT IS THE END
CNVU11:
;HACK HACK IF ADDRESS TYPE 6 OR 7 SET ASINC
TRC CH,IM.ADH
TRCN CH,IM.ADH
TLO CH,ASINC ;SET IT IF 6 OR 7
MOVEM CH,UUOSV%## ;SAVE UUO AWAY
TLNN CH,ASINC ;IS INCREMENT TO FOLLOW??
JRST CNVUU2 ;NO - LETS GET IT OVER WITH NOW
;YES INDEED LETS GO BACK AND WAIT FOR THE PUTASN CALL
SWON FUUOIC ;SET FLAG TO GET BACK
JRST CNVUED ;BACK TO CALLER OF PUTASY
CNVUNO: POP PP,TD ;RESTORE REGS
POP PP,TE
JRST PUTAYY ;RETURN PAST UUO TEST AND CONTINUE
CNVUUI:: ;PUTASN ENTRY POINT
PUSH PP,TE
PUSH PP,TD
MOVEM CH,UUINC%## ;SAVE INCREMENT
MOVE CH,UUOSV% ;GET UUO
LDB TE,[IP.OP] ;GET OPERATOR
LDB TD,[IP.AC] ; AND AC FIELD
CNVUU2:
PUSH PP,TA ;SAVE TA
JUMPE TD,CNVU2A ;USE MOVEI IF AC = 0 REGARDLESS
CAIGE TE,UUOWAC+1 ;DOES AC EXTEND OP CODE?
; THE 1 IS ADDED BECAUSE FOR OPEN/CLOSE
;THE AC IS A PARAMETER AND DEFINES OP
JRST CNVUU5 ;NO
; YES - SO WE CAN USE THE MOVEI 16,UUO.ADDRESS
CNVU2A:
TLZ CH,IM.OP!IM.AC ;CLEAR OPERATOR,AC
TLO CH,MOVEI.+AC16 ;CHANGE IT TO MOVEI 16,
PUSHJ PP,PUTASY ;PUT IT INTO ASY FILE
MOVE CH,UUOSV% ;IS THERE AN INCREMENT TO FOLLOW?
TLNN CH,ASINC
JRST CNVUU6 ;NO INCREMENT
MOVE CH,UUINC% ;YES - PUT IT INTO ASY FILE
PUSHJ PP,PUTASN
JRST CNVUU6 ;GO DO PUSHJ
CNVUU5: ;WE NEED A MOVE 16,[UUO]
; FIRST PUT UUO IN LIT TABLE
MOVE TA,[XWDLIT,,2] ;PUT OUT XWD
PUSHJ PP,STASHP
HLRZ TA,UUOSV% ;GET AC FIELD
TRZ TA,IM.CD!IM.OP ;CLEAR CODE AND OP FIELDS
;[402] TRNE TA,IM.IX!IM.IN ;ARE INDEX AND INDIRECT BITS 0?
;[402] PUSHJ PP,CNVER ;OH OH COMPILER ERROR
PUSHJ PP,STASHQ ;STORE AC AWAY AS A COMMENT
MOVE TA,UUOSV% ;GET ADDRESS FIELD
TLNN TA,ASINC ;IS THERE AN INCREMENT
SETZM UUINC% ;NO INCREMENT
HRL TA,UUINC% ;YES- GET IT
PUSHJ PP,POOLIT
;NOW THE MOVE 16,[UUO]
MOVE CH,[MOV+ASINC+AC16,,AS.MSC]
PUSHJ PP,PUTASY
SKIPN CH,PLITPC ;GET POOLED LIT
SKIPA CH,ELITPC ;NOT POOLED, USE THE INCREMENT TO LIT00%
CAIA
AOS ELITPC
IORI CH,AS.LIT
PUSHJ PP,PUTASN
HLRZ TA,UUOSV% ; [402] PICK UUO
TRNN TA,IM.IX!IM.IN ; [402] IF NO INDEX OR INDIRECT
JRST CNVUU6 ; [402] GO GENERATE NOW , THE PUSHJ
LDB TE,[POINT 7,UUOSV%,8] ;GET OPERATOR
CAIN TE,UUOWAC ;OPEN AND CLOSE ARE SPECIAL
JRST CNVUU6 ;NEED THESE BITS FOR VARIOUS FUNCTIONS
MOVE CH,[EXP <HRRI.+AC16>B17+<Z @>+<<AC16>_<-5>>] ; [402] GENERATE
PUSHJ PP,PUTASY ; [402] "HRRI 16,@16"
CNVUU6: ;NOW FOR THE PUSHJ
;FIRST GET EXTAB INDEX FROM TABLE
MOVE CH,UUOSV% ;GET UUO BACK
LDB TE,[IP.OP] ;OPERATOR
CAIGE TE,UUOWAC ;NEED AC ??
JRST CNVUU9 ;NO
LDB TD,[IP.ACH] ;YES- GET AC
CAIG TE,UUOWAC ;IS OPEN/CLOSE
SETZI TD, ;YES- CLEAR HIGH 3 BITS
TLNE CH,IM.ACL ;RIGHT OR LEFT HALF OF TABLE?
SKIPA CH,@UUOTBB-UUOWAC(TE) ;RIGHT
HLRZ CH,@UUOTBB-UUOWAC(TE) ;LEFT
JRST CNVU10
CNVUU9: ;AC DOES NOT EXTEND OP CODE
HRRZ CH,UUOTB6-FSTUUO(TE) ;GET EXTAB INDEX
CNVU10: ;PUT OUT PUSHJ
TRNN CH,77777 ;FIRST CHECK FOR LEGAL INDEX
PUSHJ PP,CNVER ;NO LEGAL
PUSHJ PP,GNPSX. ;GO GENERATE THE PUSHJ.
POP PP,TA ;RESTORE TA
CNVUED:
POP PP,TD
POP PP,TE
POPJ PP,
CNVER: OUTSTR [ASCIZ '?Compiler error - UUO conversion
']
SWON FFATAL ;SET ERROR FLAG
POPJ PP,
; A TABLE OF POINTERS TO DISPATCH TABLES
UUOTBB: Z UUO1.(TD)
Z UUO2.(TD)
Z UUO3.(TD)
Z UUO4.(TD)
Z UUO5.(TD)
DEFINE TABLE2,<
UUOTB6.: TABSEP <FIX%,0>
TABSEP <PERF%,0,FLOT%2,PD6%,PD7%,GD6%,GD7%>
TABSEP <0,0,0,0,0>
TABSEP <0,0,0,MUL%12,MUL%21,MUL%22>
TABSEP <DIV%11,DIV%12,DIV%21,DIV%22>
>
DEFINE TABSEP (Y),<
IRP Y,<IFDIF <Y><0>,<EXTERNAL Y>
EXP Y
>>
UUO1.: XWD C%OPEN##,C%CLOS##
UUO2.: XWD DSPLY%##,ACEPT%##
XWD READ%##,WRITE%##
XWD WADV%##,RDNXT%##
XWD DELET%##,RERIT%##
XWD PURGE%##,INIT%##
XWD TERM%##,0
XWD DSPL%6##,DSPL%7##
XWD 0,0
UUO3.: XWD COMP%##,CMP%76##
XWD 0,NUM%6##
XWD ALF%6##,ZERO%6##
XWD POS%6##,NEG%6##
XWD 0,NUM%7##
XWD ALF%7##,ZERO%7##
XWD POS%7##,NEG%7##
XWD COMP%D##,0
UUO4.: XWD MOVE%##,C%D6D7##
XWD C%D7D6##,CMP%E##
XWD CMP%G##,CMP%GE##
XWD CMP%L##,CMP%LE##
XWD CMP%N##,0
REPEAT 3,< XWD 0,0>
UUO5.: XWD EDIT%S##,EDIT%U##
XWD INSP%##,SUBSC%##
XWD SIZE%1##,SIZE%2##
XWD SIZE%3##,E%C3C1##
XWD E%C3C3##,OVLAY%##
XWD C%EXIT##,ARGS%##
XWD PUTF%##,RESF%##
XWD GETNM%##,ILLC%##
TABLE2
;ROUTINE TO GENERATE:
; HRRZI 16, <ADR>
; PUSHJ 17, <EXTERNAL>
;WHERE:
; EXTERNAL = RH(CH)
; ADR = (EACC) IF NON ZERO OR SXR IF (EACC) IS ZERO.
PMOPV.::
HRLM CH, (PP) ;SAVE THE EXTERNAL.
PUSH PP, [EXP PMOPU7] ;WHERE WE GO NEXT.
MOVE CH, [XWD HRRZI.+AC16,SXR] ;ASSUME (EACC)=0.
JUMPE EACC, PUTASY ;IF THE PARAMETER IS GOING TO
; BE IN SXR, GO GENERATE THE
; INSTRUCTION AND GO ON.
TLO CH, ASINC ;OTHERWISE CHANGE THE ADDRESS
HRRI CH, AS.MSC ; SO THAT IT HAS AN INCREMENT.
PUSHJ PP, PUTASY ; GENERATE THE INSTRUCTION.
HRRZI CH, (EACC) ;GET THE ADDRESS PORTION
PJRST PUTASN ;GO WRITE IT OUT AND GO ON.
;ROUTINE TO GENERATE:
; HRRZI 16, <EBASEB+EINCRB>
; PUSHJ 17, <EXTERNAL>
;WHERE:
; EXTERNAL = RH(CH)
PMOPB.::
HRLM CH,(PP) ;SAVE THE EXTERNAL.
PUSH PP,[EXP PMOPU7] ;WHERE WE GO NEXT.
MOVSI CH,HRRZI.+AC16
JRST PUT.B ;GET ADDRESS
;ROUTINE TO GENERATE:
; HRRZI 16, <POWER OF TEN>
; PUSHJ 17, <EXTERNAL>
;WHERE:
; EXTERNAL = RH(CH)
; POWER OF TEN = TC
PMOPC.::
PUSHJ PP,CREATL ;GET POWER OF TEN IN LIT POOL
MOVE EACC,EPWR10(TC) ;GET ADDRESS OF LITERAL
JRST PMOPV. ;GENERATE CALL
;ROUTINE TO GENERATE:
; MOVE 16, %LIT
; PUSHJ 17, <EXTERNAL>
; .
; .
; .
; %LIT: BYTE (9)0(4)AC(5)0(18)ADR
;WHERE:
; EXTERNAL = RH(CH)
; AC = (EAC)
; ADR = (EACC) IF NON ZERO OR SXR IF (EACC) IS 0.
PMOPU.::
SKIPN EAC ;IF THE AC FIELD IS GOING TO BE
JRST PMOPV. ; ZERO GO GENERATE HRRZI INSTEAD.
HRLM CH, (PP) ;SAVE THE EXTERNAL.
MOVE TA, [XWD XWDLIT,2] ;SET UP XWD HEADER.
PUSHJ PP, STASHP ;GO WRITE IT OUT.
HRRZ TA, EAC ;GET THE AC.
LSH TA, 5 ;PUT IT IN THE AC FIELD.
PUSHJ PP, STASHQ ;WRITE OUT THE LH OF THE XWD.
MOVEI TA, SXR ;ASSUME THE PARAMETER IS IN SXR.
JUMPE EACC, PMOPU5 ;IS IT?
HRLI TA, (EACC) ;NO, GET IT.
HRRI TA, AS.MSC ;IT IS MISCELLANEOUS.
PMOPU5: PUSHJ PP, POOLIT ;WRITE OUT THE RH OF THE XWD.
MOVE CH, [XWD MOV+AC16,AS.MSC] ;GET THE MOVE INSTR.
PUSHJ PP, PUTASY ;WRITE IT OUT.
SKIPN CH, PLITPC ;GET PC IF POOLED
SKIPA CH, ELITPC ;GET THE LITAB PC.
CAIA
AOS ELITPC ;BUMP IT OVER THE XWD.
IORI CH, AS.LIT ;FORM THE XWD'S ADDRESS.
PUSHJ PP, PUTASN ;WRITE IT OUT.
PMOPU7: HLRZ CH, (PP) ;GET THE EXTERNAL BACK AND
; FALL INTO THE ROUTINE TO PUT
; OUT "PUSHJ 17,<EXTERNAL>".
;ROUTINE TO GENERATE "PUSHJ 17,<EXTERNAL>".
; ENTER WITH THE EXTAB ADDRESS OF THE EXTERNAL IN RH(CH).
GNPSX.::
HRRZI TA, (CH) ;SAVE THE EXTAB LINK.
HRLI CH, EPJPP ;FORM THE INSTRUCTION.
PUSHJ PP, PUTASY ;GO PUT IT IN THE ASY FILE.
ANDI TA, LMASKB## ;GET THE EXTAB OFFSET.
ADD TA, EXTLOC ;FORM THE ADDRESS.
SETOI TE, ;GET SOME ONES.
TSWF FAS3; ;ARE WE IN A NONRESIDENT SEGMENT?
DPB TE, EX.NRS## ;YES, SET THE FLAG.
POPJ PP, ;RETURN.
;CREATE THE LITERAL <SIXBIT "000000">
SZERO.: SKIPE ESZERO ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
MOVE TB,[SIXBIT "000000"] ;NO
PUSHJ PP,SLITX.
MOVEM TB,ESZERO ;SET ADDRESS
POPJ PP,
;CREATE THE LITERAL <SIXBIT '""""""'>
SQUOT.: SKIPE ESQUOT ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
MOVE TB,[SIXBIT '""""""'] ;NO
PUSHJ PP,SLITX.
MOVEM TB,ESQUOT
POPJ PP,
;NOTE, DON'T POOL THESE LITERAL, THEY ARE POOLED ALREADY
ELITX.: SKIPA TA,[XWD EBCLIT,1] ;PUT ONE EBCDIC LITERAL IN LITAB.
SLITX.: MOVE TA,[XWD SIXLIT,1]
PUSHJ PP,STASHI
MOVE TA,TB
PUSHJ PP,STASHL
MOVE TB,ELITPC
AOS ELITPC
IORI TB,AS.LIT
POPJ PP,
;[722] CREATE THE LITERAL SIXBIT HIGH-VALUES WITH PROG. COL. SEQ.
SHVAL.: SKIPE ESHIVL## ;[722] HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;[722] YES--RETURN
HRRZ TB,COHVLV## ;[722] NO, GET HIGH-VALUE CHAR.
IMULI TB,10101 ;[722] THREE CHARACTERS
HRL TB,TB ;[722] SIX CHARACTERS
PUSHJ PP,SLITX. ;[722]
MOVEM TB,ESHIVL ;[722] SET ADDRESS
POPJ PP, ;[722]
;[722] CREATE THE LITERAL SIXBIT LOW-VALUES WITH PROG. COL. SEQ.
SLVAL.: SKIPE ESLOVL## ;[722] HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;[722] YES--RETURN
HRRZ TB,COHVLV+3 ;[722] NO, GET LOW-VALUE CHAR.
IMULI TB,10101 ;[722] THREE CHARACTERS
HRL TB,TB ;[722] SIX CHARACTERS
PUSHJ PP,SLITX. ;[722]
MOVEM TB,ESLOVL ;[722]SET ADDRESS
POPJ PP, ;[722]
;CREATE THE LITERAL <XWD 360360,360360> (EBCDIC '0000')
EZERO.::
SKIPE EEZERO## ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES, RETURN.
MOVE TB, [XWD 360360,360360] ;GET THE LITERAL.
PUSHJ PP, ELITX. ;GO PUT IT IN LITAB.
MOVEM TB, EEZERO## ;REMEMBER ITS ADDRESS.
POPJ PP, ;RETURN.
;CREATE THE LITERAL <XWD 377377,377377> (EBCDIC HIGH VALUES)
EHVLS.::
SKIPE EEHIGH## ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES, RETURN.
SKIPLE COLSEQ ;[1004] [722] PROGRAM COL. SEQ.?
JRST [HRRZ TB,COHVLV+2 ;[722] YES, GET EBCDIC HIGH-VALUE
IMUL TB,[1001,,1001] ;[722] 4 CHARS.
JRST .+2] ;[722]
MOVE TB, [XWD 377377,377377] ;GET THE LITERAL.
PUSHJ PP, ELITX. ;GO PUT IT IN LITAB.
MOVEM TB, EEHIGH## ;REMEMBER ITS ADDRESS.
POPJ PP, ;RETURN.
;[722] CREATE THE LITERAL (EBCDIC LOW VALUES)
ELVLS.::
SKIPE EELOW## ;[722] HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;[722] YES, RETURN.
HRRZ TB,COHVLV+5 ;[722] GET EBCDIC LOW-VALUE
IMUL TB,[1001,,1001] ;[722] 4 CHARS.
PUSHJ PP,ELITX. ;[722] GO PUT IT IN LITAB.
MOVEM TB,EELOW## ;[722] REMEMBER ITS ADDRESS.
POPJ PP, ;[722] RETURN.
;CREATE THE LITERAL <XWD 100100,100100> (EBCDIC ' ')
ESPAC.::
SKIPE EESPCE## ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES, RETURN.
MOVE TB, [XWD 100100,100100] ;GET THE LITERAL.
PUSHJ PP, ELITX. ;GO PUT IT IN LITAB.
MOVEM TB, EESPCE## ;REMEMBER ITS ADDRESS.
POPJ PP, ;RETURN.
;CREATE THE LITERAL <XWD 177177,177177> (EBCDIC '""""')
EQUOT.::
SKIPE EEQUOT## ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES, RETURN.
MOVE TB, [XWD 177177,177177] ;GET THE LITERAL
PUSHJ PP, ELITX. ;GO PUT IT IN LITAB.
MOVEM TB, EEQUOT## ;REMEMBER ITS ADDRESS.
POPJ PP, ;RETURN.
;CREATE THE LITERAL
; OCT 231231231231
; OCT 231231231231
; OCT 231231231237
;(COMP-3 HIGH-VALUES PIC S9(18).)
C3HVL.::
SKIPE EACC, C3HIVL## ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES, RETURN.
PUSH PP, [XWD 231237,C3HIVL##] ;SET UP THE
PUSH PP, [XWD 231231,231231] ; PARAMETERS.
PJRST PC3LIT ;GO WRITE OUT THE LITERAL.
;CREATE THE LITERAL
; OCT 231231231231
; OCT 231231231231
; OCT 231231231233
;(COMP-3 LOW-VALUES PIC S9(18).)
C3LVL.::
SKIPE EACC, C3LOVL## ;HAS IT ALREADY BEEN GENERATED?
POPJ PP, ;YES, RETURN.
PUSH PP, [XWD 231233,C3LOVL##] ;SET UP THE
PUSH PP, [XWD 231231,231231] ; PARAMETERS.
PJRST PC3LIT ;GO WRITE OUT THE LITERAL.
;CREATE THE LITERAL
; OCT 0
; OCT 0
; OCT 14 ;[1307] (COMP-3 ZERO PIC S9(18).)
;OR
; OCT 17 ;[1307] (COMP-3 ZERO PIC 9(18).)
;[1307] GENERATE LITERAL SEPARATELY FOR EACH RECEIVING OPERAND, AS THERE
;[1307] MAY BE A MIX OF SIGNED AND UNSIGNED RECEIVING OPERANDS.
C3ZRO.::
TSWT FBSIGN ;[1307] Is receiving item signed?
JRST C3ZRO1 ;[1307] No, must be unsigned
SKIPE EACC,C3ZROS## ;[1307] Has it already been generated?
POPJ PP, ;[1307] Yes, return
PUSH PP,[14,,C3ZROS] ;[1307] No, set up signed literal
JRST C3ZRO2 ;[1307]
C3ZRO1: SKIPE EACC,C3ZROU## ;[1307] Has it already been generated?
POPJ PP, ;[1307] Yes, return
PUSH PP,[17,,C3ZROU] ;[1307] No, set up unsigned literal
C3ZRO2: PUSH PP,EACC ;[1307] Set up the parameters
;AND FALL INTO THE SUBROUTINE.
;NOTE, DON'T POOL THESE LITERALS
PC3LIT: MOVE TA, [XWD OCTLIT,3] ;SET UP THE HEADER.
PUSHJ PP, STASHI ;GO WRITE IT OUT.
POP PP, TA ;GET THE FIRST 3 DIGITS.
PUSHJ PP, STASHL ;GO WRITE THEM OUT.
PUSHJ PP, STASHL ;THE NEXT 8 ARE THE SAME.
HLR TA, (PP) ;GET THE LAST 3 AND THE SIGN.
; THE PRECEEDING 4 DON'T CHANGE.
PUSHJ PP, STASHL ;GO WRITE THEM OUT.
MOVEI EACC, 3 ;GET THE ADDRESS AND
EXCH EACC, ELITPC ; BUMP THE PC.
ADDM EACC, ELITPC
IORI EACC, AS.LIT ;NOTE THAT IT IS IN LITTAB.
POP PP, TA ;GET THE LOCATION INTO WHICH
; WE SHOULD PUT THE ADDRESS.
MOVEM EACC, (TA) ;REMEMBER WHERE WE PUT THE LIT.
POPJ PP, ;RETURN.
;CREATE THE LITERAL <ASCII "00000">, AND THE SAME LITERAL
; SHIFTED RIGHT 1 BIT.
AZRJ.: SKIPE EAZRJ ;HAVE THEY ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
MOVE TB,[ASCII "00000"] ;NO
PUSHJ PP,AXRJ.
MOVEM TB,EAZRJ
POPJ PP,
;CREATE THE LITERAL <ASCII " ">, AND THE SAME LITERAL
; SHIFTED RIGHT 1 BIT.
ASRJ.: SKIPE EASRJ ;HAVE THEY ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
MOVE TB,[ASCII " "] ;NO
PUSHJ PP,AXRJ.
MOVEM TB,EASRJ
POPJ PP,
;CREATE THE LITERAL <ASCII '"""""'>, AND THE SAME LITERAL
; SHIFTED RIGHT 1 BIT.
AQRJ.: SKIPE EAQRJ ;HAVE THEY ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
MOVE TB,[ASCII '"""""'] ;NO
PUSHJ PP,AXRJ.
MOVEM TB,EAQRJ
POPJ PP,
;CREATE THE LITERAL ASCII HIGH-VALUES, AND THE SAME LITERAL
; SHIFTED RIGHT 1 BIT.
AHRJ.: SKIPE EAHRJ## ;HAVE THEY ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
SKIPLE COLSEQ## ;[1004] [722] PROGRAM COLLATING SEQUENCE
JRST [HRRZ TB,COHVLV+1 ;[722] YES, GET ASCII HIGH-VALUE CHAR.
IMUL TB,[2010,,40201] ;[722] 5 CHARACTERS
LSH TB,1 ;[722] LEFT JUSTIFIED (MUST BE SEPARATE TO AVOID OVERFLOW)
JRST .+2] ;[722]
MOVE TB,[BYTE (7) 177,177,177,177,177] ;NO
PUSHJ PP,AXRJ.
MOVEM TB,EAHRJ
POPJ PP,
;CREATE THE LITERAL ASCII LOW-VALUES, AND THE SAME LITERAL
; SHIFTED RIGHT 1 BIT.
ALRJ.: SKIPE EALRJ## ;HAVE THEY ALREADY BEEN GENERATED?
POPJ PP, ;YES--RETURN
SKIPLE COLSEQ## ;[1004] [722] PROGRAM COLLATING SEQUENCE
JRST [HRRZ TB,COHVLV+4 ;[722] YES, GET ASCII LOW-VALUE CHAR.
IMUL TB,[2010,,40201] ;[722] 5 CHARACTERS
LSH TB,1 ;[722] LEFT JUSTIFIED (MUST BE SEPARATE TO AVOID OVERFLOW)
JRST .+2] ;[722]
SETZ TB, ;[BYTE (7) 0,0,0,0,0]
PUSHJ PP,AXRJ.
MOVEM TB,EALRJ
POPJ PP,
;NOTE, DON'T POOL THESE LITERALS
AXRJ.: MOVE TA,[XWD ASCLIT,1]
PUSHJ PP,STASHI
MOVE TA,TB
PUSHJ PP,STASHL
AOS ELITPC
MOVE TA,[XWD OCTLIT,1]
PUSHJ PP,STASHI
MOVE TA,TB
LSH TA,-1
PUSHJ PP,STASHL
AOS TB,ELITPC
SUBI TB,2 ;BACKUP TO START OF LITERAL PAIR
IORI TB,AS.LIT
POPJ PP,
;CREATE TWO-WORD "HIGH-VALUE" LITERAL
HIVAL:: SKIPE EHIVAL ;IS THERE ONE ALREADY?
POPJ PP, ;YES--QUIT
HRLOI TC,377777 ;NO
PUSHJ PP,HILO.
MOVEM TE,EHIVAL
POPJ PP,
;CREATE TWO-WORD "LOW-VALUE" LITERAL
LOVAL:: SKIPE ELOVAL ;IS THERE ONE ALREADY?
POPJ PP, ;YES--QUIT
HRLZI TC,1B18 ;NO
PUSHJ PP,HILO.
MOVEM TE,ELOVAL
POPJ PP,
;CREATE LOW-VALUE FOR FLOATING-POINT
FPLOV.: SKIPE EFPLOV ;IS THERE ONE ALREADY?
POPJ PP, ;YES--QUIT
MOVE TA,[XWD OCTLIT,1] ;NO
PUSHJ PP,STASHI
MOVE TA,[EXP 1B0!1B35]
PUSHJ PP,STASHL
MOVE TA,ELITPC
IORI TA,AS.LIT
MOVEM TA,EFPLOV
AOS ELITPC
POPJ PP,
;COMMON ROUTINE FOR HIVAL. & LOVAL.
HILO.: MOVE TA,[XWD OCTLIT,2]
PUSHJ PP,STASHI
MOVE TA,TC
PUSHJ PP,STASHL
PUSHJ PP,STASHL
MOVEI TE,2
EXCH TE,ELITPC
ADDM TE,ELITPC
IORI TE,AS.LIT
POPJ PP,
;INCREMENT PARAMETERS OF "A" OPERAND BY THE NUMBER OF BYTES
; WHOSE VALUE IS IN "TE".
M.IA: MOVE TC,EMODEA
CAIN TC, C3MODE ;IF IT'S COMP-3, GO CHANGE
PUSHJ PP, M.IA2 ; IT TO DISPLAY-9.
IDIV TE,BYTE.W(TC) ;ADJUST INCREMENT
ADDM TE,EINCRA
HLRZ TE,ERESA
PUSHJ PP,M.IB5
JUMPG TE,M.IA1 ;TO BIT 35 OR BEYOND?
AOS EINCRA ;YES--INCREMENT THE INCREMENT
ADDI TE,^D36 ;RESET RESIDUE
M.IA1: HRLM TE,ERESA
POPJ PP,
M.IA2: SKIPN TC, ESIZEA ;SKIPPING THE WHOLE THING?
JRST M.IB7 ;YES.
JRST M.IB6N ;NO.
;INCREMENT PARAMETERS OF "B" OPERAND BY THE NUMBER OF BYTES
; WHOSE VALUE IS IN "TE".
M.IB: HRRZ TC,EMODEB
CAIN TC, C3MODE ;IF IT'S COMP-3 GO CHANGE
PUSHJ PP, M.IB6 ; IT TO DISPLAY-9.
IDIV TE,BYTE.W(TC)
ADDM TE,EINCRB
PUSHJ PP,M.IB4
JUMPG TE,M.IB1
AOS EINCRB
ADDI TE,^D36
M.IB1: HRLM TE,ERESB
POPJ PP,
M.IB4: HLRZ TE,ERESB
M.IB5: IMUL TD,BYTE.S(TC)
SUB TE,TD
CAML TE,BYTE.S(TC)
POPJ PP,
CAIN TC,D7MODE
SUBI TE,1
POPJ PP,
M.IB6: SKIPN TC, ESIZEB ;SKIPPING THE WHOLE THING?
JRST M.IB7 ;YES.
M.IB6N: ADDI TC, (TE) ;FORM THE ORIGIONAL LENGTH.
TRNN TC, 1 ;IF IT WAS EVEN
ADDI TE, 1 ; MAKE SURE WE SKIP TO THE
TRNA ; NEXT BYTE.
M.IB7: ADDI TE, 2 ;ROUND UP AND SKIP THE SIGN.
M.IB8: LSH TE, -1 ;NUMBER OF 9 BIT BYTES TO SKIP.
MOVEI TC, D9MODE ;PRETEND IT'S DISPLAY-9.
POPJ PP, ;RETURN.
;GET A BYTE POINTER TO "A", IN ASYFIL XWD FORMAT, INTO TA&TB
BYTE.A: MOVEI TE,EBASEA
BYTE.X: HRRZ TC,EMODEX(TE)
HLRZ TA,ERESX(TE)
LSH TA,6
ADD TA,BYTE.S(TC)
ROT TA,-14
BYTE.Y: HRRI TA,AS.CNB
MOVE TB,EBASEX(TE)
HRL TB,EINCRX(TE)
POPJ PP,
;SIMILAR TO BYTE.A, EXCEPT FOR "B"
BYTE.B: MOVEI TE,EBASEB
JRST BYTE.X
;SIMILAR TO BYTE.B, EXCEPT SIZE PUT INTO BITS 6-17
BYTE.C: MOVEI TE,EBASEB
HLRZ TA,ERESB
LSH TA,14
ADD TA,ESIZEZ
HRLZS TA
JRST BYTE.Y
;PUT A SINGLE WORD INTO EOPTAB.
;ENTER AT PUSEOP WITH WORD IN 'CH'.
PUSEO1: PUSHJ PP,XPNEOP ;EXPAND EOPTAB
PUSEOP: MOVE EACA,EOPNXT
CAML EACA,[XWD -1,0] ;ENOUGH ROOM?
JRST PUSEO1 ;NO
PUSH EACA,CH ;YES--STASH IT
MOVEM EACA,EOPNXT ;SAVE EACA
POPJ PP,
;STASH W1&W2 IN EOPTAB.
;ENTER AT PUSH12.
PUS12A: PUSHJ PP,XPNEOP ;EXPAND EOPTAB
PUSH12: MOVE EACA,EOPNXT ;GET END OF TABLE
CAML EACA,[XWD -2,0] ;ENOUGH ROOM FOR TWO WORDS?
JRST PUS12A ;NO
PUSH EACA,W1 ;YES--STASH W1
PUSH EACA,W2 ; AND W2
MOVEM EACA,EOPNXT ;SAVE EACA
POPJ PP,
;HERE FOR LITERAL POOLING
;STASHP JUST STORES A LITERAL IN THE TEST POOL
; IF THE POOL IS FULL DUMP THE CONTENTS INTO STASHL AND SET FLAG
;
;POOLIT STORES THE CURRENT LITERAL IN POOL
; THEN TESTS ENTIRE CONTENTS OF POOL AGAINST LITTAB
; IF A MATCH IS FOUND PLITPC POINT TO START OF LITERAL
; IF NO MATCH IS FOUND THE LITERAL IS PUT IN LITTAB AND PLITPC SET TO ZERO
;INITIALIZE THE POINTERS
POOLINI::
MOVEI TE,1
MOVEM TE,PLITOF## ;SET OFFSET TO 1 INITIALL TO ACCOUNT FOR ZERO
PLINI1: SETZM PLITPC## ;SET NO POOLED PC
PLINI2: MOVEI TE,PLITSZ## ;GET SIZE
MOVEM TE,PLITCT## ;INITIALIZE THE COUNT
PLINI3: MOVE TE,[POINT 36,PLITBF##]
MOVEM TE,PLITPT## ;INITIALIZE THE POINTER
POPJ PP,
;STORE THE HEADER OF A LITERAL IN THE POOL BUFFER
STASHP: SKIPGE PLITCT ;ANY ROOM?
JRST STASHI ;NO
SOSGE PLITCT ;ONE MORE WORD?
JRST [PUSHJ PP,POOLFL ;NO, POOL JUST FILLED UP
JRST STASHI]
TRNE TA,770000 ;VERY LARGE LITERAL
JRST [PUSHJ PP,PLINI2 ;RESET POINTERS INTO PLITBF
MOVEI DW,E.660 ;[1353] YES
JRST BADLIT] ;[1353] GIVE ERROR
HRRZ TE,TA ;GET SIZE
HLLZ TA,TA ;GET TYPE ONLY
LSH TA,-6
IOR TA,TE ;ADD IN SIZE
HRL TA,ELITPC ;AND PUT LIT P.C. IN LHS
JRST STSHP0
;STORE REST OF LITERAL IN POOL BUFFER
STASHQ: SKIPGE PLITCT ;ANY ROOM?
JRST STASHL ;NO
SOSGE PLITCT ;ONE MORE WORD?
JRST [PUSHJ PP,POOLFL ;NO, POOL JUST FILLED UP
JRST STASHL]
STSHP0: IDPB TA,PLITPT ;YES, STORE
POPJ PP,
POOLFL: PUSH PP,TA ;SAVE CURRENT LITERAL
PUSHJ PP,PLINI1 ;RESET POINTERS
ILDB TA,PLITPT ;GET LITERAL
PUSHJ PP,STASHL ;STORE
SOSLE PLITCT ;COUNT DOWN
JRST .-3 ;LOOP
SETOM PLITCT ;MAKE SURE WE DON'T COME AGAIN
POP PP,TA ;ORIGINAL LIT
POPJ PP,
;ACC USAGE
;TA POINTER INTO LITTAB
;TB POINTER INTO PLITBF
;TC END OF LITTAB
;TD COUNTER OF ITEMS IN THIS LITERAL
;TE DATUM
POOLIT::
PUSHJ PP,STASHQ ;STORE THIS LITERAL
POOL:: SKIPGE PLITCT ;ANYTHING IN POOL?
JRST PLINI1 ;NO, RESET POINTERS
MOVE TE,[TD,,SAVEAC]
BLT TE,SAVEAC+4 ;SAVE TD THRU TA
SKIPE NOPOOL## ;NO POOLING REQUESTED ?
JRST PLIT1A ;YES, SKIP POOLING TESTS
MOVEI TB,PLITBF ;BASE OF POOLED LITS
HRRZ TC,LITNXT ;END OF LITS
HRRZ TA,LITLOC ;BASE OF LITS
ADD TA,PLITOF ;BYPASS FIRST WORD (ITS ZERO)
PLIT0: MOVEI TB,PLITBF ;BASE OF POOLED LITS
PLIT1: HRRZ TE,(TA) ;GET LITERAL FROM LITTAB
HRRZ TD,(TB) ;AND FROM POOLING BUFFER
CAMN TE,TD ;MATCH?
AOJA TB,PLIT2 ;YES
ANDI TE,7777 ;GET SIZE
ADDI TA,1(TE) ;BYPASS THIS GROUP
CAIGE TA,(TC) ;AT END?
JRST PLIT1 ;NO
PLIT1A: MOVS TE,[TD,,SAVEAC] ;[1103] New label
BLT TE,TA ;RESTORE
PUSHJ PP,PLINI3 ;RESET POINTER
MOVNI TE,PLITSZ
ADDM TE,PLITCT ;- COUNT OF WORDS TO MOVE
ILDB TA,PLITPT ;GET LITERAL
PUSHJ PP,STASHL ;STORE IT
AOSGE PLITCT ;COUNT DOWN
JRST .-3
JRST PLINI1 ;RETURN WITH PLITPC=0
;POOL ROUTINE (CONT'D)
PLIT2: MOVE TD,(TA) ;GET WORD AGAIN
HLRZM TD,PLITPC ;ASSUME SUCCESS
PLIT3: ANDI TD,7777 ;FORM COUNT
MOVN TD,TD ;NEGATE TO
HRL TB,TD ; FORM AOBJN POINTER
PLIT4: ADDI TA,1 ;BUMP POINTER
MOVE TE,(TA) ;GET LITERAL
CAME TE,(TB) ;MATCH?
JRST PLIT90 ;NO
AOBJN TB,PLIT4 ;LOOP FOR ALL OF IT
HRRZ TE,PLITPT ;GET END OF BUFFER
CAIGE TE,(TB) ;FINISHED?
JRST PLIT99 ;YES, FOUND A MATCH
CAMN TA,TC ;[1103] Is the group that just matched
;[1103] the first literal group at the
;[1103] logical end of the literals?
JRST PLIT1A ;[1103] Yes, can't pool even if it matches
;[1103] past the end
ADDI TA,1 ;BYPASS HEADER
HRRZ TD,(TA) ;GET NEXT GROUP HEADER
HRRZ TE,(TB)
CAMN TD,TE ;MATCH?
AOJA TB,PLIT3 ;YES
PLIT90: HLRE TB,TB ;GET WORDS LEFT
MOVM TB,TB
ADDI TA,(TB) ;BYPASS REST OF GROUP
JRST PLIT0 ;AND TRY AGAIN
PLIT99: SKIPN PLITPC ;MAKE SURE ITS NOT AT LIT+00
JRST PLIT0 ;TOO BAD, WE CAN NOT TELL IT FROM FAILURE
MOVS TE,[TD,,SAVEAC] ;OK
BLT TE,TA ;RESTORE
JRST PLINI2 ;SUCCESSFUL RETURN
;PUT A WORD INTO AS.LIT
;IF LITAB IS FULL AND < FULLIT WORDS, EXPAND AS.LIT
;IF LITAB 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 (SEE EBURPL IN XFRGEN),
;YET SMALL ENOUGH SO THAT CURRENT LITERAL GROUP
;BEING STASHED WILL NOT BE WRITTEN OUT.
;LARGEST LITERAL GROUP IS ASCII, SIZE 120, OR
; A MULTI-DIMENSION SUBSCRIPT CALL.
STASHI: SETZM PLITPC ;JUST INCASE STILL SET
TRNE TA,770000 ;VERY LARGE LITERAL
JRST [PUSHJ PP,PLINI2 ;RESET POINTERS INTO PLITBF
MOVEI DW,E.660 ;[1353] YES
JRST BADLIT] ;[1353] GIVE ERROR
HRRZ TE,TA ;GET SIZE
HLLZ TA,TA ;GET TYPE ONLY
LSH TA,-6
IOR TA,TE ;ADD IN SIZE
HRL TA,ELITPC ;AND PUT LIT P.C. IN LHS
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,
;TABLE IS FULL
STSHL0: HLRE TE,LITLOC ;IS
MOVMS TE ; LITAB
CAILE TE,FULLIT ; AS BIG AS IT GETS?
JRST STSHL2 ;YES
SKIPE ALITSV## ;[1077] NEED TO SAVE A PTR?
JRST STSL1A ;[1077] YES
PUSHJ PP,XPNLIT ;NO--EXPAND LITAB
JRST STASHL ;TRY AGAIN
;[1077] THE ABSOLUTE POINTER TO LITTAB WILL NOT BE ANY GOOD AFTER
;[1077] THIS, SO WE HAVE TO MAKE IT A RELATIVE POINTER DURING THE
;[1077] TABLE EXPANSION.
STSL1A: PUSH PP,TA ;[1077] SAVE A COUPLE ACS
PUSH PP,TE ;[1077]
PUSH PP,TB ;[1077]
MOVE TA,ALITSV ;[1077] GET PTR TO EBASEA OR SOMETHING..
JUMPL TA,STSL1C ;[1604] MUST TEMTAB POINTER
HRRZ TE,EBYTEX(TA) ;[1077] GET PRESENT BP
HRRZ TB,VALLOC## ;[1077] START OF TABLE
SUB TE,TB ;[1077] THIS IS OFFSET
JUMPL TE,[PUSHJ PP,XPNLIT ;[1344] IF ALREADY RELATIVE POINTER
JRST STSL1B] ;[1344] SKIP CODE TO MAKE RELATIVE
PUSH PP,TE ;[1077]
PUSHJ PP,XPNLIT ;[1077] EXPAND LITTAB
POP PP,TE ;[1077] GET BP OFFSET
ADD TE,VALLOC ;[1077] GET NEW PTR INTO VALTAB
MOVE TA,ALITSV ;[1077] GET BP TO EBASEA OR SOMETHING..
HRRM TE,EBYTEX(TA) ;[1077] RESTORE BP
STSL1B: POP PP,TB ;[1344] [1077]
POP PP,TE ;[1077]
POP PP,TA ;[1077] RESTORE ACS
JRST STASHL ;[1077] GO CALL STASHL AGAIN
STSL1C: ;[1604] DO THE SAME THING BUT FOR CURIRG
HRRZ TE,CURIRG## ;[1604] GET CURIRG
HRRZ TB,TEMLOC## ;[1604] START OF TABLE
SUB TE,TB ;[1604] THIS IS OFFSET
PUSH PP,TE ;[1604]
PUSHJ PP,XPNLIT ;[1604] EXPAND LITTAB
POP PP,TE ;[1604] GET BP OFFSET
ADD TE,TEMLOC ;[1604] GET NEW PTR INTO VALTAB
MOVEM TE,CURIRG ;[1604] GET BP TO EBASEA OR SOMETHING..
JRST STSL1B ;[1604] POP AND RETURN
;LITAB IS FULL, AND IS 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
IFE TOPS20,<
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--TROUBLE
>
IFN TOPS20,<
SKIPLE LITJFN## ;IS LITFIL ALREADY OPEN?
JRST STSHL3 ;YES
PUSHJ PP,OPNLIT## ;NO, SO OPEN IT
>
SETZM LITBLK ;CLEAR WORD COUNT
;PUT WORD INTO LITAB (CONT'D)
;LITFIL IS NOW OPEN FOR OUTPUT
;NOW COUNT WORDS SO THAT WE LEAVE A COMPLETE BLOCK AS FIRST THING IN LITAB
STSHL3: HRRZ TE,LITLOC ;BASE OF LITERALS
ADD TE,PLITOF ;PLUS OFFSET
SOS TA,PLITOF ;INITIALIZE THE COUNT
STSHL6: HRRZ TD,(TE) ;GET TYPE AND COUNT
ANDI TD,7777
ADDI TA,1(TD)
ADDI TE,1(TD) ;NEXT LITERAL GROUP
CAIGE TA,FULLIT ;ENOUGH?
JRST STSHL6 ;NO
SUBI TA,FULLIT-1 ;GET EXTRA WORDS
MOVEM TA,PLITOF ;RESET OFFSET FOR COMPARES
MOVEI TE,FULLIT
ADDM TE,LITBLK ;BUMP WORD COUNT
MOVSI TE,-FULLIT ;CREATE
HRR TE,LITLOC ; IOWD LIST FOR
SETZ TD, ; OUTPUT
IFE TOPS20,<
OUT LIT,TE ;WRITE IT
JRST STSHL4 ;OK
MOVEI CH,LITDEV ;ERROR--KILL
JRST DEVDED
>
IFN TOPS20,<
DMOVEM TE,IOWLIT## ;STORE IOWD
PUSHJ PP,RITLIT## ;WRITE IT OUT
>
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 TA,FULLIT ;UPDATE
SKIPE CURLIT ; ANY NON-ZERO
ADDM TA,CURLIT ; CURLIT
MOVE TA,[XWD SAVEAC+1,TD]
BLT TA,TB
MOVE TA,SAVEAC
JRST STASHL
IFE TOPS20,<
;ENTER FAILURE
STSHL5: OUTSTR [ASCIZ "?Cannot enter "]
MOVEI DA,LITDEV
HRRZ I2,TD ;GET ERROR CODE
JRST ERATYP
>
;GET SOME TEMPORARY LOCATIONS
;ENTER WITH DESIRED NUMBER OF WORDS IN "TE".
GETEMP: MOVE EACC,ETEMPC
ADDB TE,ETEMPC
CAMLE TE,ETEMAX
MOVEM TE,ETEMAX
IORI EACC,AS.TMP
ADD EACC,TEMBAS
POPJ PP,
;SET UP "B" PARAMETERS TO REPRESENT AN ASCII TEMP.
;ENTER WITH SIZE IN "TD", RELATIVE ADDRESS IN "TA".
SETEMP: IORI TA,AS.TMP
MOVEM TA,EINCRB
MOVEI TE,AS.MSC
MOVEM TE,EBASEB
MOVEI TE,^D36
HRLM TE,ERESB
MOVEM TD,ESIZEB
SETZM EDPLB
MOVEI TE,D7MODE
MOVEM TE,EMODEB
SWOFF FBNUM!FBSIGN
POPJ PP,
;MOVE AC'S TO %TEMP.
PUTEMP: SWON FANUM!FASIGN;
SWOFF FASUB!FAINAC;
HRRZ TD,EMODEA
MOVEI TE,1
CAIE TD,D2MODE
CAIN TD,F2MODE
MOVEI TE,2
PUSHJ PP,GETEMP
MOVEM EACC,EINCRA
MOVEI TE,AS.MSC
MOVEM TE,EBASEA
MOVSI CH,MOVEM.
CAIE TD,D2MODE ;[625]
CAIN TD,F2MODE
TRNA
PJRST PUT.AA
PUSHJ PP,PUTASA
MOVSI CH,DMOVM.
PJRST PUT.AA
;PUT A TAG ONTO ASYFIL, AND RESOLVE ADDRESS
PUTTAG: ANDI CH,77777
IORI CH,AS.TAG
HRLI CH,720000 ;WRITE IT OUT
PUSHJ PP,PUTASN
TSWF FAS3 ;ARE WE IN NON-RESIDENT SEGMENT?
SKIPA TE,EAS3PC ;YES
SKIPA TE,EAS2PC ;NO--RESIDENT
IORI TE,1B18
ANDI CH,77777 ;GET LOW 15 BITS ONLY
MOVE TD,TAGLOC
ADDI CH,(TD)
HRRM TE,0(CH) ;STORE PC OF TAG
POPJ PP,
;SET UP "A" PARAMETERS.
;ENTER WITH "TC" POINTING TO AN OPERAND.
;IF ANY ERRORS DETECTED, POP OFF ONE EXIT FROM PUSH-DOWN LIST, SUCH THAT
; WE EXIT TO THE ROUTINE WHICH CALLED THE CALLING ROTUINE.
SETOPA: MOVEI LN,EBASEA
STOPA1: PUSHJ PP,SETOPN
TSWF FERROR;
POP PP,TE
POPJ PP,
;SIMILAR FOR "B"
SETOPB: MOVEI LN,EBASEB
JRST STOPA1
;SET UP OPERAND PARAMETERS.
;ENTER WITH ADDRESS OF 2-WORD OPERAND IN TC, ADDRESS OF
; EITHER EBASEA OR EBASEB IN LN.
SETOPN: DMOVE TB,0(TC)
HRRZM TA,ETABLX(LN)
SETZM RMFLG2## ;zero Ref. Mod. flag
TXNN TB,GNREFM ;is this operand ref. modded?
JRST SETOPD ;no
TLNE TB,GNFIGC ;
JRST SETOPD ;
SETOM RMFLG2## ;yes, turn on flag
MOVE TE,TA ;get second operand word
LDB TE,TESUBC ;get subscript count
ASH TE,1 ;multiply it by two
ADD TE,TC ;add operand offset
MOVE TD,1(TE) ;at end is length modifier
SKIPGE TD ;if negative, error was detected
SETZM RMFLG2 ; zero flag word
MOVEM TD,RMLEN## ;else store adjusted length
SUBI TE,2 ;back up two in operand entry
MOVE TD,1(TE) ;get offset modifier
SKIPGE TD ;if negative, error
SETZM RMFLG2 ; zero flag word
MOVEM TD,RMOFF## ;else store increment,,residue
SETOPD: LDB TE,LNKCOD
CAIE TE,TB.DAT
JRST SETOP1
ANDI TA,LMASKB
IORI TA,AS.DAT
SETOP1: HRRZM TA,EBASEX(LN) ;STASH BASE ADDRESS
TLNE TB,GNLIT ;IS THIS A LITERAL?
JRST SETOP4 ;YES
TLNE TA,GNNOTD ;IS OPERAND EITHER TEMP OR AC'S?
JRST SETOP9
MOVEI DW,E.101 ;GET READY FOR "NOT DATA-NAME" ERROR
LDB TE,LNKCOD
IFN ANS82,<
CAIN TE,TB.MNE## ;IS IT A SYMBOLIC CHAR?
JRST SETSYC ;IT MIGHT BE
>
CAIE TE,TB.DAT ;IS IT A DATA-NAME?
JRST OPERA ;NO--ERROR
SETZM EINCRX(LN) ;YES--CLEAR INCREMENT
HLRZ TA,RMOFF ;set up ref. mod. increment
SKIPE RMFLG2 ;skipe if off,
MOVEM TA,EINCRX(LN) ; else store new increment
SETZM EFLAGX(LN) ;CLEAR FLAGS
MOVE TA,ETABLX(LN)
PUSHJ PP,LNKSET ;SET UP TABLE ADDRESS
LDB TE,DA.ERR## ; [406] ERROR BIT ON?
JUMPN TE,[SWON FERROR ; [406] CANT USE SET ERROR
POPJ PP,] ; [406] RETURN
LDB TE,DA.USG
SUBI TE,1
CAIN TE,IXMODE ;INDEX MODE?
MOVEI TE,D1MODE ;YES--PRETEND IT'S 1-WORD COMP
CAIN TE,%US.C3-1 ;COMP-3?
MOVEI TE,C3MODE ;YES, USE INDEX'S SLOT.
CAIN TE,%US.C2-1 ;COMP-2?
MOVEI TE,F2MODE ;YES, USE CORRECT INDEX
MOVEM TE,EMODEX(LN)
LDB TD,DA.RES ;GET RESIDUE
SKIPE RMFLG2 ;IS THE FIELD REF. MODDED?
HRRZ TD,RMOFF ;YES, USE NEW RESIDUE
HRLM TD,ERESX(LN) ; AND STASH
LDB TD,DA.NDP ;GET DECIMAL PLACES
LDB TE,DA.DPR ;IS DECIMAL POINT
SKIPE TE ; TO RIGHT OF FIELD?
MOVNS TD ;YES--NEGATE
MOVEM TD,EDPLX(LN) ;NO--STASH DECIMAL PLACES
LDB TE,DA.INS ;GET INTERNAL SIZE
SKIPE RMFLG2 ;IS FIELD REF. MODDED?
MOVE TE,RMLEN ;YES, USE ADJUSTED LENGTH
MOVEM TE,ESIZEX(LN)
MOVEI DW,E.104 ;GET READY FOR "UNDEFINED" ERROR
LDB TD,DA.DEF ;IF DEFINED,
JUMPN TD,SETOP0 ; GO ON
SWON FERROR ;SET ERROR FLAG
HRRZ TD,DATLOC ;CK FOR DUMMY DATAB ENTRY
SUBI TD,-1(TA)
JUMPN TD,OPERA ;IF NOT, PUT OUT ?NOT DEFINED
POPJ PP, ;IF DUMMY, EXIT NOW
;SET UP OPERAND PARAMETERS (CONT'D).
SETOP0: MOVE TE,1(TC) ;ANY
LDB TE,TESUBC ; SUBSCRIPTS?
MOVE TD,0(TC) ;
TXNE TD,GNREFM ;IS OPERAND REF. MODDED?
SUBI TE,2 ; YES, DECREMENT SUBSCRIPT COUNT BY 2
JUMPE TE,SETOP2 ;NO IF JUMP
LDB TD,DA.SUB ;SHOULD
JUMPN TD,SETOP2 ; THERE BE?
MOVEI DW,E.275 ;YES
PUSHJ PP,OPERA ; ERROR
SETOP2: SKIPN FLGSW ;FIPS FLAGGER WANTED?
JRST SETP2A ;NO
LDB TE,DA.LVL ;GET THE LEVEL #
CAIE TE,LVL.66 ;IS OPERAND A RENAMES?
JRST SETP2A ;NO
PUSH PP,LN ;YES, WHAT A CROCK
PUSH PP,CUREOP ; WE HAVE TO FLAG ALL REFERENCES TO IT
MOVEM TC,CUREOP ;SO FAKE UP WHAT WE NEED
PUSHJ PP,TST.N2 ; FOR GENERAL ERROR ROUTINE
MOVE TC,CUREOP
POP PP,CUREOP
POP PP,LN
SETP2A: CAIN LN,EBASEA ;"A" OPERAND?
JRST SETOP3 ;YES
;"B" OPERAND
SKIPL TE,EDEBDB## ;DID USER WANT DEBUGGING?
JRST SETOQ2 ;NO
SKIPE INDCLR## ;ARE WE STILL IN DECLARATIVES?
TDZA TD,TD ;YES, SO NO DEBUGGING ALLOWED
LDB TD,DA.DEB## ;DEBUGING ON THIS DATA-NAME ALLOWED?
SKIPE TD ;NO
HRRZ TD,EBASEX(LN) ;YES, GET BASE ADDRESS
MOVEM TD,EDEBDB ;SIGNAL DEBUGGING REQUIRED (OR NOT)
JUMPE TD,SETOQ2 ;DONE IF NOT DEBUGGING
HRRZM TE,EDEBGB## ;SAVE AS FLAG FOR "ARO" TEST
MOVE TD,EDEBDB ;GET BASE
PUSHJ PP,TSTARO ; SEE IF IT IS "ON ALL REFERENCES OF"
SETOQ2: LDB TD,DA.SGN ;IS 'B'
SKIPE TD ; SIGNED?
SWONS FBSIGN; ;YES
SWOFF FBSIGN; ;NO
LDB TE,DA.EDT
LDB TD,DA.CLA
SKIPN TE
CAIE TD,2
SWOFFS FBNUM ;EDITED OR NOT NUMERIC
SWON FBNUM ;NUMERIC AND NOT EDITED
LDB TD,DA.SUB ;SHOULD ITEM
SKIPN TD ; BE SUBSCRIPTED?
SWOFFS FBSUB; ;NO
SWON FBSUB ;YES
LDB TD,DA.LKS## ;LINKAGE SECTION?
SKIPE TD ;NO
SWON FBSUB ;YES
TSWF FBNUM ;NUMERIC?
JRST SETOPF ;YES, SET SIGN FLAGS
POPJ PP,
;"A" OPERAND
SETOP3: SKIPL TE,EDEBDA## ;DID USER WANT DEBUGGING?
JRST SETOQ3 ;NO
SKIPE INDCLR ;ARE WE STILL IN DECLARATIVES?
TDZA TD,TD ;YES, SO NO DEBUGGING ALLOWED
LDB TD,DA.DEB## ;DEBUGING ON THIS DATA-NAME ALLOWED?
SKIPE TD ;NO
HRRZ TD,EBASEX(LN) ;YES, GET BASE ADDRESS
MOVEM TD,EDEBDA ;SIGNAL DEBUGGING REQUIRED (OR NOT)
JUMPE TD,SETOQ3 ;DONE IF NOT DEBUGGING
HRRZM TE,EDEBGA## ;SAVE AS FLAG FOR "ARO" TEST
MOVE TD,EDEBDA## ;GET BASE
PUSHJ PP,TSTARO ; SEE IF IT IS "ON ALL REFERENCES OF"
SETOQ3: LDB TD,DA.SGN ;IS 'A'
SKIPE TD ; SIGNED?
SWONS FASIGN; ;YES
SWOFF FASIGN ;NO
LDB TE,DA.EDT
LDB TD,DA.CLA
SKIPN TE
CAIE TD,2
SWOFFS FANUM ;EDITED OR NOT NUMERIC
SWON FANUM ;NUMERIC AND NOT EDITED
LDB TD,DA.SUB ;IS IT
SKIPN TD ; SUBSCRIPTED?
SWOFFS FASUB ;NO
SWON FASUB ;YES
LDB TD,DA.LKS ;LINKAGE SECTION?
SKIPE TD ;NO
SWON FASUB ;YES
TSWT FANUM ;NUMERIC?
POPJ PP,
SETOPF: LDB TE,DA.SCF## ;GET FLAGS
DPB TE,[POINT 2,EFLAGX(LN),1]
POPJ PP,
;SET UP OPERAND PARAMETERS (CONT'D).
;OPERAND IS A LITERAL.
SETOP4: SETZM EINCRX(LN) ;[1550]CLEAR INCREMENT
SETZM EFLAGX(LN) ;[1550]CLEAR FLAGS
CAIE LN,EBASEA
JRST .+3
SKIPGE EDEBDA##
SETZM EDEBDA ;DON'T DEBUG ON "A" OPERAND
CAIN LN,EBASEA
JRST .+3
SKIPGE EDEBDB##
SETZM EDEBDB ;DON'T DEBUG ON "B" OPERAND
CAIE LN,EBASEA
SWOFFS FBSUB;
SWOFF FASUB;
TLNE TB,GNFIGC
JRST SETOP6
MOVEI TE,LTMODE
MOVEM TE,EMODEX(LN)
PUSHJ PP,LNKSET
HRLI TA,(POINT 14,0,13)
LDB TD,TA ;GET SIZE
MOVEM TD,ESIZEX(LN)
HRLI TA,(POINT 7,0,13) ;RESET TO FIRST REAL CHAR
MOVEM TA,EBYTEX(LN)
SETZM EDPLX(LN)
CAIE LN,EBASEA
JRST SETOP5
TLNE TB,GNNUM ;IS IT NUMERIC?
SWONS FANUM!FASIGN;
SWOFF FANUM!FASIGN;
POPJ PP,
SETOP5: TLNE TB,GNNUM ;IS IT NUMERIC?
SWONS FBNUM!FBSIGN;
SWOFF FBNUM!FBSIGN;
POPJ PP,
;SET UP OPERAND PARAMETERS (CONT'D).
;OPERAND IS A FIGURATIVE CONSTANT
SETOP6: MOVEI TE,FCMODE
MOVEM TE,EMODEX(LN)
SETZ TE, ;IN CASE ERROR
TLNE TB,GNFCS
MOVEI TE,IXSPAC
TLNE TB,GNFCZ
MOVEI TE,IXZERO
TLNE TB,GNFCQ
MOVEI TE,IXQUOT
TLNE TB,GNFCHV
MOVEI TE,IXHIV
TLNE TB,GNFCLV
MOVEI TE,IXLOWV
TLNN TB,GNTODY ;ONE OF THE TODAY REPLACEMENTS?
JRST SETOP7 ;NO
LDB TE,[POINT 2,TB,7]
SKIPN TE ;DAY-OF-WEEK IS 0
MOVEI TE,IXDOW-IXDATE+1 ; BUT SHOULD BE 4
ADDI TE,IXDATE-1
SETOP7: MOVEM TE,EFLAGX(LN)
SETOP8: MOVEM TA,1(TC)
POPJ PP,
;SET UP OPERAND (CONT'D)
;OPERAND IS A SYMBOLIC CHARACTER
IFN ANS82,<
SETSYC: PUSHJ PP,LNKSET
MOVEI DW,E.809
LDB TE,MN.SYC## ;MAKE SURE IT IS
JUMPE TE,OPERA ;NO, GIVE ERROR
MOVEI TE,FCMODE ;MAKE IT LOOK LIKE A FIGCON
MOVEM TE,EMODEX(LN)
MOVEI TE,1
MOVEM TE,ESIZEX(LN) ;SET SIZE TO 1
MOVEI TE,IXSYCH ;MAKE IT LOOK LIKE A
MOVEM TE,EFLAGX(LN) ; SYMBOLIC CHARACTER
JRST SETOP8 ;AND RETURN
>
;SET UP OPERAND (CONT'D).
;OPERAND IS A TEMP OR THE AC'S.
SETOP9: CAIE LN,EBASEA
SWOFFS FBSUB;
SWOFF FASUB;
MOVE TD,TA
LDB TE,ACMODE
MOVEM TE,EMODEX(LN)
LDB TE,ACSIZE
MOVEM TE,ESIZEX(LN)
HRREM TD,EDPLX(LN)
MOVEI TE,(TB) ;IS IT THE AC'S?
CAIG TE,17
JRST STOP10 ;YES
MOVEI TE,AS.MSC ;NO--TEMP
MOVEM TE,EBASEX(LN)
HRRZM TB,EINCRX(LN)
JRST STOP11
STOP10: SETZM EBASEX(LN) ;YES
SETZM EINCRX(LN)
STOP11: TLNE TB,GNOPNM ;IS IT NUMERIC?
JRST STOP12 ;YES
CAIE LN,EBASEA ;NO--"A"?
SWOFFS FBSIGN!FBNUM ;NO--MUST BE "B"
SWOFF FASIGN!FANUM ;YES
POPJ PP,
STOP12: CAIE LN,EBASEA ;IS THIS "A" OPERAND?
SWONS FBNUM!FBSIGN ;NO
SWON FANUM!FASIGN;
POPJ PP,
;GENERATE CODE TO ROUND THE AC'S
ROUND: SWON FROUND ;TURN ON "WE'RE ROUNDING"
HRRZ TE,EMODEB
CAIE TE,FPMODE
CAIN TE,F2MODE
JRST ROUND5
HRRZ TE,EMODEA
CAIN TE,FPMODE
JRST ROUND9
CAIN TE,F2MODE
JRST ROUNDF ;COMP-2
ROUND0: MOVE TC,EDPLA ;COMPUTE DIFFERENCE IN DECIMAL PLACES
SUB TC,EDPLB
SKIPE REMRND## ;SPECIAL IF ROUNDING AND REMAINDER
JUMPE TC,SPCRND ;IT IS
JUMPLE TC,NOROUN ;IF NOT POSITIVE--NO NEED FOR ROUNDING
CAIN TE,D4MODE ;[673] IS "A" 4 WORDS?
JRST ROUND7 ;[673] YES, NEED TO REDUCE TO 2 FIRST
MOVEM TC,ESAVAC
CAIG TC,^D10 ;MORE THAN 10?
JRST ROUND1 ;NO
PUSHJ PP,FORCX0 ;YES--INSURE AC'S ARE 0&1
MOVEI TC,^D10 ;GENERATE <DIV.21 [10**10]>
MOVSI CH,DIV.21
PUSHJ PP,PUT.PC
MOVNI TE,^D10 ;RESET SIZE AND DECIMAL PLACES
ADDM TE,ESIZEA
ADDM TE,EDPLA
ADDM TE,ESAVAC ;[522] GENERATE THE CORRECT LITERAL
ROUND1: MOVSI CH,SKIPL. ;GENERATE <SKIPL AC>
HRR CH,EAC
PUSHJ PP,PUTASY
MOVE TC,ESAVAC ;IS LITERAL ALREADY CREATED?
SKIPN CH,RPWR10-1(TC)
PUSHJ PP,ROUND4 ;NO--CREATE IT
MOVEM CH,ESAVAC
MOVEM CH,RPWR10-1(TC)
MOVE CH,[XWD SKIPA.+AC4,AS.MSC] ;GENERATE <SKIPA 4,[LIT]>
PUSHJ PP,PUTASY
MOVE CH,ESAVAC
PUSHJ PP,PUTASN
MOVE CH,[XWD MOVN.+AC4,AS.MSC] ;GENERATE <MOVN 4,[LIT]>
PUSHJ PP,PUTASY
MOVE CH,ESAVAC
PUSHJ PP,PUTASN
ROUND6: HRRZ TE,EMODEA
CAIN TE,D2MODE
JRST ROUND3
CAIE TE,D4MODE ;[570] SPECIAL QUAD-WORD CODE?
JRST ROUND2 ;[570] NO
MOVEI CH,ADD.4R## ;[570] YES
PJRST PUT.PJ ;[570] NEED HELP WITH THIS ONE
ROUND7: AOS EDPLB ;[673] ACCOUNT FOR ROUNDING
AOS ESIZEB ;[673] AND MAKE SIZE BIGGER ALSO
MOVN TC,TC ;[673] GET NO. OF DECIMAL PLACES TO REMOVE
ADD TC,ESIZEA ;[673] GET NEW SIZE WHEN DONE
CAIGE TC,MAXSIZ ;[673] SKIP IF REDUCING D.P. WON'T DO ANY GOOD
PUSHJ PP,ADJ4C.## ;[673] ADJUST DECIMAL PLACES
MOVE TE,EMODEA ;[673] MAKE SURE WE DON'T LOOP
CAIE TE,D4MODE ;[673] MODE SHOULD HAVE CHANGED BY NOW
JRST ROUND8 ;[673] OK, SO RETURN
PUSHJ PP,CUTC4## ;[673] NO, TRY TO REDUCE INTEGERS INSTEAD
PUSHJ PP,FORCX0 ;[673] PUT RESULT IN ACC 0 & 1
MOVE TE,EMODEA ;[673] MAKE SURE WE DON'T LOOP
CAIE TE,D4MODE ;[673] MODE SHOULD HAVE CHANGED BY NOW
JRST ROUND8 ;[673] OK, SO RETURN
PUSHJ PP,ADJ4C. ;[673] ONE LAST TRY
MOVE TE,EMODEA ;[673] MAKE SURE WE DON'T LOOP
CAIN TE,D4MODE ;[673] MODE SHOULD HAVE CHANGED BY NOW
JRST KILL ;[673] SHOULD NEVER HAPPEN
ROUND8: SOS EDPLB ;[673] BACK THE WAY IT WAS
SOS ESIZEB ;[673] ...
JRST ROUND0 ;[673] SO TRY AGAIN
;GENERATE CODE TO ROUND AC'S (CONT'D).
;AC'S CONTAIN 1-WORD COMP OR INDEX
ROUND2: MOVE CH,[XWD AD,4]
JRST PUT.XA
;AC'S CONTAIN A 2-WORD COMP
ROUND3: PUSHJ PP,FORCX0
PUSHJ PP,PUTASA
MOVE CH,[ASHC.+AC4+ASINC,,AS.CNB]
PUSHJ PP,PUTASY ;"ASHC 4,-^D35"
MOVEI CH,-^D35
PUSHJ PP,PUTASN
PUSHJ PP,PUTASA
MOVE CH,[DADD.,,4]
JRST PUTASY
;GET ROUNDING VALUE INTO LITERAL POOL
ROUND4: MOVE TA,[XWD D1LIT,1]
PUSHJ PP,STASHI
MOVE TA,ROUNDR-1(TC)
PUSHJ PP,STASHL
HRRZ CH,ELITPC
IORI CH,AS.LIT
AOS ELITPC
POPJ PP,
;ROUNDING NOT ALLOWED WITH COMP-1 OR COMP-2 RECEIVING FIELDS
ROUND5: MOVEI DW,E.300
JRST OPNWRN
;AC'S ARE FLOATING POINT, "B" IS NOT.
;CONVERT AC'S TO TWO-WORD COMP LEAVING 1 EXTRA DECIMAL PLACE.
ROUND9: MOVE TD,EDPLB
AOSE TD
PUSHJ PP,GENFPL
MOVSI CH,FIX.
PUSHJ PP,PUT.XA
JRST ROUNDG
;AC'S ARE D.P. FLOATING POINT, "B" IS NOT.
;CONVERT AC'S TO TWO-WORD COMP LEAVING 1 EXTRA DECIMAL PLACE.
ROUNDF: MOVE TD,EDPLB
AOSE TD
PUSHJ PP,GENF2L
HRRZ CH,EAC
DPB CH,CHAC ;GET ACC FIELD
PUSHJ PP,PUT.16 ;OUTPUT MOVX 16,<Z AC,AC>
MOVEI CH,FIX.2##
PUSHJ PP,PUT.PJ ;PUSHJ P,FIX.2
ROUNDG: TLNE W1,GNSERA ;[1543] ON SIZE ERROR USED?
JRST ROUNDH ;[1543] DON'T CHECK FOR TRUNCATION ERROR IF SO
MOVE TE,ESIZEB ;[1543] [1411] FIND DIFFERENCE IN DIGITS BEFORE
SUB TE,EDPLB ;[1411] THE DECIMAL POINT BETWEEN RESULT FIELD
ADD TE,EDPLA ;[1411] AND OPERANDS IN EXPRESSION
SUB TE,ESIZEA ;[1411] IF B OPERAND HAS SAME OR MORE,
SKIPGE TE ;[1453] [1411] NO LEADING TRUNCATION, SO CONTINUE
PUSHJ PP,MSERA. ;[1453]
ROUNDH: MOVE TE,[XWD ESIZEB,ESIZEA] ;[1543]
BLT TE,EBASAX
AOS ESIZEA
AOS EDPLA
MOVEI TE,D2MODE
MOVEM TE,EMODEA
JRST ROUND0
;GENERATE CODE TO ROUND IF REMAINDER ALSO
; THE FOLLOWING IS TRUE:
; THE REMAINDER IS IN AC 2 (2 AND 3 IF 2-WORD).
; THE QUOTIENT TO ROUND IS IN AC0 AND AC1.
; THE DIVISOR'S ADDRESS IS POINTED TO BY REMRND AND REMRN1.
; THE REMAINDER HAS ALSO BEEN SAVED IN %TEMP.
;
; ROUNDING PROCEDURE IS:
; MULTIPLY REMAINDER IN 2 BY 2. IF THIS IS GREATER OR EQUAL TO DIVISOR,
; ROUND UP (ADD 1 TO DIVIDEND), ELSE TRUNCATE (ADD 0 TO DIVIDEND).
SPCRND: HLRZ TC,REMRND ;GET "B" SIZE
SKIPN SGNREM## ;COULD REMAINDER BE NEGATIVE?
JRST SPCRNA ;NO--DON'T GET MAGNITUDE
CAIG TC,^D10
JRST SPCR10 ;S.P. MOVM
MOVE CH,[SKPGE.,,2]
PUSHJ PP,PUTASY
PUSHJ PP,PUTASA
MOVE CH,[DMOVN.+AC2,,2]
PUSHJ PP,PUTASY
JRST SPCRNA ;DONE GETTING POSITIVE REMAINDER IN 2&3
SPCR10: MOVE CH,[MOVM.+AC2,,2]
PUSHJ PP,PUTASY ;MOVM 2,2
SPCRNA: PUSHJ PP,PUTASA ;NOW TO MULTIPLY BY 2
CAIG TC,^D10
SKIPA CH,[ASH.+AC2,,1]
MOVE CH,[ASHC.+AC2,,1]
PUSHJ PP,PUTASY
SKIPN SGNDIV## ;DID WE HAVE A SIGNED DIVISOR?
JRST SPCRNB ;NO- LEAVE IT WHERE IT IS
;GET MAGNITUDE OF DIVISOR INTO AC4&5, CHANGE REMRND ACCORDINGLY
CAIG TC,^D10 ;BIG?
JRST SPCR20 ;NO
PUSHJ PP,PUTASA
MOVSI CH,DMOVE.+AC4+ASINC
HRR CH,REMRND
MOVE TE,REMRN1
PUSHJ PP,PUTASC ;PUT OUT CORRECT FORM OF CONSTANT
JRST SPCR30
SPCR20: MOVSI CH,MOVM.+AC4+ASINC
HRR CH,REMRND
MOVE TE,REMRN1
PUSHJ PP,PUTASC
SPCR30: MOVEI TE,AS.CNB ;RESET REMRND TO POINT TO ACS
HRRM TE,REMRND
MOVEI TE,4
MOVEM TE,REMRN1
SPCRNB: MOVE TD,REMPAR## ;GET REMAINDER PARAMETERS
LDB TC,ACSIZE ;GET SIZE
CAILE TC,^D10 ;D.P.
JRST SPCRDP ;YES
HRLI CH,CAMGE.+AC2+ASINC
HRR CH,REMRND
MOVE TE,REMRN1##
PUSHJ PP,PUTASC
SPCRNC: MOVE CH,[TDCA.+AC4,,4]
PUSHJ PP,PUTASY
MOVE CH,[MOVEI.+AC4,,1]
PUSHJ PP,PUTASY
MOVSI CH,SKPGE.
HRR CH,EAC
PUSHJ PP,PUTASY
MOVE CH,[MOVN.+AC4,,4]
PUSHJ PP,PUTASY
SETZM REMRND
JRST ROUND6
SPCRDP: HRLI CH,CAMN.+AC2+ASINC
HRR CH,REMRND
MOVE TE,REMRN1
PUSHJ PP,PUTASC
HRLI CH,CAML.+AC3+ASINC
HRR CH,REMRND
MOVE TE,REMRN1
ADDI TE,1
PUSHJ PP,PUTASC
MOVSI CH,CAMGE.+AC2+ASINC
HRR CH,REMRND
MOVE TE,REMRN1
PUSHJ PP,PUTASC
JRST SPCRNC
;GENERATE "SIZE ERROR" CODING
SIZERA: SWON FSZERA ;SET 'DON'T WORRY ABOUT TOO BIG'
MOVE TE,EDPLA
CAMLE TE,EDPLB
SIZER0: PUSHJ PP,ADJDP.
HRRZ TE,EMODEB ;IS RESULT FIELD FLOATING-POINT?
CAIE TE,FPMODE
CAIN TE,F2MODE
JRST SIZER7 ;[1110] YES, TEST FOR DIVIDE BY ZERO ONLY
HRRZ TD,EMODEA ;NO--IS "A" FLOATING-POINT?
CAIE TD,FPMODE
CAIN TD,F2MODE
PUSHJ PP,CFPCX. ;YES--CONVERT
MOVE TC,ESIZEB ;FIND POWER OF 10 REQUIRED
SKIPGE EFLAGB ;SEPARATE SIGN
SUBI TC,1 ;YES, 1 LESS DIGIT
SUB TC,EDPLB
ADD TC,EDPLA
JUMPL TC,SIZER0
CAILE TC,^D10 ;NEED A 2-WORD LITERAL?
JRST SIZER6 ;YES
HRRZ TD,EMODEA ;NO
CAIE TD,D1MODE
JRST SIZER4
;AC'S CONTAIN ONE WORD COMP OR INDEX, LITERAL IS ONE WORD.
;GENERATE TEST INLINE
MOVSI CH,MOVM.+AC13
HRR CH,EAC
PUSHJ PP,PUTASY ;GENERATE MOVM 13,ACC
MOVE CH,[SKIPN.,,OVFLO.##]
SKIPGE OVFLFL## ;SEE IF NEEDED
PUSHJ PP,PUT.EX
PUSHJ PP,CREATL
MOVSI CH,CAML.+AC13
PUSHJ PP,PUT.PC ;CAML 13,[POWER OF TEN]
MOVSI CH,SKIPA.
PUSHJ PP,PUTASY ;SKIP--WE HAVE TO SET SZERA.
PUSHJ PP,GETTAG ;GET A TAG FOR JRST AROUND SETOM
PUSH PP,CH
HRLI CH,JRST.
HRRZ TA,CH
PUSHJ PP,REFTAG## ;AND REFERENCE IT
PUSHJ PP,PUTASY
MOVE CH,[SETOM.,,SZERA.##]
PUSHJ PP,PUT.EX
SKIPN EMULSZ
SKIPA CH,ESZERA
PUSHJ PP,GETTAG
MOVEM CH,ESAVAC
HRRZ TA,CH ;GET TAG NUMBER
PUSHJ PP,REFTAG## ;REFERENCE IT
HRLI CH,JRST. ;JRST SIZE-ERROR TAG
PUSHJ PP,PUTASY
POP PP,CH ;GET TAG
PUSHJ PP,PUTTAG ;OUTPUT IT
SETZM OVFLFL ;CLEAR OVFLO. FLAG
SKIPN EMULSZ ;MORE THAN ONE RESULT?
JRST MACX. ;NO--GENERATE STASH AND RETURN
PUSHJ PP,MACX.
MOVE CH,ESAVAC
JRST PUTTAG
;GENERATE "SIZE ERROR" CODING (CONT'D).
;AC'S CONTAIN TWO WORDS, LITERAL IS ONE WORD
SIZER4: CAIN TD,D4MODE ;[634] FOUR WORDS IN ACS?
JRST SZER4A ;[634] YES
MOVSI CH,SIZE.2
JRST SIZER2
SZER4A: PUSH PP,[EPJPP,,SIZE.4] ;[634] ONE WORD LIT COMPARE-- CALL TO SIZE.4
CAIA ;[634]
SIZE6A: PUSH PP,[EPJPP,,SIZE.5] ;[634] TWO WORD LIT COMPARE-- CALL TO SIZE.5
MOVSI CH,MOVEI.+AC16 ;[634]
PUSHJ PP,PUTASY ;[634] AC16 POINTS TO 1ST AC OF FOUR
POP PP,CH ;[634]
PUSHJ PP,PUTASY ;[634] PUT OUT ROUTINE CALL
JRST SIZR2A ;[634] GO PUT OUT 2ND WORD
;LITERAL IS TWO WORDS
;[634] CHECK SIZE ERROR ON QUAD-WORD RESULT
SIZER6: HRRZ TE,EMODEA ;IS AC ONE WORD?
CAIN TE,D4MODE ;[634] FOUR WORDS IN ACS?
JRST SIZE6A ;[634] YES, USE SIZE.5
CAIE TE,D2MODE
PUSHJ PP,CC1C2. ;YES--CONVERT TO TWO WORDS
MOVSI CH,SIZE.3
SIZER2: SETZM OVFLFL ;CLEAR OVFLO. FLAG
HRR CH,EAC
PUSHJ PP,PUTASY
SIZR2A: PUSHJ PP,CREATL ;[634] ADD LABEL
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTASN
SKIPN EMULSZ
SKIPA CH,ESZERA
PUSHJ PP,GETTAG
MOVEM CH,ESAVAC
LDB TA,[POINT 15,CH,35] ;GET TAG NUMBER
PUSHJ PP,REFTAG## ;REFERENCE IT
PUSHJ PP,PUTASY
HRRZI CH,AS.MSC
HRL CH,EPWR10(TC)
PUSHJ PP,PUTASN
MOVE TE,EMODEA ;[730] GET MODE OF INTERMEDIATE TEMP
CAIN TE,D4MODE ;[730] IS IT QUAD-WORD?
PUSHJ PP,CUTC2C## ;[730] YES, CONVERT TO 2 WORDS NOW
JFCL ;[730] TAKE CARE OF NON-SKIP RETURN
SKIPN EMULSZ ;MORE THAN ONE RESULT?
JRST MACX. ;NO--GENERATE STASH AND RETURN
PUSHJ PP,MACX.
MOVE CH,ESAVAC
JRST PUTTAG
;[1110] HERE TO GENERATE FLOATING OVERFLOW TEST (DIVIDE BY ZERO)
;[1110] FOR COMP-1 AND COMP-2 RESULTS
SIZER7: PUSHJ PP,PUTASA ;[1110]
MOVSI CH,JFOV. ;[1110]
HRR CH,ESZERA ;[1110] TAG OF "ON SIZE ERROR" CODE
PUSHJ PP,PUTASY ;[1110]
SETZM OVFLFL ;[1110] CLEAR OVFLO. FLAG
JRST MACX. ;[1110] AND FORGET SIZE ERROR
;[762] GENERATE CODE TO ADD A SMALL NUMBER (EPSILON) TO COMP-2 ITEMS
;[762] TO MAKE UP FOR BITS LOST IN DP INSTRUCTIONS
;[762] THE EPSILON IS MORE THAN 2 ORDERS OF MAGNITUDE LESS THAN THE ROUNDING
;[762] VALUE IF ROUNDING HAD BEEN SPECIFIED.
EPSLON: MOVE TC,EDPLB ;[1477] If destination can hold more dec pl
CAMGE TC,EDPLA ;[1477] or if source has generated extra
MOVE TC,EDPLA ;[1477] use smaller correction factor
SKIPGE TC ;[1477] [762] GET NO OF DECIMAL PLACES IN "A"
POPJ PP, ;[762] GIVE UP IF "P" SHIFTED
ADDI TC,2 ;[762] MAKE IT 1000 TIMES
MOVE TA,[F2LIT,,2] ;[762] TWO WORDS
PUSHJ PP,STASHP ;[762] INITIALIZE POOLER
MOVN TA,TC ;[762] GET NEGATIVE POWER OF TEN
PUSHJ PP,STASHQ ;[762] PUT IN POOL
MOVSI TA,(BYTE (4)0,1) ;[762] GET 0.1
PUSHJ PP,POOLIT ;[762] POOL LITERAL
SKIPE CH,PLITPC ;[762] GET LITERAL IF POOLED
JRST .+4 ;[762]
MOVEI CH,2 ;[762] NO, COUNT THE 2 NEW ONES
EXCH CH,ELITPC ;[762]
ADDM CH,ELITPC ;[762]
IORI CH,AS.LIT ;[762]
PUSH PP,CH ;[762]
PUSHJ PP,PUTASA ;[762] SECOND SET OF OPCODES
MOVE CH,[DMOVE.+AC4,,AS.MSC] ;[762]
PUSHJ PP,PUTASY ;[762]
POP PP,CH ;[762] GET BACK LITERAL
PUSHJ PP,PUTASN ;[762]
MOVSI CH,SKPGE. ;[762]
HRR CH,EAC ;[762]
PUSHJ PP,PUTASY ;[762] GENERATE <SKIPGE AC>
PUSHJ PP,PUTASA ;[762]
MOVE CH,[DMOVN.+AC4,,4] ;[762]
PUSHJ PP,PUTASY ;[762] NEGATE CONSTANT ALSO
PUSHJ PP,PUTASA ;[762]
MOVE CH,[DFAD.,,4] ;[762]
PJRST PUT.XA ;[762] ADD IN CONSTANT
;MOVE A LITERAL FROM VALTAB TO LITAB (DISPLAY ONLY)
;THE HEADER WORD HAS ALREADY BEEN PUT OUT.
VALLIT: MOVEI TE,EBASEA ;[1077] SAVE EBYTEA IF XPAND LITERALS
MOVEM TE,ALITSV## ;[1077] REMEMBER INCASE WE EXPAND
HRRZ TC,EMODEB
PUSHJ PP,VLIT5.
JUMPE TD,VLIT3A ;[1077] RETURN IF SIZE IF ZERO
VLIT2: ILDB TE,EBYTEA ;GET A CHARACTER
XCT VLIT6.(TC) ;CONVERT IT IF NECESSARY.
IDPB TE,TB ;STASH IT INTO TA
SOJLE TD,VLIT2A ;QUIT IF ALL HAVE BEEN TRANSFERRED
TLNN TB,760000 ;IS "TA" FULL?
PUSHJ PP,VLIT4. ;YES--PUT IT INTO LITAB
JRST VLIT2
VLIT2A: SKIPN TD,ADCRLF## ;NEED TO ADD CR-LF?
JRST VLIT3. ;NO
SOJE TD,VLIT2B ;ONLY NEED NULL
TLNN TB,760000 ;ANY ROOM?
PUSHJ PP,VLIT4. ;NO
MOVEI TE,15 ;CR
IDPB TE,TB
TLNN TB,760000 ;FULL?
PUSHJ PP,VLIT4. ;YES
MOVEI TE,12 ;LF
IDPB TE,TB
VLIT2B: TLNN TB,760000
PUSHJ PP,VLIT4.
IBP TB ;ENSURE NULL AT END
VLIT3.::
TLNN TB,760000 ;[1077] JUST ENOUGH TO FIT WORD?
JRST VLIT4. ;[1077] MORE WORDS
VLIT3A: SETZM ALITSV## ;[1077] DON'T WORRY ABOUT THIS ANYMORE
POPJ PP, ;[1077] RETURN
VLIT4.::
PUSHJ PP,STASHL ;PUT THAT WORD INTO LITAB
VLIT5.::
MOVEI TA,0 ;CLEAR LITAB WORD
MOVE TB,VLIT7.(TC) ;PICK UP THE APPROPRIATE BYTE POINTER.
SKIPN IMCONS## ;IMMEDIATE MODE FLAG SET?
POPJ PP, ;NO
MOVEI TB,1(TC) ;MODE + 1
IMUL TB,ESIZEB ;*SIZE
MOVE TB,VLIT7I-1(TB) ;GET BYTE POINTER
POPJ PP,
;BYTE POINTERS FOR PUTTING THE CONVERTED CHAR INTO TA.
VLIT7I:
POINT 6,TA,29 ;1-SIXBIT.
POINT 7,TA,28 ;1-ASCII.
POINT 9,TA,26 ;1-EBCDIC.
POINT 6,TA,23 ;2-SIXBIT.
POINT 7,TA,21 ;2-ASCII.
POINT 9,TA,17 ;2-EBCDIC.
POINT 6,TA,23 ;3-SIXBIT.
;SAME AS VALLIT EXCEPT THAT LITERAL WILL BE POOLED
PVALIT: MOVEI TE,EBASEA ;[1077] GET BASE FOR EBYTEA
MOVEM TE,ALITSV## ;[1077] SAVE INCASE WE EXPAND LITTAB
HRRZ TC,EMODEB
PUSHJ PP,VLIT5.
JUMPE TD,PVLT5A ;[1077] IF SIZE IF ZERO QUIT NOW
PVLIT2: ILDB TE,EBYTEA ;GET A CHARACTER
XCT VLIT6.(TC) ;CONVERT IT IF NECESSARY.
IDPB TE,TB ;STASH IT INTO TA
SOJLE TD,PVLIT3 ;QUIT IF ALL HAVE BEEN TRANSFERRED
TLNN TB,760000 ;IS "TA" FULL?
PUSHJ PP,PVLIT6 ;YES--PUT IT INTO LITAB
JRST PVLIT2
PVLIT3: SKIPN TD,ADCRLF## ;NEED TO ADD CR-LF?
JRST PVLIT5 ;NO
SOJE TD,PVLIT4 ;ONLY NEED NULL
TLNN TB,760000 ;ANY ROOM?
PUSHJ PP,PVLIT6 ;NO
MOVEI TE,15 ;CR
IDPB TE,TB
TLNN TB,760000 ;FULL?
PUSHJ PP,PVLIT6 ;YES
MOVEI TE,12 ;LF
IDPB TE,TB
PVLIT4: TLNN TB,760000
PUSHJ PP,PVLIT6
IBP TB ;ENSURE NULL AT END
PVLIT5::SKIPN IMCONS ;IMMEDIATE MODE?
TLNE TB,760000 ;JUST ENOUGH TO FIT WORD?
JRST PVLT5A ;[1077] NO--QUIT
PVLIT6::PUSHJ PP,STASHQ ;PUT THAT WORD INTO LITAB
JRST VLIT5.
PVLT5A: SETZM ALITSV## ;[1077] FORGET ABOUT THIS
POPJ PP, ;[1077] RETURN
;INSTRUCTIONS XCT'ED TO CONVERT THE CHAR IN TE FROM ASCII TO SIXBIT OR EBCDIC.
VLIT6.::
PUSHJ PP,VLIT10 ; [374] SIXBIT.
JFCL ;ASCII.
PUSHJ PP,VLIT8. ;EBCDIC.
;BYTE POINTERS FOR PUTTING THE CONVERTED CHAR INTO TA.
VLIT7.::
POINT 6,TA ;SIXBIT.
POINT 7,TA ;ASCII.
POINT 9,TA ;EBCDIC.
;ROUTINE TO CONVERT AN ASCII CHAR TO EBCDIC.
VLIT8.::
ROT TE,-2 ;FORM THE INDEX INTO THE TABLE.
JUMPL TE,VLIT8A ;LEFT OR RIGHT HALF?
HLR TE,ASEBC.##(TE) ;LEFT.
CAIA
VLIT8A: HRR TE,ASEBC.##(TE) ;RIGHT.
TLNN TE,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TE,-^D9 ;IT IS NOW.
ANDI TE,377 ;JUST SAVE CHAR VALUE.
POPJ PP, ;RETURN.
;ROUTINE TO CONVERT AN ASCII CHAR TO SIXBIT
VLIT10:: ; [374]
CAIL TE,40 ; [374] IS THIS ASCII CHAR CONVERTABLE?
CAILE TE,137 ; [374] IE TO SIXBIT?
SETOM LITERR## ; [374] NO- IFGEN WILL GIVE ERROR
VLIT76:: ROT TE,-2 ; [374] FORM THE INDEX INTO THE TABLE.
JUMPL TE,VLIT11 ; [374] LEFT OR RIGHT HALF?
HLR TE,ASCSX.##(TE) ; [374] LEFT.
CAIA ; [374]
VLIT11: HRR TE,ASCSX.##(TE) ; [374] RIGHT.
TLNN TE,(1B1) ; [374] IS THE CHAR RIGHT JUSTIFIED?
LSH TE,-^D9 ; [374] IT IS NOW.
TRZ TE,777700 ; [374] GET RID OF STATUS BITS
POPJ PP, ; [374] RETURN.
;INSTRUCTIONS XCT'ED TO CONVERT THE CHAR IN TE FROM EBCDIC TO SIXBIT OR ASCII.
VLIT9.::
PUSHJ PP,VLIT9S ;SIXBIT.
PUSHJ PP,VLIT9A ;ASCII.
TRN ;EBCDIC.
;ROUTINE TO CONVERT AN EBCDIC CHAR TO ASCII.
VLIT9A::
ROT TE,-2 ;FORM THE TABLE INDEX.
JUMPL TE,VLIT9R ;LEFT OR RIGHT HALF.
HLR TE,EBASC.##(TE) ;LEFT.
CAIA
VLIT9R: HRR TE,EBASC.##(TE) ;RIGHT.
TLNN TE,(1B1) ;IS THE CHAR RIGHT JUSTIFIED?
LSH TE,-^D9 ;IT IS NOW.
ANDI TE,177 ;GET RID OF ANY JUNK
POPJ PP, ;RETURN.
;ROUTINE TO CONVERT AN EBCDIC CHAR TO SIXBIT
VLIT9S::
PUSHJ PP,VLIT9A ;CONVERT TO ASCII
JRST VLIT10 ;THEN TO SIXBIT
;CONVERT A NUMERIC LITERAL INTO 2-WORD COMP.
;ENTER WITH EITHER "BASEA" OR "EBASEB" IN "LN".
;RETURN WITH RESULT IN TD&TC.
CONVNL: PUSHJ PP,FDIGIT ;GET FIRST DIGIT
TSWF FERROR ;ANY ERRORS SO FAR?
POPJ PP, ;YES--QUIT
SETZB TC,TD
HRRZI TE,1
JRST CNVNL2
CNVNL1: SOSGE ESIZEX(LN)
JRST CNVNL4
ILDB CH,EBYTEX(LN) ;GET NEXT CHARACTER
CAIN CH,"."
JRST CNVNL3
CAIG CH,"9"
CAIGE CH,"0"
JRST BADLK
CAILE TE,^D18
JRST TOOBIG
ADDI TE,1
CNVNL2: TSWF FLITDP ;ANY DECIMAL POINT?
AOS EDPLX(LN) ;YES--INCREMENT DECIMAL PLACES
IMULI TD,^D10
MULI TC,^D10
ADD TD,TC
MOVE TC,TB
ADDI TC,-"0"(CH)
TLZN TC,1B18
JRST CNVNL1
AOJA TD,CNVNL1
CNVNL3: CAIE LN,EBASEA
JRST CNVNL5
TSWT FANUM;
JRST BADLK
JRST CNVNL6
CNVNL5: TSWT FBNUM;
JRST BADLK
CNVNL6: SWON FLITDP ;YES--SET "DECIMAL POINT SEEN"
JRST CNVNL1 ;LOOP
CNVNL4: MOVEM TE,ESIZEX(LN)
POPJ PP,
;CREATE A FLOATING POINT LITERAL.
;EXIT WITH EXPONENT IN TD, MANTISSA IN TC.
CONVFP: PUSHJ PP,FDIGIT ;GET FIRST DIGIT
TSWF FERROR ;ANY ERRORS?
POPJ PP, ;YES
MOVEI TC,0
MOVN TD,EDPLX(LN)
HRRZI TE,1
MOVE TB,[POINT 4,TC,3]
JRST CNVFP2
CNVFP1: SOSGE ESIZEX(LN)
POPJ PP,
ILDB CH,EBYTEX(LN)
CAIN CH,"."
JRST CNVFP3
CAIG CH,"9"
CAIGE CH,"0"
JRST BADLK
CAILE TE,^D8
JRST CNVFP7
ADDI TE,1
CNVFP2: TSWT FLITDP;
AOS TD
IDPB CH,TB
JRST CNVFP1
CNVFP3: CAIE LN,EBASEA
JRST CNVFP5
TSWT FANUM;
JRST BADLK
JRST CNVFP6
CNVFP5: TSWT FBNUM;
JRST BADLK
CNVFP6: SWON FLITDP;
JRST CNVFP1
CNVFP7: CAIE CH,"0"
JRST TOOBIG
TSWT FLITDP ;IS THIS A DECIMAL PLACE?
AOJA TD,CNVFP1 ;NO--BUMP INTEGRAL SIZE
JRST CNVFP1 ;YES--LOOP WITHOUT BUMPING
;CREATE A D. P. FLOATING POINT LITERAL.
;EXIT WITH EXPONENT IN TD, MANTISSA IN C2MANT (3 WORDS).
CONVF2: PUSHJ PP,FDIGIT ;GET FIRST DIGIT
TSWF FERROR ;ANY ERRORS?
POPJ PP, ;YES
SETZM C2MANT## ;ZERO THE MANTISSA
SETZM C2MANT+1 ;...
SETZM C2MANT+2 ;...
MOVN TD,EDPLX(LN)
HRRZI TE,1
MOVE TB,[POINT 4,C2MANT,3]
JRST CNVF22
CNVF21: SOSGE ESIZEX(LN)
POPJ PP,
ILDB CH,EBYTEX(LN)
CAIN CH,"."
JRST CNVF23
CAIG CH,"9"
CAIGE CH,"0"
JRST BADLK
CAILE TE,^D18 ;ALLOW UP TO 18 DIGITS
JRST CNVF27
ADDI TE,1
CNVF22: TSWT FLITDP;
AOS TD
IDPB CH,TB
JRST CNVF21
CNVF23: CAIE LN,EBASEA
JRST CNVF25
TSWT FANUM;
JRST BADLK
JRST CNVF26
CNVF25: TSWT FBNUM;
JRST BADLK
CNVF26: SWON FLITDP;
JRST CNVF21
CNVF27: CAIE CH,"0"
JRST TOOBIG
TSWT FLITDP ;IS THIS A DECIMAL PLACE?
AOJA TD,CNVF21 ;NO--BUMP INTEGRAL SIZE
JRST CNVF21 ;YES--LOOP WITHOUT BUMPING
;SCAN A LITERAL TO GET SIZE AND DECIMAL PLACES
SCANL: HLRZ TE,OPERND ;IS "ALL" FLAG UP?
MOVE TE,0(TE)
TLNE TE,GNALL
JRST BADALL ;YES--ERROR
MOVEI LN,EBASEA
PUSHJ PP,FDIGIT ;GET FIRST DIGIT
TSWF FERROR ;ANY ERROR?
POPJ PP, ;YES--QUIT
MOVE TD,[POINT 6,LITHLD]
HRRZI TC,0 ;CLEAR SIZE
JRST SCANL3
SCANL2: SOSGE ESIZEA ;ANYTHING LEFT?
JRST SCANL5 ;NO
ILDB CH,EBYTEA
CAIN CH,"."
JRST SCANL4
CAIG CH,"9"
CAIGE CH,"0"
JRST BADLK
SCANL3: ADDI TC,1
TSWF FLITDP
AOS EDPLA
CAILE TC,^D120 ;[FCCTS NC105] ALLOW UP TO 120 CHARS
JRST TOOBIG
SUBI CH,40
IDPB CH,TD
JRST SCANL2
SCANL4: TSWT FANUM ;DECIMAL POINT SEEN
JRST BADLK
TSWT FBNUM
JRST BADDP
SWON FLITDP
JRST SCANL2
SCANL5: MOVEM TC,ESIZEA
POPJ PP,
;GET FIRST SIGNIFICANT DIGIT OF LITERAL IN VALTAB
;RETURN WITH THAT FIRST DIGIT IN "CH"
FDIGIT: SWOFF FLITDP!FLNEG!FERROR;
SETZM EDPLX(LN)
SOSGE ESIZEX(LN)
JRST LNOSIZ
ILDB CH,EBYTEX(LN)
CAIN CH,"+"
JRST FDIG4
CAIN CH,"-"
JRST FDIG3
FDIG1: CAILE CH,"9"
JRST BADLK
CAIL CH,"1"
POPJ PP,
CAIN CH,"0"
JRST FDIG6
CAIE CH,"."
JRST BADLK
SWONS FLITDP;
FDIG3: SWON FLNEG;
FDIG4: CAIE LN,EBASEA
JRST FDIG5
TSWT FANUM;
JRST BADLK
JRST FDIG7
FDIG5: TSWT FBNUM;
JRST BADLK
JRST FDIG7
FDIG6: SKIPN ESIZEX(LN)
POPJ PP,
TSWF FLITDP;
AOS EDPLX(LN)
FDIG7: SOSGE ESIZEX(LN)
JRST LNOSIZ
ILDB CH,EBYTEX(LN)
JRST FDIG1
;MULTIPLY A LITERAL BY SOME POWER OF 10.
;ENTER WITH THE POWER IN "TE", A PARAMETER TABLE BASE IN "LN".
;LITERAL IS IN TD AND TC, RESULT IS IN SAME ACCS. USES TB AND TA.
ADJSL.: JUMPLE TE,CPOPJ ;REFUSE ANY NEGATIVE OR ZERO POWERS
ADDM TE,EDPLX(LN)
MOVE TA,TE
ADDB TA,ESIZEX(LN)
CAILE TA,MAXSIZ
JRST TOOBIG
ADJSL1: LSH TE,1 ;DOUBLE WORD TABLE
DMUL TD,DPWR10(TE) ;MULT BY POWER OF 10
DMOVE TD,TB ;GET LOW ORDER WORDS
POPJ PP,
;SAME AS ADJSL. EXCEPT RESULT CAN BE 4-WORD COMP IF REQUIRED
ADJBL.: JUMPLE TE,CPOPJ ;REFUSE ANY NEGATIVE OR ZERO POWERS
SETZ TA, ;ASSUME ONLY ONE PASS NEEDED
CAIG TE,^D21 ;IS IT TOO BIG TO ADJUST IN ONE GO?
JRST ADJBL1 ;NO, OK
SUBI TE,^D21 ;YES, NEED TWO PASSES
MOVEI TA,^D21 ;REQUIRED FOR 2ND PASS
ADJBL1: PUSH PP,TA ;SAVE REMAINDER
MOVE TA,TE
ADDM TE,EDPLX(LN)
ADDB TA,ESIZEX(LN)
CAIG TA,MAXSIZ ;4-WORDS
SKIPE (PP) ;OR SECOND PASS REQUIRED
JRST ADJBL2 ;YES
POP PP,(PP)
JRST ADJSL1 ;NO, STILL 2-WORDS
ADJBL2: LSH TE,1 ;DOUBLE WORD TABLE
DMUL TD,DPWR10(TE) ;MULT BY POWER OF 10
MOVEI TE,D4MODE
MOVEM TE,EMODEX(LN) ;SO SET 4-WORD MODE
POP PP,TE ;RESTORE 2ND PASS COUNTER
JUMPE TE,CPOPJ ;YES
DMOVE TD,TB ;GET LOW-ORDER WORDS
JRST ADJBL. ;TRY AGAIN
;NEGATE THE 2-WORD LITERAL TO BE FOUND IN TD&TC.
NEGATL: DMOVN TD,TD
TLNN TD,1B18 ;COPY SIGN TO LOW-ORDER WORD
TLZA TC,1B18
TLO TC,1B18
POPJ PP,
;NEGATE THE 4-WORD LITERAL TO BE FOUND IN ELITHI THRU ELITHI+3
NEGAT4: DMOVN TD,ELITHI
DMOVN TB,ELITHI+2
TLNN TD,1B18 ;COPY SIGN TO LOW-ORDER WORDS
TLZA TC,1B18
TLOA TC,1B18
TLZA TB,1B18
TLOA TB,1B18
TLZA TA,1B18
TLO TA,1B18
POPJ PP,
;SWAP THE TWO OPERANDS.
SWAPAB: MOVE TE,[XWD EBASEA,ESAVEB]
BLT TE,ESAVBX
MOVE TE,[XWD EBASEB,EBASEA]
BLT TE,EBASAX
MOVE TE,[XWD ESAVEB,EBASEB]
BLT TE,EBASBX
MOVE TA,SW
TSWTZ FBSIGN;
SWOFFS FASIGN;
SWON FASIGN;
TSWTZ FBNUM;
SWOFFS FANUM;
SWON FANUM;
TSWTZ FBSUB;
SWOFFS FASUB;
SWON FASUB;
TRNE TA,FASIGN
SWON FBSIGN;
TRNE TA,FANUM
SWON FBNUM;
TRNE TA,FASUB
SWON FBSUB;
MOVSS OPERND
MOVE TE,EDEBDA ;SWAP THE DEBUG STUFF ALSO
EXCH TE,EDEBDB
MOVEM TE,EDEBDA
MOVE TE,EDEBPA
EXCH TE,EDEBPB
MOVEM TE,EDEBPA
MOVE TE,EDEBGA
EXCH TE,EDEBGB
MOVEM TE,EDEBGA
POPJ PP,
;CREATE A BYTE POINTER TO "A" AND PUT IT INTO LITAB
MBYTEA: MOVEI TB,EBASEA
JRST MBYTEX
;LIKEWISE FOR "B"
MBYTEB: MOVEI TB,EBASEB
MBYTEX: HRRZ TA,EBASEX(TB)
PUSHJ PP,STASHL
HLRZ TA,ERESX(TB)
ROT TA,-6
HRRZ TC,EMODEX(TB)
MOVE TC,BYTE.S(TC)
DPB TC,[POINT 6,TA,11]
HRR TA,EINCRX(TB)
JRST STASHL
;SAME BUT FOR POOLED LITERALS
MBYTPA: MOVEI TB,EBASEA
JRST MBYTPX
;LIKEWISE FOR "B"
MBYTPB: MOVEI TB,EBASEB
MBYTPX: HRRZ TA,EBASEX(TB)
PUSHJ PP,STASHQ
HLRZ TA,ERESX(TB)
ROT TA,-6
HRRZ TC,EMODEX(TB)
MOVE TC,BYTE.S(TC)
SKIPE USENBT##
IMUL TC,NBYTES## ;USE LARGER BYTES
DPB TC,[POINT 6,TA,11]
HRR TA,EINCRX(TB)
SKIPE MAKBPB## ;MAKE AN INCREMENTED BYTE PTR?
IBP TA ;YES, INCREMENT BP
SETZM MAKBPB## ;CLEAR THE FLAG
JRST STASHQ
;WRITE OUT <OP AC,EBASEA+EINCRA>
PUT.AA: MOVE TE,EAC
PUT.A0: DPB TE,CHAC
;WRITE OUT <OP EBASEA+EINCRA>
PUT.A: TSWF FASUB ;IS IT SUBSCRIPTED?
JRST PUT.A2 ;YES
PUT.A1: HRR CH,EBASEA
SKIPN EINCRA
JRST PUTAXY ;CHECK FOR EXTERNAL REF
TLO CH,ASINC
PUSHJ PP,PUTAXY ;CHECK FOR EXTERNAL SYMBOL
HRRZ CH,EINCRA
JRST PUTASN
PUT.A2: LDB TE,[POINT 3,EBASEA,20]
CAIE TE,TB.DAT
JRST PUT.A1
TLO CH,SXR
HRR CH,EINCRA
JRST PUTASY
;WRITE OUT <OP AC+1,EBASEA+EINCRA>
PUT.AO: MOVE TE,EAC
AOJA TE,PUT.A0
;WRITE OUT <OP AC,EBASEB+EINCRB>
PUT.BA: MOVE TE,EAC
PUT.B0: DPB TE,CHAC
;WRITE OUT <OP EBASEB+EINCRB>
PUT.B: TSWF FBSUB ;IS IT SUBSCRIPTED?
JRST PUT.B2 ;YES
PUT.B1: HRR CH,EBASEB
SKIPN EINCRB
JRST PUTAXY ;CHECK FOR EXT. SYMBOL AND PUT IT OUT
TLO CH,ASINC
PUSHJ PP,PUTAXY ;CHECK FOR EXT. SYMBOL
HRRZ CH,EINCRB
JRST PUTASN
PUT.B2: LDB TE,[POINT 3,EBASEB,20]
CAIE TE,TB.DAT
JRST PUT.B1
TLO CH,SXR
HRR CH,EINCRB
JRST PUTASY
;WRITE OUT <OP AC+1,EBASEB+EINCRB>
PUT.BO: MOVE TE,EAC
AOJA TE,PUT.B0
;WRITE OUT <OP AC,[LITERAL]>.
;LITERAL VALUE IS IN TC.
PUT.LA: MOVE TE,EAC
DPB TE,CHAC
TLNE TC,-1
JRST PUT.L2
ADD CH,[1B8]
PUT.L0: TRNE TC,7B20
JRST PUT.L1
HRR CH,TC
JRST PUTASY
PUT.L1: HRRI CH,AS.CNB
TLO CH,ASINC
PUSHJ PP,PUTASY
HRRZ CH,TC
JRST PUTASN
;CHECK TO SEE IF LITERAL IS NEGATIVE SMALL NUMBER
PUT.L2: TLC TC,-1
TLCN TC,-1 ;LEFT HALF ALL ONES
TLNE CH,777000 ;AND OP WAS MOVE
JRST PUT.L ;NO
TRNN TC,-1 ;[577] CHECK FOR -262144 I.E. <-1,,0>
JRST [TLO CH,MOVSI. ;[577] YES, GENERATE
MOVEI TC,-1 ;[577] MOVSI AC,-1
JRST PUT.L0] ;[577]
TLO CH,MOVNI. ;YES
MOVNS TC ;MAKE LITERAL POSITIVE
JRST PUT.L0 ;GENERATE MOVNI AC,<LIT>
;WRITE OUT <OP X,[LITERAL]>.
;PUT LITERAL INTO AS.LIT
;LITERAL VALUE IS IN TC
PUT.L: MOVE TA,[XWD D1LIT,1]
PUSHJ PP,STASHP
MOVE TA,TC
PUSHJ PP,POOLIT
SKIPN EACC,PLITPC
SKIPA EACC,ELITPC
CAIA
AOS ELITPC
;WRITE OUT <OP X,[LITERAL]>
;ADDRESS OF LITERAL IS IN EACC
PUT.LB: HRRI CH,AS.MSC
TLO CH,ASINC
PUSHJ PP,PUTASY
HRRZ CH,EACC
IORI CH,AS.LIT
JRST PUTASN
;GENERATE <OP AC,[POWER OF 10]>, OR <OPI AC,POWER OF 10>.
;ENTER WITH OP SET UP IN CH, THE POWER IN TC.
PUT.PA: MOVE TE,EAC ;SET AC FIELD
DPB TE,CHAC
PUT.P: CAIG TC,5 ;CAN IT BE IMMEDIATE MODE?
JRST PUT.P1 ;YES
;SIMILAR TO GENOPL, EXCEPT THAT AC-FIELD NOT TOUCHED, AND
; NO IMMEDIATE MODE.
PUT.PC: PUSHJ PP,CREATL ;CREATE THE LITERAL, IF NEEDED
HRRI CH,AS.MSC ;CREATE INSTRUCTION
TLO CH,ASINC
PUSHJ PP,PUTASY ;WRITE OUT FIRST OF TWO WORDS
HRRZ CH,EPWR10(TC)
JRST PUTASN ;WRITE OUT INCREMENT AND RETURN
PUT.P1: ADD CH,[1B8] ;IMMEDIATE MODE USED
CAILE TC,4 ;IS IT LESS THAN 77777?
JRST PUT.P2
HRR CH,POWR10(TC) ;YES
JRST PUTASY
PUT.P2: HRRI CH,AS.CNB ;NO
TLO CH,ASINC
PUSHJ PP,PUTASY
HRRZ CH,POWR10(TC)
JRST PUTASN
;GENERATE AN INSTRUCTION REFERENCING CURRENT LITERAL.
;OP-CODE IS IN "CH", AC-FIELD IN EAC.
PUT.LC: MOVE TE,EAC
DPB TE,CHAC
;SIMILAR TO PUT.LC, EXCEPT THAT AC-FIELD UNALTERED.
PUT.LD: HRRI CH,AS.MSC
TLO CH,ASINC
PUSHJ PP,PUTASY
SKIPN CH,PLITPC##
HRRZ CH,ELITPC
IORI CH,AS.LIT
JRST PUTASN
;SET AC-FIELD TO "EAC", AND WRITE OUT INSTRUCTION.
PUT.XA: MOVE TE,EAC
PUT.X1: DPB TE,CHAC
JRST PUTASY
;SET AC-FIELD TO EAC+1, AND WRITE OUT INSTRUCTION.
PUT.XB: MOVE TE,EAC
PUT.X2: AOJA TE,PUT.X1
INTERN PUT.XC
;SET AC-FIELD TO EAC+2, AND WRITE OUT INSTRUCTION.
PUT.XC: MOVE TE,EAC
AOJA TE,PUT.X2
;PUT OUT MOVX 16,<Z AC,MEM>
;ON ENTRY CH CONTAINS:
; LHS DESTINATION AC
; RHS SOURCE ACC OR EBASEA/EBASEB
PUT.16: TLNN CH,-1 ;LHS 0?
JRST PUT16I ;YES
PUSH PP,CH ;NO
MOVE TA,[XTNLIT,,1]
TLNE CH,ASINC ;NEED TWO WORDS?
ADDI TA,1 ;YES
PUSHJ PP,STASHP ;GET LITERAL TO HOLD ACC
MOVE TA,0(PP) ;GET <Z AC,ADDRESS>
TRNE TA,-20 ;IS SOURCE ACC?
HRR TA,(TA) ;NO, GET IT
TLNE TA,ASINC ;INCREMENT WANTED?
JRST PUT162 ;YES
PUSHJ PP,POOLIT ;NO, STORE 1 WORD
POP PP,TA ;FIXUP STACK
PUT161: MOVE CH,[MOV+ASINC+AC16,,AS.MSC]
PUSHJ PP,PUTASY
SKIPN CH,PLITPC
SKIPA CH,ELITPC
TRNA
AOS ELITPC
IORI CH,AS.LIT
JRST PUTASN
PUT162: PUSHJ PP,STASHQ ;STORE FIRST WORD
MOVE TA,0(PP) ;GET WORD AGAIN
HRRZ TA,EINCRX(TA) ;YES, GET IT
PUSHJ PP,POOLIT ;STORE SECOND WORD
POP PP,TA
JRST PUT161 ;GO GENERATE THE MOVE
PUT16I: TLO CH,MOVEI.+AC16
TLNE CH,ASINC ;INCREMENT TO FOLLOW?
PUSH PP,EINCRX(CH) ;SAVE INCREMENT
TRNE CH,-20 ;IS SOURCE ACC?
HRR CH,(CH) ;NO, GET IT
TLNN CH,ASINC ;INCREMENT TO FOLLOW?
JRST PUTASY ;NO
PUSHJ PP,PUTASY
POP PP,CH
JRST PUTASN
;PUT OUT REFERENCE TO EXTERNAL AND CHECK FOR NON-RESIDENT
PUT.PJ: HRLI CH,EPJPP ;COMPLETE INSTRUCTION
PUT.EX: PUSHJ PP,PUTASY
TSWT FAS3
POPJ PP,
ANDI CH,77777
ADD CH,EXTLOC
MOVSI TE,NR.EXT
IORM TE,1(CH)
POPJ PP,
;SAME AS PUT.EX BUT TURNS ON @ SIGN NEEDED FLAG ALSO
PUT.SX: PUSHJ PP,PUTASY
TSWT FAS3
POPJ PP,
ANDI CH,77777
ADD CH,EXTLOC
MOVSI TE,NR.EXT!NR.IND
IORM TE,1(CH)
POPJ PP,
;ADJUST DECIMAL PLACES OF FLOATING-POINT ITEM IN AC'S.
GENFPL: MOVM TC,TD
SKIPE TD
CAILE TC,MAXSIZ
POPJ PP,
MOVSI CH,FMP.
SKIPG TD
MOVSI CH,FDV.
SKIPE TB,EFPCNV(TC)
JRST GENFP1
MOVE TB,ELITPC
IORI TB,AS.LIT
MOVEM TB,EFPCNV(TC)
MOVE TA,[XWD FLTLIT,2]
PUSHJ PP,STASHI
MOVEI TA,1(TC)
PUSHJ PP,STASHL
MOVSI TA,1B<^D18+7>
PUSHJ PP,STASHL
AOS ELITPC
GENFP1: HRRI CH,AS.MSC
TLO CH,ASINC
PUSHJ PP,PUT.XA
HRRZ CH,TB
JRST PUTASN
;ADJUST DECIMAL PLACES OF D.P. FLOATING-POINT ITEM IN AC'S.
GENF2L: MOVM TC,TD
SKIPE TD
CAILE TC,MAXSIZ
POPJ PP,
PUSHJ PP,PUTASA
MOVSI CH,DFMP.
SKIPG TD
MOVSI CH,DFDV.
SKIPE TB,EF2CNV(TC) ;ALREADY GENERATED
JRST GENFP1 ;YES
MOVE TB,ELITPC
IORI TB,AS.LIT
MOVEM TB,EF2CNV(TC) ;STORE LOCATION
SKIPE EFPCNV(TC) ;[762] S.P. LOC ALREADY STORED?
JRST GENF21 ;[762] YES
MOVN TD,TC ;[762] NO, SEE IF S.P. VALUE IS SAME
MOVSI TA,(1B0) ;[762] AS HIGH WORD OF D.P. VALUE
LSH TA,(TD) ;[762] SHIFT BIT INTO POSITION
AND TA,[1B12+1B14+1B15+1B16+1B18+7B23+7777] ;[762] MASK
JUMPN TA,GENF21 ;[762] ITS NOT THE SAME (S.P. IS ROUNDED UP)
MOVEM TB,EFPCNV(TC) ;[762] SAME SO MAY AS WELL STORE IT ALSO
GENF21: MOVE TA,[F2LIT,,2] ;[762] D. P. FLOATING POINT
PUSHJ PP,STASHI
MOVEI TA,1(TC)
PUSHJ PP,STASHL
MOVSI TA,(BYTE (4)0,1)
PUSHJ PP,STASHL
AOS ELITPC
AOS ELITPC ;SPACE FOR SECOND WORD OF ZERO
JRST GENFP1
;PUT A POWER OF 10 IN THE LITERAL POOL, AND PUT ENTRY ADDRESS INTO "EPWR10".
;ENTER WITH POWER IN "TC".
CREATL: SKIPE EPWR10(TC)
POPJ PP,
CAILE TC,^D10 ;2 WORDS?
JRST CREAT2 ;YES
MOVE TA,[XWD D1LIT,1];NO--1 WORD
PUSHJ PP,STASHI
MOVE TA,POWR10(TC)
PUSHJ PP,STASHL
MOVE TE,ELITPC ;SAVE ADDRESS OF THE LITERAL
AOS ELITPC ;BUMP THE ADDRESS
CREAT1: IORI TE,AS.LIT ;SET TABLE ENTRY WITH ADDRESS
MOVEM TE,EPWR10(TC)
CAILE TC,^D20
SKIPE EPWR10-^D20(TC)
POPJ PP,
ADDI TE,1
MOVEM TE,EPWR10-^D20(TC)
POPJ PP,
CREAT2: MOVE TA,[XWD D2LIT,2] ;GENERATE 2-WORD LITERAL
PUSHJ PP,STASHI
CAILE TC,^D20
JRST CREAT4
MOVE TE,TC
LSH TE,1
MOVE TA,DPWR10(TE)
MOVE TD,DPWR10+1(TE)
PUSHJ PP,STASHL
MOVE TA,TD
CREAT3: PUSHJ PP,STASHL
MOVEI TE,2 ;BUMP UP LITERAL ADDRESS
EXCH TE,ELITPC
ADDM TE,ELITPC
JRST CREAT1
CREAT4: MOVEI TA,0
PUSHJ PP,STASHL
MOVE TA,POWR10-^D20(TC)
JRST CREAT3
;INSURE THAT AC'S ARE 0&1.
;IF NOT, GENERATE A MOVE.
FORCX0: SKIPN CH,EAC
POPJ PP,
HRLI CH,MOV
SETZM EAC
HRRZ TE,EMODEA
CAIE TE,D2MODE
JRST PUTASY
HRLI CH,DMOVE.
PUSH PP,CH
PUSHJ PP,PUTASA ;SIGNAL ALTERNATE
POP PP,CH
JRST PUTASY
;PUT OUT A "JRST" TO A MISCELLANEOUS ADDRESS.
;ENTER WITH ADDRESS INCREMENT IN "TC".
JOUT: MOVE CH,[XWD JRST.+ASINC,AS.MSC]
PUSHJ PP,PUTASY
MOVEI CH,(TC)
JRST PUTASN
;DOUBLE PRECISION DIVIDE. "TE" SPECIFIES SOME POWER OF 10.
DPDIV.: CAILE TE,^D10
JRST DPDIV1
MOVE TA,POWR10(TE)
JRST DPD21
DPDIV1: LSH TE,1
DMOVE TB,DPWR10(TE)
JRST DPD22
;DIVIDE A DOUBLE PRECISION NUMBER BY A SINGLE PRECISION NUMBER..
;ENTER WITH DIVIDEND IN TD&TC, DIVISOR IN TA.
;EXIT WITH QUOTIENT IN TD&TC, REMAINDER IN TB&TA.
DPD21: JOV .+1
DIV TD,TA
JOV DPD21A
MOVE TA,TC
MOVE TC,TD
SETZB TD,TB
POPJ PP,
;QUOTIENT IS DOUBLE PRECISION.
DPD21A: MOVE TE,TD
IDIV TE,TA
DIV TD,TA
MOVE TA,TC
MOVE TC,TD
MOVE TD,TE
HRRZI TB,0
POPJ PP,
;DIVIDE A DOUBLE PRECISION NUMBER BY A DOUBLE PRECISION NUMBER.
;ENTER WITH DIVIDEND IN TD&TC, DIVISOR IN TB&TA.
;EXIT WITH QUOTIENT IN TD&TC, REMAINDER IN TB&TA.
COMMENT \
DPD22: DMOVE LN,TD
IDIV TD,TB
MOVE CH,TD
DPDIV3: MUL TD,TA
MOVE TE,TB
IMUL TE,CH
ADD TD,TE
SUBM LN,TD
SUBM CP,TC
TLZE TC,1B18
SUBI TD,1
TLNE TD,1B18
TLO TC,1B18
JUMPGE TD,DPDIV5
MOVEI TD,-1(CH)
SOJA CH,DPDIV3
DPDIV5: MOVE TA,TC
MOVE TB,TD
HRRZI TD,0
MOVE TC,CH
POPJ PP,
\
DPD22: PUSH PP, SW ;SAVE SW.
MOVE LN, TD ;SAVE A (THE DIVIDEND.)
MOVE CP, TC
IDIV TD, TB ;FORM S (INITIAL APPROXIMATION
; TO THE QUOTENT.)
MOVE SW, TD ;SAVE I (THE INCREMENT.)
SKIPA CH, TD ;SAVE S.
DPDIV3: MOVE TD, CH ;GET S.
LSH SW, -1 ;FORM I FOR THE NEXT ITERATION.
SKIPN SW
MOVEI SW, 1
MUL TD, TA ;FORM S * B (B IS THE DIVISOR.)
MOVE TE, TB
IMUL TE, CH
ADD TD, TE
SUBM LN, TD ;FORM S * B - A.
SUBM CP, TC
TLZE TC, (1B0)
SUBI TD, 1
JUMPL TD, DPDIV7 ;IF S * B - A < 0, S > Q, GO
; MAKE S SMALLER.
;S * B - A > OR = 0.
CAMLE TD, TB ;SEE IF S * B - A > B.
JRST DPDIV5 ;IT IS.
CAMN TD, TB
CAMGE TC, TA
JRST DPDIV9 ;IT ISN'T, S = Q, GO RETURN.
;S * B - A > B ==> S < Q, MAKE S LARGER.
DPDIV5: ADD CH, SW
JRST DPDIV3 ;ITERATE.
;S * B - A < 0 ==> S > Q, MAKE S SMALLER.
DPDIV7: SUB CH, SW
JRST DPDIV3 ;ITERATE.
;COME HERE TO RETURN.
DPDIV9: POP PP, SW ;RSTORE SW.
DMOVE TB, TD ;GET THE REMAINDER.
SETZI TD, ;GET THE QUOTENT.
MOVE TC, CH
POPJ PP, ;RETURN.
;SET CUREOP TO THE NEXT OPERAND IN EOPTAB.
BMPEOP: MOVE TE,CUREOP
MOVE TD,0(TE)
MOVE TE,1(TE)
TLNN TE,GNNOTD
TLNE TD,GNLIT
TDCA TD,TD
LDB TD,TESUBC
LSH TD,1
ADDI TD,2
ADDB TD,CUREOP
HRRZ TE,EOPNXT
CAILE TE,(TD)
AOS (PP)
POPJ PP,
;PUT A LITERAL INTO %LIT.
;ENTER WITH VALUE OF LITERAL IN TD&TC.
MAKEL: MOVEI TA,AS.MSC
MOVEM TA,EBASEX(LN)
MOVE TE,ESIZEX(LN) ;IS IT TWO WORDS?
CAILE TE,^D10
JRST MAKL1A ;YES
MAKEL1: MOVE TA,[XWD D1LIT,1] ;NO--CREATE A 1-WORD LITERAL
PUSHJ PP,STASHP
TSWT FLNEG ;LITERAL NEGATIVE?
SKIPA TA,TC ;NO--USE POSITIVE VALUE
MOVN TA,TC ;YES--USE NEGATIVE VALUE
PUSHJ PP,POOLIT
SKIPN TA,PLITPC
SKIPA TA,ELITPC ;GET %LIT ADDRESS
CAIA
AOS ELITPC
IORI TA,AS.LIT
MOVEM TA,EINCRX(LN)
MOVEI TA,D1MODE
MOVEM TA,EMODEX(LN)
POPJ PP,
MAKL1A: JUMPE TD,MAKEL3
MAKL1B: MOVE TA,[XWD D2LIT,2]
PUSHJ PP,STASHP
TSWF FLNEG;
PUSHJ PP,NEGATL
MOVE TA,TD
PUSHJ PP,STASHQ
MOVE TA,TC
PUSHJ PP,POOLIT
SKIPN TA,PLITPC
SKIPA TA,ELITPC
TDZA TE,TE ;ZERO
MOVEI TE,2
IORI TA,AS.LIT
MOVEM TA,EINCRX(LN)
ADDM TE,ELITPC
MOVEI TE,D2MODE
MOVEM TE,EMODEX(LN)
POPJ PP,
MAKEL3: MOVEI TE,^D10
MOVEM TE,ESIZEX(LN)
JRST MAKEL1
MAKEL2: MOVEI TA,AS.MSC
MOVEM TA,EBASEX(LN)
JRST MAKL1B
;PUT A LITERAL INTO %LIT.
;ENTER WITH VALUE OF LITERAL IN ELITHI THRU ELITHI+3.
;USES D2LIT MODE TWICE. PROBABLY SHOULD HAVE A NEW MODE D4LIT AT SOME FUTURE TIME.
MAKEL4: MOVEI TA,AS.MSC
MOVEM TA,EBASEX(LN)
TSWF FLNEG
PUSHJ PP,NEGAT4 ;NEGATE ALL 4 WORDS
MOVE TA,[D2LIT,,2]
PUSHJ PP,STASHP
MOVE TA,ELITHI
PUSHJ PP,STASHQ
MOVE TA,ELITHI+1
PUSHJ PP,STASHQ
MOVE TA,[D2LIT,,2]
PUSHJ PP,STASHP
MOVE TA,ELITHI+2
PUSHJ PP,STASHQ
MOVE TA,ELITHI+3
PUSHJ PP,POOLIT
SKIPN TA,PLITPC
SKIPA TA,ELITPC
TDZA TE,TE ;ZERO
MOVEI TE,4
IORI TA,AS.LIT
MOVEM TA,EINCRX(LN)
ADDM TE,ELITPC
MOVEI TE,D4MODE
MOVEM TE,EMODEX(LN)
POPJ PP,
;BUILD A SINGLE PARAMETER FROM "A" DATA.
;IF "A" IS SUBSCRIPTED, CALL SUBSCRIPT GENERATOR.
;IF "A" NOT SUBSCRIPTED, LEAVE PARAMETER IN %LIT.
;IF "SUBINP" IS -1, PUT BYTE POINTER IN SOME PLACE IT CAN BE MODIFIED.
B1PAR: SKIPE IBPFLG## ;THIS BETTER BE 0
JRST E$IBP
PUSHJ PP,SUBSCD
TSWF FASUB ;IS "A" SUBSCRIPTED NOW?
POPJ PP, ;YES--RETURN
SKIPN SUBINP ;SKIP IF WE'RE SUPPOSED TO BE ABLE TO
; MODIFY IT
JRST B1PARN ;NO, PUT IT IN %LIT
;PUT PARAMETER IN %PARAM (OR %TEMP IF A NON-RESIDENT SECTION)
TSWF FAS3 ;ARE WE IN A NON-RESIDENT SECTION?
JRST B1PAR7 ;YES, CAN'T USE %PARAM.
;PUT BASE PARAMETER IN %PARAM.
PUSHJ PP,BYTE.A ;GET BYTE PTR TO "A" IN TA AND TB
TLZ TA,7777 ;MAKE IT LOOK LIKE A PARAMETER
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1
MOVE CH,TA
PUSHJ PP,PUTAS1
MOVE CH,TB
PUSHJ PP,PUTAS1
HRRZ EACC,EAS1PC
IORI EACC,AS.PAR ;RETURN AS.PAR AS ADDRESS
AOS EAS1PC
POPJ PP,
;HERE IF WE ARE IN A NON-RESIDENT SECTION.. BYTE POINTER MUST BE PUT
; INTO A TEMP. NOTE WE MUST USE A RUNTIME AC.. AC7 IS ASSUMED TO BE FREE
; AT THIS POINT.
B1PAR7: MOVE TA,[BYTLIT,,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPA
PUSHJ PP,POOL
SKIPN TE,PLITPC ;GET PTR TO LITERAL
HRRZ TE,ELITPC
IORI TE,AS.LIT
SKIPN PLITPC
AOS ELITPC ;UPDATE LITERAL PC
MOVE CH,[MOV+AC7+ASINC,,AS.MSC]
PUSHJ PP,PUTASY ;"MOVE AC7,LIT"
MOVE CH,TE
PUSHJ PP,PUTASN
MOVEI TE,1
PUSHJ PP,GETEMP
PUSH PP,EACC ;REMEMBER AS.TMP+N
MOVE CH,[MOVEM.+AC7+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,-1(PP)
PUSHJ PP,PUTASN
POP PP,EACC ;SETUP EACC FOR RETURN
POPJ PP,
B1PARN: MOVE TA,[XWD XWDLIT,2] ;NO--PUT PARAMETER INTO %LIT
PUSHJ PP,STASHP
HLRZ TA,ERESA
LSH TA,14
ADD TA,SUBCON
HRLZS TA
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
MOVE TA,EBASEA
HRL TA,EINCRA
PUSHJ PP,POOLIT
SKIPN EACC,PLITPC
MOVE EACC,ELITPC
SKIPN PLITPC
AOS ELITPC
IORI EACC,AS.LIT
POPJ PP,
;ALTERNATE VERSION OF B1PAR
;SETUP BYTE PTR TO "A" IN AC5.
NB1PAR:: MOVEI TE,5
MOVEM TE,SUSEAC## ;USE AC5 FOR SUBSCRIPTING
SETOM IBPFLG## ;USING B.P. FOR ILDB OR EXTEND
PUSHJ PP,SUBSCA ;DO SUBSCRIPTING IF NECESSARY
TSWT FASUB ;CONSTANT OR NO SUBSCRIPTS?
JRST NB1PR1 ;YES
NB1PR2: SETZM SUSEAC## ;CLEAR "USE AC" FLAG
SETZM IBPFLG## ;CLEAR INCASE SUBSCR NOT CALLED
POPJ PP, ;RETURN
NB1PR1: SKIPN USENBT ;USE LARGER BYTE OPT. ON?
JRST NB1PR3 ;NO
MOVE TA,NBYTES
CAIE TA,4 ;FULL WORD BYTES?
CAIN TA,6
JRST NB1PR2 ;YES--DON'T SETUP AC
NB1PR3: MOVE TA,[BYTLIT,,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPA ;BYTE PTR TO "A"
PUSHJ PP,POOL
MOVSI CH,MOV+AC5
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
JRST NB1PR2
;LIKE NB1PAR, EXCEPT SETUP BYTE PTR TO "B" IN AC10
NBBPAR:: MOVEI TE,10
MOVEM TE,SUSEAC##
SETOM IBPFLG##
PUSHJ PP,SUBSCB
TSWT FBSUB ;CONSTANT OR 0 SUBSCRIPTS?
JRST NBBPR1 ;YES
NBBPR2: SETZM SUSEAC##
SETZM IBPFLG##
POPJ PP,
NBBPR1: SKIPN USENBT
JRST NBBPR3
MOVE TE,NBYTES
CAIE TE,4
CAIN TE,6
JRST NBBPR2 ;DON'T SETUP AC
NBBPR3: MOVE TA,[BYTLIT,,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPB
PUSHJ PP,POOL
MOVSI CH,MOV+AC10
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
JRST NBBPR2
;SET UP TWO PARAMETERS (FOR MOVE OR IF).
;IF BOTH FIELDS ARE SUBSCRIPTED, PARAMETERS ARE PUT INTO %TEMP.
;IF ONLY ONE FIELD IS SUBSCRIPTED, PARAMETERS ARE PUT INTO %PARAM.
;IF NEITHER FIELD IS SUBSCRIPTED, PARAMETERS ARE PUT INTO %LIT.
B2PAR: PUSHJ PP,SUBSCA ;SUBSCRIPT "A" IF NECESSARY
TSWF FASUB ;IS IT SUBSCRIPTED NOW?
JRST B2PAR3 ;YES
PUSHJ PP,SUBSCC ;NO--SUBSCRIPT "B" IF NECESSARY
TSWF FBSUB ;IS "B" SUBSCRIPTED?
JRST B2PAR6 ;YES
;NEITHER IS SUBSCRIPTED
PUSH PP,ELITPC ;[543] SAVE LITERAL PC NOW
SKIPN COLSCP## ;[1004] SPECIAL
JRST B2PAR1 ;NO
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
MOVEI TA,AS.CNB ;LHS = 0
PUSHJ PP,STASHQ
MOVE TA,EMODEA
HRLZ TA,COLSQS##(TA) ;GET COLLATING SEQUENCE
HRRI TA,AS.MSC
PUSHJ PP,STASHQ
AOS ELITPC
B2PAR1: MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,BYTE.A
EXCH TB,TA
HLR TB,TA
HRRZS TA
PUSHJ PP,STASHQ
MOVE TA,TB
PUSHJ PP,STASHQ
AOS ELITPC ;[543]
MOVE TA,[XWD XWDLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,BYTE.C
TSWF FBSIGN;
TLO TA,SYNBIT
PUSHJ PP,STASHQ
MOVE TA,TB
PUSHJ PP,POOLIT
POP PP,ELITPC ;[543] RESTORE INITIAL ELITPC
SKIPN EACC,PLITPC
MOVE EACC,ELITPC ;GET PC AT START OF THIS BUNCH OF LITS
IORI EACC,AS.LIT
;SET UP TWO PARAMETERS (CONT'D).
MOVEI TE,2 ;NORMAL NUMBER OF WORDS
SKIPE COLSCP ;[1004] SPECIAL COLL. SEQ.?
ADDI TE,1 ;ONE MORE
SKIPN PLITPC
ADDM TE,ELITPC ;GET LIT PC CORRECT
POPJ PP,
;"A" IS SUBSCRIPTED
B2PAR3: TSWT FAS3 ;ARE WE IN NON-RESIDENT SEGMENT?
TSWF FBSUB ;NO--IS "B" ALSO SUBSCRIPTED?
JRST B2PAR8 ;YES
SKIPE COLSCP ;[1004] [743] SPECIAL COL. SEQ.?
PUSHJ PP,B2PR6C ;[743] YES
MOVE CH,[XWD AS.OCT,1] ;NO--USE IMPPAR
PUSHJ PP,PUTAS1
HRRZI CH,0
PUSHJ PP,PUTAS1
MOVE CH,MOVSAC
PUSHJ PP,PUTASY
HRRZ CH,EAS1PC
IORI CH,AS.PAR
PUSHJ PP,PUTASN
PUSHJ PP,BYTE.C
TSWF FBSIGN;
TLO TA,SYNBIT
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1
MOVE CH,TA
PUSHJ PP,PUTAS1
MOVE CH,TB
PUSHJ PP,PUTAS1
B2PAR4: MOVEI EACC,2
EXCH EACC,EAS1PC
ADDM EACC,EAS1PC
SKIPE COLSCP ;[1004] [721] SPECIAL COL. SEQ.?
SUBI EACC,1 ;[721] YES, ACCOUNT FOR EXTRA PARAM
IORI EACC,AS.PAR
POPJ PP,
;SET UP PARAMETERS (CONT'D).
;"B" IS SUBSCRIPTED, "A" ISN'T
B2PAR6: TSWF FAS3 ;ARE WE IN NON-RESIDENT SEGMENT?
JRST B2PAR7 ;YES
SKIPE COLSCP ;[1004] [743] [721] SPECIAL COL. SEQ.?
PUSHJ PP,B2PR6C ;[743] [721] YES
PUSHJ PP,BYTE.A
MOVSI CH,AS.BYT
HRR CH,TB
PUSHJ PP,PUTAS1
MOVS CH,TB
HLL CH,TA
PUSHJ PP,PUTAS1
MOVE CH,[XWD AS.OCT,1]
PUSHJ PP,PUTAS1
MOVEI CH,0
PUSHJ PP,PUTAS1
MOVE CH,MOVSAC
PUSHJ PP,PUTASY
HRRZ CH,EAS1PC
ADDI CH,1
IORI CH,AS.PAR
PUSHJ PP,PUTASN
JRST B2PAR4
B2PR6C: MOVE CH,[AS.XWD,,1] ;[743] [721] NEED EXTRA WORD FOR COL. SEQ.
PUSHJ PP,PUTAS1 ;[721] PUT IN LOW SEQ DATA
SETZ CH, ;[721] LHS = 0
PUSHJ PP,PUTAS1 ;[721]
MOVE CH,EMODEA ;[721]
HRLZ CH,COLSQS##(CH) ;[721] GET COLLATING SEQUENCE
HRRI CH,AS.MSC ;[721]
PUSHJ PP,PUTAS1 ;[721]
AOS EAS1PC ;[721] ACCOUNT FOR EXTRA WORD
POPJ PP, ;[743]
B2PAR7: MOVEI TE,2
SKIPE COLSCP ;[1004] [721] SPECIAL COL. SEQ.?
ADDI TE,1 ;[721] YES, NEED EXTRA WORD
PUSHJ PP,GETEMP
SKIPE COLSCP ;[1004] [721] SPECIAL COL. SEQ. CODE?
AOS EACC ;[721] YES, LEAVE FIRST WORD FREE
PUSH PP,EACC
MOVE CH,MOVSAC
PUSHJ PP,PUTASY
HRRZ CH,0(PP)
ADDI CH,1
PUSHJ PP,PUTASN
PUSHJ PP,B2PR9A
MOVE CH,MOVSAC
PUSHJ PP,PUTASY
POP PP,CH
MOVE EACC,CH ;[721] INCASE COL. SEQ.
JRST B2PR9B ;[721] SEE IF SPECIAL COL. SEQ.?
;SET UP TWO PARAMETERS (CONT'D).
;WE ARE GOING TO USE %TEMP TO HOLD PARAMETERS.
;EITHER BOTH ITEMS WERE SUBSCRIPTED, OR WE ARE IN NON-RESIDENT SEGMENT.
B2PARD:: ;ENTER HERE TO FORCE PARAMS INTO TEMP FOR DEPENDENT MOVE
PUSHJ PP,SUBSCA ;SUBSCRIPT "A" IF NECESSARY
PUSHJ PP,SUBSCC ;DITTO "B"
B2PAR8: MOVEI TE,2
SKIPE COLSCP ;[1004] [721] SPECIAL COL. SEQ.?
ADDI TE,1 ;[721] YES, NEED EXTRA WORD
PUSHJ PP,GETEMP
SKIPE COLSCP ;[1004] [721] SPECIAL COL. SEQ. CODE?
AOS EACC ;[721] YES, LEAVE FIRST WORD FREE
PUSH PP,EACC ;SAVE ADDRESS
TSWT FASUB ;IS "A" SUBSCRIPTED?
PUSHJ PP,B2PR9A ;NO
MOVE CH,MOVSAC
PUSHJ PP,PUTASY
HRRZ CH,(PP)
PUSHJ PP,PUTASN
PUSHJ PP,SUBSCC
TSWF FBSUB ;"B" SUBSCRIPTED?
JRST B2PAR9 ;YES
MOVE TA,[XWD XWDLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,BYTE.C
TSWF FBSIGN
TLO TA,SYNBIT
PUSHJ PP,STASHQ
MOVE TA,TB
PUSHJ PP,POOLIT
MOVSI CH,MOV+SAC
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
B2PAR9: MOVE CH,MOVSAC
PUSHJ PP,PUTASY
POP PP,EACC
HRRZI CH,1(EACC)
B2PR9B: SKIPN COLSCP ;[1004] [721] SPECIAL COL. SEQ.?
JRST PUTASN ;[721] NO
SOS EACC ;[721] BACKUP TO FIRST WORD
PUSH PP,EACC ;[721] SAVE AGAIN
PUSHJ PP,PUTASN ;[721] SAVE SECOND SUBSCRIPT
MOVE CH,[MOVEI.+AC12+ASINC,,AS.MSC] ;[721]
PUSHJ PP,PUTASY ;[721]
MOVE CH,EMODEA ;[721]
HRRZ CH,COLSQS(CH) ;[721] GET COLLATING SEQUENCE
PUSHJ PP,PUTASN ;[721]
MOVE CH,MOVSAC ;[721]
PUSHJ PP,PUTASY ;[721]
POP PP,CH ;[721] POINT TO WORD 1
JRST PUTASN
B2PR9A: MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPA
PUSHJ PP,POOL
MOVSI CH,MOV+SAC
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
POPJ PP,
;SET UP TWO PARAMETERS, AND GET REAL BYTE POINTERS TO BOTH.
;THIS GENERATES CODE TO LEAVE AN ILDB BYTE PTR TO "A" IN AC5, BYTE
;POINTER TO "B" IN AC10
; NOTE: IF USING FULL-WORD BYTES (4 OR 6 BYTES/BYTE), ONLY THE
;ADDRESS WILL BE PUT IN THE SUBSCRIPT AC, NOT A BYTE PTR.
NB2PAR:: PUSHJ PP,EXMAB ;GET SUBSCRIPTS INTO TEMP LOCS IF NECESSARY
TSWF FERROR ;ANY ERRORS?
POPJ PP, ;YES, GIVE UP
PUSHJ PP,NB1PAR ;GET BYTE PTR TO "A" IN AC5
PJRST NBBPAR ;BYTE PTR TO "B" IN AC10
;ROUTINES TO SETUP BYTE PTRS FOR MOVE/COMPARE OF ONLY ONE BYTE.
; RETURNS TA= XWD <PTR TO "A">, <PTR TO "B">
;IF PTR POINTS TO AC, E.G. "5", BYTE PTR SHOULD BE INCREMENTED BEFORE
;USE. IF PTR POINTS TO %LIT00+N, BYTE PTR SHOULD BE ONLY "LDB'D" OR "DPB'D".
PCXBP2:: PUSHJ PP,EXMAB ;MAKE SURE SUBSCRIPTS ARE IN %TEMP.
PUSHJ PP,PCXBPA ;PUT PTR TO "A" IN LH (PCXPTR)
TSWF FERROR ;ERRORS?
JRST PCX2B ;YES
PUSHJ PP,PCXBPB ;PUT PTR TO "B" IN RH (PCXPTR)
TSWF FERROR ;ERRORS?
PCX2B: SETZM PCXPTR## ;ERRORS - CLEAR PCXPTR
POPJ PP, ;RETURN
;ROUTINE TO DO THE SAME FOR ONLY 1 PARAMETER
PCXBP1:: PUSHJ PP,PCXBPA ;DO IT FOR "A"
TSWF FERROR ;ERRORS?
SETZM PCXPTR## ;YES, CLEAR
POPJ PP, ;RETURN
;ROUTINE TO SETUP BYTE PTR TO "A", PUT IN LITAB IF NOT SUBSCRIPTED,
;AND RETURN PTR TO WHERE IT WILL BE IN LH (PCXPTR)
PCXBPA: MOVEI TE,5 ;USE AC 5 FOR SUBSCRIPTING
MOVEM TE,SUSEAC##
SETOM IBPFLG## ;IGNORE SUBCON
PUSHJ PP,SUBSCA
TSWT FASUB
JRST PCXC ;CONSTANT OR NO SUBSCRIPTS
;RETURN "5" AS PTR TO "A"
PCXRT5: MOVEI TE,5 ;SUBSCRIPTING WAS DONE
PCXRTA: HRLM TE,PCXPTR## ;RETURN PTR TO "A"
PCXRTT: SETZM SUSEAC##
SETZM IBPFLG##
POPJ PP,
PCXC: SKIPN USENBT## ;USING THE BIG BYTE OPTIMIZATION?
JRST PCXC1 ;NO
MOVE TE,NBYTES## ;YES
CAIE TE,6
CAIN TE,4 ;4 OR 6 (36-BIT BYTES)?
JRST PCXRT5 ;YES--DON'T SETUP AC
PCXC1: MOVE TA,[XWD BYTLIT,2] ;PUT ANSWER IN LITAB
PUSHJ PP,STASHP
SETOM MAKBPB## ;TELL MBYTPA TO INCREMENT THE B.P.
PUSHJ PP,MBYTPA
PUSHJ PP,POOL
SKIPN TE,PLITPC ;GET PTR TO LITERAL
HRRZ TE,ELITPC
IORI TE,AS.LIT
SKIPN PLITPC ;DID WE POOL IT?
AOS ELITPC ;NO, UPDATE LITERAL PC
JRST PCXRTA ;STORE PTR TO "A" & RETURN
;SAME AS PCXBPA, EXCEPT FOR "B". USES AC 10 FOR SUBSCRIPTING
PCXBPB: MOVEI TE,10
MOVEM TE,SUSEAC##
SETOM IBPFLG##
PUSHJ PP,SUBSCB
TSWT FBSUB
JRST PCXD ;CONSTANT OR NO SUBSCRIPTS
;RETURN "10" AS PTR TO "B"
PCXR10: MOVEI TE,10
PCXRTB: HRRM TE,PCXPTR## ;RETURN PTR IN RH (PCXPTR)
JRST PCXRTT ;RETURN
PCXD: SKIPN USENBT##
JRST PCXD1
MOVE TE,NBYTES##
CAIE TE,6
CAIN TE,4
JRST PCXR10 ;DON'T SETUP AC10, RETURN
PCXD1: MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
SETOM MAKBPB##
PUSHJ PP,MBYTPB
PUSHJ PP,POOL
SKIPN TE,PLITPC
HRRZ TE,ELITPC
IORI TE,AS.LIT
SKIPN PLITPC
AOS ELITPC
JRST PCXRTB ;RETURN PTR TO "B"
;GETNB -- ROUTINE TO CHECK FOR "LARGER BYTE" OPTIMIZATION.
; CALLED FROM MOVGEN & IFGEN.
;
;INPUTS:
; "A" & "B" SETUP BY SETOPN.
; NCHARS/ #CHARS TO MOVE OR COMPARE
;
;RETURNS:
; NBYTES/ MULTIPLE # OF BYTES TO USE, E.G., IF
; MODE IS SIXBIT AND NBYTES=2, USE 12 BIT BYTES.
;
; NOTE: THIS ROUTINE ONLY WORKS WHEN "A" AND "B" ARE
; DISPLAY ITEMS OF THE SAME MODE
GETNB:: SKIPE USENBT## ;THIS SHOULD BE 0 AT THIS POINT
JRST E$UNZ ;? INTERNAL COMPILER ERROR
PUSHJ PP,DEPCKK ; ANY DEPENDING ITEMS?
TRNA ;NO, OK
JRST GOTAN1 ;"A" OR "B" HAS A DEPENDING ITEM - RETURN 1
SETOM ONLYEX## ;TELL SUBSCRIPT ROUTINE WE JUST WANT INFO,
;NO REAL SUBSCRIPT CODE GENERATED
MOVEI DT,EBASEA ;POINT TO "A"
MOVE TD,[FASUB] ;"A" SUBSCRIPT FLAG IN TD
PUSHJ PP,GETNB1 ;HOW MANY BYTES/BYTE?
PUSH PP,TA ;SAVE ANSWER FOR A
MOVEI DT,EBASEB ;NOW DO THE SAME FOR B
MOVE TD,[FBSUB]
PUSHJ PP,GETNB1
POP PP,TC ;TC= "A" ANSWER, TA= "B" ANSWER
;USE EUCLID'S ALGORITHM TO FIND GREATEST COMMON DIVISOR
CAMLE TA,TC ;GET TC= LARGER NUMBER
EXCH TA,TC
E1: IDIVI TC,(TA) ;GET TB= REMAINDER
JUMPE TB,GOTNB ;IF 0, ANSWER=TA
MOVE TC,TA
MOVE TA,TB
JRST E1
GOTNB: MOVE TC,NCHARS## ;GET # CHARS TO MOVE/COMPARE
CAMLE TA,TC ;GET GREATEST COMMON DIVISOR AGAIN
EXCH TA,TC
E1AGEN: IDIVI TC,(TA)
JUMPE TB,GOTANS
MOVE TC,TA
MOVE TA,TB
JRST E1AGEN
GOTAN1: MOVEI TA,1 ;RETURN 1 IF CAN'T DO IT
GOTANS: MOVEM TA,NBYTES## ;SAVE # TO USE
SETZM ONLYEX## ;CLEAR FLAG FOR SUBSCR
POPJ PP, ;RETURN
;ROUTINE TO LOOK AT OPERAND POINTED TO BY DT, WITH CUREOP
;POINTING TO THE ITEM, AND FIGURE OUT HOW MANY BYTES WE CAN
;LDB AT ONCE (INDEPENDENT OF HOW MANY CHARS TO MOVE).
;RETURNS TA= MAX # BYTES.
GETNB1: TDCN SW,TD ;IS IT SUBSCRIPTED?
JRST NOTSB ;NO
PUSH PP,TD ;SAVE FLAG
SETOM IBPFLG## ;GENERATE A BYTE PTR!
CAIN DT,EBASEB ;POINTING TO B?
SKIPA TE,OPERND
HLRZ TE,OPERND
HRRZM TE,CUREOP ;SETUP CUREOP
PUSH PP,DT ;SAVE PTR TO A OR B
CAIN DT,EBASEA ;SETUP PTR THE WAY SUBSCR LIKES IT
SKIPA DT,[ESAVES]
MOVEI DT,ESAVSB ;. .
PUSHJ PP,SUBSCR
JRST NOTSBA ;LITERAL SUBSCRIPTS OR ERRORS
POP PP,DT
POP PP,TD
TDO SW,TD ;REMEMBER IT IS SUBSCRIPTED
;RETURN GCD OF NUMBER RETURNED BY GETNBS AND S1SIZ
PUSHJ PP,GETNBS ;# BYTES BASED ON BYTE RESIDUE
MOVE TC,S1SIZ## ;TC= SIZE OF ELEMENTARY ITEM
CAMLE TA,TC
EXCH TA,TC ;GET TC=LARGER NUMBER
GETNLP: IDIVI TC,(TA)
JUMPE TB,CPOPJ ;ANSWER= TA
MOVE TC,TA
MOVE TA,TB
JRST GETNLP ;LOOP
;HERE IF THE ITEM WAS NOT SUBSCRIPTED (OR LITERAL SUBSCRIPTS)
NOTSBA: POP PP,DT
POP PP,TD
TSWF FERROR ;ERRORS?
POPJ PP, ;YES. RETURN IMMEDIATELY
HRRZM TE,EINCRX(DT)
LSH TE,-14
HLLM TE,ERESX(DT)
NOTSB: TDZ SW,TD ;CLEAR SUBSCRIPT FLAG
PJRST GETNBS ;RETURN TA= # BYTES TO USE
;ROUTINE TO GET # BYTES/BYTE TO USE, DEPENDING ON BYTE RESIDUE ONLY
;RETURNS ANSWER IN TA
GETNBS: HLRZ TB,ERESX(DT) ;GET BYTE RESIDUE
SKIPN TB ;0? (END-OF-WORD)
MOVEI TB,^D36 ;YES, SAME AS 36
MOVE TD,EMODEX(DT) ;GET MODE
IDIV TB,[ EXP 6
EXP 7
EXP 9](TD) ;CONVERT BIT RESIDUE TO # BYTES
MOVE TE,[ EXP NB6TBL
EXP NB7TBL
EXP NB9TBL](TD) ;GET TABLE TO USE
HRLI TE,(POINT 6) ;POINT TO IT
MOVEI TC,6
SUB TC,TB
IMULI TC,6 ;GET BYTE RESIDUE IN "TABLE"
DPB TC,[POINT 6,TE,5] ;MAKE TE POINT TO ANSWER
LDB TA,TE ;PUT IT IN TA
POPJ PP, ;AND RETURN
;1-WORD "TABLES" FOR GETNBS
NB6TBL: BYTE(6) 1,2,3,2,1,6
NB7TBL: BYTE(6) 1,1,1,1,5,0
NB9TBL: BYTE(6) 1,2,1,4,0,0
;GENERATE SUBSCRIPT CALL FOR "A"
SUBSCA: TSWT FASUB ;IS IT SUBSCRIPTED?
POPJ PP, ;NO--NO ACTION
HRRZ TE,EMODEA
CAIN TE,C3MODE ;IS IT COMP-3?
MOVEI TE,D9MODE ;YES, WE WILL USE 9 BIT BYTES THEN.
CAILE TE,DSMODE
TDCA TE,TE
MOVE TE,BYTE.S(TE)
LSH TE,6
MOVEM TE,SUBCON
SBSCA1: MOVEI DT,ESAVES
HLRZ TE,OPERND
MOVEM TE,CUREOP
PUSHJ PP,SUBSCR
SWOFFS FASUB ;LITERAL SUBSCRIPTS
POPJ PP, ;NON-LITERAL SUBSCRIPTS
HRRZM TE,EINCRA
LSH TE,-14
HLLM TE,ERESA
POPJ PP,
;GENERATE SUBSCRIPT CALL FOR "B"
SUBSCB: TSWT FBSUB;
POPJ PP,
HRRZ TE,EMODEB
CAIN TE,C3MODE ;IF IT'S COMP-3,
MOVEI TE,D9MODE ;PRETEND IT'S EBCDIC.
CAILE TE,DSMODE
TDCA TE,TE
MOVE TE,BYTE.S(TE)
LSH TE,6
SUBSB0: MOVEM TE,SUBCON
SUBSB1: MOVEI DT,ESAVSB
HRRZ TE,OPERND
MOVEM TE,CUREOP
PUSHJ PP,SUBSCR
SWOFFS FBSUB ;LITERAL SUBSCRIPTS
POPJ PP, ;NON-LITERAL SUBSCRIPTS
HRRZM TE,EINCRB
LSH TE,-14
HLLM TE,ERESB
POPJ PP,
;GENERATE SUBSCRIPT CALL FOR "B", WITH SIZE IN SUBCON
SUBSCC: TSWT FBSUB ;IS IT SUBSCRIPTED?
POPJ PP, ;NO
HRRZ TE,ESIZEB
TSWF FBSIGN;
IORI TE,SYNBIT
JRST SUBSB0
;GENERATE SUBSCRIPT CALL FOR "A", WITH "ESIZEZ" IN SUBCON.
SUBSCD: HRRZ TE,ESIZEZ
TSWF FASIGN;
IORI TE,SYNBIT
MOVEM TE,SUBCON
TSWT FASUB;
POPJ PP,
JRST SBSCA1
;GENERATE SUBSCRIPT CALL FOR "B", ASSUMING "SUBCON" IS SET UP
SUBSCE: TSWT FBSUB ;IS "B" SUBSCRIPTED?
POPJ PP, ;NO
JRST SUBSB1 ;YES
;ROUTINE TO MAKE SURE THAT SUBSCRIPTS TO "A" AND "B" ARE
;PUT IN TEMP LOCATIONS BEFORE THE ACTUAL SUBSCRIPT CODE IS
;GENERATED. THIS ALLOWS THE LIBOL CONVERSION ROUTINES TO
;USE ALL AC'S WITHOUT FEAR OF SMASHING SOMETHING.
EXMAB:: SETOM ONLYEX## ;"ONLY EXAMINE" FLAG
SETOM IBPFLG## ; BYTE PTR BEING GENERATED
PUSHJ PP,SUBSCA ; FOR "A"
SETOM IBPFLG##
PUSHJ PP,SUBSCB ; FOR "B"
SETZM ONLYEX## ;DONE WITH THIS
SETZM IBPFLG##
POPJ PP, ;RETURN
SUBTTL SUBSCR - GENERATE CODE FOR SUBSCRIPTING
;ENTER WITH "CUREOP" POINTING TO THE ITEM, A CONSTANT IN "SUBCON",
; AND "DT" POINTING TO EITHER ESAVES (FOR A), OR ESAVSB (FOR B).
;EXIT TO CALL+1 IF ALL SUBSCRIPTS ARE LITERALS, OR IF ERRORS FOUND
; WITH "TE" CONTAINING THE BYTE POINTER.
;EXIT TO CALL+2 IF NOT ALL SUBSCRIPTS WERE LITERALS, AFTER GENERATING CODE.
;
; IF "ONLYEX" IS -1, JUST CALL "EXMSUB" TO GEN CODE TO PUT SUBSCRIPTS
;INTO %TEMP, DON'T GENERATE ANY OTHER SUBSCRIPT CODE, AND RETURN S1SIZ=
;SIZE OF BASE ITEM. ON EXIT, "ONLYEX" WILL STILL BE -1.
;
; IF "ALSTMP" IS -1, PUT ALL SUBSCRIPTS IN %TEMP, EVEN COMP ONES.
;THIS FLAG SHOULD ONLY BE SET IN CONJUNCTION WITH "ONLYEX". ON
;EXIT, "ALSTMP" WILL STILL BE -1.
;
; IF "IBPFLG" IS -1, A BYTE PTR WILL BE GENERATED, AND "SUBCON"
;WILL BE IGNORED. THIS FLAG SHOULD ONLY BE SET IF THE BYTE PTR WILL
;BE USED FOR AN "EXTEND", "ILDB", OR "IDPB". ON EXIT, "IBPFLG" IS SET TO 0.
;
; IF DEBUGGING ON THIS DATA ITEM, ON ENTRY:
;1) EDEBDA (EDEBDB) WILL BE NON-ZERO (THE BASE DATA ITEM)
;2) EDEBPA (EDEBPB) WILL POINT TO THE %PARAM BLOCK TO STORE
; THE SUBSCRIPT INDICES.
;
; IN THIS CASE, CODE WILL BE GENERATED TO STORE THE SUBSCRIPT
; VALUES IN %PARAM THRU %PARAM+2, AND THE BASE ITEM POINTER
; IN %PARAM+3.
SUBSCR: MOVEM SW,ESAVSW
SWOFF FASUB!FBSUB!FALWY0;
MOVEM DT,ESAVDT
MOVE TE,[XWD EBASEA,ESAVES] ;SAVE "A" AND "B" PARAMS
BLT TE,ESAVSX
MOVE TC,CUREOP ;SAVE CUREOP
MOVEM TC,ESAVOP
MOVSI TE,(LKSFLG) ;GET OPERAND'S L.S. FLAG
AND TE,(TC)
MOVEM TE,ELNKSF## ;REMEMBER SETTING
MOVE TE,1(TC) ;ANY SUBSCRIPTS WAITING?
LDB TE,TESUBC
SKIPN ELNKSF ;LINKAGE SECTION ARGUMENT?
JUMPE TE,BADSB3 ;NO -- ERROR
MOVE DT,0(TC) ;
TXNE DT,GNREFM ;IS OPERAND REF. MODDED?
SUBI TE,2 ;DECREMENT SUBSCRIPT COUNT
MOVE DT,ESAVDT ;RESTORE DT
MOVEM TE,ENOCC2 ;YES -- SAVE COUNT
; IF DEBUGGING THIS ITEM, PUT ADDR OF %PARAM BLOCK IN "SUBPBL".
; ELSE CLEAR IT.
CAIN DT,ESAVES ;IS THIS "A"
JRST SDEBA ;YES
;CHECK FOR DEBUGGING "B" ITEM
SKIPN EDEBDB ;ARE WE DEBUGGING ON "B"?
JRST SDEBNO ;NO
MOVE TE,EDEBPB## ;GET %PARAM ADDR
MOVEM TE,SUBPBL## ;SAVE IT
JRST SDEBDN ;DONE
;CHECK FOR DEBUGGING "A" ITEM
SDEBA: SKIPN EDEBDA ;ARE WE DEBUGGGING ON "A"?
JRST SDEBNO ;NO
MOVE TE,EDEBPA## ;GET %PARAM ADDR
MOVEM TE,SUBPBL## ;SAVE IT
TRNA ;SKIP
SDEBNO: SETZM SUBPBL## ;NO DEBUGGING--CLEAR ITEM
SDEBDN: PUSHJ PP,EXMSUB ;LOOK AT THE SUBSCRIPTS
JRST SUBS20 ;THEY ARE ALL LITERALS
SUBSC0: TSWF FERROR ;ANY ERRORS?
JRST SUBS10 ;YES -- QUIT
AOS (PP) ;EXIT WILL BE TO CALL+2
MOVE TC,ESAVOP ;RESET CUREOP
MOVEM TC,CUREOP
MOVEM TC,HLDEOP## ;SAVE PTR FOR SUBS15
SETZM ENOCC1 ;CLEAR COUNTER
;GENERATE CODING FOR SUBSCRIPT (CONT'D).
MOVE DT,ESAVDT
JRST SILGO ; GENERATE INLINE CODE
SUBS10: MOVE TA,[XWD ESAVES,EBASEA];RESTORE "A" AND "B"
BLT TA,EBASBX
MOVE TA,ESAVOP ;RESET CUREOP
MOVEM TA,CUREOP
SETZM IBPFLG## ;RESET "BP WILL BE INCREMENTED" FLAG
TSWT FERROR ; [330]ANY ERRORS?
JRST SUBS11 ; [330] NO-GO ON
MOVSI TE,(FFATAL) ; [330] MAKE SURE THAT FFATAL
IORM TE,ESAVSW ; [330] FLAG STAYS ON
MOVEI TE,0 ;[330] NOW -- RETURN 0
SUBS11: MOVE SW,ESAVSW ; [330] GET BACK SAVED SW-
;WITH FFATAL FLAG ON IF SET BY SUBSCR. ERROR
POPJ PP,
;ALL SUBSCRIPTS WERE NUMERIC LITERALS -- GENERATE INCREMENT
SUBS20: SETZM EREMAN
SETZM ENOCC1
MOVE TC,ESAVOP
MOVEM TC,CUREOP
MOVE DT,ESAVDT
HLRZ TE,ERESX(DT)
ROT TE,-6
HRRZ TD,EMODEX(DT)
PUSHJ PP,SUBSCK ;IF COMP, GET GRANDFATHER'S USAGE
TSWF FERROR ;IF ERRORS,
POPJ PP, ;GIVE UP
CAILE TD,DSMODE ;[610] IS TOP LEVEL DISPLAY?
MOVEI TD,D6MODE ;[610] NO, PRETEND DISPLAY-6
;[610] (SO "COMP" WILL WORK RIGHT)
MOVEM TD,ESAVMD## ;[306] SAVE MODE OF FATHER FOR LATER CHECKING.
MOVE TD,BYTE.S(TD) ;BITS/BYTE
SKIPE USENBT## ;USE LARGER BYTES?
IMUL TD,NBYTES## ;YES
DPB TD,[POINT 6,TE,11] ;STORE BYTE SIZE IN BYTE PTR
HRR TE,EINCRX(DT)
MOVEM TE,EWORDB
MOVE TC,CUREOP
MOVE TA,1(TC)
PUSHJ PP,LNKSET
LDB TE,DA.OCC ;IS THERE AN OCCURS AT THIS LEVEL?
JUMPN TE,SUBS21 ;YES, IF JUMP
LDB TA,DA.OCH ;NO--BACK UP ONE LEVEL
PUSHJ PP,LNKSET ;GET IT'S ADDRESS
SUBS21: HRRZM TA,CURDAT ;SAVE ADDRESS OF ITEM
LDB TE,DA.DEP ;ANY 'DEPENDING' ITEM?
JUMPN TE,SUBSC0 ;YES--WE HAVE TO CALL SUBSCRIPT UUO
LDB TE,DA.NOC ;GET NUMBER OF OCCURENCES
MOVEM TE,ESMAX ;SAVE IT
MOVEI TC,2 ;KICK UP TO NEXT SUBSCRIPT
ADDB TC,CUREOP
MOVEI LN,EBASEA ;SET UP "A" TO BE SUBSCRIPT
PUSHJ PP,SETOPN
PUSHJ PP,CONVNL ;GET VALUE
JUMPN TD,BADLSB ;> 10**10?
SKIPN EDPLA ;NO -- ANY DECIMAL PLACES?
TSWF FLNEG ;NO -- NEGATIVE?
JRST BADLSB ;YES -- TOUGH
CAMLE TC,ESMAX ;LARGER THAN MAXIMUM?
JRST BADSB6 ;YES -- ERROR
SOJL TC,BADLSB ;NO -- DECREMENT AND IF IT WAS ZERO, ERROR
PUSH PP,TC
MOVE TA,CURDAT ;GET BACK TO OCCURENCE ITEM
LDB TC,DA.USG ;GET SIZE IN BYTES
XCT SUBSIZ(TC)
POP PP,TC ;GET LITERAL VALUE BACK
IMUL TE,TC ;MULTIPLY BY <LITERAL VALUE -1>
ADDM TE,EREMAN ;ADD TO SUM
; IF DEBUGGING ON THIS ITEM, GENERATE CODE TO STORE THE SUBSCRIPT VALUE
; IN THE %PARAM BLOCK.
SKIPN SUBPBL ;SKIP IF DEBUGGING
JRST SUBS23 ;NO
; Since we are using the ANSI 74 DEBUGGER, we can only store three
; subscripts, if ENOCC1 > 2, bypass the debug statements
MOVE TE,ENOCC1 ;
CAIG TE,2 ;3 is maximum subs allowed for ANSI 74
JRST SUBS2A ;can still handle subscript
CAIE TE,3 ;give warning once, on 4th subscript
JRST SUBS23 ;continue beyond debug stmts
MOVEI DW,E.854 ;
PUSHJ PP,OPNWRN ;
JRST SUBS23 ;
;GENERATE MOVEI AC,VALUE
; MOVEM AC,%PARAM + SUBSCR# - 1
SUBS2A: ADDI TC,1 ;GET REAL VALUE
SKIPN TE,SUSEAC ;GET AC TO USE
MOVEI TE,SXR ;(DEFAULT)
CAILE TC,77777 ;SKIP IF VALUE SMALL
SKIPA CH,[MOVEI.+ASINC,,AS.CNB]
MOVSI CH,MOVEI.
DPB TE,CHAC ;STORE AC FIELD
CAILE TC,77777 ;SKIP IF SMALL
JRST [PUSH PP,TC ;SAVE CONST.
PUSHJ PP,PUTASY ;GEN FIRST PART
POP PP,CH ;GET CONST. BACK
PUSHJ PP,PUTASN ;GEN LAST PART
JRST SUBS2B] ;NOW GEN THE MOVEM
HRR CH,TC ;PUT IN INSTRUCTION
PUSHJ PP,PUTASY ;GENERATE IT
SUBS2B: MOVE CH,[MOVEM.+ASINC,,AS.MSC] ;GET START OF "MOVEM"
SKIPN TE,SUSEAC ;PUT AC VALUE IN
MOVEI TE,SXR ;(DEFAULT AC)
DPB TE,CHAC
PUSHJ PP,PUTASY ;GEN FIRST PART
MOVE CH,SUBPBL ;GET %PARAM BASE
HRRZ TE,SUBNUM ;GET TOTAL # SUBSCRIPTS
CAILE TE,3 ; UNLESS MORE THAN 3
MOVEI TE,3 ;3 IS ANSI-74 DEBUGGER MAX
SUB TE,ENOCC1 ; - THIS ONE
SUBI TE,1 ; (BECAUSE THEY COUNT FROM 0)
ADD CH,TE ;GET %PARAM OFFSET TO USE
PUSHJ PP,PUTASN ;GEN THE INSTRUCTION
SUBS23: AOS TE,ENOCC1 ;KICK UP COUNT
MOVE TA,CURDAT
LDB TA,DA.OCH ;BACK UP TO PREVIOUS LEVEL
CAML TE,ENOCC2 ;DONE?
JRST SUBS24 ;YES
JUMPE TA,SUBS25 ;NO -- ANY LEVELS LEFT?
PUSHJ PP,LNKSET ;YES -- GET NEXT LEVEL'S ADDRESS
JRST SUBS21 ;LOOP
SUBS24: JUMPE TA,SUBS26 ;NO SUBSCRIPTS LEFT--ANY LEVELS LEFT?
SUBS25: PUSHJ PP,NOTNUF ;YES -- ERROR
SUBS26: MOVE TD,EREMAN ;GET COMPUTED OFFSET
LDB TE,[POINT 6,EWORDB,11];COMPUTE BYTES/WORD
MOVEI TB,^D36
IDIV TB,TE
IDIV TD,TB ;COMPUTE NUMBER OF WORDS
MOVE TE,EWORDB ;GET POINTER TO (1,...,1) BACK
ADD TE,TD ;PUT #WORDS IN RH
SUBS27: SOJL TC,SUBS28 ;ANY BYTES LEFT OVER?
IBP TE ;YES -- BUMP POINTER
JRST SUBS27 ;LOOP
SUBS28: SKIPE IBPFLG## ;WANT A BYTE PTR TO INCREMENT?
JRST SUBS29 ;YES, NO "SUBCON"
MOVE TD,SUBCON
DPB TD,[POINT 12,TE,17]
JRST SUBS30
SUBS29: TLNE TE,760000 ;MAKE "POINT 36,BLAH" OR "POINT 35,BLAH"
JRST SUBS30 ;IF NECESSARY
TLZ TE,770000
ADD TE,[440000,,1]
JRST SUBS30
;SUBS30: CHECK FOR DEBUGGING, IF SO,
; GEN CODE TO STORE BASE POINTER, AND CLEAR LAST SUBSCRIPT
; JRST'S TO SUBS10 WHEN DONE
SUBS30: SKIPN SUBPBL ;SKIP IF DEBUGGING
JRST SUBS10 ;NO, JUST GO TO SUBS10
PUSH PP,TE ;SAVE TE
;WE WILL GET THE FINAL BYTE PTR IN SUSEAC
MOVE TA,[BYTLIT,,2]
PUSHJ PP,STASHP
HRRZ TA,EBASEX(DT) ;GET BASE ITEM
PUSHJ PP,STASHQ
MOVE TA,(PP) ;GET REST OF B.P.
PUSHJ PP,POOLIT ;FINISH UP
HRRZ TE,ELITPC ;LITERAL PC
SKIPN PLITPC ;SKIP IF WE POOLED
AOSA ELITPC ;NO, BUMP LITERAL PC
HRRZ TE,PLITPC ;GET PC TO USE
MOVE CH,[MOV+ASINC,,AS.MSC]
SKIPN TD,SUSEAC
MOVEI TD,SXR ;DEFAULT AC
DPB TD,CHAC ;PUT IN INSTRUCTION
PUSH PP,TE ;SAVE LIT PC FOR A SEC..
PUSHJ PP,PUTASY ;GEN FIRST PART
POP PP,CH ;RESTORE LIT PC
IORI CH,AS.LIT
PUSHJ PP,PUTASN ;GEN REST OF INSTRUCTION
;GEN "MOVEM AC,%PARAM + MAXSUB"
MOVE CH,[MOVEM.+ASINC,,AS.MSC]
SKIPN TD,SUSEAC
MOVEI TD,SXR
DPB TD,CHAC
PUSHJ PP,PUTASY ;FIRST PART OF INSTRUCTION
HRRZ CH,SUBPBL ;%PARAM BASE
; ADDI CH,MAXSUB ;+ MAX # SUBSCRIPTS
ADDI CH,3 ;+ 3, ANSI 74 subscript maximum
PUSHJ PP,PUTASN ;LAST PART OF INSTRUCTION
;GEN CODE TO CLEAR LAST SUBSCRIPT VALUE (IF NECESSARY)
PUSHJ PP,DBCLRL ;CLEAR LAST SUBSCRIPT IF NECESSARY
POP PP,TE ;RESTORE TE
JRST SUBS10 ;DONE, RETURN
;ROUTINE TO GENERATE THE SETZM TO CLEAR LAST SUBSCRIPT
;CALL: SUBNUM/ TOTAL # OF SUBSCRIPTS THIS DATA ITEM HAS
; MAXSUB = MAX NUMBER OF SUBSCRIPTS THIS COMPILER ALLOWS
; Ansi8x has increased nbr of subs to 48
; This has not been implemented in the debugger
; since the whole thing will probably be dropped
; from the Ansi standards. We are still using
; a maximum of three subscripts as Ansi74 specifies.
; SUBPBL/ %PARAM BASE FOR "DEBUGGING ITEM"
;
; PUSHJ PP,DBCLRL
; <RETURNS HERE, MAY GENERATE "SETZM">
;ALL ACS SMASHED
DBCLRL: MOVE TE,SUBNUM ;GET # OF SUBSCRIPTS SEEN
; CAIL TE,MAXSUB ; LESS THAN MAX?
CAIL TE,3 ; Ansi74 max = 3
POPJ PP, ;NO, DON'T GENERATE ANY CODE
MOVE CH,[SETZM.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY ;YES, GENERATE SETZM
HRRZ CH,SUBPBL ;GET %PARAM BASE
ADD CH,SUBNUM ; LAST SUBSCRIPT+1
JRST PUTASN ;FINISH INSTRUCTION AND POPJ
NOTNUF: HRRZ TC,ESAVOP ;GET BACK EOP PTR TO MAIN ITEM
MOVEM TC,CUREOP
MOVEI DW,E.250
NOTNF1: SWON FERROR
JRST OPNFAT
BADLSB: MOVEI DW,E.251
JRST BADSB7
BADSB4: SKIPA DW,[E.264] ;[661] ?MUST REPRESENT AN INTEGER
BADSB1: MOVEI DW,E.251
BADSB2: PUSHJ PP,NOTNF1
JRST EXMS9
;LINKAGE SUBSCRIPT ERROR
BADLS2: MOVEI TC,2 ;SKIP OVER THE ADDITIVE
ADDM TC,CUREOP
AOS ENOCC1 ; (ACCOUNT FOR THE ADDITIVE)
BADLS1: MOVEI DW,E.598 ;?MUST BE USAGE COMP, FEWER THAN 11
; DIGITS, AND NOT HAVE AN ADDITIVE
JRST BADSB2 ;COMPLAIN, THEN GO ON TO NEXT SUBSCRIPT
;NO SUBSCRIPTS WHEN THERE SHOULD BE
BADSB3: MOVEI DW,E.274
PUSHJ PP,NOTNF1
JRST SUBS10
BADSB6: MOVEI DW,E.252
BADSB7: PUSHJ PP,NOTNF1
JRST SUBS23
BADSB8: POP PP,DW ;REMOVE ONE FROM STACK
MOVEI DW,E.251
PUSHJ PP,NOTNF1
JRST EXMS8A
;A TABLE WHICH DETERMINES SIZE OF ITEM (ALWAYS IN BYTES)
SUBSIZ: PUSHJ PP,BADBAD ;0
PUSHJ PP,SUBSZX ;1 SIXBIT
PUSHJ PP,SUBSZX ;2 ASCII
PUSHJ PP,SUBSZX ;3 EBCDIC
PUSHJ PP,SUBSZ1 ; [306] 4 1-WORD COMP
PUSHJ PP,SUBSZ2 ; [306] 5 2-WORD COMP
PUSHJ PP,SUBSZ1 ; [306] 6 COMP-1
PUSHJ PP,SUBSZ1 ; [306] 7 INDEX
PUSHJ PP,SUBSZ3 ;10 COMP-3.
PUSHJ PP,SUBSZ2 ;11 COMP-2.
BADBAD: OUTSTR [ASCIZ "Compiler error--bad usage at SUBSIZ
"]
JRST KILL
SUBSZX: LDB TE,DA.EXS
SBSZX1: LDB TD,DA.SYL
JUMPN TD,SUBSZY
LDB TD,DA.SYR
JUMPN TD,SUBSZY
LDB TD,DA.SLL ;SYNC AT LOWER LEVEL?
JUMPE TD,CPOPJ ;NO
SUBSZY: IDIV TE,BYTE.W-1(TC)
SKIPE TD
ADDI TE,1
IMUL TE,BYTE.W-1(TC)
POPJ PP,
;CHECK FATHER OF BINARY ITEMS TO SEE IF ASCII OR SIXBIT
; LEAVE USAGE IN TD
SUBSCK: CAIN TD,C3MODE ;IF IT'S COMP-3, HIS FATHER
SKIPA TD,[EXP D9MODE] ; MUST BE EBCDIC, IF HE EXISTS.
CAIG TD,DSMODE ;[716] [161] SKIP IF USAGE IS BINARY
POPJ PP, ;[161]; ELSE RETURN
PUSH PP,TE ;SAVE AC'S
HRRZ TA,ERESX(DT)
PUSHJ PP,LNKFA##
LDB TD,DA.USG
POP PP,TE
SOJA TD,CPOPJ
; MAKE SURE OCCURS SIZE WILL BE IN ACCORDANCE WITH MODE OF FATHER
SUBSZ1: MOVE TD,ESAVMD ; [306] GET MODE OF FATHER
MOVEI TE,6 ; [306] SIX CHAR/WORD IF SIXBIT
CAIN TD,D7MODE ; [306] IF ASCII
MOVEI TE,5 ; [306] FIVE CHAR/ WORD
CAIN TD,D9MODE ;IF EBCDIC,
MOVEI TE,4 ; 4 CHARS/WORD.
POPJ PP, ; [306]
SUBSZ2: PUSHJ PP,SUBSZ1 ;GET BYTES PER WORD.
LSH TE,1 ;DOUBLE IT.
POPJ PP, ;RETURN.
SUBSZ3: LDB TE,DA.EXS## ;GET THE ITEM'S SIZE.
ADDI TE,2 ;CONVERT IT TO NINE BIT BYTES.
LSH TE,-1
MOVEI TC,%US.EB ;PRETEND IT'S EBCDIC.
JRST SBSZX1 ;GO SEE IF IT'S JUSTIFIED.
;HERE TO DO INLINE SUBSCRIPTING GENERATION
;CALL:
; SUBNUM/ # OF SUBSCRIPTS (SET BY EXMSUB)
; JRST SILGO
; <RETURN TO CALLER OF SUBSCR>
SILGO: SKIPE ONLYEX## ;ONLY EXAMINE?
JRST RETSIZ ;YES, RETURN SIZE OF ITEM
HRRZ TD,EMODEX(DT) ;MODE OF ITEM
CAILE TD,DSMODE ;DISPLAY?
CAIN TD,C3MODE ;OR COMP-3?
CAIA ;YES, NEED BYTE PTR
JRST SILGOB ;SKIP
;GET BYTE PTR TO (1,...,1) ELEMENT IF NEEDED
HRRZ TD,EMODEX(DT) ;GET USAGE
CAIN TD,C3MODE
MOVEI TD,D9MODE ;CHANGE COMP-3 TO DISPLAY-9 MODE
MOVEM TD,SSMODE##
PUSHJ PP,SUBSCK ;CHECK FATHER OF COMP ITEMS
TSWF FERROR ;ERRORS?
POPJ PP, ;YES, GO AWAY
MOVEM TD,ESAVMD## ;SAVE IT
MOVE TD,BYTE.S(TD) ;GET # BITS/BYTE
SKIPE USENBT## ;USE LARGER BYTES?
IMUL TD,NBYTES## ;YES -- TD= # BITS IN BYTE
CAIN TD,^D36 ;36 BITS/BYTE?
JRST SILGOC ;YES, NO BYTE PTR GENERATED THEN
PUSH PP,TD ;SAVE # BITS/BYTE
MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
HRRZ TA,EBASEX(DT) ;ADDRESS PORTION
PUSHJ PP,STASHQ
HLRZ TE,ERESX(DT)
ROT TE,-6 ;SHIFT BYTE RESIDUE INTO LEFTMOST 6 BITS
POP PP,TD ;GET # BITS/BYTE
DPB TD,[POINT 6,TE,11] ;STORE IN BYTE PTR.
HLLZ TA,TE
HRR TA,EINCRX(DT)
PUSHJ PP,POOLIT
JRST SUBSIL ;CONTINUE
SILGOB: MOVEM TD,SSMODE## ;MODE OF BASE ITEM
PUSHJ PP,SUBSCK ;FATHER'S MODE
TSWF FERROR ;[643] ERRORS?
POPJ PP, ;[643] YES, GIVE UP
MOVEM TD,ESAVMD##
; HERE WHEN SSMODE AND ESAVMD HAVE BEEN STORED, AND NO BYTE POINTER
;WAS GENERATED. STORE THE ADDRESS OF THE (1,...,1) ITEM IN "BASITM".
SILGOC: HRRZ TE,EBASEX(DT)
HRL TE,EINCRX(DT)
MOVEM TE,BASITM## ;SAVE INFO OF BASE ITEM
SUBSIL: MOVE TE,SUBNUM## ;TE:= # SUBSCRIPTS LEFT
SKIPE ELNKSF## ;LINKAGE SECTION?
JRST SILLNK ;YES, MAY BE 0 SUBSCRIPTS
SUBSLA: SETZM ZEROSB## ;NOT 0 SUBSCRIPTS
CAIL TE,1 ;REASONABLE #?
CAILE TE,MAXSUB ; (BETWEEN 1 AND MAXSUB)
JRST E$WNS ;?INTERNAL COMPILER ERROR
MOVEI TE,1 ;START WITH 1ST SUBSCRIPT
MOVEM TE,SUBNM1##
JRST SETEAC
SILLNK: JUMPN TE,SUBSLA
SETOM ZEROSB## ;THERE ARE 0 SUBSCRIPTS
;...
;SET GENERATED AC TO DESIRED DESTINATION AC FOR BYTE PTR
; CODE GENERATED WILL USE AC THRU AC+2 FOR CALCULATIONS.
SETEAC: PUSH PP,EAC
SKIPN TE,SUSEAC## ;SHOULD I LEAVE BYTE PTR IN SOME AC?
MOVEI TE,SXR ;NO, USE DEFAULT
MOVEM TE,EAC
SKIPE ZEROSB## ;ZERO SUBSCRIPTS?
JRST SILZRO ;YES
MOVE TA,CUREOP
MOVE TA,1(TA)
PUSHJ PP,LNKSET
LDB TE,DA.OCC ;OCCURS AT THIS LEVEL?
JUMPN TE,SUBS74 ;[745] YES, GO CHECK FOR CONVERSION
LDB TA,DA.OCH ;NO, BACK UP ONE LEVEL
PUSHJ PP,LNKSET
;[753] MOVED LINE TO SUBSI1+1
;[745] IF ANY SUBSCRIPTS HAVE DEPENDING VARIABLES THAT REQUIRE
;[745] CONVERSION TO COMP, GENERATE THE CODE NOW SO THE SUBSCRIPT
;[745] ACS DON'T GET SMASHED IN THE MIDDLE OF THE COMPUTATION
SUBS74: HRRZM TA,CURDAT ;[745] SAVE CURRENT DATA ITEM
SUBS75: LDB CH,DA.DCR ;[745] CONVERSION REQUIRED?
JUMPE CH,NOCNVT ;[745] NO
IORI CH,AS.TAG ;[745] YES, CALL ROUTINE
HRLI CH,EPJPP ;[745] "PUSHJ PP,<CONVERSION ROUTINE>"
MOVE TE,ESAVDT ;ARE WE SUBSCRIPTING "B"?
CAIE TE,ESAVSB ;...
JRST SUBS78 ;NO, MUST BE "A"
PUSH PP,CH ;ITS "B", SAVE CURRENT INST.
PUSHJ PP,PUTASA ;WE MUST PRESERVE AC5 FOR "A"
MOVE CH,[PUSH.+AC17,,5]
PUSHJ PP,PUTASY ; SINCE CONVERSION ROUTINE MIGHT DESTROY IT
POP PP,CH
PUSHJ PP,PUTASY ;GENERATE CONVERSION INST.
PUSHJ PP,PUTASA
MOVE CH,[POP.+AC17,,5] ;RESTORE AC5
SUBS78: PUSHJ PP,PUTASY ;[745]
JRST SUBS76 ;[745] DONE NOW
NOCNVT: LDB TA,DA.OCH ;[745] CHECK ALL LEVELS
JUMPE TA,SUBS76 ;[745] NO MORE, DONE
PUSHJ PP,LNKSET ;[745]
JRST SUBS75 ;[745] LOOP FOR ALL SUBSCRIPT LEVELS
SUBS76: HRRZ TA,CURDAT ;[745] RESTORE TA
; HERE TO GEN CODE FOR NEXT SUBSCRIPT
SUBSI1: HRRZM TA,CURDAT ;SAVE ADDRESS OF OCCURS LEVEL
;[753] AT SUBSI1+1 (MOVED LINE DOWN)
LDB TE,DA.NOC
MOVEM TE,ESMAX ;SAVE # OF OCCURS
SETZM SUBFLG## ;CLEAR SUBSCRIPT FLAGS
LDB CH,DA.DCR ;[745]
JUMPE CH,SUBS77 ;[745] NO CONVERSION REQUIRED
MOVE TA,[AS.PAR,,AS.MSC] ;[745] DEP. VAR HAS BEEN PUT IN %PARAM+0
JRST SUBSI2 ;[745] GO STORE IT
SUBS77: ;[745]
;STILL IN SUBSIL
;PUT DEPENDING ITEM INFO (OR 0) IN DEPITM
LDB TA,DA.DEP
JUMPE TA,SUBSI2 ;JUMP IF NONE
PUSH PP,TA
PUSHJ PP,LNKSET
LDB TE,DA.LKS
JUMPE TE,SUBSI3 ;JUMP IF DEP. VARIABLE NOT IN LINKAGE S.
LDB TE,DA.RBE ;YES, CHECK TO MAKE SURE IT WAS
;REFERENCED BY AN ENTRY OR PD USING
JUMPE TE,SUBSIE ;GIVE ERROR, USE DATANAME
POP PP,TE ;FIX STACK
MOVSI TE,1B20 ;REMEMBER DEP. VARIABLE IN LINK. SEC.
MOVEM TE,SUBFLG
LDB TA,DA.ARG ;GET ARG
IORI TA,AS.PAR ;IN %PARAM
HRLZ TA,TA
HRRI TA,AS.MSC
JRST SUBSI2
SUBSIE: MOVEI DW,E.401
PUSHJ PP,OPNFAT
SUBSI3: POP PP,TA
ANDI TA,TM.DAT
IORI TA,AS.DAT ;CHANGE CODE TO "DATANAME"
SUBSI2: MOVEM TA,DEPITM## ;SAVE DEPENDING VARIABLE ITEM
;GET SUBSCRIPT VALUE
MOVEI TC,2
ADDB TC,CUREOP
MOVEI LN,EBASEA ;PUT SUBSCR AS "A" PARAM
PUSHJ PP,SETOPN
HRRZ TE,EMODEA ;A LITERAL?
CAIN TE,LTMODE
JRST SUBILL ;YES, CHECK IT OUT
SKIPE EDPLA ;NO - ANY DECIMAL PLACES?
JRST BADSL0 ;YES, COMPLAIN
LDB TE,[POINT 3,EBASEA,20]
CAIE TE,TB.DAT ;SKIP IF A DATANAME
JRST SUBSI4
LDB TE,DA.LKS ;IS IT IN LINKAGE SECTION?
JUMPN TE,SUBSL1 ;YES
SUBSI4: MOVE TA,EBASEA
HRL TA,EINCRA ;NORMAL INFO
SUBSI5: MOVEM TA,SUBITM## ;STORE SUBSCRIPT INFO
JRST SUBSI6
;HERE IF SUBSCRIPT WAS A LITERAL
;
SUBILL: PUSHJ PP,CONVNL ;GET VALUE IN TD&TC
SKIPN EDPLA
TSWF FLNEG
JRST BADSL0
JUMPN TD,BADSL1
JUMPE TC,BADSL0
CAMLE TC,ESMAX
JRST BADSL1
MOVS TA,TC
HRRI TA,AS.CNB
JRST SUBSI5
;USER ERRORS
BADSL0: SKIPA DW,[E.251] ;?IMPROPER SUBSCRIPT
BADSL1: MOVEI DW,E.252 ;?SUBSCR. VALUE .GT. OCCURS VALUE
PUSHJ PP,NOTNF1
SETZ TA, ;PUT ZERO IN SUBITM
JRST SUBSI5
;HERE IF SUBSCRIPT IN LINKAGE SECTION
SUBSL1: MOVSI TE,1B21
IORM TE,SUBFLG ;REMEMBER INDIRECTING NEEDED
SUBSL2: LDB TE,DA.VAL## ;GET VALUE
MOVS TE,TE
IOR TE,[AS.PAR,,AS.MSC]
MOVEM TE,SUBITM## ;STORE SUBSCRIPT INFO
LDB TE,DA.RBE ;REF. BY ENTRY?
JUMPN TE,SUBSI6 ;YES, THEN ALL DONE
SUBSL3: LDB TE,DA.LVL## ;GET LEVEL
CAIE TE,01 ;AT LEVEL 01
CAIN TE,77 ;OR LEVEL 77
JRST SUBSI6 ;YES, DONE
PUSHJ PP,LNKFA1## ;NO, BACKUP TO FATHER
LDB TE,DA.RBE ;WAS FATHER REF. BY ENTRY?
JUMPE TE,SUBSL3 ;NO, KEEP ON TRYING
JRST SUBSL2 ;YES, STORE VALUE
;NOW WE'RE READY TO CALL GEN. SUBROUTINES
SUBSI6: MOVSI TE,1B18
HRRZ TD,EMODEA
CAIE TD,LTMODE
IORM TE,SUBFLG ;SET FLAG IF NOT LITERAL
PUSHJ PP,SILG00 ;GEN: SKIPLE AC,SUBSC. VALUE
; CAILE AC,OCCURS VALUE
; PUSHJ PP,SUBE1##
SKIPE DEPITM## ;SKIP IF NO DEPENDING ITEM
PUSHJ PP,SILG02 ;GEN: SKIPLE AC+1,DEPENDING.VAR
; CAILE AC,AC+1
; PUSHJ PP,SUBE2##
;[1565] deleted 2L
PUSHJ PP,SILG01 ;GEN: SUBI AC,1
AOS TE,SUBNM1## ;INCREMENT COUNTER
CAIG TE,2
JRST SUBSI7 ;SKIP IF FIRST PASS
;[1565] deleted 2L
PUSHJ PP,GENIML ;GENERATE THE IMULI AC,SIZE
SOS EAC ;AC:=AC-1
PUSHJ PP,SILG03 ;GEN: ADD AC,AC+1
;[1565] deleted 2L
MOVE TE,SUBNM1## ;GET SUBSCR. INDEX AGAIN
SUBSI7: CAMLE TE,SUBNUM ;SKIP IF .LE. NUMBER
JRST SUBSI8 ;NO MORE, GEN END
CAIG TE,2 ;ON 1ST SUBSCRIPT?
PUSHJ PP,[MOVE TE,ESMAX ;YES, GET OCCURS VALUE
SOJG TE,GENIML ;OK, GEN "IMULI AC,SIZE"
PUSHJ PP,PUTASA
MOVSI CH,SETZ. ;GENERATE SETZ AC,
JRST PUT.XA]
AOS EAC ;BUMP EAC
MOVE TE,CUREOP
MOVE TE,1(TE)
TLNN TE,BSUBSC ;DID IT HAVE AN ADDITIVE?
JRST SUBSI9 ;NO
MOVEI TE,2
ADDM TE,CUREOP ;YES, BUMP PAST ONE OPERAND
SUBSI9: MOVE TA,CURDAT
LDB TA,DA.OCH
JUMPE TA,[PUSHJ PP,NOTNUF
JRST SUBIDN]
PUSHJ PP,LNKSET
JRST SUBSI1 ;LOOP BACK FOR ALL
;HERE WHEN DONE CALCULATION OF OFFSET
;GEN. CODE TO ADJUST BYTE POINTER
SUBSI8: MOVE TE,SSMODE ;GET MODE OF BASE ITEM
CAILE TE,DSMODE ;IF NOT DISPLAY..
JRST SUBILC ;DON'T BOTHER WITH BYTE PTR STUFF
MOVE TE,SUBNM1
CAIG TE,2 ;ONLY 1 SUBSCRIPT?
PUSHJ PP,CHKIML ;YES, GEN "IMULI AC,SIZE"
PUSHJ PP,SILG04 ;GEN CODE TO ADJUST BYTE PTR
SKIPN IBPFLG## ;SKIP IF WE ARE MAKING A BYTE PTR
PUSHJ PP,SILG05 ;GEN CODE TO DPB "SUBCON" INTO BITS 6-17
JRST SUBID1 ;AND THEN WE'RE DONE
;HERE IF BASE ITEM IS COMP
;GEN. "ADDI AC,BASE" INSTEAD OF BOTHERING WITH BYTE POINTER
SUBILC: MOVE TE,SUBNM1
CAIG TE,2 ;ONLY 1 SUBSCRIPT?
PUSHJ PP,GENIML ;YES, GENERATE "IMULI AC,<SIZE>"
PUSHJ PP,SILG06 ;"ADDI AC,BASE"
SKIPE ELNKSF## ;ITEM IN LINKAGE SECTION?
PUSHJ PP,SILG07 ;YES, ADD OFFSET
;HERE WHEN NO MORE CODE GENERATION TO DO - RESULT IS IN AC "SXR".
;IF DEBUGGING, STORE AWAY THE BYTE PTR FROM AC,
; AND MAYBE GENERATE "SETZM %PARAM + LAST.SUBSCRIPT - 1"
SUBID1: SKIPN SUBPBL ;DEBUGGING?
JRST SUBID3 ;NO, SKIP THIS
MOVE CH,[MOVEM.+ASINC,,AS.MSC]
PUSHJ PP,PUT.XA ;FIRST PART OF INSTRUCTION
HRRZ CH,SUBPBL ;GET %PARAM BASE
; ADDI CH,MAXSUB ; OFFSET SKIPS ALL SUBSCRIPTS
ADDI CH,3 ; ANSI74 debugger => 3 subscripts max
PUSHJ PP,PUTASN ;FINISH "MOVEM".
PUSHJ PP,DBCLRL ;(MAYBE) GENERATE A "SETZM"
SUBID3:
SUBIDN: POP PP,EAC ;RESTORE VALUE OF EAC
PJRST SUBS10 ;RESTORE PARAMS & RETURN TO CALLER
;OF SUBSCR
;HERE FOR 0 SUBSCRIPTS - MOVE "A" TO "B" WHERE "A" IN LINKAGE.
SILZRO: MOVE TE,SSMODE##
CAILE TE,DSMODE
JRST SILZRB ;NOT DISPLAY
SKIPN USENBT## ;LARGER BYTES?
JRST SILZR1 ;NO
MOVE TD,NBYTES## ;HOW BIG?
CAIE TD,4
CAIN TD,6
JRST SILZRB ;FULL WORD-- NO BYTE PTR
SILZR1:
;DISPLAY - GEN "MOVE AC,BYTE.PTR", "ADD AC,OFFSET"
MOVSI CH,MOV
PUSHJ PP,PUT.LC ;"MOVE AC,CURRENT.LITERAL"
SKIPN PLITPC
AOS ELITPC
PUSHJ PP,SILG07 ;"ADD AC,OFFSET"
SKIPN IBPFLG## ;SKIP IF MAKING A BYTE PTR
PUSHJ PP,DPBSUB ;DPB SUBCON
JRST SUBIDN
;NOT DISPLAY - GEN "MOVEI AC,BASITM", "ADD AC,OFFSET"
SILZRB: MOVSI CH,MOVEI.
PUSHJ PP,SILG6A
PUSHJ PP,SILG07 ;"ADD AC,OFFSET"
JRST SUBIDN
;HERE IF ONLYEX FLAG WAS ON, AND SUBSCRIPTS ARE NOT ALL LITERALS
; RETURN SIZE OF ELEMENTARY ITEM IN S1SIZ
RETSIZ: MOVE TA,CUREOP ;BASE ITEM
MOVE TA,1(TA)
PUSHJ PP,LNKSET
SKIPN TB,SUBNUM## ;ZERO SUBSCRIPTS?
JRST RETSZ1 ;RIGHT, RETURN SIZE OF BASE ITEM
LDB TE,DA.OCC ;AN OCCURS AT THIS LEVEL?
JUMPN TE,RETSZA
LDB TA,DA.OCH ;NO, BACK UP ONE LEVEL
PUSHJ PP,LNKSET
RETSZA: CAIN TB,1 ;JUST ONE SUBSCRIPT?
JRST RETSZ1 ;YES, BE FAST
;MORE THAN 1 SUBSCRIPT. WE HAVE TO GET THE GREATEST COMMON DIVISOR
; OF ALL THE SUBSCRIPTS
RETSZL: LDB TC,DA.USG
PUSH PP,TA ;SAVE TA
XCT SUBSIZ(TC) ;GET FIRST SIZE IN TE
POP PP,TA ;RESTORE TA
PUSH PP,TE ;SAVE SIZE ON STACK
SOJLE TB,RETSZB ;JUMP IF ALL DONE NOW
LDB TA,DA.OCH ;BACK UP ONE LEVEL
PUSHJ PP,LNKSET
JRST RETSZL ;LOOP
RETSZB: POP PP,TA ;GET 1ST SUBSCRIPT SIZE
MOVE TD,SUBNUM ;TD:= # SUBSCRIPTS LEFT
SOJ TD,
RETSZE: POP PP,TC ;NEXT ONE
CAMLE TA,TC
EXCH TA,TC
RETSZC: IDIVI TC,(TA)
JUMPE TB,RETSZD ;ANSWER = TA
MOVE TC,TA
MOVE TA,TB
JRST RETSZC
RETSZD: SOJG TD,RETSZE ;LOOP FOR ALL REMAINING SUBSCRIPTS
MOVEM TA,S1SIZ## ;RETURN GCD
JRST SUBS10 ;RESTORE PARAMS & RETURN
RETSZ1: LDB TC,DA.USG
XCT SUBSIZ(TC) ;GET SIZE IN TE
MOVEM TE,S1SIZ## ;RETURN SIZE
JRST SUBS10 ;RESTORE PARAMS & RETURN
;ROUTINE TO GENERATE:
; SKIPLE AC,SUBSCRIPT.VALUE
; CAILE AC,OCCURS.VALUE
; PUSHJ PP,SUBE1##
;
;OR;
; MOVE AC,SUBSCRIPT.VALUE
SILG00: SKIPN TA,SUBITM## ;GET SUBSCRIPT INFO
POPJ PP, ;?ERROR HAPPENED, DON'T DO ANYTHING
HLRZ TB,SUBFLG
TRNE TB,1B18 ;SKIP IF A VALUE
JRST SILGA0 ;NO, A VARIABLE
;SUBSCRIPT VALUE IS A LITERAL - SET SIMULATED AC THEN RETURN
SETOM SSMACF## ;SIMULATE RUN-TIME AC VALUE
HLRZM TA,SSMACV## ;STORE INITIAL VALUE
; IF DEBUGGING, STORE SUBSCRIPT VALUE
SKIPN SUBPBL ;SKIP IF DEBUGGING..
POPJ PP, ;NO, JUST RETURN
MOVE CH,[MOVEI.+ASINC,,AS.CNB] ;ASSUME A LARGE CONSTANT
PUSHJ PP,PUT.XA
MOVE CH,SSMACF
PUSHJ PP,PUTASN ;WRITE VALUE
SILGA7: MOVE CH,[MOVEM.+ASINC,,AS.MSC]
PUSHJ PP,PUT.XA ;START INSTRUCTION..
HRRZ CH,SUBPBL ;GET %PARAM START
HRRZ TE,SUBNUM ;TOTAL # SUBSCRIPTS
SUB TE,SUBNM1 ; - THIS #
ADD CH,TE ;GET %PARAM OFFSET TO USE
PJRST PUTASN ;FINISH INSTRUCTION, AND RETURN
;STILL IN SILG00 ROUTINE
SILGA0: SETZM SSMACF## ;NOT SIMULATING AC
TRNE TB,1B21 ;IF SUBSC. IN LINKAGE SECTION
JRST SILGA2 ;INDIRECTING REQUIRED
MOVE TA,(TC) ;
TXNN TA,GNEVSB ;EVALUATES SUBSCRIPTS HAVE BEEN CHECKED
SKIPE QUIKSW## ;/Q TYPED?
JRST SILGA1 ;YES, DON'T GENERATE ERROR CHECK
MOVSI CH,SKPLE.
PUSHJ PP,PUT.AA ;SKIPLE SUBSCRIPT.VALUE
SILGA5: MOVE CH,[CAILE.+ASINC,,AS.CNB]
PUSHJ PP,PUT.XA
HRRZ CH,ESMAX
PUSHJ PP,PUTASN ;CAILE AC,OCCURS.VALUE
MOVEI CH,SUBE1.##
PUSHJ PP,PUT.PJ ;'PUSHJ PP,SUBE1.##"
JRST SILGA6 ;GO SEE IF DEBUGGING THE ITEM
;GENERATE "MOVE AC,SUBSCRIPT.VALUE" (NO ERROR CHECK)
SILGA1: MOVSI CH,MOV
PUSHJ PP,PUT.AA ;GEN THE MOVE
JRST SILGA6 ;GO SEE IF DEBUGGING
;STILL IN SILG00 ROUTINE
;STILL IN SILG00 ROUTINE
;HERE TO GENERATE INDIRECTING
; MOVE AC,SUBSC.ADDR.
; MOVE AC,(AC) OR SKIPLE AC,(AC)
;EBASEA POINTS TO THE COMP SUBSCRIPT
SILGA2: MOVE CH,[MOV+ASINC,,AS.MSC]
PUSHJ PP,PUT.XA
HLRZ CH,SUBITM ;POINT TO %PARAM+N
PUSHJ PP,PUTASN
;CODE GENERATED HAS PUT ADDRESS OF SUBSCRIPT INTO EAC
MOVE TA,(TC) ;
TXNN TA,GNEVSB ;EVALUATES SUBSCRIPTS HAVE BEEN CHECKED
SKIPE QUIKSW## ;/Q?
JRST SILGA3 ;YES, GEN "MOVE AC,EBASEA(AC)"
;GENERATE "SKIPLE AC,EBASEA(AC)"
HRRZ CH,EAC
IORI CH,SKPLE.
HRLZ CH,CH
HRR CH,EBASEA ;[671] GENERATES OFFSET INTO %PARAM BLOCK
PUSHJ PP,PUT.XA
JRST SILGA5 ;THEN DO ERROR CHECK
;GENERATE "MOVE AC,EBASEA(AC)" THEN RETURN
SILGA3: HRRZ CH,EAC
IORI CH,MOV
HRLZ CH,CH
HRR CH,EBASEA ;[671] OFFSET INTO %PARAM BLOCK
PUSHJ PP,PUT.XA
;CHECK FOR DEBUGGING ITEM.. IF SO, GENERATE A STORE OF THE SUBSC. VALUE
SILGA6: SKIPN SUBPBL ;SKIP IF DEBUGGING THE ITEM
POPJ PP, ;NO, JUST RETURN
JRST SILGA7 ;GENERATE THE "MOVEM" FROM AC
;ROUTINE TO GENERATE;
; SUBI AC,1
SILG01: SKIPE SSMACF## ;SIMULATING RUN-TIME AC?
JRST SIMSL1 ;YES, DON'T GENERATE INSTRUCTIONS
MOVSI CH,SUBI.
AOJA CH,PUT.XA ;SUBI AC,1
SIMSL1: SOS SSMACV## ;SIMULATE "SUBI AC,1"
POPJ PP, ;AND RETURN
;ROUTINE TO GENERATE:
; ADD AC,AC+1
SILG03: MOVE CH,[AD+ASINC,,AS.CNB]
PUSHJ PP,PUT.XA
HRRZ CH,EAC
AOJA CH,PUTASN ;AC+1
;ROUTINE TO GENERATE "IMULI AC,<SIZE>" OR "LSH"
GENIML: PUSHJ PP,SIZTE ;GET SIZE OF ITEM IN TE
GENIM1: SKIPE SSMACF## ;SIMULATING AC?
JRST SIMSL2 ;YES, PUT OUT MOVEI
CAIN TE,1 ;IF SIZE IS 1 NO NEED FOR INSTRUCTION
POPJ PP, ; . .
;USE LSH IF TE CONTAINS A MULTIPLE OF 2
JFFO TE,.+2 ;FIND FIRST 1 BIT
JRST E$SIZ ;?TE WAS ZERO???
HRRZ TC,TE ;COPY NUMBER TO TC
LSH TC,1(TD) ;SHIFT FIRST BIT OUT OF NUMBER
JUMPN TC,USEIML ; IF THERE WERE MORE, # WAS NOT AN
;EVEN MULTIPLE OF 2 - USE "IMULI"
;# IN TE IS AN EVEN MULTIPLE OF 2
;TD CONTAINS THE # OF 0'S TO THE LEFT OF IT
MOVEI TE,^D35
SUB TE,TD ;TE= # TO LSH
PUSHJ PP,PUTASA ;USE "LSH", IN ALTERNATE CODE SET
SKIPA CH,[LSH.+ASINC,,AS.CNB]
USEIML: MOVE CH,[IMULI.+ASINC,,AS.CNB] ;USE "IMULI"
PUSH PP,TE ;SAVE #
PUSHJ PP,PUT.XA
POP PP,CH
PJRST PUTASN
;
;HERE TO SIMULATE IMULI (AND ACTUALLY PUT OUT "MOVEI")
SIMSL2: IMUL TE,SSMACV##
MOVEM TE,SSMACV##
PJRST GENMVI ;GO GENERATE THE "MOVEI" AND RETURN
;ROUTINE TO GENERATE:
; SKIPLE AC+1,DEPENDING.VARIABLE
; CAILE AC,(AC+1)
; PUSHJ PP,SUBE3.##
; CAILE AC+1,OCCURS.VALUE
; PUSHJ PP,SUBE2.##
SILG02: SKIPN TA,DEPITM## ;SKIP IF ANY
POPJ PP, ;NO, RETURN
SKIPE SSMACF## ;WERE WE SIMULATING AC?
PUSHJ PP,GENMVI ;YES, GET VALUE INTO RUNTIME AC
HLRZ TB,SUBFLG
TRNE TB,1B20 ;IN LINKAGE SECTION?
JRST SILGB2 ;YES, INDIRECTING REQUIRED
;GENERATE "SKIPLE AC+1,DEPENDING VARIABLE"
HRLI CH,SKPLE.
HRR CH,DEPITM
PUSHJ PP,PUT.XB ;AC+1
HLRZ CH,DEPITM
SKIPE CH ;ANY INCREMENT?
PUSHJ PP,PUTASN ;YES
;GENERATE "CAILE AC,(AC+1)"
SILGB1: MOVE TE,EAC
ADDI TE,1 ;AC+1
IORI TE,CAILE.
HRLZ CH,TE ;CAILE (AC+1)
PUSHJ PP,PUT.XA
;GENERATE "PUSHJ PP,SUBE3."
MOVEI CH,SUBE3.##
PUSHJ PP,PUT.PJ
;GENERATE CODE TO MAKE SURE DEPENDING VARIABLE VALUE IS
; .LE. AMOUNT OF OCCURS
MOVE CH,[CAILE.+ASINC,,AS.CNB]
PUSHJ PP,PUT.XB ;AC+1
HRRZ CH,ESMAX
PUSHJ PP,PUTASN
;PUT OUT "PUSHJ PP,SUBE2.##"
MOVEI CH,SUBE2.##
PJRST PUT.PJ ;THEN RETURN
;STILL IN SILG02 ROUTINE
;STILL IN SILG02 ROUTINE
;HERE TO GEN INDIRECTING FOR DEPENDING VARIABLE
;PUT OUT "MOVE AC+1,<PARAM ADDRESS>"
SILGB2: MOVE CH,[MOV+ASINC,,AS.MSC]
PUSHJ PP,PUT.XB ;"MOVE AC+1,DEP.VAR.ADDR"
HLRZ CH,DEPITM
SKIPE CH ;PUT OUT INCREMENT IF ANY
PUSHJ PP,PUTASN
;"SKIPLE AC+1,(AC+1)"
HRRZ CH,EAC
ADDI CH,1
IORI CH,SKPLE.
HRLZ CH,CH
PUSHJ PP,PUT.XB
JRST SILGB1 ;THEN GO BACK TO GEN "CAILE.."
;ROUTINE TO GENERATE:
; ADJBP AC,CURRENT LITERAL
; [ADD AC,OFFSET] ;FOR ITEM IN LINKAGE SECTION
; TLNE AC,760000 ;RAN OUT OF BYTES IN WORD?
; JRST .+3 ;NO
; TLZ AC,770000 ;YES, CLEAR BIT 10000 IF SET
; ADD AC,[440000,,1] ;POINT TO NEXT WORD
;OR;
; IDIVI AC,BYTES/WORD
; ADD AC,CURRENT LITERAL
; [ADD AC,OFFSET] ;FOR ITEM IN LINKAGE SECTION
; JUMPE AC+1,.+3
; IBP AC
; SOJG AC+1,.-1
SILG04: SKIPN USENBT## ;USING LARGE BYTES?
JRST HAVLTR ;NO, LITERAL WAS GENERATED AT SILGO
MOVE TD,NBYTES## ;GET # BYTES/BYTE
CAIE TD,4
CAIN TD,6 ;4 OR 6 MEANS 36-BIT BYTES
CAIA
JRST HAVLTR ;ELSE WE GENERATED A LITERAL AT SILGO
;HERE WHEN FULL WORD BYTES ARE USED. ROUTINES IN IFGEN OR MOVGEN
;WILL ONLY CARE ABOUT THE ADDRESS, NOT THE WHOLE BYTE POINTER.;
; GENERATE "ADDI AC,BASE.ADDR"
PUSHJ PP,SILG06 ;GENERATE THE ADDI USING "BASITM"
JRST SILG4C
;HERE WHEN LITERAL WAS GENERATED AT SILGO
HAVLTR: SKIPN ELNKSF## ;ITEM IN LINKAGE SECTION?
JRST SILG4B ;NO
;WE MUST GENERATE THE FOLLOWING TWO WORDS IN THIS CASE BECAUSE
; IF THE ITEM IS IN THE LINKAGE SECTION, THE BYTE POINTER MAY BE
; POINT 7,0 OR POINT 6,0, IN WHICH CASE THE ADJBP WILL DO THE
; WRONG THING IF ADJUSTING 0 BYTES.
;GEN "CAIN AC,0"
MOVSI CH,CAIN.
PUSHJ PP,PUT.XA
;GEN "SKIPA AC,<CURRENT LITERAL>"
MOVSI CH,SKIPA.
PUSHJ PP,PUT.LC ;FAKE ADJBP OF 0 BYTES
SILG4B: PUSHJ PP,PUTASA ;ALTERNATE CODE SET
MOVSI CH,ADJBP.
PUSHJ PP,PUT.LC ;"ADJBP AC,CURRENT.LITERAL"
SKIPN PLITPC ;UNLESS WE POOLED IT..
AOS ELITPC ; COUNT THE LITERAL
SILG4C: SKIPE ELNKSF## ;LINKAGE SECTION ARG?
PUSHJ PP,SILG07 ;YES, ADD OFFSET
SKIPE IBPFLG## ;WILL BYTE PTR BE INCREMENTED?
POPJ PP, ;YES, NO NEED FOR THE FOLLOWING
;GEN "TLNE AC,760000"
MOVE CH,[TLNE.+ASINC,,AS.CNB]
PUSHJ PP,PUT.XA
MOVEI CH,760000
PUSHJ PP,PUTASN
;GEN "JRST .+3"
MOVE CH,[JRST.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVEI CH,AS.DOT+3
PUSHJ PP,PUTASN
;GEN "TLZ AC,770000"
MOVE CH,[TLZ.+ASINC,,AS.CNB]
PUSHJ PP,PUT.XA
MOVEI CH,770000
PUSHJ PP,PUTASN
;GEN "ADD AC,[440000,,1]
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
MOVE TA,[XWD 440000,AS.CNB]
PUSHJ PP,STASHQ ;LEFT HALF
MOVE TA,[XWD 1,AS.CNB]
PUSHJ PP,POOLIT ;RIGHT HALF
PJRST GENADL ;GEN "ADD AC,CURR.LIT" THEN RETURN
;ROUTINE TO GEN "ADD AC,CURRENT.LITERAL"
; THEN BUMP LITERAL PC
GENADL: MOVSI CH,AD
PUSHJ PP,PUT.LC
SKIPN PLITPC
AOS ELITPC
POPJ PP,
CHKIML==GENIML ;NO IDIVI IF BIS
;ROUTINE TO GEN CODE TO PUT SUBCON IN BITS 6-17 OF RESULT
;THIS ROUTINE MUST BE CALLED RIGHT AFTER SILG04 IS CALLED
SILG05: MOVE TE,SSMODE## ;GET MODE
MOVE TD,[EXP 600
EXP 700
EXP 1100](TE) ; GET DEFAULT SUBCON
CAMN TD,SUBCON## ;IS IT ALREADY SETUP RIGHT?
POPJ PP, ;YES, NO NEED FOR DPB
DPBSUB: MOVE CH,SUBCON
CAILE CH,77777 ;SMALL CONST.
SKIPA CH,[HRRZI.+ASINC,,AS.CNB]
HRLI CH,HRRZI. ;YES, PRINT AS OCTAL
PUSHJ PP,PUT.XB
MOVE CH,SUBCON
CAILE CH,77777 ;DO WE NEED TO OUTPUT CONST.
PUSHJ PP,PUTASN ;YES
;PUT THE BYTE POINTER IN THE LITERAL TABLE
SILG5A: MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
MOVE TA,EAC ;ADDRESS PORTION
PUSHJ PP,STASHQ
MOVSI TA,(POINT 12,,17)
PUSHJ PP,POOLIT ;REST OF IT
;NOW DPB AC+1,<CURRENT LITERAL>
MOVSI CH,DPB.
HRRZ TE,EAC
ADDI TE,1
DPB TE,CHAC
PUSHJ PP,PUT.LD
SKIPN PLITPC ;SKIP IF WE POOLED IT
AOS ELITPC ;REMEMBER WE MADE A LITERAL
POPJ PP,
;ROUTINE TO GEN "ADDI AC,BASITM" (BASE ITEM WAS COMP)
SILG06: MOVSI CH,ADDI.
SILG6A: HRR CH,BASITM##
HLRZ TE,BASITM## ;INCREMENT
JUMPE TE,PUT.XA ;NONE
TLO CH,ASINC
PUSHJ PP,PUT.XA
HLRZ CH,BASITM## ;GET INCREMENT
PJRST PUTASN
;ROUTINE TO GET THE SIZE OF ITEM IN TE
SIZTE: HRRZ TA,CURDAT
LDB TC,DA.USG
XCT SUBSIZ(TC)
SKIPE USENBT## ;USE LARGER BYTES?
IDIV TE,NBYTES## ; YES
MOVE TC,SSMODE## ;GET MODE OF LOWEST LEVEL
CAIG TC,DSMODE ;DISPLAY?
POPJ PP, ;YES, KEEP BYTES
MOVE TB,ESAVMD## ;NO, GET WORDS
CAILE TB,DSMODE ;[606] THIS DISPLAY?
JRST SIZTE1 ;[606] NO, DIVIDE BY 6
IDIV TE,BYTE.W(TB)
POPJ PP,
SIZTE1: IDIVI TE,6 ;[606] DEFAULT TO 6 BYTES/WORD, THIS GIVES
POPJ PP, ;[606] US # OF WORDS
;ROUTINE TO GENERATE "MOVEI AC,<SIMULATED AC VALUE>
GENMVI: SETZM SSMACF## ;CLEAR FLAG
HRRZ CH,SSMACV ;GET CONST
CAILE CH,77777 ;SMALL?
SKIPA CH,[MOVEI.+ASINC,,AS.CNB]
HRLI CH,MOVEI. ;YES
PUSHJ PP,PUT.XA
HRRZ CH,SSMACV##
CAILE CH,77777 ;DO WE NEED TO OUTPUT IT?
PJRST PUTASN ;YES
POPJ PP,
;ROUTINE TO GENERATE CODE TO ADD EXTERNAL LINKAGE OFFSET
;
SILG07: MOVE TA,HLDEOP## ;DUMMY INDEX LOC.
MOVE TA,1(TA)
PUSHJ PP,LNKFA## ;GET GRANDFATHER'S TABLE ADDRESS
MOVEM TA,HLDBRO## ;[1300] INITIALIZE TEMP BROTHER POINTER TO SELF
LDB TB,DA.RBE## ;REFERENCED BY AN ENTRY OR PD USING?
JUMPN TB,SILG7A ;[1300] YES, REF'D BY ENTRY OR PD USING
PUSH PP,TA ;[1300] SAVE POINTER TO CURRENT ITEM
SILG7D: LDB TA,DA.BRO## ;[1300] SEE IF IT HAS A BROTHER
JUMPE TA,SILG7E ;[1300] NO, GIVE UP
PUSHJ PP,LNKSET ;[1300] POINT TO IT
LDB TB,DA.RDF## ;[1300] IS IT A REDEFINES
JUMPE TB,SILG7D ;[1300] NO, TRY NEXT
LDB TB,DA.ARG ;[1300] IS ITS INDEX LOC SET UP?
JUMPE TB,SILG7D ;[1300] NO, TRY TO GET NEXT BROTHER
MOVEM TA,HLDBRO ;[1300] YES, PUT IN TEMP BROTHER PTR
POP PP,TA ;[1300] RESTORE PTR TO ORIGINAL ITEM
;[1300] AND CONTINUE ON TO GENERATE INSTR
SILG7A: MOVE CH,[AD+ASINC,,AS.MSC]
PUSHJ PP,PUT.XA ;"ADD AC,"
;[1300] HERE WE USE THE TEMP BROTHER PTR TO SEE IF INDEX LOC IS SET UP
EXCH TA,HLDBRO ;[1300] SAVE PTR TO CURRENT ITEM
;[1300] GET PTR TO BROTHER (OR MAYBE SELF)
;[1300] THEN WE GET ITS INDEX LOC. IF THIS IS SET UP WE USE IT TO GENERATE
;[1300] THE SECOND OPERAND FOR THE INSTRUCTION. IF IT IS NOT SET UP WE
;[1300] FALL THRU THE CODE AND PUT A 0 IN FOR THE SECOND OPERAND.
LDB TB,DA.ARG## ;WHERE IS THE ARG?
EXCH TA,HLDBRO ;[1300] RESTORE PTR TO CURRENT ITEM
JUMPN TB,SILG7B ;THERE IT IS!
MOVE TB,EAS1PC ;NOT SET UP, HAVE TO GET ONE
AOS EAS1PC
DPB TB,DA.ARG
PUSHJ PP,PUTOC0## ;OCTAL 0 TO AS1FIL
SILG7B: IORI TB,AS.PAR ;%PARAM+N
HRRZ CH,TB
PJRST PUTASN ;"%PARAM+N" , THEN RETURN
SILG7E: POP PP,TA ;[1300] NO VALID BRO, SO RESTORE ORIG PTR
;[1300] AND FALL THRU TO REPORT ERROR.
SILG7C: HRRZI DW,E.401 ;?NOT DECLARED BY ENTRY OR PD USING
PUSHJ PP,OPNFAT
JRST SILG7A
;INTERNAL COMPILER ERRORS
DEFINE $ERRF(MSG),<
JSP TA,E$$INT
XLIST
ASCIZ /MSG/
LIST
>
E$$INT:
IFE TOPS20,<
OUTSTR [ASCIZ/?Internal compiler error in CMNGEN - /]
OUTSTR (TA) ;TYPE EXPLANATION
OUTSTR [ASCIZ/
/]
>
IFN TOPS20,<
PUSH PP,T1
HRROI T1,[ASCIZ/?Internal compiler error in CMNGEN - /]
PSOUT%
HRRO T1,(TA) ;TYPE EXPLANATION
PSOUT%
HRROI T1,[ASCIZ/
/]
PSOUT%
POP PP,T1
>
JRST KILL## ;AND GO TAKE A DUMP
E$WNS: $ERRF <wrong number of subscripts>
E$UND: $ERRF <usage not DISPLAY>
E$UNZ: $ERRF <USENBT not zero at GETNB>
E$SIZ: LDB TE,DA.EXS ;IF SIZE IS ZERO
JUMPE TE,CPOPJ ;THEN ITS AN ERROR IN PHASE C
$ERRF <SIZTE returned 0>
E$IBP: $ERRF <B1PAR with IBPFLG not zero>
E$BAC: $ERRF <DEPVB not positive at DPBDEP>
E$DLT: $ERRF <DPBDEP trying to deposit into a literal>
;SCAN THRU SUBSCRIPTS LOOKING FOR OBVIOUS ERRORS.
;IF ALL ARE LITERALS--RETURN TO CALL+1.
;IF ANY NON-LITERALS--RETURN TO CALL+2.
EXMSUB: SWOFF FERROR!FSDAT ;CLEAR SOME FLAGS
SKIPE ELNKSF ;LINKAGE SECTION REFERENCE
SWON FSDAT ;YES, FORCE NON-CONSTANT SUBSCRIPT ACTION
SETZM SUBNUM## ;# OF SUBSCRIPTS SEEN
SETZM ENOCC1
SKIPN ENOCC2
JRST EXMS9L ;LINKAGE SECTION ITEM WITH NO SUBSCRIPTS
EXMS1: MOVEI TC,2 ;LOOK AT NEXT SUBSCRIPT
ADDB TC,CUREOP
MOVEI LN,EBASEA ;SET UP "A" PARAMETERS
PUSHJ PP,SETOPN
TSWF FERROR ; [***] ANY ERRORS?
JRST EXMS9 ; [***] YES, GIVE UP
TSWT FASUB ;[251] IS SUBSCRIPT SUBSCRIPTED?
JRST EXMS1A ; [***] NO
LDB TE,DA.SUB ; [***] IS IT REALLY SUBSCRIPTED?
JUMPN TE,NOTSUB ; [***] YES, ILLEGAL
LDB TE,DA.LKS ; [***] IS IT IN LINKAGE SECTION
JUMPE TE,NOTSUB ; [***] NO, GIVE UP
SWOFF FASUB ; [***] YES, TREAT AS NOT SUBSCRIPTED
MOVE TE,CUREOP ; MAKE SURE IT'S A COMP ITEM
MOVE TE,1(TE) ;WITH NO ADDITIVE
TLNE TE,BSUBSC
JRST BADLS2 ;(ADDITIVE)
HRRZ TE,EMODEA ; ELSE WE WOULD HAVE TO CALL
CAIE TE,D1MODE ; THE SUBSCRIPT ROUTINE AGAIN!
JRST BADLS1
EXMS1A: TSWT FANUM ; [***] IS IT NUMERIC?
JRST BADSB1 ;NO -- ERROR
HRRZ TE,EMODEA ;IS IT A LITERAL?
CAIN TE,LTMODE
JRST EXMS9 ;YES -- NO WORK NEEDED NOW
SWON FSDAT ;NO -- SET FLAG
HRRZ TE,EBASEA ;TALLY?
CAIN TE,AS.MSC ; SUBSCRIPT IN TEMP LOCATION?
JRST [MOVE TE,CUREOP ;YES, WE'VE BEEN HERE BEFORE
MOVE TE,1(TE) ; SEE IF ADDITIVE FOLLOWS
TLNN TE,BSUBSC
JRST EXMS9 ;IT DOESN'T, ALL IS OK
MOVEI TC,2
ADDM TC,CUREOP ;ADDITIVE FOLLOWS, SO SKIP IT
AOS ENOCC1 ;BUMP OPERAND COUNT
JRST EXMS9] ;AND COUNT THE SUBSCRIPT
;[661] BETTER ERROR CHECKING FOR ILLEGAL SUBSCRIPTS
SKIPE TE,EDPLA ;ANY DECIMAL PLACES?
JRST BADSB4 ;[661] YES -- ERROR
HRRZ TE,EMODEA ;[661] DISALLOW COMP-1
CAIE TE,FPMODE ;[661] FLOATING POINT?
CAIN TE,F2MODE
JRST BADSB4 ;[661] YES, COMPLAIN
MOVE TE,CUREOP ;DOES THIS
MOVE TE,1(TE) ; SUBSCRIPT HAVE
TLNE TE,BSUBSC ; ADDITIVE?
JRST EXMS2 ;YES--TEMP NEEDED
SKIPE ALSTMP## ;SHOULD WE PUT ALL SUBSCRIPTS IN %TEMP?
JRST EXMS2 ;YES, GO DO SO EVEN IF IT IS COMP
HRRZ TE,EMODEA ;1-WORD COMP?
CAIN TE,D1MODE
JRST EXMS9 ;YES -- NO WORK NEEDED NOW
;PUT SUBSCRIPT INTO TEMP; EITHER BECAUSE IT IS NOT COMP, OR
; BECAUSE IT HAS AN ADDITIVE.
EXMS2: MOVE TE,EMODEA ;SAVE THE MODE.
MOVEM TE,SSU.MD##
MOVEI TE,1 ;GET A TEMPORARY LOCATION
PUSHJ PP,GETEMP
MOVEI TE,0(EACC)
TLO TE,GNOPNM
MOVEM TE,0(TC)
MOVSI TD,GNNOTD
MOVE TE,ESIZEA
DPB TE,ACSIZE
MOVEI TE,D1MODE
DPB TE,ACMODE
MOVE TE,1(TC)
TLNE TE,ASUBSC
TLO TD,ASUBSC
TLNE TE,SSUBSC
TLO TD,SSUBSC
MOVEM TD,1(TC)
PUSH PP,ESIZEZ
PUSH PP,SUBCON
PUSH PP,EAC ;SAVE CURRENT SETTING OF AC'S
PUSH PP,CUREOP ;SAVE CURRENT CUREOP
MOVEI TE,4 ;SET AC'S
MOVEM TE,EAC ; TO 4&5
PUSH PP,IBPFLG##
SETZM IBPFLG##
PUSH PP,SUSEAC## ;SAVE VALUE OF SUSEAC
PUSHJ PP,MXAC. ;GET OPERAND INTO AC'S
POP PP,SUSEAC## ;RESTORE SUSEAC
POP PP,IBPFLG## ;SET IBPFLG AGAIN IF IT WAS
HRRZ TC,CUREOP ;DOES SUBSCRIPT
MOVE TE,1(TC) ; HAVE
TLNN TE,BSUBSC ; ADDITIVE?
JRST EXMS8 ;NO
AOS ENOCC1 ;YES--BUMP COUNT ONCE
ADDI TC,2 ;STEP TO NEXT OPERAND
MOVEM TC,CUREOP
MOVEI LN,EBASEB ;GET ADDITIVE AS
PUSHJ PP,SETOPN ; 'B' OPERAND
TSWF FERROR ;IF ERROR,
JRST EXMS8 ; FORGET IT
PUSHJ PP,CONVNL ;CONVERT LITERAL
SKIPE EDPLB ;IF DECIMAL PLACES,
JRST BADSB8 ; ERROR
MOVSI CH,AD ;ASSUME 'ADD'
MOVE TE,CUREOP ;IS
MOVE TE,-1(TE) ; IT
TLNN TE,ASUBSC ; REALLY 'ADD'?
MOVSI CH,SUB. ;NO--MUST BE SUBTRACT
PUSHJ PP,PUT.LA ;GENERATE <ADD/SUB LITERAL>
;PUT SUBSCRIPT IN TEMP (CONT'D)
EXMS8: POP PP,TC ;GET CUREOP BACK
MOVE TD,1(TC)
LDB TE,ACMODE
MOVEM TE,EMODEB
LDB TE,ACSIZE
MOVEM TE,ESIZEB
SETZM EDPLB
MOVE TE,[XWD ^D36,AS.MSC]
MOVEM TE,EBASEB
MOVE TE,0(TC)
HRRZM TE,EINCRB
SWON FBSIGN
PUSH PP,SW ;[525] SAVE SWITCHES
SWOFF FALWY0 ;[525] TURN OFF AC'S = 0
PUSHJ PP,MACX. ;STASH OPERAND INTO TEMP
POP PP,SW ;[525] GET SWITCHES BACK
EXMS8A: POP PP,EAC ;RESET AC'S
POP PP,SUBCON
POP PP,ESIZEZ
EXMS9: AOS SUBNUM## ;COUNT SUBSCRIPTS
AOS TE,ENOCC1 ;BUMP COUNT
CAMGE TE,ENOCC2 ;DONE?
JRST EXMS1 ;NO--LOOP
;MAKE SURE WE GOT THE CORRECT NUMBER OF SUBSCRIPTS
TSWF FERROR ;ANY ERRORS?
JRST EXMS9B ;YES--SKIP RETURN
MOVE TA,ESAVOP ;POINT TO BASE ITEM
MOVEM TA,CUREOP ;[660] MAKE ERROR MESSAGE POINT TO BASE ITEM
MOVE TA,1(TA)
PUSHJ PP,LNKSET
LDB TE,DA.OCC
JUMPN TE,EXMS9C
LDB TE,DA.SUB ;[1476] DOES THIS ITEM NEED A SUBSCRIPT?
JUMPE TE,NOTSUB ;[1476] NO, SO THERE IS NO DA.OCH ENTRY
LDB TA,DA.OCH ;
JUMPE TA,NOTSUB ;[1123] IF NO SUBSCR AT ALL IN DATAB WE HAVE
;[1123] AN ERROR, DON'T TRY TO FIND ITS LINK
PUSHJ PP,LNKSET ;
EXMS9C: MOVE TB,SUBNUM ;NUMBER OF SUBSCRIPTS WE SAW
EXMS9F: SOJL TB,EXMS9D ;NO MORE SUBSCRIPTS
LDB TA,DA.OCH
JUMPE TA,EXMS9E ;NO MORE LEVELS
PUSHJ PP,LNKSET
JRST EXMS9F
EXMS9E: SOJL TB,EXMS9A ;SUBSCRIPTS RAN OUT ALSO--OK
EXMS9D: MOVEI DW,E.250 ;?WRONG NUMBER OF SUBSCRIPTS
AOS (PP)
JRST OPNFAT ;FATAL RETURN
;HERE IF WE SAW LINKAGE SECTION ITEM WITH NO SUBSCRIPTS
; MAKE SURE IT DOESN'T NEED SUBSCRIPTS
EXMS9L: MOVE TA,ESAVOP
MOVE TA,1(TA)
PUSHJ PP,LNKSET
LDB TE,DA.SUB ;IT IS SUPPOSED TO BE SUBSCRIPTED?
JUMPN TE,EXMS9G ;NEEDS A SUBSCRIPT - COMPLAIN
;DIDN'T NEED ANY SUBSCRIPTS - OK
; FALL INTO EXMS9A
EXMS9A: TSWT FERROR ;YES--ANY ERRORS?
TSWF FSDAT ;NO--ANY NON-LITERALS?
EXMS9B: AOS (PP) ;YES--EXIT TO CALL+2
POPJ PP,
EXMS9G: MOVEI DW,E.274 ;?MUST BE SUBSCRIPTED
AOS (PP)
JRST OPNFAT ;GIVE ERROR, AND SKIP RETURN
NOTSUB: SWON FERROR ;[251] TURN ON ERROR SWITCH
JRST EXMS9 ;[251] GO ON TO NEXT SUBSCRIPT
; TEST FOR DEPENDENCY AT LOWER LEVEL
;SKIP IF EITHER "A" OR "B" HAS A DEPENDING ITEM
DEPCKK: PUSHJ PP,DEPTSA ;DOES "A"?
CAIA ;NO
JRST CPOPJ1 ;YES--SKIP
PUSHJ PP,DEPTSB ;DOES "B"?
POPJ PP, ;NO
JRST CPOPJ1 ;YES--SKIP
;SKIP IF "A" HAS A DEPENDING ITEM
DEPTSA: HRRZ TA,ETABLA ;GET "A"
TRNA
DEPTSB: HRRZ TA,ETABLB ;GET "B"
LDB TC,[POINT 3,TA,20]
CAIE TC,CD.DAT ;MAKE SURE ITS A DATAB ENTRY
POPJ PP, ;NO
PUSHJ PP,LNKSET
LDB TC,DA.DLL## ;IS THERE A DEPENDING ITEM?
JUMPN TC,CPOPJ1 ;YES
POPJ PP,
;ROUTINE TO SETUP AC = SIZE OF VARIABLE, WHERE VARIABLE HAS A DEPENDING ITEM
;CALLED BY:
; MOVEI TE,WHICH AC TO USE (0-16)
; SAVPR0/ 0 (NORMAL CASE) OR -1 (%PARAM+0 MUST BE PRESERVED)
; PUSHJ PP,SZDPVA (OR SZDPVB)
; <RETURN HERE IF NO DEPENDING VARIABLE OR ERRORS, DEPVB/ -1, FERROR SET>
; <RETURN HERE IF SIZE SETUP IN AC SPECIFIED, DEPVB / RUNTIME AC USED>
; ALL RUNTIME AC'S MAY BE SMASHED!!
SZDPVA: MOVEI LN,EBASEA ;REMEMBER WE'RE DOING 'A'
HRRZ TA,ETABLA
JRST GTABDP
SZDPVB: MOVEI LN,EBASEB ;REMEMBER WE'RE DOING 'B'
HRRZ TA,ETABLB
GTABDP: MOVEM TE,DEPVB## ;SAVE RUNTIME AC TO USE
PUSHJ PP,LNKSET ;LOOK AT ITEM
LDB TB,DA.SON ;FIND THE DEPENDING ITEM
GTSONA: PUSHJ PP,FNDBRO ; THIS CODE COPIED FROM OTHER MOVGEN CODE
SKIPA TA,TB ;FOUND LAST BROTHER
JRST GTSONA ;NO, LOOP
PUSHJ PP,LNKSET
LDB TB,DA.NOC ;[1073] IS THERE AN OCCURS CLAUSE?
JUMPE TB,GTSNA1 ;[1073] NO, THIS ISN'T THE DEPENDING ITEM
LDB TB,DA.DEP ;IS THIS THE DEPENDING VARIABLE?
JUMPN TB,GTSONB ; YES-- GO DO IT
GTSNA1: LDB TB,DA.SON ;[1073] LOOK AT ELEMENTARY ITEM
JUMPN TB,GTSONA ;THIS ISN'T IT, GO DOWN DEEPER
JRST QITDPV ;?ERROR--SHOULD HAVE FOUND DEPENDING ITEM!
GTSONB: LDB CH,DA.DCR ;CONVERSION NECESSARY?
JUMPE CH,GTBDP1 ;NO, COMP ALREADY
;CONVERSION ROUTINE MAY POTENTIALLY SMASH ALL AC'S. IF WE HAVE ONE
; TO PRESERVE, MUST MOVE IT TO %TEMP AND MOVE IT BACK AFTER CONVERSION!!
SKIPN SAVPR0## ;MUST SAVE %PARAM+0?
JRST NOSV0 ;NO
PUSH PP,TA ;SAVE DA.* POINTER
PUSHJ PP,PUTASA
MOVE CH,[PUSH.+AC17,,AS.MSC]
PUSHJ PP,PUTASY
MOVEI CH,AS.PAR
PUSHJ PP,PUTASN
POP PP,TA
NOSV0: SKIPN CONVSV## ;AC TO PRESERVE?
JRST NOPRES ;NO
PUSH PP,TA ;SAVE DA.* POINTER
PUSHJ PP,PUTASA
MOVSI CH,PUSH.+AC17
HRR CH,CONVSV ;SAVE THIS AC
PUSHJ PP,PUTASY
POP PP,TA ;RESTORE ACS SAVED
LDB CH,DA.DCR ;CONVERSION TAG
NOPRES: IORI CH,AS.TAG
HRLI CH,EPJPP
PUSHJ PP,PUTASY
PUSH PP,TA
LDB TA,DA.DCR ;GET CONVERSION TAG
PUSHJ PP,REFTAG## ;REFERENCE IT
SKIPN CONVSV ;DID WE SAVE AN AC?
JRST NORSTR ;NO, DON'T "POP" ANY THEN
PUSHJ PP,PUTASA
MOVSI CH,POP.+AC17
HRR CH,CONVSV ;GET SAVED AC
PUSHJ PP,PUTASY ;"POP 17,AC"
NORSTR: POP PP,TA ;GET DA.* BASE
SKIPA TB,[ASINC,,AS.MSC] ;NOW IT'S IN %PARAM
GTBDP1: LDB TB,DA.DEP## ;MAKE SURE WE ARE LOOKING AT A DEPENDING ITEM
JUMPE TB,QITDPV ;? NO, GIVE UP
LDB TE,DA.USG ;[1633] GET USAGE
CAIGE TE,%US.C1 ;[1633] SEE IF WE HAVE COMP-1
JRST GTBDPA ;[1633] NO
PUSH PP,TA ;[1633] SAVE CURRENT DATAB ENTRY
PUSH PP,TE ;[1633] SAVE USAGE
LDB TA,DA.BRO ;[1633] GET DATAB ENTRY FOR FATHER
PUSHJ PP,LNKSET ;[1633] GET OFFSET
LDB CH,DA.USG ;[1633] GET USAGE OF FATHER
MOVE CH,BYTE.W-1(CH) ;[1633] GET #BYTES/ITEM = INTERNAL SIZE
POP PP,TE ;[1633] RESTORE USAGE
CAIN TE,%US.C2 ;[1633] SEE IF WE HAVE COMP-2
LSH CH,1 ;[1633] YES - MULTIPLY SIZE BY 2
POP PP,TA ;[1633] RESTORE DATAB ENTRY
SKIPA ;[1633]
GTBDPA: LDB CH,DA.INS ;[1633] GET SIZE
LDB TE,DA.NOC ; # OF OCCURANCES
IMUL CH,TE ;TOTAL SIZE
MOVEM CH,DPVAR
MOVEM TA,DPLNK
MOVEM TB,DPITM
MOVE CH,TB ;PUT ITEM IN CH
TLNN CH,-1 ;IN %PARAM?
JRST GTBDP2 ;NO, A REGULAR COMP ITEM
HRRZ TE,DEPVB ;GET AC
LSH TE,5 ; SHIFT TO AC POSITION
TLO CH,SKPLE.
TLO CH,(TE) ;FINISH INSTRUCTION
PUSHJ PP,PUTASY
MOVEI CH,AS.PAR
PUSHJ PP,PUTASN ;SKIPLE AC,%PARAM
SKIPN SAVPR0## ;SAVED %PARAM+0?
JRST GTBDP3 ;NO, GO GENERATE "CAILE.."
;RESTORE (POP FROM STACK) %PARAM+0
PUSHJ PP,PUTASA
MOVE CH,[POP.+AC17,,AS.MSC]
PUSHJ PP,PUTASY
MOVEI CH,AS.PAR
PUSHJ PP,PUTASN
JRST GTBDP3 ;GO GENERATE "CAILE.."
GTBDP2: PUSH PP,CUREOP ;SAVE CUREOP
SKIPE TE,CUROPP ;HAVE AN OVER-RIDING POINTER TO AN OPERAND?
JRST GTBDP5 ;YES, USE THAT FOR ERRORS
HRRZ TE,OPERND ;MAKE "CUREOP" POINT TO "B"
CAIN LN,EBASEA
HLRZ TE,OPERND ; (NO, "A")..
GTBDP5: MOVEM TE,CUREOP ; (INCASE ERRORS)
PUSHJ PP,CHKLNK ;LOOK AT ITEM IN "CH" -- IN LINKAGE SECTION?
JRST GTBDP4 ;NO, NORMAL CASE
POP PP,CUREOP ;RESTORE CUREOP
PUSH PP,CH ;SAVE ITEM
MOVE CH,[MOV+ASINC,,AS.MSC]
HRRZ TE,DEPVB ;GET AC AGAIN
LSH TE,5
TLO CH,(TE) ;FINISH INSTRUCTION
PUSHJ PP,PUTASY
POP PP,CH
PUSHJ PP,PUTASN ;MOVE AC,ADDRESS.OF.A
MOVEI CH,SKPLE.
TRO CH,(TE)
ADD CH,DEPVB ;SKIPLE AC,(AC)
HRLZ CH,CH
PUSHJ PP,PUTASY
JRST GTBDP3 ;GO GENERATE "CAILE.."
GTBDP4: POP PP,CUREOP ;RESTORE CUREOP
HRLI CH,SKPLE. ;NORMAL COMP ITEM..
HRRZ TE,DEPVB ;GET AC AGAIN
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"SKIPLE AC,DEPENDING VARIABLE"
;HERE TO DO UPPER BOUND TEST
;SKIPLE AC, DEPENDING.VARIABLE JUST PUT OUT
; NOW GENERATE:
;CAILE AC,UPPER.BOUND.FOR.DEPENDING.VARIABLE
GTBDP3: SETZM SAVPR0## ;CLEAR FLAG
MOVE TA,DPLNK
LDB CH,DA.NOC ;NUMBER OF OCCURANCES
HRLI CH,CAILE.
HRRZ TE,DEPVB
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"CAILE AC,NUMBER.OF.OCCURANCES"
MOVEI CH,SUBE2.##
PUSHJ PP,PUT.PJ ;"PUSHJ PP,SUBE2." - DEPENDING VARIABLE
;OUT OF RANGE
LDB TE,DA.USG ;[1633] GET USAGE
CAIGE TE,%US.C1 ;[1633] SEE IF WE HAVE COMP-1
JRST GTBDPB ;[1633] NO
PUSH PP,TA ;[1633] SAVE CURRENT DATAB ENTRY
PUSH PP,TE ;[1633] SAVE USAGE
LDB TA,DA.BRO ;[1633] GET DATAB ENTRY FOR FATHER
PUSHJ PP,LNKSET ;[1633] GET OFFSET
LDB CH,DA.USG ;[1633] GET USAGE OF FATHER
MOVE CH,BYTE.W-1(CH) ;[1633] GET #BYTES/ITEM = INTERNAL SIZE
POP PP,TE ;[1633] RESTORE USAGE
CAIN TE,%US.C2 ;[1633] SEE IF WE HAVE COMP-2
LSH CH,1 ;[1633] YES - MULTIPLY SIZE BY 2
POP PP,TA ;[1633] RESTORE DATAB ENTRY
SKIPA ;[1633]
GTBDPB: LDB CH,DA.INS ;[1633] SIZE OF EACH ITEM
CAIG CH,1 ;IF 1, DON'T DO IMULI
JRST NOIMLI
HRLI CH,IMULI.
HRRZ TE,DEPVB
LSH TE,5
TLO CH,(TE)
PUSHJ PP,PUTASY ;"IMULI AC,SIZE"
NOIMLI: HRRZ TA,ETABLB
CAIN LN,EBASEA
HRRZ TA,ETABLA
PUSHJ PP,LNKSET
LDB CH,DA.INS ;TOTAL SIZE
MOVE TB,DPVAR ;DEPENDING SIZE
SUB CH,TB ;CH=SIZE OF FIXED PART
JUMPLE CH,CPOPJ1 ;NO FIXED PART... DONE
HRLI CH,ADDI.
HRRZ TE,DEPVB
LSH TE,5
TLO CH,(TE)
AOS (PP) ;SKIP RETURN
PJRST PUTASY ;"ADDI AC,SIZE.OF.FIXED.PART"
QITDPV: SETOM DEPVB ;SET DEPVB TO -1 TO INDICATE ERROR
SETZM SAVPR0## ;CLEAR FLAG
SWON FERROR ;SET "ERROR" BIT
POPJ PP,
;ROUTINE TO SKIP IF ITEM IN CH IS IN LINKAGE SECTION
; IF IT IS, MAKE CH POINT TO %PARAM+N (THE ADDRESS OF THE ARG ADDRESS)
CHKLNK: HRRZ TA,CH
PUSHJ PP,LNKSET
LDB TE,DA.LKS
JUMPE TE,CPOPJ ;SKIP IF IN LINKAGE SECTION
LDB TE,DA.RBE ;MAKE SURE THERE IS AN ARG FOR IT
JUMPE TE,CHKLN1 ;? NO, FATAL ERROR
LDB CH,DA.ARG
IORI CH,AS.PAR
JRST CPOPJ1 ;RETURN, CH POINTS TO %PARAM+N
CHKLN1: PUSH PP,CH ;WE WILL RETURN JUST ADDRESS OF THE GUY
PUSH PP,LN ;[1107] Save value of "LN"
MOVEI DW,E.597 ;? HAS A DEPENDING VARIABLE NOT REFERENCED
; IN AN ENTRY OR PD USING CLAUSE.
PUSHJ PP,OPNFAT ;GIVE ERROR
POP PP,LN ;[1107] Restore "LN"
POP PP,CH ;THIS WILL ASSEMBLE WITHOUT ERRORS
POPJ PP,
;ROUTINE TO GENERATE A "DPB DEPVB,[PARAMETER WORD]"
; CALLED TO PUT THE ACTUAL SIZE OF THE ITEM INTO THE PARAMETER
; WORD FOR A LIBOL ROUTINE.
;CALL:
; DEPVB/ RUNTIME AC WHICH CONTAINS THE SIZE OF THE ITEM
; EACC/ WHERE THE PARAMETER IS
; EITHER C(EACC) = AN AC (0-17), OR
; LH (EACC) = AS.MSC, RH (EACC) = AS.TMP+N OR AS.PAR+N
; PUSHJ PP,DPBDEP
; <RETURN HERE, ALL ACS CLOBBERED>
DPBDEP: SKIPG DEPVB ;BETTER BE A RUNTIME AC AND NOT ZERO!
JRST E$BAC ;? BAD AC SPECIFIED
TLNN EACC,-1 ;FIRST CHECK TO MAKE SURE
JRST DPBDP1 ; WE CAN DPB TO THIS PLACE
HRRZ TE,EACC
TRC TE,AS.LIT ;NOT INTO A LITERAL!
TRNN TE,700000 ; SKIP IF NOT A LITERAL
JRST E$DLT ;? DEPOSIT INTO A LITERAL
DPBDP1: PUSH PP,EACC ;SAVE LOC TO DPB INTO
MOVE TA,[BYTLIT,,2]
PUSHJ PP,STASHP ;MAKING A BYTE PTR TO THE PLACE
HLRZ TA,(PP) ;ASSUME AS.MSC FOR ADDRESS
SKIPN TA ;IS IT?
HRRZ TA,(PP) ;NO, JUST AN AC
PUSHJ PP,STASHQ
POP PP,EACC ;GET EACC BACK INCASE IT WAS SMASHED
MOVSI TA,(POINT 12,0,17) ;WHERE THE PARAMETER IS
TLNE EACC,-1
HRR TA,EACC ;AS.MSC, GET INCREMENT
PUSHJ PP,POOLIT
HRRZ CH,DEPVB ;RUNTIME AC
LSH CH,5 ;SHIFT TO AC POSITION
IORI CH,DPB.
HRLZ CH,CH ;GET LH OF INSTRUCTION
PUSHJ PP,PUT.LD ; USE CURRENT LITERAL
SKIPN PLITPC
AOS ELITPC ;UPDATE LITERAL PC
POPJ PP, ;RETURN, ALL DONE
;DEBUG MODULE ROUTINES
GDEBV: SKIPN GDEBSW## ;SEE IF ITS WORTH LOOKING AT DEBTAB
JRST GDEBV4 ;NO, BUT CLEAN UP
PUSH PP,TA ;JUST IN CASE
HRRZ TA,DEBLOC ;GET BASE
HRRZ TE,DEBNXT ;GET END
SUB TE,TA
IFE SZ.DEB-2,<
LSH TE,-1 ;SAVES WORRYING ABOUT TE+1
>
IFN SZ.DEB-2,<
PUSH PP,TE+1
IDIVI TE,SZ.DEB
POP PP,TE+1
>
MOVN TE,TE
HRL TA,TE ;FORM AOBJN POINTER
ADDI TA,1 ;BYPASS FIRST WORD
GDEBV1: LDB TE,DB.IDP## ;NEED TO GENERATE CODE FOR THIS ONE?
JUMPE TE,GDEBV2 ;NO
SETZ TE,
DPB TE,DB.IDP ;YES, BUT ONLY ONCE
PUSHJ PP,GDEBV4 ;CLEAN UP JUNK
MOVEI CH,DBDA.##
PUSHJ PP,PUT.PJ ;PUSHJ 17,DBDA.
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTASN
LDB CH,DB.LN## ;LINE NUMBER
PUSHJ PP,PUTASN
LDB CH,DB.DAT## ;GET DATAB LINK
ANDI CH,077777 ;INDEX ONLY
PUSHJ PP,PUTASY
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTASN
LDB CH,DB.PRM ;GET 0, OR BASE OF SUBSCRIPTS
HRLZ CH,CH ;PUT PARAM OFSET IN LHS
SKIPE CH
HRRI CH,AS.MSC ;MAKE IT %PARAM+N
PUSHJ PP,PUTASN
PUSH PP,TA ;SAVE DATAB LINK
LDB TA,DB.DUP ;GET USER ROUTINE LINK
ADD TA,USELOC
LDB CH,US.PRO ;GET ACTUAL TAG
PUSHJ PP,PUTASY
POP PP,TA
GDEBV2: ADDI TA,SZ.DEB-1 ;NEXT
AOBJN TA,GDEBV1 ;LOOP OVER ALL OF DEBTAB
GDEBV3: POP PP,TA
GDEBV4: SETZM EDEBDA ;MAKE SURE NO JUNK LEFT AROUND
SETZM EDEBDB
SETZM GDEBSW
POPJ PP,
GDEBAB: PUSHJ PP,GDEBA ;GENERATE CODE FOR "A"
GDEBB: SKIPG EDEBDB ;ANYTHING TO DO
JRST [SETZM EDEBDB ;NO, BUT SET TO ZERO
POPJ PP,] ;AND RETURN
PUSHJ PP,GDEBC ;PUT OUT COMMON CODE
PUSH PP,EDEBGB ;SAVE USE PROCEDURE TO GO TO
HRRZ CH,EDEBDB ;GET BASE
SETZM EDEBDB ;ONLY DO IT ONCE
JRST GDEBG ;OUTPUT USE PROCEDURE
GDEBA: SKIPG EDEBDA ;ANYTHING TO DO
JRST [SETZM EDEBDA ;NO, BUT SET TO ZERO
POPJ PP,] ;AND RETURN
PUSHJ PP,GDEBC ;PUT OUT COMMON CODE
PUSH PP,EDEBGA ;SAVE USE PROCEDURE TO GO TO
HRRZ CH,EDEBDA ;GET BASE
SETZM EDEBDA ;ONLY DO IT ONCE
GDEBG: ANDI CH,077777 ;INDEX ONLY
PUSHJ PP,PUTASY
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTASN
HLLZ CH,0(PP) ;GET 0, OR BASE OF SUBSCRIPTS
SKIPE CH
HRRI CH,AS.MSC ;MAKE IT %PARAM+N
PUSHJ PP,PUTASN
POP PP,CH ;GET ADDRESS BACK
HRRZS CH
JRST PUTASY
GDEBC: MOVEI CH,DBDA.##
PUSHJ PP,PUT.PJ ;PUSHJ 17,DBDA.
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTASN
LDB CH,[POINT 13,OPLINE,28] ;LINE #
JRST PUTASN
;ROUTINE TO FIND DEBTAB ENTRY
;CALLED WITH TD = DATAB
;RETURNS WITH
; EDEBDX(LN) = DATAB POINTER OR ZERO
; EDEBPX(LN) = DEBTAB ,, PARAM BASE
; EDEBGX(LN) = PARAM BASE OR ZERO ,, USE PROCEDURE
TSTARO: PUSH PP,TA
HRRZ TA,DEBLOC## ;GET BASE
HRRZ TE,DEBNXT## ;GET END
SUB TE,TA
IFE SZ.DEB-2,<
LSH TE,-1 ;SAVES WORRYING ABOUT TE+1
>
IFN SZ.DEB-2,<
PUSH PP,TE+1
IDIVI TE,SZ.DEB
POP PP,TE+1
>
MOVN TE,TE
HRL TA,TE ;FORM AOBJN POINTER
ADDI TA,1 ;BYPASS FIRST WORD
TSARO1: LDB TE,DB.DAT## ;GET DATAB LINK
CAMN TE,TD ;ONE WE WANT?
JRST TSARO2 ;YES
ADDI TA,SZ.DEB-1 ;NO
AOBJN TA,TSARO1 ;LOOP UNTIL WE FIND IT
HALT ;ERROR
TSARO2: PUSH PP,LN
CAIE LN,EBASEA ;CHANGE LN TO POINT TO DEBUG DATA
SKIPA LN,[EXP EDEBDB]
MOVEI LN,EDEBDA
LDB TE,DB.IDP## ;ALREADY GENERATED DEBUG INFO?
SKIPE TE
SETZM EDEBDX(LN) ;YES, DON'T DO IT TWICE
HRRZ TE,DEBLOC
HRRZ TD,TA
SUB TD,TE ;GET OFFSET INTO DEBTAB
HRLZM TD,EDEBPX(LN)
LDB TE,DB.ARO##
LDB TD,DB.PRM## ;GET BASE OF PARAMS OR ZERO (IF NOT SUBSCRIPTED)
HRRM TD,EDEBPX##(LN)
HRLM TD,EDEBGX(LN) ;AND FOR CODE GENERATION
LDB TA,DB.DUP## ;GET USE ROUTINE
ADD TA,USELOC## ;ADD IN BASE
LDB TD,US.PRO##
IOR TE,EDEBGX##(LN) ;BIT 35 WILL BE ON IF WE EANT TO DEBUG
HRRM TD,EDEBGX(LN) ;STORE %PARAM,,<USE-PROCEDURE>
TRNN TE,1 ;EITHER USER SET -1 OR DA.ARO WAS ON
SETZM EDEBDX##(LN) ;NO, SO DON'T WANT IT
POP PP,LN
POP PP,TA
POPJ PP,
CDEBAB: PUSHJ PP,CDEBB ;DO IT FOR "B"
CDEBA: SKIPG EDEBDA ;ANYTHING TO DO
JRST [SETZM EDEBDA ;NO, BUT SET TO ZERO
POPJ PP,] ;AND RETURN
PUSH PP,TA
HLRZ TA,EDEBPA ;GET DEBTAB OFFSET
SETZM EDEBDA
JRST CDEBC ;COMMON CODE
CDEBB: SKIPG EDEBDB ;ANYTHING TO DO
JRST [SETZM EDEBDB ;NO, BUT SET TO ZERO
POPJ PP,] ;AND RETURN
PUSH PP,TA
HLRZ TA,EDEBPB ;GET DEBTAB OFFSET
SETZM EDEBDB
CDEBC: ADD TA,DEBLOC ;ADD IN BASE
LDB TE,[POINT 13,OPLINE,28]
DPB TE,DB.LN## ;SAVE LINE NUMBER IN CASE IT CHANGES
SETO TE,
DPB TE,DB.IDP ;SIGNAL WE NEED IT
POP PP,TA
AOS GDEBSW ;SO WE WILL SEARCH DEBTAB AT GDEBV
POPJ PP,
;IMPROPER "ALL"
BADALL::MOVEI DW,E.273 ;[621] CALLED FROM MOVGEN
JRST BADLIT
;LITERAL HAS ZERO SIZE
LNOSIZ: MOVEI DW,E.183
JRST BADLIT
;BAD CHARACTER FOR NUMERIC LITERAL
BADLK: MOVEI DW,E.211
JRST BADLIT
;LITERAL IS BEING MOVED TO ALPHANUMERIC FIELD, AND HAS DECIMAL PLACES
BADDP: MOVEI DW,E.96
JRST BADLIT
;LITERAL IS TOO LARGE TO BE NUMERIC
TOOBIG: MOVEI DW,E.56
BADLIT: SWON FERROR;
CAIN LN,EBASEB
SKIPA TC,OPERND
MOVS TC,OPERND
MOVE TC,0(TC)
LDB LN,TCLN
LDB CP,TCCP
JRST FATAL
;"ROUNDED" CLAUSE SEEN, BUT NO NEED FOR ROUNDING.
NOROUN: MOVEI DW,E.218
JRST OPNWRN
;"SIZE ERROR" SEEN, BUT A SIZE ERROR CAN'T HAPPEN.
NOSERA: MOVEI DW,E.217
MOVE W1,OPLINE
JRST OPWRN
;COMMON ERROR ROUTINES
;PUT OUT A FATAL DIAG AT OPERAND
OPNFAT: SWON FERROR;
MOVE TC,CUREOP
MOVE TC,0(TC)
LDB CP,TCCP
LDB LN,TCLN
JRST FATAL
;PUT OUT A FATAL DIAG AT OPERATOR
OPFAT: SWON FERROR;
LDB CP,W1CP
LDB LN,W1LN
JRST FATAL
;PUT OUT A WARNING DIAG AT OPERAND
OPNWRN: MOVE TC,CUREOP
MOVE TC,(TC)
LDB CP,TCCP
LDB LN,TCLN
JRST WARN
;PUT OUT A WARNING DIAG AT OPERATOR
OPWRN: LDB CP,W1CP
LDB LN,W1LN
JRST WARN
;OPERAND IS NOT NUMERIC
NOTNUM: MOVEI DW,E.211
JRST OPNFAT
;WRONG NUMBER OF OPERANDS
BADEOP: SKIPE COUNTF## ;[1631]Suppress this if we've had already had
POPJ PP, ;[1631] a fatal error
MOVEI DW,E.214
JRST OPFAT
;NOT A DATA-NAME
NOTDAT: MOVEI DW,E.101
JRST OPNFAT
;COMMON ERROR ROUTINES (CONT'D)
;ERROR DETECTED DURING "SETOPN"
OPERA: SWON FERROR;
PUSH PP,LN
LDB CP,TBCP
LDB LN,TBLN
PUSHJ PP,FATAL
POP PP,LN
POPJ PP,
;ITEM NOT DEFINED
NOTDEF: MOVEI DW,E.104
JRST OPNFAT
;IF FIPS FLAGGER REQUESTED FOR NUCLEUS 2 FEATURES
INTERN TST.N2
TST.N2: SKIPN FLGSW## ;ARE WE CHECKING FIPS LEVEL?
POPJ PP, ;NO
MOVE TC,CUREOP ;POSSIBLE ERROR
MOVE TC,0(TC) ;SETUP TO POINT TO "B"
LDB CP,TCCP ;LOAD UP LN & CP
LDB LN,TCLN
PUSH PP,TA ;ACC TO CONTAIN THE LEVEL FLAG
MOVEI TA,%LV.HI ;GET FLAG LEVEL OF HIGH-INTERMEDIATE
ANDCM TA,FLGSW ;CLEAR THE BITS WE ALLOW
SKIPE TA ;IS THIS WITHIN LIMITS?
PUSHJ PP,FLG.ES## ;NO
POP PP,TA
POPJ PP,
;TABLE OF ONE-WORD POWERS OF 10
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 TWO-WORD POWERS OF 10
DPWR10: OCT 0
DEC 1 ;0
OCT 0
DEC 10 ;1
OCT 0
DEC 100 ;2
OCT 0
DEC 1000 ;3
OCT 0
DEC 10000 ;4
OCT 0
DEC 100000 ;5
OCT 0
DEC 1000000 ;6
OCT 0
DEC 10000000 ;7
OCT 0
DEC 100000000 ;8
OCT 0
DEC 1000000000 ;9
OCT 0
DEC 10000000000 ;10
OCT 2 ;11
OCT 351035564000
OCT 35 ;12
OCT 032451210000
OCT 443 ;13
OCT 011634520000
OCT 5536 ;14
OCT 142036440000
OCT 70657 ;15
OCT 324461500000
OCT 1070336 ;16
OCT 115760200000
OCT 13064257 ;17
OCT 013542400000
OCT 157013326 ;18
OCT 164731000000
OCT 2126162140 ;19
OCT 221172000000
OCT 25536165705 ;20
OCT 254304000000
OCT 330656232670 ;21
OCT 273650000000
;TABLE OF ROUNDING VALUES
ROUNDR: ^D5
^D50
^D500
^D5000
^D50000
^D500000
^D5000000
^D50000000
^D500000000
^D5000000000
;SOME CONSTANTS
CHAC: POINT 4,CH,12 ;AC-FIELD IN "CH"
CHOP: POINT 7,CH,8 ;OP-CODE FIELD IN "CH"
TCLN: POINT 13,TC,28 ;LINE NUMBER FIELD
TCCP: POINT 7,TC,35 ;CHARACTER POSITION FIELD
TBLN: POINT 13,TB,28
TBCP: POINT 7,TB,35
W1LN: POINT 13,W1,28 ;LINE-NUMBER FIELD
W1CP: POINT 7,W1,35 ;CHARACTER-POSITION FIELD
TASUBC: POINT 6,TA,17
TESUBC: POINT 6,TE,17 ;SUBSCRIPT COUNT IN OPERAND
W2SUBC: POINT 6,W2,17 ;SUBSCRIPT COUNT IN W2
ACMODE: POINT 4,TD,3
ACSIZE: POINT 6,TD,17
BYTE.S: OCT 6 ;SIXBIT BYTE SIZE
OCT 7 ;ASCII BYTE SIZE
OCT 11 ;EBCDIC BYTE SIZE
NBYT.S::
OCT -6 ;SIXBIT (NEGATIVE)
OCT -7 ;ASCII (NEGATIVE)
OCT -11 ;EBCDIC (NEGATIVE)
OCT 11 ;COMP-3 BYTE SIZE.
BYTE.W: OCT 6 ;SIXBIT BYTES PER WORD
OCT 5 ;ASCII BYTES PER WORD
OCT 4 ;EBCDIC BYTES PER WORD
;'ADDITIVE SUBSCRIPT' BITS IN OPERAND
ASUBSC==1B29 ;ADD LITERAL TO SUBSCRIPT
SSUBSC==2B29 ;SUBTRACT LITERAL FROM SUBSCRIPT
BSUBSC==ASUBSC!SSUBSC
;DEFINITION OF ASYFIL OPERATOR CODES
DEFINE SETVAL (X,Y),<
X=Y'B26
INTERNAL X
>
DEFINE %OPCT%(A,B,C,D,E,F,G,H,I,J,K,L,M,N),<
SETVAL C,B ;MAKE AVAILABLE THE INTERNAL OPCODE
>
DEFINE %OPCU%(A,B,C,D,E,F,G,H,I,J,K,L,M,N),<
SETVAL C,B ;MAKE AVAILABLE THE INTERNAL OPCODE
>
;NOW INVOKE THE TABLE EXCERCISER
OPCTAB;
OPCTB2;
;DEFINITION OF UUO CALLS
DEFINE SETVAL (X,Y,Z),<
X=Y'B26+Z'B30
INTERNAL X
>
UUOWAC==172 ;FIRST UUO WHICH DOES NOT USE AC
;TO EXTEND THE OP CODE
SETVAL OPCLS.,172,0
SETVAL OPN,172,0
SETVAL OPEN.I,172,4;
SETVAL OPEN.O,172,10;
SETVAL CLOS,172,1;
SETVAL IO.,173,0
SETVAL DSPLY.,173,0;
SETVAL ACEPT.,173,1;
SETVAL READ,173,2;
SETVAL WRITE,173,3;
SETVAL WADV.,173,4;
SETVAL RDNXT.,173,5;
SETVAL DELETE,173,6;
SETVAL RERIT.,173,7;
SETVAL PURGE.,173,10;
SETVAL INITT,173,11;
SETVAL TERM,173,12;
SETVAL SORT,173,13; ;[1652]ADD SORT TO THIS LIST
SETVAL DSPL.6,173,14;
SETVAL DSPL.7,173,15;
;SETVAL COMP,174,0
;SETVAL CMP.76,174,1
;SETVAL SPAC.6,174,2
;SETVAL NUM.6,174,3
;SETVAL ALF.6,174,4
;SETVAL ZERO.6,174,5
;SETVAL POS.6,174,6
;SETVAL NEG.6,174,7
;SETVAL SPAC.7,174,10
;SETVAL NUM.7,174,11
;SETVAL ALF.7,174,12
;SETVAL ZERO.7,174,13
;SETVAL POS.7,174,14
;SETVAL NEG.7,174,15
;SETVAL COMP.D,174,16
;UUO CALLS (CONT'D).
SETVAL C.DD,175,0;
SETVAL C.D6D7,175,1;
SETVAL C.D7D6,175,2;
SETVAL CMP.,175,2 ;BASE OF CMP.X UUO'S
; CMP.E=3,CMP.G=4,CMP.GE=5,CMP.L=6,CMP.LE=7,CMP.N=10
SETVAL EDIT.S,176,0
SETVAL EDIT.U,176,1
SETVAL INSP.,176,2
;SETVAL SUBSC.,176,3;
;SETVAL SIZE.1,176,4
SETVAL SIZE.2,176,5
SETVAL SIZE.3,176,6
SETVAL E.C3C1,176,7;
SETVAL E.C3C3,176,10;
SETVAL OVLAY.,176,11;
SETVAL XIT,176,12
SETVAL ARGS.,176,13 ;ROUTINE TO PICK UP ARGS AT ENTRY
;SETVAL PUTF.,176,14 ;PUT FIXED ITEMS INTO LIBIMP
;SETVAL RESF.,176,15 ;RESTORE CALLER'S FIXED ITEMS
;176,16 IS USED BY COBDDT
;SETVAL ILLC.,176,17 ;KILL RECURSIVE CALL ERROR
;MORE UUO CALLS
DEFINE SETVAL (X,Y),<
X=Y'B26
INTERNAL X
>
;140 NOT USED
;141 NOT USED
FSTUUO==142 ;FIRST UUO CODE
UUOMSK==140000 ;MASK TO CHECK FOR UUO IN PUTASY
SETVAL FIX.,142;
;143 RESERVED FOR COMP.D
SETVAL PERF.,144;
;SETVAL FLOT.1,145; ;NOT USED ANY MORE
SETVAL FLOT.2,146;
SETVAL PD6.,147;
SETVAL PD7.,150;
SETVAL GD6.,151;
SETVAL GD7.,152;
REPEAT 0,< ;NOT USED ANY MORE
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
>
;DEFINITION OF MODES
SETVAL D6MODE,0 ;SIXBIT
SETVAL D7MODE,1 ;ASCII
SETVAL D9MODE,2 ;EBCDIC
SETVAL DSMODE,2 ;HIGHEST MODE FOR DISPLAY
SETVAL D1MODE,3 ;1-WORD DECIMAL
SETVAL D2MODE,4 ;2-WORD DECIMAL
SETVAL FPMODE,5 ;FLOATING POINT
SETVAL IXMODE,6 ;INDEX
SETVAL C3MODE,6 ;COMP-3 (INDEX GETS CHANGED TO D1MODE)
SETVAL EDMODE,7 ;EDITED
SETVAL LTMODE,10 ;LITERAL
SETVAL FCMODE,11 ;FIG. CONST.
SETVAL D4MODE,12 ;4-WORD DECIMAL (TEMP DURING D2 OPERATIONS)
SETVAL F2MODE,13 ;D.P. FLOATING POINT (COMP-2)
SETVAL IMMODE,14 ;IMMEDIATE (ADDRESS IS VALUE)
SETVAL ZERO,2 ;EFLAG VALUE FOR "ZERO"
SETVAL CORR,1B<^D18+^D12> ;"CORRESPONDING" FLAG IN OPERATOR
SETVAL INVKEY,1B29 ;"INVALID KEY" FLAG IN SPIF OPERATOR
SETVAL ATEND,1B27 ;"AT END" FLAG IN SPIF OPERATOR
SETVAL OVERFL,1B31 ;"ON OVERFLOW" FLAG IN SPIF
SETVAL ATINVK,INVKEY!ATEND!OVERFL
SETVAL ATEOP,1B<^D18+^D15> ;"AT END OF PAGE" FLAG IN SPIF OPERATOR
SETVAL ATPINV,ATINVK!ATEOP
SETVAL FLOBIT,1B20 ;BIT IN 2ND WORD OF OPERAND TO DENOTE "FLOTAB"
SETVAL SPIF.,23 ;OPERATOR CODE FOR SPIF
SETVAL NOOP.,106 ;OPERATOR CODE FOR NOOP (USED IN READ)
;MISCELLANEOUS CONSTANTS
SETVAL EPJPP,PUSHJ.+AC17 ;"PUSHJ 17,"
SETVAL JOV.,JFCL.+AC10 ;"JOV"
SETVAL JFOV.,JFCL.+AC1 ;[1110] "JFOV"
SETVAL MAXSIZ,^D20 ;LARGEST ALLOWED NUMERIC ITEM
SETVAL MXPSZ.,3770 ;LARGEST SIZE WE CAN FIT IN A PARAMETER.
; (AND STILL BE DIVISIBLE BY 4,5,6)
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 CONSTANT
SETVAL FLTLIT,7 ;LITAB CODE FOR FLOATING-POINT CONSTANT
SETVAL OCTLIT,10 ;LITAB CODE FOR OCTAL CONSTANT
SETVAL EBCLIT,11 ;LITAB CODE FOR EBCDIC CONSTANT
SETVAL XTNLIT,12 ;LITAB CODE FOR EXTEND [OPCODE]
SETVAL F2LIT,13 ;LITAB CODE FOR D.P. FLOATING POINT CONSTANT
SETVAL MAXLIT,13 ;MAXIMUM LITAB CODE
;TABLE OF LITAB CODES FOR DISPLAY LITERALS.
D.LTCD::
EXP SIXLIT ;SIXBIT.
EXP ASCLIT ;ASCII.
EXP EBCLIT ;EBCDIC.
INTERNAL MOVSAC
MOVSAC: XWD MOVEM.+SAC+ASINC,AS.MSC ;FIRST HALF OF INSTRUCTION TO STASH AC12
SETVAL SYNBIT,1B<^D18+6> ;SIGN FLAG IN PARAMETERS
END