Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/ifgen.mac
There are 22 other files named ifgen.mac in the archive. Click here to see a list.
; UPD ID= 1955 on 2/1/89 at 2:39 PM by KSTEVENS
TITLE IFGEN FOR COBOL V13
SUBTTL CODE GENERATORS FOR ALL "IF" OPERATORS 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
%%P==:%%P
DBMS==:DBMS
IFN TOPS20,< SEARCH MONSYM,MACSYM>
IFE TOPS20,< SEARCH MACTEN,UUOSYM>
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
;EDITS
;NAME DATE COMMENTS
;KWS 01-Feb-89 [1651] Fix Code generation so that CMPxx always gen 3
;; words.
;MJC 30-OCT-85 [1612] Move COLSEQ check from IFDD43 to IFDD30.
;JSM 01-APR-83 [1457] IF SET-NAME SET generated literal has garbage.
;SMI 15-Sep-82 [1404] If LITTAB is expanded, update byte pointer to literal.
;JEH 22-Jul-82 [1374] Check collating sequence when generating HIGH-VALUES.
;JEH 5-May-82 [1353] If literal generated by call to LITD. is too large
; set FERROR to force exit.
;JEH 9-Apr-82 [1351] Store READ ... INTO operands in a fixed location to avoid link failures.
;WTK 23-Jul-81 [1317] Fix alphanumeric compare of greater than 2040 characters.
;V12B****************
;[1067] FIX COBOL-74 COMPARE NUMERIC TO NON-NUMERIC ITEMS
;[1060] FIX IF DATA-ITEM = ZEROES FOR FIELD GREATER THAN 2040 CHARACTERS
;[1057] GIVE ERROR ON ILLEGAL USE OF ALL IN NUMERIC COMPARISONS.
;[1040] FIX NON-BIS CASE OF EDIT 1034; "IF ..NOT SPACES" DIDN'T WORK
;[1037] FIX ?ASSEMBLY ERRORS WHEN DEP. VAR. ON "READ..INTO" AND COMP ITEM
;[1034] MAKE IF = ZERO TEST GENERATE INLINE CODE, FIXES LARGE RECORD PROBLEM.
;[1027] BUILD RECORD NAME TABLE IF NESTED READS
;[1004] MAKE ASCII & EBCDIC COLLATING SEQUENCES WORK.
;V12A****************
;[720] FIX COBOL-74 COMPARE TO SPACES WITH PROGRAM COLLATING SEQUENCE
;[717] FIX IF A NOT = SPACES FOR A ALPHANUMERIC AND LONGER THAN 2040 CHARACTERS
;[630] FIX EDIT 562 FOR NON-BIS CASE
;[611] FIX IF DBMS-STATEMENT TO GENERATE CORRECT CODE (THIS WAS IN BWR FILE)
;[605] STORE DEPENDING ITEM AFTER READ OF VARIABLE LENGTH RECORD
;V12*****************
;[600] ADJUST D.P. OF "A" IN ACCS IF LESS THAN D.P. OF "B"
;[562] FIX SIXBIT 6 CHAR FIG-CON COMPARE WHEN SIGN GETS IN THE WAY
;[550] FIX IF SUBSCRIPTED ITEM IS ALPHABETIC
;[547] FIX EXAMINE REPLACING HIGH-VALUES BY
;[544] FIX HIGH-VALUES COMPARES FOR SIXBIT VARIABLES
;[542] FIX NUMERIC COMPARE OF FIELD WITH DECIMAL PLACES WITH EXPRESSION
; WITH NO DECIMAL PLACES
;V10*****************
;[473] FIX COMPARE OF NON-NUMERICS OF UNEQUAL LENGTH
;[445] TEST FOR ERRORS AFTER RETURN FROM SETED
;[444] GIVE WARNING WHEN MAXIMUM COMPARE LENGTH FOR IF STATEMENT IS EXCEEDED
;[441] FOR NONNUMERIC TEST OF ZEROES OF FORM 'IF A OP ZERO' USE CHAR COMPARE
;[437] FIX DBMS IF STATEMENTS INCASE OF LITTAB TABLE OVERFLOWS
;********************
;[436] FIX DBMS IF STATEMENTS IN SEGMENTED SECTIONS
;[426] FIX ZERO TESTING.
;[413] HANDLE NEGATIVE EXPRESSIONS IN IF STATEMENTS
;[374] /JEC FLAG ERROR WHEN SIXBIT LITERAL HAS A NON-SIXBIT CHAR IN IT
;[372] /JEC MAKE SURE %PARAM IS PUT INTO AS1 FILE FOR DBMS IF STATEMENTS
;[322] FIX "IF CONDITION" SO THAT AN ERROR IN PREVIOUS STATMENT DOES NOT CAUSE A COMPILER ERROR MESSAGE
;[217] /ACK FIX FATAL DIAG PRODUCED IN A VALID PROGRAM.
;[174] FIXES D.P. COMPARES WITH ZERO FOR >, AND NOT <
;[170-A] FIXES EDIT 170
;[170] FIXES COMPARES OF NON-NUMERIC ITEMS OF FORM
; IF A(I) = B(J) OR IF A(I) = C; WHERE AN ITEM
; OF A IS SMALLER THAN B (OR C).
;[154] FIXES DOUBLE PRECISION COMPARES AND ALSO SIGN PROBLEMS.
ENTRY ENDIFG ;"ENDIF" OPERATOR
ENTRY SPIFGN ;"SPIF" OPERATOR
ENTRY IFCGEN ;"IFC" OPERATOR
ENTRY IFTGEN ;"IFT" OPERATOR
ENTRY IFGEN ;"IF" OPERATOR
ENTRY IFUGEN ;"IF" OPERATOR IN PERFORM VARYING UNTIL CASE
ENTRY ELSEGN ;"ELSE" OPERATOR
ENTRY IFGNZC ;ENTRY POINT FOR RPWGEN & SEARCH
ENTRY IFPOS ;ENTRY POINT FOR SEARCH
IFN DBMS,<ENTRY IFDBGN> ;"IFDB" OPERATOR
INTERN IFZROS ;VALUES OF ZERO CHARACTER IN SIXBIT, ASCII, AND EBCDIC
INTERN IFSPCS ;VALUE OF SPACE CHARACTER IN SIXBIT, ASCII, AND EBCDIC
EXTERNAL COMEBK,MOVGN.,PUTASN,PUTASY,SETOPN,B1PAR,B2PAR,SUBSCA
EXTERN STASHI,STASHL,STASHP,STASHQ,POOL,POOLIT,PLITPC
EXTERN MBYTPA,MBYTPB,CPOPJ1,CPOPJ
EXTERNAL LNKSET,GETTAG,KILLF,WARN,FATAL,PUTEMP,CCXFP.,CCXF2.,MSFP%L,MSF2%L,PUSEOP
EXTERNAL BMPEOP,PUTTAG,CONVNL,NEGATL,MAKEL,MAKEL2,MAKEL4,GETEMP
EXTERNAL FORCX0,MBYTEA,BADEOP,OPNFAT,JOUT,NOTNUM,NOTDAT
EXTERNAL PUT.A,PUT.AA,PUT.B,PUT.BA,PUT.L,PUT.LA,PUT.LB,PUT.LC,PUT.LD
EXTERNAL PUT.P,PUT.PA,PUT.PC,PUT.XA,PUT.XB
EXTERNAL M1CAC.,M2CAC.,MDAC.,CC1C2.,CCXFP.,ADJDP.,ADJSL.,ADJBL.,SWAPAB
EXTERNAL M.IA,M.IB,MXAC.,MXFPA.,LITD.,LITN.,LITN.A,SCANL
EXTERNAL FPLOV.
EXTERNAL SUBSCR,SUBSCA,SUBSCB,SUBSCC,SUBSCD
;"IF" GENERATOR
IFUGEN: SETOM INPERF## ;SIGNAL WE ARE IN PERFORM CONTROL
IFGEN:
MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;ANYTHING IN EOPTAB?
POPJ PP, ;NO--WE MUST HAVE HAD A YECCH
IFGENA: MOVE TC,OPLINE ;SAVE W1 (LN & CP) OF PREVIOUS OPERATOR
MOVEM TC,EXPLNC## ;FOR FIPS FLAGGER
MOVEM W1,OPLINE
PUSHJ PP,IFGENZ
IFDONE: HRRZ TC,EOPLOC ;RESET EACA SUCH THAT THERE IS ONE OPERAND
ADDI TC,1
MOVEM TC,CUREOP
PUSHJ PP,BMPEOP
JFCL
MOVE EACA,CUREOP
SUB EACA,EOPLOC
HRLS EACA
ADD EACA,EOPLOC
MOVEM EACA,EOPNXT
MOVE TC,CURXSQ ;COPY CURRENT SEQ #
MOVEM TC,LSTXSQ ;TO LAST FOR FIPS FLAGGER
JRST COMEBK
;"IFT" GENERATOR
IFTGEN: SETZM TAGTRU
MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;ANY OPERANDS?
POPJ PP, ;NO--MUST HAVE HAD A YECCH
MOVEM W1,OPLINE ;SAVE LN&CP OF OPERATOR
PUSHJ PP,IFTGNZ ;GENERATE CODE
JRST IFDONE ;GO HOME
IFTGNZ: SWOFF FEOFF1 ;TURN OFF MOST FLAGS
PUSHJ PP,MAK1OP ;INSURE THAT THERE IS ONLY ONE OPERAND
TSWF FERROR;
JRST BADEOP
MOVE TC,CUREOP
MOVSM TC,OPERND
MOVE TE,1(TC) ;IS OPERAND %TEMP OR AC'S?
TLNN TE,GNNOTD
JRST IFTGNY
HRRZ TE,0(TC) ;YES--IS IT AC'S?
CAIG TE,17
SWON FAINAC ;YES--SET FLAG
JRST IFTGNX
IFTGNY: LDB TE,[POINT 3,1(TC),20]
CAIE TE,TB.DAT
JRST NOTDAT ;NOT DATAB - ERROR
IFTGNX: MOVEI LN,EBASEA
PUSHJ PP,SETED
LDB TA,[POINT 3,W1,11] ;GET CODE
MOVE TA,IFTTAB(TA)
TLZ W1,CONCMP
TLO W1,EQUALF
TLON W1,GOFALS
TLC W1,NOTF
JRST @TA
IFTTAB: EXP BADIFT
EXP IFNUM
EXP IFALF
EXP IFPOS
EXP IFNEG
EXP IFZERO
EXP IFLCA ;LOWER-CASE ALPHABETIC
EXP IFUCA ;UPPER-CASE ALPHABETIC
;"IFC" GENERATOR
IFCGEN: MOVEM W1,OPLINE
MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;ANY OPERANDS?
JRST IFCSW7 ;NO--MUST BE "IF SWITCH"
SWOFF FEOFF1 ; [322] TURN OFF ALL ERROR INDICATORS
MOVE CH,[XWD 2,2] ;MAKE THIS LOOK LIKE EXPRESSION
PUSHJ PP,PUSEOP
SETZM TAGTRU
PUSHJ PP,MAK1OP
TSWF FERROR;
JRST BADEOP
LDB TE,[POINT 3,-1(EACA),20]
CAIN TE,TB.MNE
JRST IFCSW
TLON W1,GOFALS ;GO IF FALSE?
TLC W1,NOTF ;NO--COMPLEMENT "NOT"
TLNN W1,NOTF ;"NOT"?
JRST IFCGNF ;NO
HLRZM W2,ECTRUE ;YES--SET "TRUE" TAG
SETZM ECFALS ;CLEAR "FALSE" TAG
JRST IFCGNA
IFCGNF: HLRZM W2,ECFALS ;SET UP TAG FOR "FALSE"
SETZM ECTRUE
IFCGNA: SETZM ECXTRA ;TURN OFF "EXTRA TAG NEEDED"
TLZ W1,CONCMP ;CLEAR CONDITION FLAGS
MOVEM W1,OPLINE
MOVEI TC,ECNAME
MOVEM TC,OPERND
SWOFF FEOFF1 ;CLEAR MOST FLAGS
MOVE TC,EOPLOC ;CONVERT COND. NAME LINK TO TABLE ADDRESS
ADDI TC,1
MOVE TA,TC ;SET UP DUMMY "B"
TLZ TA,-4
TLO TA,1B18
MOVEM TA,ECNAME
MOVE TA,1(TC)
PUSHJ PP,LNKSET
MOVE TE,1(TA) ;GET LITERAL COUNT
HRRZM TE,CONCTR
SKIPN CONCTR ;ANY THERE?
POPJ PP, ;NO--MUST HAVE HAD TROUBLE--QUIT
HLRM TE,1(TC) ;RESET "A" TO BE DATA-NAME
MOVEM TC,CUREOP
ROT TE,3
ANDI TE,7
CAIE TE,TB.DAT
JRST NOTDAT
MOVEI TE,2(TA) ;CREATE A BYTE POINTER TO CONTAB ENTRIES
HRLI TE,442200
MOVEM TE,ECNBP
HRRZ CH,CUREOP ;GET PTR TO DATA OPERAND
HRRZ TA,1(CH)
PUSHJ PP,LNKSET
LDB TB,DA.LKS## ;IS IT IN LINKAGE SECTION?
SKIPE TB ;NO
MOVSI TB,(LKSFLG) ;YES, SET GENFIL FLAG
IORM TB,(CH)
;"IFC" GENERATOR (CONT'D).
;THIS IS THE START OF THE MAIN LOOP
IFCGN1: SWOFF FAINAC ;CLEAR "A IN AC'S" FLAG
HRRZ TC,EOPLOC
ADDI TC,1
MOVEM TC,CUREOP
HRLM TC,OPERND
MOVEI LN,EBASEA ;SET UP "A" PARAMETERS
PUSHJ PP,SETED
ILDB TA,ECNBP ;IS IT A RANGE?
TRNE TA,CRANGE
JRST IFCG10 ;YES
;"IFC" GENERATOR (CONT'D)
;NOT A RANGE
PUSHJ PP,SETUPB
MOVE W1,OPLINE
IBP ECNBP ;BUMP BYTE POINTER
SOSG CONCTR ;IS THIS THE LAST VALUE?
JRST IFCGN4 ;YES
TLZ W1,NOTF ;YES--SHUT OFF "NOT"
TLO W1,LESSF!GREATF ;SET "NOT EQUAL"
PUSHJ PP,GETTRU ;TRUE IF EQUAL
JRST IFCGN6
IFCGN4: TLZE W1,NOTF ;"NOT"?
JRST IFCGN5 ;YES
TLO W1,EQUALF ;SET "EQUAL"
PUSHJ PP,GETFLS ;FALSE IF NOT EQUAL
JRST IFCGN6
IFCGN5: TLO W1,LESSF!GREATF ;SET "NOT EQUAL"
PUSHJ PP,GETTRU ;TRUE IF EQUAL
IFCGN6: PUSHJ PP,GOTOIF
SKIPE CONCTR
JRST IFCGN1
SKIPE CH,ECXTRA
PUSHJ PP,PUTTAG
POPJ PP,
;"IFC" GENERATOR (CONT'D).
;A RANGE
IFCG10: PUSHJ PP,SETUPB
MOVE W1,OPLINE
TLZ W1,NOTF ;TURN OFF "NOT" FOR NOW
SOSLE CONCTR##
JRST IFCG20
;THE LAST RANGE IN THE VALUE CLAUSE
;FIRST COMPARISON
; < FALSE
; > FALL THRU
; = FALL THRU
PUSHJ PP,GETFLS
TLO W1,GREATF!EQUALF
PUSHJ PP,GOTOIF
;SECOND COMPARISON
; NOTF OFF NOTF ON
; < FALL THRU TRUE
; > FALSE FALL THRU
; = FALL THRU TRUE
SWOFF FAINAC ;CLEAR "A IN AC'S" FLAG
HRRZ TC,EOPLOC
ADDI TC,1
MOVEI LN,EBASEA
PUSHJ PP,SETED
ILDB TA,ECNBP
PUSHJ PP,SETUPB
MOVE TC,CUREOP ;SET LEFT HALF OF OPERAND PTR
HRLM TC,OPERND ; FOR SUBSCR SO LINKAGE FLAG HANDLED RIGHT
MOVE W1,OPLINE
TLZN W1,NOTF
JRST IFCG13
PUSHJ PP,GETTRU
TLO W1,GREATF
JRST IFCGN6
IFCG13: TLO W1,LESSF!EQUALF
PUSHJ PP,GETFLS
JRST IFCGN6
;"IFC" GENERATOR (CONT'D).
;A RANGE (CONT'D)
;ALL RANGE COMPARISONS EXCEPT THE LAST IN VALUE CLAUSE
;FIRST COMPARISON
; < NEXT COND'N
; > FALL THRU
; = FALL THRU
IFCG20: TLO W1,GREATF!EQUALF
PUSHJ PP,GETTAG
MOVEM CH,ECSTEP
PUSHJ PP,GOTOIF
;SECOND COMPARISON
; < TRUE
; > FALL THRU
; = TRUE
SWOFF FAINAC ;CLEAR "A IN AC'S" FLAG
PUSHJ PP,GETTRU
HRRZ TC,EOPLOC
ADDI TC,1
MOVEI LN,EBASEA
PUSHJ PP,SETED
ILDB TA,ECNBP
PUSHJ PP,SETUPB
MOVE TC,CUREOP ;[217]
HRLM TC,OPERND ;[217]
MOVE W1,OPLINE
PUSHJ PP,GETTRU
TLZ W1,NOTF
TLO W1,GREATF
PUSHJ PP,GOTOIF
MOVE CH,ECSTEP
PUSHJ PP,PUTTAG
JRST IFCGN1
;"IFC" GENERATOR (CONT'D).
;CALL THE "IF" ROUTINE FROM "IFC"
GOTOIF: HRRZ TA,EBASEA ; IF ONE OF THE OPERANDS IS A TAG, UPDATE REF
;COUNT SINCE A COMPARISON WILL REFERENCE THE TAG
TRC TA,AS.TAG##
TRNN TA,700000 ;SKIP IF NOT AS.TAG+N
PUSHJ PP,REFTAG##
HRRZ TA,EBASEB
TRC TA,AS.TAG
TRNN TA,700000 ;SAME FOR "B"
PUSHJ PP,REFTAG##
MOVS W2,CH ;SET UP FALSE PATH
TSWT FAINAC ;IS "A" IN THE AC'S?
JRST IFGNZC ;NO
JRST IFGN0 ;YES
;GET A TAG FOR THE TRUE PATH
GETTRU: SKIPN CH,ECTRUE
PUSHJ PP,IFCTAG
MOVEM CH,ECTRUE
POPJ PP,
;GET A TAG FOR THE FALSE PATH
GETFLS: SKIPN CH,ECFALS
PUSHJ PP,IFCTAG
MOVEM CH,ECFALS
POPJ PP,
;GET A TAG FOR EITHER THE TRUE OR THE FALSE PATH
IFCTAG: SKIPN CH,ECXTRA
PUSHJ PP,GETTAG
MOVEM CH,ECXTRA
POPJ PP,
;"IFC" GENERATOR (CONT'D).
;SET UP "B" OPERAND
SETUPB: TRNN TA,CNFIGC ;FIG. CONST.?
JRST SETUB1 ;NO
LDB TE,[POINT 5,TA,25] ;PICK UP FLAGS FOR FIG. CONST.
DPB TE,[POINT 5,ECNAME,14] ;STASH THEM AWAY
MOVSI TE,GNLIT!GNFIGC!1B18
IORM TE,ECNAME
SETZM ECNAME+1
MOVEI TC,ECNAME
MOVEI LN,EBASEB
JRST SETOPN
SETUB1: MOVE TE,[XWD EBASEA,EBASEB]
BLT TE,EBASBX
TSWF FASIGN;
SWONS FBSIGN;
SWOFF FBSIGN;
TSWF FANUM;
SWONS FBNUM;
SWOFF FBNUM;
SWOFF FBSUB;
ANDI TA,77777
IORI TA,AS.TAG
HRLI TA,^D36
MOVEM TA,EBASEB
SETZM EINCRB
POPJ PP,
;"IFC" GENERATOR (CONT'D).
;GENERATE A CONDITIONAL FOR HARDWARE SWITCHES
IFCSW: HRRZ TA,-1(EACA) ;GET "ON" OR "OFF"
PUSHJ PP,LNKSET
MOVE TE,1(TA)
JUMPL TE,IFCSW0
LDB TE,MNESF
DPB TE,W1SF
TLNN W1,SWITCH
JRST NOTSWC
IFCSW0: LDB TC,SWNUM ;PICK UP SWITCH NUMBER FROM MNETAB
IFCSWA: TLNN W1,SWCHON ;"ON" TEST?
TLC W1,NOTF ;NO--COMPLEMENT "NOT"
TLNN W1,GOFALS ;"GO IF FALSE"?
TLC W1,NOTF ;NO--COMPLEMENT "NOT"
MOVSI CH,MOVEI.+AC16
HRR CH,TC ;GENERATE <MOVEI 16,SWITCH>
PUSHJ PP,PUTASY
MOVEI CH,SWT.ON##
TLNE W1,NOTF ;SEE IF SWITCH SHOULD BE OFF OR ON
MOVEI CH,SWT.OF##
PUSHJ PP,PUT.PJ ;GENERATE <PUSHJ 17,SWT.ON/SWT.OF>
JRST JFALSE ;PUT OUT <JRST FALSE> AND RETURN
NOTSWC: MOVEI DW,E.290
JRST OPNFAT
;GENERATE CODE FOR "IF SWITCH (N)"
IFCSW7: TLNN W1,SWITCH ;IS EITHER SWITCH FLAG ON?
JRST BADEOP ;NO-TROUBLE
LDB TC,[POINT 6,W1,35] ;GET SWITCH NUMBER
JRST IFCSWA
;GENERATE CODE FOR "IF".
IFGENZ:
SETZM TAGTRU
LDB TE,CONDIT ;INSURE VALIDITY OF FLAGS
JUMPE TE,BADIF
CAIN TE,7
JRST BADIF
SWOFF FEOFF1 ;TURN OFF MOST FLAGS
PUSHJ PP,MAK2OP ;INSURE RIGHT NUMBER OF OPERANDS
TSWF FERROR ;ANY ERROR?
JRST BADEOP ;YES
TLZE W1,NOTF ;"NOT"?
TLC W1,CONCMP ;YES--COMPLEMENT CONDITION
TLNN W1,GOFALS ;IS TAG FOR "FALSE"?
TLC W1,CONCMP ;NO--COMPLEMENT CONDITION
MOVE TC,CUREOP ;SET UP FIRST OPERAND
MOVSM TC,OPERND
MOVEI LN,EBASEA
PUSHJ PP,SETED
TSWF FERROR ;ANY ERRORS YET?
POPJ PP, ;YES--QUIT
PUSHJ PP,BMPEOP ;SET UP SECOND OPERAND
JRST BADEOP ;NO MORE-- WE LOSE
AOS TC,CUREOP
HRRM TC,OPERND
MOVEI LN,EBASEB
PUSHJ PP,SETED
TSWF FERROR ;[445] ERRORS?
POPJ PP, ;[445] YES--QUIT
PUSHJ PP,CDEBAB## ;STORE "A" AND "B" OPERANDS
PUSHJ PP,GDEBV## ;OUTPUT THEM PLUS ALL PREVIOUS EXPRESSIONS
SETZM INPERF ;CLEAR CONTROL FLAG NOW
HRRZ TE,OPERND ;IS "B" THE AC'S?
MOVE TD,1(TE)
HRRZ TE,0(TE)
TLNE TD,GNNOTD
CAILE TE,17
JRST IFGNZA ;NO
PUSHJ PP,SWAPIT ;YES--SWAP OPERANDS
JRST IFGNZB
IFGNZA: HLRZ TE,OPERND ;IS "A" THE AC'S?
MOVE TD,1(TE)
HRRZ TE,0(TE)
TLNE TD,GNNOTD
CAILE TE,17
JRST IFGNZC ;NO
IFGNZB: SWON FAINAC!FASIGN ;YES--SET "'A' IS AC'S"
SWOFF FASUB;
HRROM TE,IFEAC## ;SAVE "A" ACC TO UNDO "B" DAMAGE
JRST IFGNZD
;"IF" GENERATOR (CONT'D).
IFGNZC: SETZM EAC ;SET AC'S TO BE 0&1
HRRZ TA,EMODEA ;IS "A" A LITERAL?
CAIN TA,LTMODE
JRST IFGN1 ;YES
CAIN TA,FCMODE ;FIG. CONST.?
JRST IFGN3 ;YES
IFGNZD: HRRZ TB,EMODEB ;IS "B" A LITERAL?
CAIN TB,LTMODE
JRST IFGN2 ;YES
CAIN TB,FCMODE ;FIG. CONST.?
JRST IFGN3E ;YES
;NEITHER OPERAND IS A LITERAL NOR A FIG. CONST.
TSWT FAINAC ;IS "A" IN THE AC'S?
JRST IFGN0A ;NO
;"A" IS IN THE AC'S
IFGN0: HRRZ TA,EMODEA
HRRZ TB,EMODEB
TSWT FBNUM ;IS "B" NUMERIC?
JRST NOTNMB ;NO--TROUBLE
CAIE TA,FPMODE ;IS EITHER "A" OR "B" COMP-1?
CAIN TB,FPMODE
JRST IFGN0N ;YES
CAIE TA,F2MODE ;NO, IS EITHER "A" OR "B" COMP-2?
CAIN TB,F2MODE
JRST IFGN0N ;YES
MOVE TE,EDPLA ;[600] DOES "A" HAVE SAME DECIMAL PLACES AS "B"?
SUB TE,EDPLB ;[600]
JUMPE TE,IFGN0N ;[600] YES
JUMPL TE,IFGN0L ;[600] "A" LESS THAN "B"
PUSHJ PP,SETBCX
JRST IFGN0E
;"IF" GENERATOR (CONT'D)
;"A" IS NOT THE AC'S
IFGN0A: TSWF FANUM ;IS "A" NUMERIC?
JRST IFGN0B ;YES
CAIG TB,DSMODE ;IS "B" DISPLAY?
TSWF FBSIGN ;YES, BUT NOT SIGNED?
CAIA
JRST IFDD ;YES
PUSHJ PP,SWAPIT ;SWAP OPERANDS (and the CONDITION).
JRST IFKAD ;MOVE IT TO UNSIGNED DISPLAY, THEN COMPARE.
;"A" ISN'T IN THE AC'S, BUT IS NUMERIC
IFGN0B: CAIE TB,FPMODE ;IS "B" COMP-1?
CAIN TB,F2MODE ;OR COMP-2?
JRST IFGN0E ;YES
CAIE TA,FPMODE ;NO--IS "A" COMP-1?
CAIN TA,F2MODE ;OR COMP-2?
JRST IFGN0G ;YES
TSWF FBNUM ;IS "B" NUMERIC?
JRST IFGN0C ;YES
CAIG TA,DSMODE ;IS "A" DISPLAY
TSWF FASIGN ;YES, BUT NOT SIGNED?
JRST IFKAD ;NO, CONVERT "A" TO DISPLAY
JRST IFDD ;YES
;BOTH "A" AND "B" ARE NUMERIC
IFGN0C: MOVE TE,EDPLA ;COMPARE DECIMAL PLACES
CAMN TE,EDPLB ;THE SAME?
JRST IFGN0F ;YES
CAML TE,EDPLB ;NO--"A" HAVE MORE THAN "B"?
JRST IFGN0G ;YES--SWAP OPERANDS
JRST IFGN0E ;NO--NO POINT IN SWAPPING
;"A" AND "B" HAVE THE SAME NUMBER OF DECIMAL PLACES
IFGN0F: CAIG TA,DSMODE ;IS "A" DISPLAY?
JRST IFGN0E ;YES--NO POINT IN SWAPPING
TSWT FBSIGN ;NO--IS "B" SIGNED?
IFGN0G: PUSHJ PP,SWAPIT ;SWAP OPERANDS
IFGN0E: PUSHJ PP,MOVXAC ; [413] GET "A" INTO THE AC'S
SWON FAINAC;
IFGN0L: PUSHJ PP,ADJDP. ;[600] ADJUST THE DECIMAL PLACES OF "A"
;"A" IS NOW IN THE AC'S -- DISPATCH TO CORRECT ROUTINE
IFGN0N: HRRZ TE,EMODEA ;IS MODE OF "A" LEGAL?
CAIN TE,D4MODE ;IS "A" A 4-WORD COMP?
JRST IF4WD ;YES, MAKE IT 2-WD
CAIL TE,D1MODE
CAILE TE,F2MODE
JRST IFCONA ;NO--SOMEBODY IS CONFUZED
CAIG TE,FPMODE ;IN FIRST SET?
JRST IFGN0P ;YES
CAIGE TE,D4MODE ;IN SECOND SET?
JRST IFCONA ;NO, ERROR
SUBI TE,D4MODE-FPMODE-1 ;REMOVE MODES NOT IN TABLE
IFGN0P: SUBI TE,D1MODE ;YES--REDUCE IT
HRRZ TD,EMODEB ;IS MODE OF "B" LEGAL?
CAIN TD,D4MODE ;4-WORD COMP?
JRST IF4WD ;YES--MAKE IT TWO WORDS
CAILE TD,F2MODE
JRST IFCONB ;NO
IMULI TE,<F2MODE+1>/2 ;YES--DISPATCH THRU TABLE
ROT TD,-1
ADDI TE,(TD)
TLNE TD,1B18
SKIPA TE,IFACT(TE)
MOVS TE,IFACT(TE)
JRST (TE)
;DISPATCH TABLE
IFACT: XWD IFC1D,IFC1D ;1C-S,1C-A
XWD IFC1D,IFC1C1 ;1C-E,1C-1C
XWD IFC1C2,IFCXFP ;1C-2C,1C-FP
XWD IFC1D,IFCONB ;1C-C3,1C-ED
XWD IFCONB,IFCONB ;1C-LT,1C-FG
XWD IFCONB,IFCXF2 ;1C-4C,1C-F2
XWD IFC2D,IFC2D ;2C-S,2C-A
XWD IFC2D,IFC2C1 ;2C-E,2C-1C
XWD IFC2C2,IFCXFP ;2C-2C,2C-FP
XWD IFC2D,IFCONB ;2C-C3,2C-ED
XWD IFCONB,IFCONB ;2C-LT,2C-FG
XWD IFCONB,IFCXF2 ;2C-4C,2C-F2
XWD IFPAC.,IFPAC. ;FP-S,FP-A
XWD IFPAC.,IFPAC. ;FP-E,FP-1C
XWD IFPAC.,IC1C1A ;FP-2C,FP-FP
XWD IFPAC.,IFCONB ;FP-C3,FP-ED
XWD IFCONB,IFCONB ;FP-LT,FP-FG
XWD IFCONB,IFC2C2 ;FP-4C,FP-F2
XWD IFCONA,IFCONA ;4C-S,4C-A
XWD IFCONA,IFCONA ;4C-E,4C-1C
XWD IFCONA,IC1C1A ;4C-2C,4C-FP
XWD IFCONA,IFCONA ;4C-C3,4C-ED
XWD IFCONA,IFCONA ;4C-LT,4C-FG
XWD IFCONA,IFCONA ;4C-4C,4C-F2
XWD IF2AC.,IF2AC. ;F2-S,F2-A
XWD IF2AC.,IF2AC. ;F2-E,F2-1C
XWD IF2AC.,IC1C1A ;F2-2C,F2-FP
XWD IF2AC.,IFCONB ;F2-C3,F2-ED
XWD IFCONB,IFCONB ;F2-LT,F2-FG
XWD IFCONB,IFC2C2 ;F2-4C,F2-F2
;HERE IFCONA AND/OR "B" IS 4-WORD COMP
IF4WD: MOVE TE,ESIZEA ;GET SIZE OF A
CAIG TE,MAXSIZ ;4-WORD COMP?
JRST IF4WDB ;NO
;CUT DOWN "A"
SUBI TE,MAXSIZ ;POWER OF 10 TO DIVIDE BY
PUSH PP,TE
MOVSI CH,MOVEI.+AC15
HRR CH,EBASEA ;"MOVEI 15,A"
PUSHJ PP,PUTASY##
POP PP,TC ;GET POWER OF 10
MOVEI CH,DVI41.## ;GET A LIBOL ROUTINE
CAILE TC,^D10
MOVEI CH,DVI42.## ;SORRY--WRONG ONE
PUSHJ PP,PMOPC.## ;"MOVEI 16,[^D1000..]"
;"PUSHJ PP,ROUTINE"
MOVEI TE,D2MODE ;NEW "A" PARAMETERS
MOVEM TE,EMODEA
MOVEI TE,^D18
MOVEM TE,ESIZEA
IF4WDB: MOVE TE,ESIZEB
CAIG TE,MAXSIZ
JRST IFGN0N ;START AGAIN
;CUT DOWN "B"
SUBI TE,MAXSIZ
PUSH PP,TE ;SAVE POWER OF 10
MOVSI CH,MOVEI.+AC15
PUSHJ PP,PUT.B## ;"MOVEI AC15,B"
POP PP,TC
MOVEI CH,DVI41.## ;A LIBOL ROUTINE
CAILE TC,^D10
MOVEI CH,DVI42.##
PUSHJ PP,PMOPC.##
MOVEI TE,D2MODE ;NEW "B" PARAMETERS
MOVEM TE,EMODEB
MOVEI TE,^D18
MOVEM TE,ESIZEB
JRST IFGN0N ;NOW CAN DO THE IF GENERATION
;CONVERT NUMERIC TO DISPLAY UNSIGNED
;COME HERE WHEN "B" IS NON-NUMERIC DISPLAY, AND "A" IS NUMERIC.
;"A" IS MOVED TO A TEMP NON-NUMERIC, SAME MODE AS "B".
IFKAD: MOVE TD,EMODEB ;[1067] GET MODE TO CONVERT TO
PUSHJ PP,IFKADM ;[1067] CALL ROUTINE TO CONVERT "A" TO TEMP
JRST IFDD ;[1067] GO DO NON-NUMERIC COMPARISON
;[1067] ROUTINE TO MOVE "A" (A NUMERIC ITEM) TO A NON-NUMERIC TEMP
;[1067] FOR COMPARISON PURPOSES.
;[1067] CALL: TD/ MODE TO CONVERT TO (MUST BE DISPLAY)
;[1067] PUSHJ PP,IFKADM
;[1067] <RETURN HERE>, "A" CHANGED TO BE THE TEMP, "B" NOT AFFECTED
IFKADM: MOVE TE,[EBASEB,,ESAVBI] ;[1067]
BLT TE,ESVIBX ;[1067] SAVE "B"
MOVE TE,[EBASEA,,EBASEB] ;[1067]
BLT TE,EBASBX ;[1067] COPY "A" TO "B"
MOVEM TD,EMODEB ;[1067] SET MODE OF RESULT
MOVE TE,ESIZEB ;[1067] GET SIZE
ADD TE,[EXP 6-1,7-1,^D9-1](TD) ;[1067]Round up
IDIV TE,[EXP 6,5,4](TD) ;[1067][1542] GET # OF WORDS
PUSHJ PP,GETEMP ;[1067]
MOVEM EACC,EINCRB ;[1067]
MOVE TE,[^D36,,AS.MSC] ;[1067]
MOVEM TE,EBASEB ;[1067]
PUSH PP,SW ;[1067] SAVE FLAGS
SWOFF FBSIGN!FBNUM!FBSUB ;[1067] MAKE DESTINATION ITEM
;[1067] A SIMPLE NON-NUMERIC TEMP
PUSH PP,EACC ;[1067] SAVE %TEMP OFFSET
PUSHJ PP,MXX.## ;[1067] MOVE "A" TO TEMP
POP PP,EACC ;[1067] RESTORE %TEMP OFFSET
MOVE TE,[EBASEB,,EBASEA] ;[1067]
BLT TE,EBASAX ;[1067] COPY "B" TO "A"
MOVEM EACC,EINCRA ;[1067] RESET OFFSET,
MOVE TE,[^D36,,AS.MSC] ;[1067] AND BASE,
MOVEM TE,EBASEA ;[1067] INCASE MXX. CHANGED THEM
MOVE TE,[ESAVBI,,EBASEB] ;[1067]
BLT TE,EBASBX ;[1067] RESTORE "B"
POP PP,SW ;[1067] RESTORE ORIGINAL "B" FLAGS
SWOFF FASIGN!FANUM!FASUB ;[1067] THE NEW "A" IS THE TEMP
POPJ PP, ;[1067] RETURN
;"A" IS A LITERAL
IFGN1: HRRZ TE,EMODEB
CAIE TE,LTMODE
CAIN TE,FCMODE
JRST TWOLIT
;"A" IS A LITERAL, "B" ISN'T
TSWT FBNUM ;IS "B" NUMERIC?
JRST IFGN2C ;NO
PUSHJ PP,SWAPIT ;YES--SWAP OPERANDS
;[1067] "A" IS A NUMERIC ITEM, "B" IS A LITERAL
TSWT FBNUM ;[1067] IS "B" A NUMERIC LITERAL?
JRST IFGN2D ;[1067] NO
PUSHJ PP,MOVXAC ; [413] PUT INTO ACS
SWON FAINAC;
;COME HERE WHEN "A" HAS BEEN MOVED TO ACS. SINCE THIS MAY HAVE
; EXPANDED THE TABLES, WE CAN NO LONGER BELIEVE THAT EBYTEB POINTS
; TO THE LITERAL. WE HAVE TO SET IT UP AGAIN, THEN GO TO IFGN9.
IFGN1A: HRRZ TA,EBASEB ;SET UP ETABLB AGAIN,
PUSHJ PP,LNKSET ; INCASE THE TABLES EXPANDED
HRRM TA,EBYTEB
JRST IFGN9
;"B" IS A LITERAL, "A" ISN'T
IFGN2: TSWT FANUM!FAINAC ;IS "A" NUMERIC?
JRST IFGN2A ;NO
TSWF FBNUM ;[1067] SKIP IF "B" IS NOT NUMERIC
JRST IFGN2E ;[1067] COMPARE NUMERICALLY
;[1067] "A" IS A NUMERIC ITEM, "B" IS A NON-NUMERIC LITERAL
IFGN2D: MOVEI TD,D7MODE ;[1067] MOVE "A" TO ASCII TEMP
PUSHJ PP,IFKADM ;[1067]
PUSHJ PP,SWAPIT ;[1067] SWAP SO "A" IS LITERAL,
;[1067] "B" IS NON-NUMERIC TEMP
JRST IFDD2 ;[1067] GO DO NON-NUMERIC COMPARISON
;[1067] "A" IS A NUMERIC ITEM, "B" IS A NUMERIC LITERAL
IFGN2E: TSWTS FAINAC ;[1067] GET IT INTO AC'S UNLESS
PUSHJ PP,MOVXAC ; [413] IT'S THERE ALREADY
JRST IFGN1A
IFGN2A: PUSHJ PP,SWAPIT ;"A" ISN'T NUMERIC--SWAP OPERANDS
;"A" IS A LITERAL, "B" IS NON-NUMERIC DISPLAY
IFGN2C: TSWT FANUM ;IS IT A NUMERIC LITERAL?
JRST IFDD2 ;NO
;"A" IS A NUMERIC LITERAL,"B" IS NON-NUMERIC DISPLAY
MOVE TA,ETABLB ;IS
PUSHJ PP,LNKSET ; 'B'
LDB TE,DA.EDT ; EDITED?
JUMPN TE,NOTNMA ;IF SO, ERROR
PUSH PP,EBYTEA ;NO--SEE IF ANY DECIMAL PLACES IN LITERAL
PUSHJ PP,SCANL
POP PP,EBYTEA
TSWF FERROR ;ANY ERRORS OF ANY KIND?
POPJ PP, ;YES--FORGET IT
PUSHJ PP,LITN.A ;NO--CREATE A NUMERIC DISPLAY LITERAL
JRST IFDD2 ;DO COMPARISON
;"A" IS A FIGURATIVE CONSTANT
IFGN3: HRRZ TE,EMODEB
CAIE TE,LTMODE
CAIN TE,FCMODE
JRST TWOLIT
;"A" IS A FIG. CONST., "B" ISN'T
PUSHJ PP,SWAPIT ;SWAP OPERANDS
;NOW "B" IS THE FIG. CONST.
IFGN3A: HRRZ TE,EMODEA ;IS 'A' DISPLAY?
CAIG TE,DSMODE
JRST IFGN3C ;YES
CAIN TE,C3MODE ;IS A COMP-3?
JRST IFGN4 ;YES, SPECIAL CASE FOR HIGH AND LOW VALUES.
CAIE TE,D1MODE ;IS IT COMP
CAIN TE,FPMODE ;OR COMP-1
CAIA ;YES
JRST IFG3AM ;NO
HRRZ TE,EFLAGB ;GET WHICH FIGCON
CAIN TE,IXZERO ;ZERO IS SPECIAL
JRST IFGN3B ;YES, DON'T LOAD ACCS
IFG3AM: PUSHJ PP,MXAC. ;NO--GET IT INTO AC'S
SWON FAINAC;
IFGN3B: HRRZ TE,EFLAGB ;DISPATCH TO APPROPRIATE ROUTINE
CAILE TE,IXSYCH
MOVEI TE,IXSPAC
JRST @IFFCTA(TE)
IFGN3C: HRRZ TE,EFLAGB
CAILE TE,IXSYCH
MOVEI TE,IXSPAC
JRST @IFFCT(TE)
;"B" IS A FIG. CONST., "A" ISN'T
IFGN3E: TSWF FAINAC ;IS "A" IN THE AC'S?
JRST IFGN3B ;YES
JRST IFGN3A ;NO
IFGN4: HRRZ TE, EFLAGB ;SEE WHICH FIGURATIVE CONSTANT IT IS.
CAIN TE, IXHIV ;IF IT'S HIGH-VALUES, SPECIAL CASE.
JRST IFGN4F
CAIE TE, IXLOWV ;IF IT'S NOT LOW-VALUES, USE
JRST IFG3AM ; THE STANDARD ROUTINE.
TSWF FASIGN; ;IT'S LOW VALUES, IF IT'S SIGNED
JRST IFGN4F ; SPECIAL CASE.
HRRZI TE, IXZERO ;OTHERWISE, MAKE IT A COMPARISON
HRRM TE, EFLAGB ; TO ZERO.
JRST IFG3AM
;COMPARE A COMP-3 ITEM TO HIGH OR LOW VALUES.
IFGN4F: PUSHJ PP, MOVXAC ; [413] GET THE COMP-3 ITEM INTO THE AC'S.
SWON FAINAC;
MOVE TA, ESIZEA ;SEE HOW MANY DIGITS THE ITEM HAS.
CAILE TA, ^D10
JRST IFGN4L
; GET 10**N-1.
SETZ TD, ;ONE WORD COMP.
MOVE TC, POWR10(TA)
JRST IFGN4R
IFGN4L: LSH TA, 1 ;TWO WORD COMP.
DMOVE TD, DPWR10(TA)
IFGN4R: SOS TC ;DON'T WORRY ABOUT UNDERFLOW, IT
; CAN'T HAPPEN (FAMOUS LAST WORDS!)
;NOW WE HAVE THE THING TO COMPARE THE ITEM TO, MAKE IT LOOK LIKE A LITERAL.
DMOVEM TD, ELITHI
HRRZ TA, EFLAGB ;IF IT'S LOW VALUES, MAKE THE
CAIN TA, IXLOWV ; LITERAL NEGATIVE.
SWON FLNEG;
MOVE TA, [XWD EBASEA,EBASEB] ;GIVE THE LITERAL ALL OF
BLT TA, EBASBX ; THE ITEM'S CHARACTERISTICS
SWON FBNUM!FBSIGN; ; (EXCEPT SUBSCRIPTING
SWOFF FBSUB; ; AND MODE OF COURSE.)
HRRZI TA, LTMODE
MOVEM TA, EMODEB
JRST IFGN9A ;GO GENERATE THE COMPARE.
;THE "A" OPERAND IS IN THE AC'S, "B" IS A LITERAL
IFGN9: MOVEI LN,EBASEB
HRRZ TE,OPERND ;[1057] IS "ALL" SPECIFIED?
MOVE TE,0(TE) ;[1057]
TLNE TE,GNALL ;[1057]
JRST BADALL## ;[1057] YES
HRRZ TE,EMODEA ;SEE IF "A" IS SPECIAL
CAIN TE,FPMODE
JRST IFGN9B ;"A" IS COMP-1
CAIN TE,F2MODE
JRST IFGN9C ;"A" IS COMP-2
CAIN TE,D4MODE
JRST IFGN9D ;"A" IS 4-WORD COMP
PUSHJ PP,CONVNL ;CONVERT LITERAL TO 2-WORD COMP
TSWF FERROR ;ANY ERRORS?
POPJ PP, ;YES--FORGET THE WHOLE THING
MOVE TE,EDPLA
SUB TE,EDPLB
PUSHJ PP,ADJSL.
DMOVEM TD,ELITHI
PUSHJ PP,ADJDP.
DMOVE TD,ELITHI
IFGN9A: HRRZ TE,EMODEA
CAIE TE,D2MODE ;IF "A" IS NOT A 2-WORD COMP, AND
JUMPE TD,IC1C1E ; LITERAL ONLY 1-WORD, JUMP
PUSHJ PP,MAKEL2
HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPN TE,IC2C2Z ; [413] IF NEGATED GO SEE TO IT.
JRST IC2C2E
IFGN9B: PUSHJ PP,MSFP%L ;"A" IS COMP-1
MOVEI TA,FPMODE
MOVEM TA,EMODEB
MOVEM TC,EINCRB
MOVEI TE,AS.MSC
MOVEM TE,EBASEB
JRST IC1C1B
IFGN9C: PUSHJ PP,MSF2%L ;"A" IS COMP-2
MOVEI TA,F2MODE
MOVEM TA,EMODEB
MOVEM TC,EINCRB
MOVEI TE,AS.MSC
MOVEM TE,EBASEB
JRST IC2C2E
IFGN9D: PUSHJ PP,CONVNL ;CONVERT LITERAL TO 2-WORD COMP
TSWF FERROR ;ANY ERRORS?
POPJ PP, ;YES--FORGET THE WHOLE THING
MOVE TE,EDPLA ;ADJUST SIGNIFICANT DIGITS IN LITERAL
SUB TE,EDPLB
PUSHJ PP,ADJBL. ;TURN INTO 4-WORD COMP IF NEED BE
DMOVEM TD,ELITHI
PUSHJ PP,ADJDP. ;ADJUST DECIMAL PLACES OF "A"
DMOVE TD,ELITHI
MOVE TE,EMODEB
CAIN TE,D4MODE ;IS "B" STILL 2-WORD COMP?
JRST IFGD9E ;NO, GONE TO 4-WORD
PUSHJ PP,MAKEL2
JRST IFC4C2
IFGD9E: DMOVEM TD,ELITHI ;SAVE ALL 4 WORDS
DMOVEM TB,ELITHI+2
PUSHJ PP,MAKEL4 ;MAKE 4-WORD LITERAL
JRST IFC4C4
;GENERATE CODE TO COMPARE 1-WORD COMP VERSUS 1-WORD COMP
IFC1C1: HRRZ TE,OPERND ; [413] IF NEGATED
LDB TE,EOPSGN ; [413] THEN MOVE NEGATIVE
JUMPN TE,IC1C1Z ; [413] TO ACS
TSWF FBSIGN ;IS "B" SIGNED?
JRST IC1C1A ;YES
IC1C1Z: PUSHJ PP,SETBCX ;SAVE LOCATION OF "A" & MAKE IT "B"
PUSHJ PP,MOVC1 ; [413] GET NEW "A" INTO AC'S
JRST IC1C1B
IC1C1A: PUSHJ PP,SUBSCB
IC1C1B: MOVSI CH,CAM. ;GENERATE THE COMPARE
LDB TE,CONDIT
ROT TE,-^D8
ADD CH,TE
PUSHJ PP,PUT.BA
JRST JFALSE
;"B" IS A LITERAL.
IC1C1E: SKIPN ELITLO ;IS LITERAL 0?
JRST IC1C1G ;YES
MOVSI CH,CAM.
LDB TE,CONDIT
ROT TE,-^D8
ADD CH,TE
HRRZ TE,OPERND ; [413] SEE IF "B" OPERAND
LDB TE,EOPSGN ; [413] IS NEGATED
JUMPN TE,IC1C1F ; [413] IF SO NEGATE IT
TSWT FLNEG ;IS LITERAL NEGATIVE?
SKIPA TC,ELITLO ;NO
IC1C1F: MOVN TC,ELITLO ;[413] YES
PUSHJ PP,PUT.LA ;GENERATE <CAMX AC,[LITERAL]>
JRST JFALSE ;GENERATE JRST TO FALSE, AND RETURN
;"B" IS A LITERAL OF ZERO
IC1C1G: MOVSI CH,JUMP.
LDB TE,CONDIT
TRC TE,CONCMP/100 ;COMPLEMENT CONDITION
ROT TE,-9
ADD CH,TE ;GENERATE JUMPX
MOVE TE,EAC
DPB TE,CHAC ;LOAD AC FIELD
JRST JFLSEA ;GENERATE JUMPX AC,FALSE
;GENERATE CODE TO COMPARE A 1-WORD COMP OR INDEX VS. A 2-WORD COMP
IFC1C2: MOVE TC,EDPLB ;COMPUTE DIFFERENCE IN DECIMAL PLACES
SUB TC,EDPLA
ADDM TC,EDPLA ;ADJUST DECIMAL PLACES OF "A"
ADDM TC,ESIZEA ;ALSO SIZE
MOVSI CH,MUL. ;GENERATE <MUL. AC,[POWER OF 10]>
PUSHJ PP,PUT.PA
MOVEI TE,D2MODE ;"A" IS NOW A 2-WORD COMP
MOVEM TE,EMODEA
JRST IFC2C2 ;DO DOUBLE-PRECISION COMPARE
;GENERATE CODE TO COMPARE A 2-WORD COMP VS. A 1-WORD COMP OR INDEX
IFC2C1: PUSHJ PP,SETBCX ;SWAP OPERANDS
HRRZ TE,EBASEA ;IF NEW 'A' IS
CAILE TE,17 ; NOT YET IN AC'S
PUSHJ PP,MOVC1 ; [413] GET IT THERE
JRST IFC1C2
;GENERATE CODE TO COMPARE 2-WORD COMPS.
IFC2C2: HRRZ TE,OPERND ; [413] GET "B" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPN TE,IC2C2Z ; [413] IF SO NEGATE IT
TSWF FBSIGN ;IS "B" SIGNED?
JRST IC2C2D ;YES
PUSHJ PP,SETBCX ;SWAP OPERANDS
IC2C2Z: HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPE TE,IC2C2Y ; [413]
PUSHJ PP,MNXAC.## ; [413] MOVE ITS NEGATIVE
JRST IC2C2E ; [413] DO COMPARISON.
IC2C2Y: PUSHJ PP,M2CAC. ;GET NEW "A" INTO AC'S
JRST IC2C2E
IC2C2D: PUSHJ PP,SUBSCB
IC2C2E: SKIPE EAC ;[154] MAKE SURE SETBCX DONE EVEN NO. OF TIMES
PUSHJ PP,SETBCX ;[154] TO FORCE CORRECT COMPARE UUO OF COMP. 2
IC2C2F: MOVSI CH,CAMN.
PUSHJ PP,PUT.BA
AOS EAC
HRRZ TE,EBASEB
CAIG TE,17 ;IN ACCS?
AOSA EBASEB ;YES
AOS EINCRB
LDB TE,CONDIT
CAIE TE,EQ
CAIN TE,NOTEQ
JRST IC2C2Q ;EITHER EQUAL OR NOT EQUAL
;HERE FOR LESS, LESS EQUAL, GREATER, GREATER EQUAL
MOVSI CH,CAM.
LDB TE,CONDIT
TRC TE,7 ;INVERSE CONDITION
ROT TE,-8
ADD CH,TE ;CREATE CAMX
PUSHJ PP,PUT.BA
SOS EAC
HRRZ TE,EBASEB
CAIG TE,17 ;IN ACCS?
SOSA EBASEB ;YES
SOS EINCRB
MOVSI CH,CAM.
LDB TE,CONDIT
TRO TE,EQ ;TURN ON EQ
ROT TE,-8
ADD CH,TE ;CREATE CAMX
PUSHJ PP,PUT.BA
JRST JFALSE
;HERE FOR EQUAL OR NOTEQUAL
IC2C2Q: MOVSI CH,CAME.
PUSHJ PP,PUT.BA
MOVEI TC,AS.DOT+2
TLNN W1,EQUALF
PUSHJ PP,JOUT ;NOT EQUAL
SOS EAC
HRRZ TE,EBASEB
CAIG TE,17 ;IN ACCS?
SOSA EBASEB ;YES
SOS EINCRB
JRST JFALSE
;GENERATE CODE TO COMPARE 4-WORD COMP WITH 2-WORD COMP.
IFC4C2: HLRZ TE,OPERND ; GET "A" OPERAND
LDB TE,CONDIT ;GET CONDITION
JRST @.(TE) ;DISPATCH
EXP IC4C2E ;EQUAL
EXP IC4C2G ;GREATER
EXP IC4C2G ;GREATER EQUAL
EXP IC4C2L ;LESS
EXP IC4C2L ;LESS EQUAL
EXP IC4C2N ;NOT EQUAL
IC4C2E: MOVSI CH,JUMPN.
JUMPE TD,IC4C2J ;UNLESS NEGATIVE LITERAL
MOVSI CH,AOJE.
JRST IC4C2J
IC4C2G: MOVSI CH,JUMPL.
JUMPE TD,IC4C2J ;UNLESS NEGATIVE LITERAL
MOVSI CH,AOJL.
JRST IC4C2J
IC4C2L: MOVSI CH,JUMPG.
JUMPE TD,IC4C2J ;UNLESS NEGATIVE LITERAL
MOVSI CH,AOJG.
IC4C2J: HLR CH,W2 ;GET FALSE TAG
ANDCMI CH,7B20 ;JUST TO BE SURE
IORI CH,AS.TAG
IC4C2K: PUSH PP,CH
JUMPGE TD,IC4C2P ;JUMP IF POSITIVE LITERAL
PUSHJ PP,PUTASA ;PICK OTHER SET
MOVE CH,(PP) ;RESTORE INST
IC4C2P: HRRZ TA,CH
PUSHJ PP,REFTAG
PUSHJ PP,PUT.XA
POP PP,CH ;RESTORE INST
AOS TE,EAC
CAIGE TE,2 ;DONE WITH 2 WORDS?
JRST IC4C2K ;NO, LOOP
JRST IC2C2F ;YES, OUTPUT CODE FOR REMAINING 2 WORDS
IC4C2N: MOVE CH,[JUMPN.+ASINC,,AS.MSC]
JUMPE TD,IC4C2J ;UNLESS NEGATIVE LITERAL
MOVE CH,[AOJN.+ASINC,,AS.MSC]
IC4C2M: PUSH PP,CH
JUMPGE TD,IC4C2O ;JUMP IF POSITIVE LITERAL
PUSHJ PP,PUTASA ;PICK OTHER SET
MOVE CH,(PP) ;RESTORE INST
IC4C2O: PUSHJ PP,PUT.XA
MOVEI CH,AS.DOT+6
SKIPE EAC ;IF FIRST TIME
MOVEI CH,AS.DOT+5 ; ELSE 2ND TIME
PUSHJ PP,PUTASN
POP PP,CH
AOS TE,EAC
CAIE TE,2 ;DONE WITH 2 WORDS?
JRST IC4C2N ;NO
JRST IC2C2F ;YES, OUTPUT CODE FOR REMAINING 2 WORDS
;GENERATE CODE TO COMPARE 4-WORD COMP WITH 4-WORD COMP.
IFC4C4: HLRZ TE,OPERND ;GET "A" OPERAND
LDB TE,CONDIT ;GET CONDITION
PUSH PP,TE ;SAVE ACTUAL CONDITION
CAIE TE,NOTEQ
IORI TE,EQ ;CONVERT GR OR LE INTO NOT LESS OR NOT GREATER
DPB TE,CONDIT ; AND STORE FOR FIRST PART OF TEST
PUSHJ PP,IC2C2F ;TEST FIRST 2 WORDS
POP PP,TE
DPB TE,CONDIT ;RESTORE TRUE CONDITION
MOVEI TE,2
ADDM TE,EAC
ADDM TE,EINCRB ;ADVANCE TO 2ND HALF OF LITERAL
JRST IC2C2F ;AND FINISH OF TEST
;AC'S ARE FLOATING POINT, "B" IS NOT
IFPAC.: PUSHJ PP,PUTEMP
SETZM EAC
PUSHJ PP,SWAPIT
HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPE TE,IFFPCY ; [413]
PUSHJ PP,MNXAC.## ; [413] MOVE NEGATIVE INTO ACS
JRST IC1C1B ; [413] DO COMPARISON
IFFPCY: PUSHJ PP,MXFPA.
JRST IC1C1B
;AC'S CONTAIN 1- OR 2-WORD COMP, "B" IS FLOATING POINT
IFCXFP: PUSHJ PP,CCXFP.
HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPN TE,IC1C1Z ; [413] GO NEGATE "A"
JRST IC1C1A
;AC'S ARE COMP-2, "B" IS NOT
IF2AC.: PUSHJ PP,PUTEMP
SETZM EAC
PUSHJ PP,SWAPIT
HLRZ TE,OPERND ;GET "A" OPERAND
LDB TE,EOPSGN ;SEE IF NEGATED
JUMPE TE,IFF2CY
PUSHJ PP,MNXAC.## ;MOVE NEGATIVE INTO ACS
JRST IC2C2E ;DO COMPARISON
IFF2CY: PUSHJ PP,MXFPA.
JRST IC2C2E
;AC'S CONTAIN 1- OR 2-WORD COMP, "B" IS COMP-2
IFCXF2: PUSHJ PP,CCXF2.
HLRZ TE,OPERND ;GET "A" OPERAND
LDB TE,EOPSGN ;SEE IF NEGATED
JUMPN TE,IFC2C2 ;GO NEGATE "A"
JRST IC2C2D
;"A" IS A 1-WORD COMP IN AC'S, "B" IS DISPLAY
IFC1D: MOVE TE,ESIZEB
CAIG TE,^D10
JRST IFC1DA
;"B" WILL BE 2 WORDS
MOVE TC,EDPLB ;[542] COMPUTE DIFF IN DECIMAL PLACES
SUB TC,EDPLA ;[542]
ADDM TC,EDPLA ;[542] ADJUST DECIMAL PLACES OF "A"
ADDM TC,ESIZEA ;[542] ALSO ADJUST SIZE
MOVSI CH,MUL. ;[542] GENERATE <MUL. AC,[POWER OF 10]>
PUSHJ PP,PUT.PA ;[542]
MOVEI TE,D2MODE ;[542] "A" IS NOW A 2-WORD COMP
MOVEM TE,EMODEA ;[542]
PUSHJ PP,SETBCX
PUSHJ PP,MOVXAC ; [413] MOVE INTO ACS
PUSHJ PP,SETBCX
JRST IC2C2E
;"B" WILL BE 1 WORD
IFC1DA: PUSHJ PP,SETBCX
PUSHJ PP,MOVXAC ; [413] MOVE INTO ACS
JRST IC1C1B
;"A" IS A 2-WORD COMP IN AC'S, "B" IS DISPLAY
IFC2D: PUSHJ PP,SETBCX
PUSHJ PP,MOVXAC ; [413] MOVE INTO ACS
HRRZ TE,EMODEA
CAIN TE,D1MODE
PUSHJ PP,CC1C2.
PUSHJ PP,SETBCX
HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPN TE,IC2C2Z ; [413] IF NEGATED GO SEE TO IT.
JRST IC2C2E
;GENERATE CODE FOR NON-NUMERIC DISPLAY COMPARISON
IFDD: HRRZ TE, EMODEA ;IF A IS DISPLAY-6 AND B IS
CAMGE TE, EMODEB ; DISPLAY-7 OR DISPLAY-9, OR
PUSHJ PP, SWAPIT ; A IS DISPLAY-7 AND B IS
; DISPLAY-9, SWAP THE OPERANDS.
PUSHJ PP,TSTCOL ;[1004] NEED TO WORRY ABOUT ASCII/EBCDIC COLL. SEQ.?
PUSHJ PP,SWAPIT ;[1004] YES, SIGNAL BY EMODEA .LT. EMODEB
IFDD2: MOVE TE,ESIZEA ;COMPARE SIZES
MOVEM TE,ESIZEZ
CAME TE,ESIZEB
JRST IFDD4
;'A' IS SAME SIZE AS 'B'
IFDD3: HRRZ TE,EMODEA ;IS 'A' A
CAIN TE,LTMODE ; LITERAL?
JRST IFDD30 ;YES
HRRZ TD,EMODEB ;NO--IS MODE OF 'A'
CAME TD,TE ; SAME AS MODE OF 'B'?
JRST IFDD3A ;NO
PUSHJ PP,TSTCOL ;[1004] SEE IF WE HAVE TO USE THE OTHER COL. SEQ.
JRST IFDD3A ;[1004] YES
MOVEI LN,EBASEB ;YES--IS 'B'
TSWT FBSUB ; NON-SUBSCRIPTED AND
PUSHJ PP,IFDD50 ; WORD-CONTAINED?
JRST IFDD3A ;IT IS SUBSCRIPTED OR NOT WORD-CONTAINED
MOVEI LN,EBASEA ;YES--IS 'A'
TSWT FASUB ; NON-SUBSCRIPTED AND
PUSHJ PP,IFDD50 ; WORD-CONTAINED?
JRST IFDD3A ;IT IS SUBSCRIPTED OR NOT WORD-CONTAINED
SKIPG COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
JRST IFDD40 ;NO--SPECIAL CODE
IFDD3A: HRRZ TE,ESIZEZ
MOVE TD,EMODEA ;[1317] NO NEED TO BREAK DOWN THE SIZE
CAME TD,EMODEB ;[1317] IF THE MODES ARE THE SAME
JRST IFDD3F ;[1317] NOT TRUE
SKIPN COLSEQ ;[1317] AND NO SPECIAL COLLATING SEQUENCE
JRST IFDD3B ;[1317] SO USE THE WHOLE SIZE
IFDD3F: CAIG TE,MXPSZ.## ;TOO BIG
JRST IFDD3B ;NO
SUBI TE,3770 ;GET REMAINDER
PUSH PP,EINCRA
PUSH PP,EINCRB
PUSH PP,TE
PUSH PP,TD ;[1317] SAVE TD FOR A SECOND
IDIVI TE,3770 ;[1317] FIND OUT HOW MANY
SKIPE TD ;[1317] PARTS LEFT
ADDI TE,1 ;[1317]
MOVEM TE,ECNTA ;[1317] SAVE PART COUNT
POP PP,TD ;[1317] RESTORE TD
MOVEI TE,3770 ;DIVISIBLE BY 6, 5 AND 4
MOVEM TE,ESIZEZ ;SET SIZE
PUSHJ PP,IFDD3B ;AND DO FIRST PART
IFDD3C: POP PP,ESIZEZ
SOS ECNTA ;[1317] DECREMENT NUMBER OF PARTS LEFT
MOVE TE,EMODEA ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRA ;MOVE DOWN STRING
MOVE TE,EMODEB ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRB
MOVE TE,ESIZEZ
CAIG TE,MXPSZ. ;STILL TOO BIG?
JRST IFDD3D ;NO, DO LAST COMPARE
SUBI TE,3770 ;YES, CUT DOWN AGAIN
PUSH PP,TE
MOVEI TE,3770
MOVEM TE,ESIZEZ
PUSHJ PP,IFDD3B
JRST IFDD3C
IFDD3D: PUSHJ PP,IFDD20
POP PP,EINCRB
POP PP,EINCRA
CAIA
IFDD3B: PUSHJ PP,IFDD20
HRRZ TE,EMODEB
CAME TE,EMODEA ;[1004] IF NOT THE SAME MODE
JRST ADDRS3 ;PUT OUT 3 JRSTS
PUSHJ PP,TSTCOL ;[1004] SAME MODE, BUT SEE IF OTHER COL. SEQ.
JRST ADDRS3 ;[1004] YES, SO NEED 3 JRSTS ALSO
JRST JFALSE ; ONLY ONE JRST REQUIRED
;PRETEND 'A' AND 'B' ARE THE SAME SIZE
IFDD3E: MOVE TE,ESIZEA
CAMLE TE,ESIZEB
MOVE TE,ESIZEB
MOVEM TE,ESIZEA
MOVEM TE,ESIZEB
JRST IFDD3
;BOTH 'A' AND 'B' ARE NON-NUMERIC (CONT'D)
;'A' HAS DIFFERENT SIZE THAN 'B'
IFDD4: SKIPN FLGSW## ;ARE WE CHECKING FIPS LEVEL?
JRST IFDD4E ;NO
PUSHJ PP,TST.N2## ;TEST AT HIGH-INTERMEDIATE LEVEL
MOVE TE,ESIZEA ;RELOAD SIZE OF "A"
IFDD4E: CAML TE,ESIZEB
JRST IFDD16 ;"A" LARGER THAN "B"
;"A" SMALLER THAN "B"
HRRZ TE,EMODEA
CAIN TE,LTMODE
JRST IFDD30
CAMN TE,EMODEB ;IS "A" SAME MODE AS "B"?
PUSHJ PP,TSTCOL ;[1004] SEE IF OTHER COL. SEQ.
CAIA ;[1004] YES, CANNOT USE EXTEND INST.
JRST GENEXD ;YES-- DIFF SIZE COMPARE USING EXTEND
LDB TE,CONDIT ;IS IT ">" OR "NOT >"?
CAIE TE,NOTGR
CAIN TE,GR
JRST IFDD3E ;YES
MOVE TD,ESIZEB ;[170-A] GET SIZE OF B
PUSH PP,TD ;[170-A] SAVE SIZE OF B
MOVE TD,ESIZEA ;[170] GET A SIZE (SMALLER THAN B)
MOVEM TD,ESIZEB ;[170] SET B SIZE = TO A SIZE
CAIG TD,MXPSZ. ;TOO BIG
JRST IFDD4A ;NO
SUBI TD,3770 ;GET REMAINDER
PUSH PP,EINCRA ;SO WE CAN GET END CONDITION RIGHT
PUSH PP,EINCRB
PUSH PP,TD
MOVEI TE,3770 ;DIVISIBLE BY 6, 5 AND 4
MOVEM TE,ESIZEZ ;SET SIZE
PUSHJ PP,IFDD17 ;AND DO FIRST PART
IFDD4B: POP PP,ESIZEZ
MOVE TE,EMODEA ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRA ;MOVE DOWN STRING
MOVE TE,EMODEB ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRB
MOVE TE,ESIZEZ
CAIG TE,MXPSZ. ;THIS THE LAST TIME WE HAVE TO LOOP?
JRST IFDD4C ;YES, DO LAST COMPARE
SUBI TE,3770
PUSH PP,TE
MOVEI TE,3770
MOVEM TE,ESIZEZ
PUSHJ PP,IFD17A
JRST IFDD4B
IFDD4C: PUSHJ PP,IFD17A ;TAG IS ALREADY SET UP
POP PP,EINCRB
POP PP,EINCRA
CAIA
IFDD4A: PUSHJ PP,IFDD17 ;[170] GO GENERATE COMP CODE FOR 'A' SIZE
PUSHJ PP,SWAPIT ;[473] [170-A] MAKE 'B' OPERAND 'A' FOR SPACE COMPARE
POP PP,TD ;[170-A] GET BACK ORIGINAL B SIZE
MOVE TE,ESIZEA ;[170] GET A SIZE FOR ARGUMENT TO M.IA
SUB TD,TE ;[170] GET DIFFERENCE OF A AND B
MOVEM TD,ESIZEA ;[170-A] DIFFERENCE IS LEFT OVER CHARS OF ORIG B FOR SPACE COMP
JRST IFD16A
;"A" LARGER THAN "B"
IFDD16: HRRZ TE,EMODEA
CAIN TE,LTMODE
PUSHJ PP,IFDD51
HRRZ TE,EMODEA ;GET "A" MODE NOW
CAMN TE,EMODEB ;SKIP IF "A" AND "B" NOT THE SAME MODE
PUSHJ PP,TSTCOL ;[1004] SEE IF OTHER COL. SEQ.
JRST IFD6AA ;[1004] YES, CANNOT USE EXTEND
PUSHJ PP,SWAPIT ;MAKE "A" THE SMALLER OPERAND
JRST GENEXD ; AND GENERATE THE EXTEND
IFD6AA: MOVE TE,ESIZEB
MOVEM TE,ESIZEZ
LDB TE,CONDIT ;IS IT "<" OR "NOT <"?
CAIE TE,LS
CAIN TE,NOTLS
JRST IFDD3E ;YES
MOVE TE,ESIZEB
MOVEM TE,ESIZEZ
CAIG TE,MXPSZ. ;TOO BIG
JRST IFD16B ;NO
SUBI TE,3770 ;GET REMAINDER
PUSH PP,EINCRA ;SO WE CAN GET END CONDITION RIGHT
PUSH PP,EINCRB
PUSH PP,TE
MOVEI TE,3770 ;DIVISIBLE BY 6, 5 AND 4
MOVEM TE,ESIZEZ ;SET SIZE
PUSHJ PP,IFDD17 ;AND DO FIRST PART
IFD16C: POP PP,ESIZEZ
MOVE TE,EMODEA ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRA ;MOVE DOWN STRING
MOVE TE,EMODEB ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRB
MOVE TE,ESIZEZ ;CAN WE FINISH NOW?
CAIG TE,MXPSZ.
JRST IFD16D ;YES, DO LAST COMPARE
SUBI TE,3770 ;NO, DO A 3770 COMPARE AGAIN
PUSH PP,TE
MOVEI TE,3770
MOVEM TE,ESIZEZ
PUSHJ PP,IFD17A
JRST IFD16C ;LOOP
IFD16D: PUSHJ PP,IFD17A ;TAG IS ALREADY SET UP
POP PP,EINCRB
POP PP,EINCRA
CAIA
IFD16B: PUSHJ PP,IFDD17
MOVE TE,ESIZEB
MOVN TD,ESIZEB
ADDM TD,ESIZEA
IFD16A: PUSHJ PP,M.IA
PUSHJ PP,IFSPAC
HRRZ CH,TAGTRU
SETZM TAGTRU
JRST PUTTAG
;GENERATE CODE FOR NON-NUMERIC DISPLAY COMPARISON (CONT'D).
;ONE FIELD IS SMALLER THAN THE OTHER. GENERATE COMPARISON FOR SMALLER SIZE.
IFDD17: PUSHJ PP,GETTAG ;GET A TAG FOR TRUE PATH
HRLI CH,JRST.
MOVEM CH,TAGTRU
IFD17A: PUSHJ PP,B2PAR
PUSHJ PP,IFDD24
MOVEI TC,5
TLNE W1,LESSF
PUSHJ PP,JTRUES
PUSHJ PP,JFALSE
MOVEI TC,4
TLNE W1,GREATF
JRST JTRUE
JRST JFALSE
;GENERATE THE ACTUAL COMPARISON INSTRUCTION
IFDD20: PUSH PP,EREMAN ;SAVE UNTIL PARAMETERS BUILT
SKIPG COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
PUSHJ PP,TSTCOL ;[1004] SEE IF WE HAVE TO USE OTHER COL. SEQ.
JRST OLDF20 ;[1004] YES, CAN'T USE EXTEND
HRRZ TE,EMODEB
CAMN TE,EMODEA ;MODES EQUAL?
JRST NEWF20 ;YES, USE NEW METHOD
OLDF20: SKIPLE COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
SETOM COLSCP## ;[1004] YES, SIGNAL SUBSCRIPTER TO USE IT
PUSHJ PP,B2PAR ;BUILD PARAMETERS
SETZM COLSCP ;[1004] BACK TO NORMAL
POP PP,EREMAN
HRRZ TE,EMODEB ;SAME MODE?
CAME TE,EMODEA
JRST IFDD24
PUSHJ PP,TSTCOL ;[1004] SEE IF WE NEED OTHER COL. SEQ.
JRST IFDD24 ;[1004] YES
MOVE CH,[XWD CMP.+ASINC,AS.MSC] ;YES--USE "COMP."
LDB TE,CONDIT
ROT TE,-^D13
ADD CH,TE
PUSHJ PP,PUTASY
HRRZ CH,EACC
JRST PUTASN
NEWF20: PUSHJ PP,EXTNGN ;GENERATE THE EXTEND
POP PP,EREMAN## ;RESTORE THIS
POPJ PP, ;AND RETURN
EXTNGN: PUSHJ PP,DEPCKK## ;SKIP IF ANY DEPENDING ITEMS
JRST EXTNG1 ;NO
;WE ASSUME 'ESIZEA' IS THE MAX SIZE OF 'A' AND 'ESIZEB' IS MAX SIZE FOR 'B'.
; ESIZEZ IS IGNORED. AC4 WILL BE SETUP TO HAVE COUNT OF 'A' AND AC7 FOR 'B'.
PUSHJ PP,EXMAB## ;PUT SUBSCRIPTS IN %TEMP NOW
; SO WE DON'T SMASH ACS 4 & 7 AT NB2PAR
PUSHJ PP,DEPTSA## ;DOES 'A' HAVE A DEPENDING ITEM?
JRST NODPIA ;NO, DO 'MOVEI' LATER ON
MOVEI TE,4 ;USE RUNTIME AC 4
PUSHJ PP,SZDPVA## ; SET IT UP
POPJ PP, ; ?ERROR, GIVE UP NOW
MOVEI TE,4
MOVEM TE,CONVSV## ;HAVE TO PRESERVE THIS AC
NODPIA: PUSHJ PP,DEPTSB## ;DOES 'B' HAVE A DEPENDING ITEM?
JRST NODPIB ;NO
MOVEI TE,7 ;SETUP AC 7 WITH SIZE OF 'B'
PUSHJ PP,SZDPVB## ; SET IT UP
NODPIB: SETZM CONVSV## ;CLEAR 'AC TO SAVE'
EXTNG1: MOVE TA,ESIZEZ ;# CHARS TO MOVE
MOVEM TA,NCHARS## ;STORE FOR GETNB
PUSHJ PP,GETNB## ;CAN WE USE LARGER BYTES?
MOVE TE,NBYTES## ;CAN WE USE LARGER BYTES?
CAIE TE,1
SETOM USENBT## ;IF NOT 1, ANSWER IS YES!
MOVE TE,ESIZEZ ;NOW FIND OUT # BYTES
IDIV TE,NBYTES##
SOJE TE,[HRRZ TE,EMODEA ;[544] COMPARING ONE BYTE?
CAIE TE,D6MODE ;[544] YES, SIXBIT CAN BE PROBLEM
JRST ONEBYT ;[544] OK, DON'T USE EXTEND
MOVE TE,NBYTES ;[544] GET NUMBER OF BYTES
CAIE TE,6 ;[544] A FULL WORD?
JRST ONEBYT ;[544] NO
JRST .+1] ;[544] YES, USE EXTEND INST
PUSHJ PP,NB2PAR## ;SETUP ACS 5-10
;IF 36-BIT BYTES ARE BEING USED, THE BYTE POINTER MUST BE SETUP.
MOVE TE,NBYTES## ;HOW MANY BYTES/BYTE?
CAIE TE,4
CAIN TE,6 ;4 OR 6 MEANS OPTIMIZATION WAS APPLIED
CAIA
JRST GOTBPS ;B.P.'S OK
TSWT FASUB ;IS RH OF AC5 SETUP?
JRST XXSET5 ;NO
MOVE CH,[TLO.+ASINC+AC5,,AS.CNB]
PUSHJ PP,PUTASY
MOVEI CH,(POINT 36,) ;"TLO 5,(POINT 36,)"
PUSHJ PP,PUTASN
JRST XXSET7
XXSET5: MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPA
PUSHJ PP,POOL
MOVSI CH,MOV+AC5
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
XXSET7: TSWT FBSUB ;IS RH OF AC10 SETUP?
JRST XXSET8 ;NO
MOVE CH,[TLO.+ASINC+AC10,,AS.CNB]
PUSHJ PP,PUTASY
MOVEI CH,(POINT 36,) ;"TLO 10,(POINT 36,)"
PUSHJ PP,PUTASN
JRST GOTBPS ;OK, GOT BYTE PTRS NOW
XXSET8: MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPB
PUSHJ PP,POOL
MOVSI CH,MOV+AC10
PUSHJ PP,PUT.LD
SKIPN PLITPC
AOS ELITPC
;GENERATE "MOVEI 4,<NUMBER OF BYTES>"
GOTBPS: PUSHJ PP,DEPTSA## ;'A' SIZE SETUP?
SKIPA CH,[MOVEI.+AC4+ASINC,,AS.CNB]
JRST GOTBPA ;YES
PUSHJ PP,PUTASY
MOVE TE,ESIZEZ ;NUMBER OF SMALL BYTES TO COMPARE
IDIV TE,NBYTES## ; # OF "BIG" BYTES TO COMPARE
MOVE CH,TE
PUSHJ PP,PUTASN
;GENERATE "MOVEI 7,<NUMBER OF BYTES>"
GOTBPA: PUSHJ PP,DEPTSB## ;'B' SIZE SETUP?
SKIPA CH,[MOVEI.+ASINC+AC7,,AS.CNB]
JRST GOTBPB ;YES
PUSHJ PP,PUTASY##
MOVE TE,ESIZEZ ;NUMBER OF SMALL BYTES TO COMPARE
IDIV TE,NBYTES## ; # OF 'BIG' BYTES TO COMPARE
MOVE CH,TE
PUSHJ PP,PUTASN##
;ACS HAVE BEEN SETUP. NOW GENERATE THE EXTEND
GOTBPB: PUSHJ PP,DEPCKK ;CHECK ANY DEPENDING ITEMS
JFCL ;[1651]don't care what it returns
USE2EX: ;[1651]USE2EX and USE3EX should be the same
USE3EX: ;[1651]
MOVE TA,[XTNLIT,,1] ;[1651]
PUSHJ PP,STASHP ;[1651] (FOR CMPXX EXTEND CODE)
LDB TE,CONDIT ;[1651]WHICH CONDITION TO TEST?
HLLZ TA,CMXTB(TE) ;[1651]
PUSHJ PP,STASHQ ;[1651]
AOS ELITPC ;[1651]GET LITERAL PC RIGHT FOR POOL
MOVE TA,[OCTLIT,,2] ;[1651]
PUSHJ PP,STASHP ;[1651]
HRRZ TE,EMODEA ;[1651]
HRRZ TA,IFSPCS(TE) ;[1651]GET A SPACE
PUSHJ PP,STASHQ ;[1651]E0+1
HRRZ TE,EMODEB ;[1651]
HRRZ TA,IFSPCS(TE) ;[1651]GET A SPACE
PUSHJ PP,POOLIT ;[1651]FINISH LITERAL BLOCK FOR EXTEND
SOS ELITPC ;[1651]
PUSHJ PP,PUTASA## ;[1651]EXTEND IS IN 2ND SET OF OPCODES
MOVSI CH,XTND.+AC4 ;[1651]
PUSHJ PP,PUT.LD## ;[1651]OUTPUT "EXTEND AC4,<CURRENT LITERAL>"
SETZM USENBT## ;[1651]CLEAR FLAG
SKIPE PLITPC ;[1651]
POPJ PP, ;[1651]
MOVEI TE,3 ;[1651]
ADDM TE,ELITPC ;[1651]
POPJ PP,
CMXTB: 0
CMPSE ;EQ
CMPSG ;GREATER
CMPSGE ;GREATER OR EQUAL
CMPSL ;LESS
CMPSLE ;LESS OR EQUAL
CMPSN ;NOT EQUAL
;HERE FOR COMPARE WHEN "A" IS SMALLER THAN "B"
; GENERATE THE EXTEND USING SMALL BYTES & FILLER CHARS
GENEXD: PUSHJ PP,NB2PAR## ;SETUP BYTE PTRS TO "A" AND "B"
;GENERATE "MOVEI 4,<# BYTES IN A>
MOVE CH,[MOVEI.+AC4+ASINC,,AS.CNB]
PUSHJ PP,PUTASY##
MOVE CH,ESIZEA ;NUMBER OF BYTES IN A
PUSHJ PP,PUTASN##
;GENERATE "MOVEI 7,<# BYTES IN B>
MOVE CH,[MOVEI.+AC7+ASINC,,AS.CNB]
PUSHJ PP,PUTASY##
MOVE CH,ESIZEB
PUSHJ PP,PUTASN##
PUSHJ PP,USE2EX ; USE THE EXTEND WITH FILLER CHARS
JRST JFALSE ;GEN "JRST FALSE" THEN RETURN
;HERE TO COMPARE ONE BYTE
ONEBYT: PUSHJ PP,PCXBP2## ;GEN PROPER BYTE PTRS
MOVE TE,EMODEA
CAIN TE,D7MODE
JRST ONEBY1 ;USE ILDB, CAMX
MOVE TE,ESIZEZ
CAIGE TE,4 ;FULL WORD BYTE?
JRST ONEBY1 ;NO
;COMPARE FULL WORDS
TSWT FASUB ;WAS "A" SUBSCRIPTED?
JRST FULWW1 ;NO
HLRZ CH,PCXPTR## ;GET INDEX AC
IORI CH,MOV
HRLZ CH,CH
PUSHJ PP,PUT.XA## ;"MOVE AC, (SUBSC.AC)"
JRST FULWD2
FULWW1: MOVSI CH,MOV
PUSHJ PP,PUT.AA## ;"MOVE AC,A"
FULWD2: TSWT FBSUB ;SKIP IF "B" SUBSCRIPTED
JRST FULWD4 ;NO
; "B" WAS SUBSCRIPTED. ADDRESS OF IT IS IN AN AC.
FULWD3: MOVSI CH,CAM.
LDB TE,CONDIT
ROT TE,-8
ADD CH,TE
HRLZ TE,PCXPTR## ;GET AC "B" IS IN
OR CH,TE ;INDEX BY IT
SETZM USENBT## ;CLEAR FLAG
PJRST PUT.XA## ;"CAMX AC,0(SUBSC.AC)"
FULWD4: MOVSI CH,CAM.
LDB TE,CONDIT
ROT TE,-8
ADD CH,TE
SETZM USENBT## ;CLEAR FLAG
PJRST PUT.BA## ;"CAMX AC,B"
;HERE TO GENERATE ILDB, ILDB, CAMX
ONEBY1: HLRZ TA,PCXPTR## ;WHERE IS "A" GOING TO END UP?
CAIGE TA,AS.LIT ;SKIP IF LITTAB
JRST ONEBYA ;NO, IN AC
MOVE CH,[LDB.+ASINC,,AS.MSC]
PUSHJ PP,PUT.XA## ;"LDB AC,LIT00+N"
HLRZ CH,PCXPTR##
PUSHJ PP,PUTASN## ;. .
JRST ONEBYB
ONEBYA: MOVSI CH,ILDB. ;"ILDB AC,<SUBSC. AC>"
HLR CH,PCXPTR##
PUSHJ PP,PUT.XA##
ONEBYB: HRRZ TA,PCXPTR## ;WHERE IS "B" GOING TO END UP?
CAIGE TA,AS.LIT ;SKIP IF LITTAB
JRST ONEBYC ;NO, IT WAS SUBSCRIPTED
MOVE CH,[LDB.+ASINC,,AS.MSC]
PUSHJ PP,PUT.XB##
HRRZ CH,PCXPTR##
PUSHJ PP,PUTASN##
JRST ONEBYD
ONEBYC: MOVSI CH,ILDB.
HRR CH,PCXPTR##
PUSHJ PP,PUT.XB##
;GENERATE "CAMX AC,AC+1"
ONEBYD: SETZM USENBT## ;CLEAR FLAG
MOVSI CH,CAM.
LDB TE,CONDIT
ROT TE,-8
ADD CH,TE
HRR CH,EAC
AOJA CH,PUT.XA##
;GENERATE "HRRZI 16, <PARAMETER ADDRESS>".
IFDD24: MOVE CH, [XWD HRRZI.+AC16+ASINC,AS.MSC]
PUSHJ PP, PUTASY
HRRZI CH, (EACC)
PUSHJ PP, PUTASN
;GENERATE "PUSHJ 17, <ROUTINE>".
HRRZ TE, EMODEA ;FIGURE OUT WHICH ROUTINE TO USE.
HRRZI CH, COMP%## ;ASSUME A AND B ARE OF THE SAME MODE.
CAMN TE, EMODEB
JRST IFDD25 ;[1004] SEE IF SPECIAL COLLATING SEQ. SPECIFIED
IMULI TE,D9MODE+1 ;[1004] INDEX IS EMODEA*3+EMODEB
ADD TE, EMODEB ;THEY AREN'T, FORM THE INDEX.
JUMPL TE, GNPSX.## ;IF AN ERROR OCCURED IN PHASE D
CAIG TE, CDDSLN ;[1004] THE MODES MAY BE MESSED UP, SO
; USE COMP.
MOVE CH, CDDS-1(TE) ;GET THE ROUTINE.
PJRST GNPSX.## ;GO GENERATE THE INSTRUCTION.
CDDS:
; XWD 0,COMP% ;[1004] CANNOT HAPPEN
XWD 0,CMP.67## ;[1004] COMPARE DISPLAY-6 TO DISPLAY-7 IN EBCDIC.
XWD 0,CMP.69## ;[1004] COMPARE DISPLAY-6 TO DISPLAY-9 IN EBCDIC.
XWD 0,CMP%76## ;COMPARE DISPLAY-7 TO DISPLAY-6 IN ASCII.
XWD 0,COMP% ;[1004] COMPARE DISPLAY-7 TO DISPLAY-7.
XWD 0,CMP.79## ;[1004] COMPARE DISPLAY-7 TO DISPLAY-9 IN ASCII.
XWD 0,CMP%96## ;COMPARE DISPLAY-9 TO DISPLAY-6.
XWD 0,CMP%97## ;COMPARE DISPLAY-9 TO DISPLAY-7.
; XWD 0,COMP% ;[1004] COMPARE DISPLAY-9 TO DISPLAY-9.
CDDSLN==.-CDDS ;[1004] LENGTH OF DISPATCH TABLE
IFDD25: PUSHJ PP,TSTCOL ;[1004] ASCII OR EBCDIC SPECIFIED?
SKIPA TE,EMODEA ;[1004] YES, USE SPECIAL ROUTINE
JRST GNPSX. ;[1004] NO, ITS IN THE RIGHT MODE
MOVE CH,CDDSAE(TE) ;[1004] GET THE ROUTINE
JRST GNPSX. ;[1004] GENERATE THE INSTRUCTION
CDDSAE: EXP COMP.6## ;[1004] SIXBIT IN EBCDIC MODE
EXP COMP.7## ;[1004] ASCII IN EBCDIC MODE
EXP COMP.9## ;[1004] EBCDIC IN ASCII MODE
;'A' IS A LITERAL WITH SIZE NOT GREATER THAN 'B', AND 'B' IS NON-NUMERIC
IFDD30: MOVE TE,ESIZEB ;IS 'B'
CAIN TE,1 ; A SINGLE CHARACTER?
TSWF FBSUB ;YES--SUBSCRIPTED?
JRST IFDD36 ;SUBSCRIPTED, OR NOT SINGLE CHARACTER
HRRZ TE,VALLOC## ;MAKE EBYTEA RELATIVE TO VALTAB
MOVNS TE ; IN CASE LITTAB EXPANDS
ADDM TE,EBYTEA ; AND CAUSES VALTAB TO MOVE
SKIPL COLSEQ ;[1612]NEED TO TRANSLATE?
PUSHJ PP,IFDD42 ;[1612]NO--GENERATE <LDB 0,B>
SKIPGE COLSEQ ;[1612] SKIP IF NOW IF LDB GENERATED
PUSHJ PP,IDD42A ;[1612]YES--USE <LDB 1,B> INSTEAD
HRRZ TE,VALLOC ;PUT BACK THE VALTAB BASE
ADDM TE,EBYTEA ; SO EBYTEA POINTS TO CURRENT VALUE
PUSHJ PP,SWAPIT ;SWAP OPERANDS AND CONDITION
SKIPGE TC,COLSEQ ;IF A DIFFERENT ALPHABET WAS SPECIFIED,
JRST IFD32A ; GO TRANSLATE THE CHARACTER PUT IN AC1
HRRZ TA,EBASEB ;[1404] SET UP ETABLB AGAIN
PUSHJ PP,LNKSET ;[1404] INCASE THE TABLES EXPANDED
HRRM TA,EBYTEB ;[1404]
ILDB CH,EBYTEB ;GET LITERAL VALUE INTO 'CH'
HRRZ TE,EMODEA ;IS 'A'
CAIE TE,D6MODE ; SIXBIT?
JRST IFDD31 ;NO
CAIG CH,137 ;YES-- IS LITERAL
CAIGE CH,40 ; REASONABLE?
JRST IFDD39 ;NO
SUBI CH,40 ;YES--CONVERT TO SIXBIT
JRST IFDD32
IFDD31: CAIE TE, D9MODE## ;IS 'A' DISPLAY-9?
JRST IFDD32 ;NO, MUST BE DISPLAY-7 THEN.
MOVEI TE, (CH) ;SET UP FOR VLIT8. CALL.
PUSHJ PP, VLIT8.## ;GO CONVERT THE CHAR.
LDB CH, [POINT 9,TE,35] ;GET IT IN CH (THERE MAY BE 2 CHARS.)
IFDD32:
SKIPG COLSEQ ;[1004] PROGRAM COL SEQ = ALPHABET-NAME?
JRST IFDD33 ;NO
HRRZ TE,EMODEA ;GET MODE AGAIN
EXCH TD,CH ;PUT CHAR IN RIGHT PLACE
XCT CSCHAR(TE) ;CONVERT
EXCH TD,CH ;RESTORE
JRST IFDD33 ;NOW GENERATE THE 'CAIX'
;TABLE OF BYTE POINTERS INTO EASTBL TRANSLATION TABLES
; WHICH USE AC1
IPTTBL: BLOCK 0 ;
EXP IPT671## ;
EXP IPT691## ;
EXP 0 ; DON'T NEED TO TRANSLATE
EXP IPT791## ;
EXP IPT971## ;
EXP 0 ; DON'T NEED TO TRANSLATE
; NEED AN 'LDB 1,IPTxx1' TO CONVERT CHARACTER IN AC1 TO
; SPECIFIED ALPHABET
IFD32A: HRRZ TD,EMODEA ;GET THE MODE OF 'A' OPERAND
LSH TD,1 ;DOUBLE IT
TRNE TC,%AN.EB ;EBCDIC?
AOS TD ; YES, INCREMENT INDEX
HRRZ TD,IPTTBL(TD) ;GET THE BASE ADDRESS OF TABLE NEEDED
JUMPE TD,IFD32B ;DATA ALREADY IN SPECIFIED MODE
MOVSI CH,LDB.+AC1 ;SET UP 'LDB 1,'
HRR CH,TD ;ADD BASE ADDRESS
PUSHJ PP,PUTASY ;
IFD32B: MOVSI CH,CAI.+AC1 ;SET UP 'CAIx 1,'
MOVE TE,EBYTEB ;BYTE PTR TO LITERAL
ILDB TE,TE ;GET THE LITERAL CHARACTER
MOVEI TD,D9MODE ;GET READY TO TRANSLATE TO EBCDIC
TRNE TC,%AN.EB ;LITERALS COME IN ASCII,
XCT VLIT6.##(TD) ; CONVERT TO EBCDIC IF NECESSARY
HRR CH,TE ;PUT CONVERTED CHAR INTO CH
SKIPA ;NOW GENERATE 'CAIX AC1,LIT'
IFDD33: HRLI CH,CAI. ;GET DUMMY CAI OPERATOR
LDB TE,CONDIT ;CONVERT
ROT TE,-^D8 ; OPERATOR TO
ADD CH,TE ; SOMETHING VALID
PUSHJ PP,PUTASY ;GENERATE <CAIX 0,LITERAL>
JRST JFALSE ;PUT OUT FALSE JUMP AND LEAVE
;CANNOT USE SPECIAL CODE
IFDD36: PUSHJ PP,IFDD51 ;PUT LITERAL IN LITAB
TSWF FERROR ;[1353] LITERAL TOO LARGE?
POPJ PP, ;[1353]
JRST IFDD2 ;TRY AGAIN
;LITERAL HAS NON-SIXBIT VALUE
IFDD39: HRRZ TE,OPERND
MOVEM TE,CUREOP
MOVEI DW,E.329 ; [374] NON-SIXBIT CHAR ERROR
PUSHJ PP,OPNFAT
MOVEI CH,0
JRST IFDD33
;BOTH 'A' AND 'B' ARE WORD-CONTAINED, AND HAVE SAME MODE
IFDD40: CAIN TE,^D36 ;ARE THEY FULL WORDS?
JRST IFDD44 ;YES, SPECIAL TREATMENT
PUSHJ PP,IFDD42 ;GENERATE <LDB 0,B>
PUSHJ PP,IFDD41 ;GENERATE <LDB 1,A>
MOVSI CH,CAM.+AC1 ;GET DUMMY CAM OPERATOR
LDB TE,CONDIT ;CONVERT
ROT TE,-^D8 ; OPERATOR TO
ADD CH,TE ; SOMETHING REASONABLE
PUSHJ PP,PUTASY ;GENERATE <CAMX 1,0>
JRST JFALSE ;PUT OUT FALSE PATH AND QUIT
;GENERATE <LDB 1,A>
IFDD41: MOVSI CH,LDB.+AC1
MOVEI LN,EBASEA
PUSHJ PP,IFDD45 ;SEE IF WE CAN USE HALF-WORD INST
SKIPG COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
JRST IFDD43
PUSHJ PP,IFDD43 ;YES, LOAD AC1
MOVE CH,[MOV+AC1+ASINC+1,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,EMODEA
MOVE CH,COLSQS(CH)
PJRST PUTASN
;GENERATE <LDB 0,B>
IDD42A: MOVSI CH,LDB.+AC1 ;[1612]USE AC1 INSTEAD
SKIPA ;[1612]
IFDD42: MOVSI CH,LDB.
MOVEI LN,EBASEB
PUSHJ PP,IFDD45 ;SEE IF WE CAN USE HALF-WORD INST
SKIPG COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
JRST IFDD43
MOVSI CH,LDB.+AC1
PUSHJ PP,IFDD43 ;YES, LOAD AC1
MOVE CH,[MOV+ASINC+1,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,EMODEB
MOVE CH,COLSQS(CH)
PJRST PUTASN
IFDD43: JUMPE CH,CPOPJ ;ALREADY DONE VIA HALF-WORD INST
PUSH PP,CH ;SAVE INST
MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
HRRZ TA,EBASEX(LN)
PUSHJ PP,STASHQ
MOVE TA,ESIZEX(LN)
HRRZ TD,EMODEX(LN)
IMUL TA,BYTE.S(TD)
HLR TD,ERESX(LN)
SUB TD,TA
ROT TA,-6
HRRI TA,(TD)
ROT TA,-6
HRR TA,EINCRX(LN)
PUSHJ PP,POOLIT
POP PP,CH
IDD43A: PUSHJ PP,PUT.LD ;GENERATE <LDB [CURRENT LITERAL]>
SKIPN PLITPC
AOS ELITPC
POPJ PP,
;BOTH 'A' AND 'B' ARE WORD-CONTAINED, HAVE SAME MODE, AND ARE 36 BITS
IFDD44: LDB TE,CONDIT ;IF CONDITION IS
CAIE TE,EQ ; EQUAL OR
CAIN TE,NOTEQ ; NOT EQUAL, GENERATE
JRST .+2 ; SPECIAL CODE, ELSE
JRST IFDD3A ; RETURN TO NORMAL
MOVSI CH,MOV+AC1 ;WE CAN USE MOVE RATHER THAN LDB
PUSHJ PP,PUT.A ;GENERATE <MOVE 1,A>
MOVSI CH,CAM.+AC1 ;NO NEED TO LOAD B
LDB TE,CONDIT ;CONVERT
ROT TE,-^D8 ; CONDITION TO
ADD CH,TE ; CAMX
PUSHJ PP,PUT.B ;GENERATE <CAMX 1,B>
JRST JFALSE ;PUT OUT FALSE AND QUIT
;SEE IF WE CAN USE HALF-WORD INST
IFDD45: HLRZ TA,ERESX(LN) ;GET BYTE OFFSET
CAIE TA,44 ;MUST START ON HALF WORD BOUNDARY
CAIN TA,22
CAIA ;SO FAR SO GOOD
POPJ PP, ;FAILED FIRST TEST
MOVE TA,ESIZEX(LN)
HRRZ TD,EMODEX(LN)
IMUL TA,BYTE.S(TD)
CAIE TA,^D18 ;MUST BE EXACTLY 18 BITS
POPJ PP, ;FAILED
PUSHJ PP,PUTASA ;SIGNAL SECOND INST SET
HLRZ TA,ERESX(LN) ;GET BYTE OFFSET AGAIN
CAIE LN,EBASEA ;SEE IF "A" OR "B"
JRST IFDD46 ;"B"
;GENERATE <HXRZ 1,A>
CAIE TA,22
SKIPA CH,[HLRZ.##+AC1,,0]
MOVSI CH,HRRZ.##+AC1
PUSHJ PP,PUT.A
SETZ CH, ;SIGNAL DONE
POPJ PP,
;GENERATE <HXRZ 0,B>
IFDD46: CAIE TA,22
SKIPA CH,[HLRZ.##,,0]
MOVSI CH,HRRZ.##
PUSHJ PP,PUT.B
SETZ CH, ;SIGNAL DONE
POPJ PP,
;CHECK TO SEE IF FIELD IS WORD-CONTAINED.
;IF SO, RETURN TO CALL+2; IF NOT RETURN TO CALL+1.
IFDD50: MOVE TE,ESIZEX(LN)
HRRZ TD,EMODEX(LN)
IMUL TE,BYTE.S(TD)
HLRZ TD,ERESX(LN)
CAML TD,TE
AOS (PP)
POPJ PP,
;PUT VALUE OF THE LITERAL 'A' INTO LITAB
IFDD51: PUSH PP,ESIZEB
HLRZ TE,OPERND
MOVE TE,0(TE)
TLNE TE,GNALL
JRST IFDD52
MOVE TE,ESIZEA
CAMLE TE,ESIZEB
MOVEM TE,ESIZEB
IFDD52: SETZM LITERR## ; [374] CLEAR LITERAL ERROR SW
PUSHJ PP,LITD.0## ; [374] SET UP LITERAL
POP PP,ESIZEB
SKIPN LITERR ; [374] ERRORS IN CONVERSION?
POPJ PP, ;NO
MOVEI DW,E.329 ; [374] SET UP FOR POSSIBLE ERROR
HLRZ TE,OPERND ; [374] GET LITERAL OPERAND
MOVEM TE, CUREOP ; [374] SET UP FOR ERROR
PUSHJ PP,OPNFAT ; [374] YES GIVE ERROR
SETZM LITERR ; [374] CLEAR ERROR SW
POPJ PP,
;TABLE OF FIG. CONST. ENTRY POINTS, WHEN "A" IS NOT AC'S
IFFCT: EXP 0 ;TODAY (ANS68)
EXP IFSPAC ;SPACE
EXP IFZERO ;ZERO
EXP IFQUOT ;QUOTE
EXP IFHIV ;HIGH-VALUES
EXP IFLOV ;LOW-VALUES
EXP IFSPAC ;DATE
EXP IFSPAC ;DAY
EXP IFSPAC ;TIME
EXP IFSPAC ;DAY-OF-WEEK
EXP IFSYMB ;SYMBOLIC CHARACTER
;TABLE OF FIG. CONST. ENTRY POINTS, WHEN "A" IS AC'S
IFFCTA: EXP 0 ;TODAY (ANS68)
EXP BADCLS ;SPACE
EXP IFZERO ;ZERO
EXP BADCLS ;QUOTE
EXP IFHIV ;HIGH-VALUES
EXP IFLOV ;LOW-VALUES
EXP BADCLS ;DATE
EXP BADCLS ;DAY
EXP BADCLS ;TIME
EXP BADCLS ;DAY-OF-WEEK
EXP BADCLS ;SYMBOLIC CHARACTER
;ERROR ROUTINES
;TWO LITERALS BEING COMPARED
TWOLIT: MOVEI DW,E.331
JRST OPNFAT
;AC'S BEING COMPARED WITH SOMETHING NOT NUMERIC
BADCLS: MOVEI DW,E.211
JRST OPNFAT
;CONFUSION -- "B" AT FAULT
IFCONB: SKIPA TC,OPERND
;CONFUSION -- "A" AT FAULT
IFCONA: MOVS TC,OPERND
HRRZM TC,CUREOP
MOVEI DW,E.276
JRST OPNFAT
;"B" MUST BE NUMERIC
NOTNMB: SKIPA TC,OPERND
;"A" MUST BE NUMERIC
NOTNMA: MOVS TC,OPERND
HRRZM TC,CUREOP
MOVEI DW,E.211
JRST OPNFAT
;GENERATE CODE FOR "ENDIF"
ENDIFG: TLNN W1,GNENDS ;[605] IS THIS AN "END SPIF"?
POPJ PP, ;[605] NO
TLNE W1,(1B10) ;END SPIF, BUT NO I-O?
POPJ PP, ;YES, NOTHING TO GENERATE
ENDIFR::
;[12B] Sometimes there is information passed to this routine from
; the various I-O generators, such as the "READ INTO" item, or
; the file-table pointer and flag saying that this is a READ INTO
; a variable length item.
; This information is stored in a HLDTAB entry. EVERY special IF
;creates a HLDTAB entry, and they are stored as a LIFO "stack" as follows:
;PTRHLD contains information about the last entry made, (entry flags
;and pointer into HLDTAB).
; Each HLDTAB entry contains a header word which describes the
;NEXT entry in the chain (not the entry the header word is contained in!!!),
;and information that allows ENDIFG to generate the appropriate code.
; If there is only one entry in HLDTAB, the header word of that entry
;is zero.
; Every type of special IF must generate a HLDTAB entry. This includes
;all "INVALID KEY/AT END/AT END OF PAGE" etc.-type things.
; This type of arrangement is necessary to preserve the "pushdown"
;stack data structure, so nested "SPECIAL IF's" will work.
; Guard against errors
SKIPN PTRHLD## ;A MISMATCH INDICATES SYNTAX ERRORS
POPJ PP, ;SO JUST FORGET IT.
; Check for the various options
ENDIF0: MOVE TB,PTRHLD## ;GET PTRHLD WITH ITS FLAGS
TXNE TB,HE%VLR ; VARIABLE-LENGTH READ?
PUSHJ PP,ENDF0B ;YES
TXNE TB,HE%DEB ; DEBUGGING CODE?
PUSHJ PP,ENDF0C ;YES
TXNE TB,HE%RIN ;READ..INTO OR RETURN..INTO?
PUSHJ PP,ENDF0A ;YES
HRRZ TA,PTRHLD ;FIND HLDTAB ENTRY
ADD TA,HLDLOC##
MOVE TB,(TA) ;"POP" THE STACK
MOVEM TB,PTRHLD
;Return space to HLDTAB
MOVE TB,[.HESIZ,,.HESIZ] ; # WORDS IN ENTRY USED
MOVE TD,HLDNXT##
SUB TD,TB ;ADJUST HLDNXT
MOVEM TD,HLDNXT ;AS IF WE HAD NEVER USED THE SPACE
POPJ PP, ;RETURN FROM ENDIFG
;ENDIFG - SUBROUTINES
;READ--INTO or RETURN...INTO
ENDF0A: MOVEI TA,.HERIN ;START OF ENTRY
ADD TA,PTRHLD ;POINT INTO THIS ENTRY
ADD TA,HLDLOC ;START OF THE READ..INTO OPERANDS
HRLI TB,0(TA) ;[1351] MOVE HLDTAB ENTRY
HRRI TB,EINTO## ;[1351] TO A FIXED LOCATION
BLT TB,EINTO+OPNSIZ+OPNMAX-1 ;[1351] BECAUSE TABLE EXPANSION
;[1351] IS CLOBBERING CUREOP'S PTR
MOVEI TA,EINTO ;[1351] TA POINTS TO RECORD ITEM
MOVEI TC,2(TA) ;[1351] TC POINTS TO INTO ITEM
MOVEM TC,CUREOP ;SETUP CUREOP THE WAY MOVGN. LIKES
PUSHJ PP,MOVGN. ;GENERATE THE MOVE CODE
SETZM EINTO ;[1351] RESET EINTO
MOVE TB,PTRHLD ;REGET PTRHLD
POPJ PP, ;RETURN
;READ--VARIABLE-LENGTH FLAG WAS ON
ENDF0B: MOVEI TA,.HEVLR ;GET OFFSET INTO ENTRY
ADD TA,PTRHLD ;POINT INTO THIS ENTRY
ADD TA,HLDLOC
MOVE TB,(TA) ;FETCH FILE-TABLE PTR
MOVEM TB,EDEPFT## ;STORE INFORMATION
PUSHJ PP,ENDFVL ;DO VARIABLE-LENGTH CODE
MOVE TB,PTRHLD ;RE-GET PTRHLD
POPJ PP, ;RETURN
;ENDIFG - SUBROUTINES
;CALLED BY ENDF0B TO DO THE VARIABLE LENGTH CODE
;INPUT: EDEPFT = FILE-TABLE POINTER
ENDFVL: HRRZ TA,EDEPFT ;[605] GET FILE TABLE
HRLZM TA,CURFIL## ;[605] MAKE SURE IT POINTS TO FILE WE WANT
PUSHJ PP,LNKSET ;[605] CONVERT TO ADDRESS
HRRM TA,CURFIL ;[605] SAVE IT
SETZM EDEPFT ;[605]
LDB CH,FI.DEP## ;SEE IF 8x VARIABLE LENGTH READ
JUMPN CH,ENDIF1 ;YES IT IS
PUSHJ PP,VLTST## ;[605] CALL AGAIN TO SETUP POINTER TO RECORD
ENDIF1: MOVEM CH,EDEPFT ;[605] SOMEWHERE SAFE TO STORE POINTERS
HLRZ CH,CURFIL ;[605] GET FILE TABLE
IOR CH,[MOV+ASINC,,AS.FIL##] ;[605] GET RECORD COUNT
PUSHJ PP,PUTASY ;[605] PUT OUT FIRST PART
MOVSI CH,FI.CLR## ;[605] NEG OFFSET IN LHS.
PUSHJ PP,PUTASN ;[605] PUT OUT NEG. OFFSET
SETZM EAC ;[605] RESULT IS IN AC0
LDB CH,FI.DEP## ;SEE IF 8x VARIABLE LENGTH READ
JUMPN CH,ENDIF4 ;YES IT IS, JUST DO MOVE
HRRZ TA,EDEPFT ;[605] GET OFFSET OF 01 RECORD
PUSHJ PP,LNKSET ;[605] ITS ADDRESS
LDB TB,DA.EXS ;[605] GET MAX. SIZE
PUSH PP,TB ;[605] SAVE
LDB TB,DA.USG ;[1037] GET USAGE OF 01 ITEM
SUBI TB,1 ;[1037] CONVERT TO MODE
MOVEM TB,ESAVMD## ;[1037] SAVE FOR SUBSIZ
HLRZ TA,EDEPFT ;[605] GET OFFSET OF OCCURS ITEM
PUSHJ PP,LNKSET ;[605] ITS ADDRESS
LDB TC,DA.USG ;[1037] GET USAGE
XCT SUBSIZ##(TC) ;[1037] CALL ROUTINE TO GET SIZE IN BYTES
MOVE TB,TE ;[1037] PUT SIZE IN TB
LDB TC,DA.NOC## ;[605] NO. OF OCCURS
IMULI TC,(TB) ;[605] SIZE OF VARIABLE PART
POP PP,CH ;[605] REGET SIZE OF RECORD
SUB CH,TC ;[605] GET FIXED PART
JUMPE CH,ENDIF3 ;[605] NO FIXED PART
HRLI CH,SUBI.## ;[605] GENERATE CODE TO SUBTRACT IT FROM CHAR COUNT
PUSHJ PP,PUTASY ;[605] SO OCCURS DEP. VARIABLE IS WHAT COBOL EXPECTS
ENDIF3: CAIN TB,1 ;[605] IF SIZE IS 1
JRST ENDIF4 ;[605] DON'T GENERATE DIVIDE INST
MOVSI CH,ADDI.## ;[605] FASTEST WAY TO ROUND UP
HRRI CH,-1(TB) ;[605] BY ADDING SIZE -1
PUSHJ PP,PUTASY ;[605] TO VALUE IN AC0
MOVSI CH,IDIVI.## ;[605] GENERATE DIVIDE
HRRI CH,(TB) ;[605] BY INDIVIDUAL ITEM
PUSHJ PP,PUTASY ;[605]
ENDIF4: SETZM EBASEA ;[605] SET UP A FAKE "A"
MOVE TA,[EBASEA,,EBASEA+1] ;[605]
BLT TA,EFLAGA ;[605] START WITH IT ALL ZERO
MOVEI TA,D1MODE ;[605] 1 WORD COMP
MOVEM TA,EMODEA ;[605]
SWOFF FEOFF1 ;[605] GET THE FLAGS RIGHT
SWON FAINAC!FANUM!FASIGN ;[605]
;[605] NOW TO FAKE "B"
PUSH PP,W1 ;[605] SAVE W1
PUSH PP,W2 ;[605] AND W2.
PUSH PP,OPERND## ;[605] SAVE OPERND TOO. (IN CASE IT'S
;[605] IN THE LINKAGE SECTION.)
HRRZ TA,CURFIL
LDB W2,FI.DEP## ;SEE IF 8x VARIABLE LENGTH READ
JUMPN W2,ENDIF8 ;YES IT IS
HLRZ TA,EDEPFT ;[605] GET OCCURS ITEM
PUSHJ PP,LNKSET ;[605] POINT TO IT
LDB W2,DA.DEP## ;[605] GET THE DEPENDING ITEM.
ENDIF8: MOVEI TA,(W2) ;[605] AND POINT AT IT.
PUSHJ PP,LNKSET## ;[605]
MOVSI W1,(1B0) ;[605] SET THE OPERAND FLAG.
LDB TD,DA.SYL## ;[605] SET THE SYNC FLAGS.
DPB TD,[POINT 1,W1,5] ;[605]
LDB TD,DA.SYR## ;[605]
DPB TD,[POINT 1,W1,6] ;[605]
LDB TD,DA.CLA## ;[605] SET THE NUMERIC FLAG.
CAIN TD,%CL.NU ;[605]
TLO W1,(1B7) ;[605]
LDB TD,DA.JST## ;[605] SET THE JUSTIFIED FLAG.
DPB TD,[POINT 1,W1,8] ;[605]
LDB TD,DA.LKS## ;[605] SET THE LINKAGE SECTION FLAG.
DPB TD,[POINT 1,W1,9] ;[605]
LDB TD,DA.USG## ;[605] SET THE USAGE.
DPB TD,[POINT 4,W1,13] ;[605]
PUSHJ PP,PUSH12## ;[605] STASH THE INFO IN EOPTAB.
HRRZI TC,-1(EACA) ;[605] POINT AT THE EOPTAB ENTRY.
MOVEM TC,CUREOP ;[605] MAKE IT THE CURRENT ENTRY.
HRRZM TC,OPERND## ;[605] MAKE IT THE CURRENT OPERAND TOO.
MOVEI LN,EBASEB ;[605] POINT TO "B"
PUSHJ PP,SETOPN ;[605] SET UP "B" OPERAND
TSWT FERROR ;[605] DON'T TRY TO STORE IF ERROR FOUND
PUSHJ PP,MACX.## ;[605] STORE DEPENDING ITEM
POP PP,OPERND## ;[605] RESTORE OPERND.
POP PP,W2 ;[605] RESTORE W2
POP PP,W1 ;[605] AND W1.
MOVE EACA,EOPNXT## ;[605] RESET EOPTAB.
POP EACA,(EACA) ;[605]
POP EACA,(EACA) ;[605]
HRRZ TA,EDEPFT ;[605] GET CURRENT 01
SETZM EDEPFT ;[605] SO WE KNOW IF ANOTHER IS FOUND
PUSHJ PP,VLTSTN## ;[605] LOOK FOR ONE
SKIPE EDEPFT ;[605] DID WE FIND SOMETHING?
JRST ENDIF1 ;[605] YES, GENERATE CODE FOR THIS DEP. VAR. ALSO
POPJ PP, ;DONE, RETURN
;ENDIFG - SUBROUTINES
;GENERATE DEBUGGING CODE
ENDF0C: MOVEI TA,.HEDEB ;GET PTR TO HLDTAB ENTRY
ADD TA,PTRHLD ;POINT INTO THIS ENTRY
ADD TA,HLDLOC
MOVE TC,(TA) ;GET THE DEBUGGING WORD
MOVEM TC,DBSPIF## ;REMEMBER IT WHILE WE GENERATE CODE.
TXNE TB,HE%RIN ;IF THIS IS READ..INTO
JRST ENDIF5 ; NO TAG NEEDED
;HAVE TO CREATE A TAG FOR DEBUGGING CODE
TSWF FAS3 ;IN NON-RESIDENT SECTION?
JRST [LDB CH,AS3BHO##+1 ;YES
JRST .+2]
LDB CH,AS2BHO##+1
HLRZ TE,CH ;GET OP-CODE
CAIE TE,720000 ;IS IT TAGGEN?
JRST ENDIF5 ;NO, LEAVE IT ALONE, GENERATE WRONG CODE!
LDB TE,[POINT 3,CH,20] ;GET TABLE #
CAIE TE,AC.TAG## ;MAKE SURE ITS A TAG
JRST ENDIF5 ;NO
PUSH PP,CH ;SAVE CURRENT INST
MOVE CH,[JRST.+ASINC,,AS.MSC]
TSWF FAS3
JRST [DPB CH,AS3BHO+1 ;CHANGE TO JRST .+3
JRST .+2]
DPB CH,AS2BHO+1
IFN MCS,<
HRRZ CH,DBSPIF
CAIN CH,DBCD. ;DBCD. NEEDS JRST .+4
SKIPA CH,[AS.DOT+4]
>
MOVEI CH,AS.DOT+3
PUSHJ PP,PUTASY ;FINISH OFF INST.
POP PP,CH
HRRZ TE,CH
ANDI TE,077777 ;GET TAG NUMBER
ADD TE,TAGLOC##
AOS (TE) ;INCREMENT PC OF TAG
PUSHJ PP,PUTASN ;OUTPUT TAG AGAIN
ENDIF5: HRRZ CH,DBSPIF
PUSHJ PP,PUT.PJ## ;PUSHJ 17,DBXX.
MOVE CH,[AS.XWD##,,1]
PUSHJ PP,PUTASN
LDB CH,[POINT 13,DBSPIF+1,28] ;GET LINE NUMBER
PUSHJ PP,PUTASN
IFN MCS,<
HRRZ CH,DBSPIF ;GET ROUTINE
CAIN CH,DBCD.## ;CHECK FOR DEBUG ON CD-NAME
JRST [HLRZ TA,DBSPIF ;YES, GET CD-NAME
ADD TA,CDLOC## ;ADD IN BASE
PUSHJ PP,DBGEN1## ;USE CODE IN MESGEN
JRST ENDIF6]
>
HLRZ CH,DBSPIF
IORI CH,AS.FIL ;CONVERT INTO FILTAB ADDRESS
PUSHJ PP,PUTASY ;XWD LINE #,FILTAB
ENDIF6: SETZM DBSPIF
MOVE TB,PTRHLD ;REGET PTRHLD
POPJ PP, ;RETURN
;GENERATE CODE FOR "SPIF" OPERATOR
SPIFGN: TLNN W1,ATPINV## ;ALSO TEST FOR ATEOP
JRST SPIF5
SPIF3: HLRZ CH,W2
ANDI CH,LMASKS
IORI CH,AS.TAG
HRLI CH,XJRST.## ;SO OPTIMIZER WON'T REMOVE
HRRZ TA,CH
PUSH PP,CH
PUSHJ PP,REFTAG## ;REFERENCE THE TAG
PUSHJ PP,PUTASA ;OTHER CODE SET
POP PP,CH
JRST PUTASY
;NEITHER INVALID KEY NOR AT END--MUST BE SIZE ERROR
SPIF5: MOVE CH,[XWD SKIPN.,SZERA.]
SKIPE EMULSZ
PUSHJ PP,PUT.EX##
SETZM EMULSZ
PUSHJ PP,SPIF3 ;PUT OUT THE JRST
SKIPN CH,ESZERA ;ANY TAG TO GO?
POPJ PP, ;NO--QUIT
SETZM ESZERA ;YES--CLEAR INDICATOR
JRST PUTTAG ;PUT OUT THE TAG--THEN QUIT
;GENERATE CODE TO COMPARE A FIELD TO ZEROES.
IFZERO: TSWF FAINAC ;IS 'A' IN AC'S?
JRST IFZ20 ;YES
MOVE TE,ESIZEA
MOVEM TE,ESIZEZ
HRRZ TE,EMODEA
CAILE TE,DSMODE
JRST IFZ2
TSWF FANUM ;IS 'A' NUMERIC?
JRST IFZ19 ;YES
HRRZ TD,W2 ; [441] GET IF OPERATOR
CAIN TD,22 ; [441] IFT ( IF A ZERO ) TYPE?
JRST IFZZ0 ; [441] YES USE ALGEBRAIC COMPARES
; IF A OP ZERO FOR A NON-NUMERIC USE CHAR COMPARE
HRRZ TD,IFZROS(TE) ;[1034] [441] GET SOME KIND OF ZERO.
SETO CH, ;[1034] ALWAYS USE IN-LINE CODE
SKIPLE COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
XCT CSCHAR(TE) ;YES, GET CONVERTED ZERO
PUSHJ PP,TSTCOL ;[1004] NEED OTHER COL. SEQ.?
JRST [MOVE TE,EMODEA ;[1004] YES
HRRZ TD,OTHZRO(TE) ;[1004] GET OTHER MODE'S ZERO
JRST .+1] ;[1004]
JRST IFSP1 ;[1034]
;NOT DISPLAY
IFZ2: CAIN TE,C3MODE ;IF THE OPERAND IS COMP-3,
JRST IFZ19 ; GO GET IT INTO THE AC'S.
TLZE W1,NOTF
TLC W1,CONCMP
PUSHJ PP,SUBSCD
HRRZ TE,EMODEA
CAIN TE,D2MODE
JRST IFZ5
IFZ3: MOVSI CH,SKIP.
LDB TE,CONDIT
ROT TE,-^D9
ADD CH,TE
PUSHJ PP,PUT.A
JRST JFALSE
IFZZ0: HRRZ TD,IFZROS(TE) ;GET SOME KIND OF ZERO
MOVEM TD,ESAVAC ;SAVE ZERO CHAR
SETO CH,
JRST IFZ1D
IFZROS: XWD ZERO%6##,20 ;DISPLAY-6 ZERO.
XWD ZERO%7##,60 ;DISPLAY-7 ZERO.
XWD ZERO%9##,360 ;DISPLAY-9 ZERO.
OTHZRO: XWD 0,360 ;[1004] DISPLAY-9 ZERO
XWD 0,360 ;[1004] DISPLAY-9 ZERO
XWD 0,60 ;[1004] DISPLAY-7 ZERO
IFZ5: LDB TE,CONDIT
JRST @.(TE)
EXP IFZ6 ;=
EXP IFZ12 ;> [177]
EXP IFZ9 ;NOT <
EXP IFZ3 ;<
EXP IFZ10 ;NOT >
EXP IFZ8 ;NOT =
IFZ6: MOVSI CH,SKIPN.
PUSHJ PP,PUT.A
MOVSI CH,SKIPE.
IFZ6A: AOS EINCRA ; SKIPX AC+1 [177]
PUSHJ PP,PUT.A
IFZ7: SOS EINCRA
JRST JFALSE
IFZ8: MOVSI CH,SKIPN.
PUSHJ PP,PUT.A
AOS EINCRA
MOVSI CH,SKIPE.
PUSHJ PP,PUT.A
MOVSI CH,SKIPA.
PUSHJ PP,PUTASY
JRST IFZ7
IFZ9: MOVSI CH,SKPGE. ;[177] SKIPGE AC
PUSHJ PP,PUT.A ;[177] PUT IN ASSEMBLY FILE
JRST JFALSE ;[177] ENTER JRST FALSE
;[177] NO NEED TO CHECK 2ND WORD SINCE G.E. 0
IFZ10: MOVSI CH,SKPGE. ;[177] SKIPGE AC
PUSHJ PP,IFZ13
JRST IFZ6
IFZ12: MOVSI CH,SKPLE. ;[177] SKIPLE AC,
PUSHJ PP,IFZ13
MOVSI CH,SKIPN. ;[177] SKIPN AC
PUSHJ PP,PUT.A ;[177] PUT IN ASSY FILE
MOVSI CH,SKIPN. ;[177] SKIPN AC+1
JRST IFZ6A ;[177] FINISH UP
IFZ13: PUSHJ PP,PUT.A ;[177] PUT IN ASSY FILE
MOVE CH,[XWD JRST.+ASINC,AS.MSC] ;[177] PUT IN JRST .+4
PUSHJ PP,PUTASY ;[177] PUT IN ASSY FILE
HRRZI CH,AS.DOT+4 ;[177] .+4
JRST PUTASN ;[177]
;COMPARE A FIELD AGAINST ZEROES (CONT'D).
;"A" IS NUMERIC DISPLAY OR COMP-3.
IFZ19: PUSHJ PP,MOVXAC ; [413] GET IT INTO AC'S
SWON FAINAC;
;"A" IS IN THE AC'S.
IFZ20: HRRZ TE,EMODEA
CAIN TE,D2MODE
JRST IFZ22
IFZ21: ;ENTER HERE FROM CAMX AC,0
MOVSI CH,JUMP.
LDB TE,CONDIT
TLNN W1,NOTF
TRC TE,CONCMP/100
ROT TE,-^D9
ADD CH,TE
MOVE TE,EAC
DPB TE,CHAC
JRST JFLSEA
IFZ22: LDB TE,CONDIT
TLNE W1,NOTF
TRC TE,CONCMP/100
JRST @.(TE)
EXP IFZ26 ;=
EXP IFZ23 ;>
EXP IFZ24 ;NOT <
EXP IFZ23A
EXP IFZ25 ;NOT >
EXP IFZ27 ;NOT =
IFZ23: MOVE CH,[XWD JUMPG.+ASINC,AS.MSC] ;[177] JUMPG AC,
PUSHJ PP,PUT.XA ;[177] ASSEMBLE IT
HRRZI CH,AS.DOT+3 ;[177] RH OF JUMPG .+3
PUSHJ PP,PUTASN ;[177] ASSEMBLE IT
MOVSI CH,JUMPN. ;[177] JUMPN AC,
MOVE TE,EAC ;[177] GET AC
DPB TE,CHAC ;[177] PUT IN AC FIELD
PUSHJ PP,JFLSEA ;[177] JUMPN AC, FALSE
MOVSI CH,JUMPE. ;[177] JUMPE AC+1,
AOSA EAC ;[177] BUMP AC
IFZ23A: MOVSI CH,JMPGE. ;[177] FOR <, JUMPGE AC,
IFZ23B: MOVE TE,EAC
DPB TE,CHAC
JRST JFLSEA
IFZ24: MOVE CH,[XWD JUMPG.+ASINC,AS.MSC] ;[177] JUMPG AC.
PUSHJ PP,PUT.XA ;[177] ASSEMBLE IT
HRRZI CH,AS.DOT+2 ;[177] JUMPG AC,.+2
PUSHJ PP,PUTASN ;[177] ASSEMBLE
MOVSI CH,JUMPN. ;[177] JUMPN AC+1,
JRST IFZ23B ;[177] FINISH UP
IFZ25: MOVE CH,[XWD JUMPL.+ASINC,AS.MSC]
MOVE TE,EAC
DPB TE,CHAC
PUSHJ PP,PUTASY
HRRZI CH,AS.DOT+3
PUSHJ PP,PUTASN
IFZ26: MOVSI CH,JUMPN.
MOVE TE,EAC
DPB TE,CHAC
PUSHJ PP,JFLSEA
IFZ261: MOVE TE,EAC
ADDI TE,1
DPB TE,CHAC
JRST JFLSEA
IFZ27: MOVE CH,[XWD JUMPN.+ASINC,AS.MSC]
PUSHJ PP,PUT.XA
HRRZI CH,AS.DOT+2 ; .+2
PUSHJ PP,PUTASN
MOVSI CH,JUMPE.
JRST IFZ261
;GENERATE CODE TO COMPARE AN ALPHANUMERIC FIELD TO SPACES.
IFSPAC: MOVE TE,ESIZEA
MOVEM TE,ESIZEZ
SWOFF FASIGN;
MOVE TE,EMODEA
CAILE TE,DSMODE ;IF IT'S NOT SOME KIND OF
JRST BADFIG ; DISPLAY, IT'S AN ERROR.
HRRZ TD,IFSPCS(TE) ;GET SOME KIND OF SPACE.
SETO CH, ;[1034] ALWAYS GENERATE INLINE CODE IF POSSIBLE
SKIPLE COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
XCT CSCHAR(TE) ;[1034] [720] YES, GET CONVERTED SPACE
PUSHJ PP,TSTCOL ;[1004] SEE IF OTHER COL. SEQ.
JRST [MOVE TE,EMODEA ;[1004]
HRRZ TD,OTHSPC(TE) ;[1004] GET THE OTHER COL. SEQ. SPACE
JRST .+1] ;[1004]
IFSP1: MOVEM TD,ESAVAC ;[1034]
PUSHJ PP,SPECIL ;[1034]
POPJ PP, ;[1034] "CAM" GENERATED--EXIT
SKIPLE COLSEQ ;[1034] IF PROGRAM COLL. SEQ. = ALPHABET-NAME
JRST IFQHV2 ;[1034] WE MUST WORRY ABOUT EQUIVALENT CHARS.
IFZ1D: LDB TE,CONDIT ;[1034] IF CONDITION IS
CAIE TE,EQ ;[1034] EQUAL OR
CAIN TE,NOTEQ ;[1034] NOT EQUAL,
JRST IFSP3 ;[1034] SPECIAL PROCESSING
JRST IFQHV2 ;[1034] ELSE NORMAL
IFSP3: JUMPL CH,IFSP3A ;[1034] [717] IF GENERATING INLINE CODE SIZE DOES'NT MATTER
HRRZ TE,ESIZEA ;[717] GET LENGTH OF ITEM
SUBI TE,10 ;[717] TO GET REMAINDER OF 3777
IDIVI TE,3770 ;[717] FIND NUMBER OF PIECES TO BREAK IT INTO
ADDI TD,10 ;[717] AVOIDS REMAINDER OF 0
PUSH PP,TD ;[717] SAVE REMAINDER
MOVEM TE,ECNTA ;[717] SAVE COUNT OF LEADING PIECES
JUMPE TE,IFSP3C ;[717] ONLY ONE PIECE
IFSP3B: MOVEI TE,3770 ;[717] LENGTH OF FIRST PIECES IS CONSTANT
MOVEM TE,ESIZEA ;[717] ...
MOVEM TE,ESIZEZ ;[717] ...
PUSH PP,CH ;SAVE CONVERSION ROUTINE
PUSHJ PP,IFSP3A ;AND DO FIRST PART
POP PP,CH
MOVE TE,EMODEA ;GET MODE
MOVE TE,[EXP 3770/6,3770/5,3770/4](TE)
ADDM TE,EINCRA ;MOVE DOWN STRING
SOSLE ECNTA ;[717] DECREMENT PIECE COUNT
JRST IFSP3B ;[717] LOOP UNTIL STRING IS SMALL ENOUGH
IFSP3C: POP PP,TE ;[717] GET SIZE OF LAST PIECE
MOVEM TE,ESIZEA ;[717] RESTORE IT
MOVEM TE,ESIZEZ ;[717] ...
IFSP3A: TLZE W1,NOTF
TLC W1,CONCMP
PUSH PP,CH ;COULDN'T USE "CAM"
;IF WE HAVE PUT -1 IN CH, USE INLINE CODE (EXTEND IF BIS).
; ELSE, CH WILL CONTAIN AN EXTAB ADDRESS - USE OLD METHOD
JUMPGE CH,IFSP4 ;[1034] NOT INLINE CODE, SETUP OPERAND OLD WAY
PUSHJ PP,NB1PAR##
POP PP,CH
JRST BFIGCM ;GENERATE INLINE COMPARISON, THEN "JRST FALSE"
IFSP4: PUSHJ PP,B1PAR ;[1034]
POP PP,CH
IFSP5: TSWF FASUB; ;IS THE OPERAND SUBSCRIPTED?
SETZ EACC, ;YES, NOTE IT FOR PMOPV.
PUSHJ PP,PMOPV.## ;GO GENERATE
; HRRZI 16, PARM
; PUSHJ 17, RTN
IFSP6: SKIPLE ECNTA ;[717] ON LAST PIECE?
JRST JMPOUT ;[717] NO
MOVSI CH,SKIPA.
TLNN W1,EQUALF
PUSHJ PP,PUTASY
JRST JFALSE
BADFIG: MOVEI DW,E.211
MOVE TC,OPERND
MOVE TC,0(TC)
LDB LN,TCLN
LDB CP,TCCP
JRST FATAL
IFSPCS: EXP 0 ;DISPLAY-6 SPACE.
EXP 40 ;DISPLAY-7 SPACE.
EXP 100 ;DISPLAY-9 SPACE.
CSCHAR: HLRZ TD,PRGCOL##+240(TD) ;SIXBIT
HLRZ TD,PRGCOL(TD) ;ASCII
HRRZ TD,PRGCOL(TD) ;EBCDIC
OTHSPC: XWD 177,100 ;[1004] DISPLAY-9 QUOTE ,, SPACE
XWD 177,100 ;[1004] DISPLAY-9 QUOTE ,, SPACE
XWD 42, 40 ;[1004] DISPLAY-7 QUOTE ,, SPACE
;HERE TO GENERATE INLINE CODE TO
;COMPARE A STRING AGAINST A FIG. CONSTANT
; (ZEROES OR SPACES)
;CALL:
; <GEN CODE TO PUT BYTE PTR IN AC5>
; ESAVAC/ A CHARACTER OF FIG. CONSTANT IN THE CORRECT MODE
; GENERATES:
; EXTEND OR EQUIVALENT CODE
; JRST FALSE ;CONDITION (EQ,NOTEQ) NOT MET
BFIGCM: MOVE TE,ESIZEA ;IF SIZE IS 1
SOJE TE,BFIGC1 ;DON'T USE EXTEND
MOVE CH,[MOVEI.+AC4+ASINC,,AS.CNB]
PUSHJ PP,PUTASY##
MOVE CH,ESIZEA
PUSHJ PP,PUTASN##
MOVE CH,[SETZB.+AC7,,10]
PUSHJ PP,PUTASY##
MOVE TA,[XTNLIT,,1]
PUSHJ PP,STASHP
MOVSI TA,(CMPSE)
TLNN W1,EQUALF
MOVSI TA,(CMPSN)
PUSHJ PP,STASHQ
MOVE TA,[OCTLIT,,1]
PUSHJ PP,STASHP
SETZ TA,
PUSHJ PP,STASHQ
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHP
SETZ TA,
PUSHJ PP,STASHQ
MOVE TA,ESAVAC ;GET CHARACTER VALUE
PUSHJ PP,POOLIT ;THAT'S ALL!
PUSHJ PP,PUTASA## ;EXTEND, IN 2ND SET OF OPCODES
MOVSI CH,XTND.+AC4
PUSHJ PP,PUT.LD## ;GENERATE THE EXTEND
SKIPE PLITPC
JRST JFALSE ;"JRST FALSE"
MOVEI TE,3
ADDM TE,ELITPC## ;UPDATE ELITPC IF NOT POOLED
JRST JFALSE ;PUT OUT JUMP TO FALSE PATH
BFIGC1: MOVE CH,[ILDB.,,5]
PUSHJ PP,PUT.XA## ;GEN ILDB AC,5
;CAIE AC,"CHAR"
MOVSI CH,CAIE.
TLNN W1,EQUALF
MOVSI CH,CAIN.
HRR CH,ESAVAC##
PUSHJ PP,PUT.XA##
JRST JFALSE
;GENERATE CODE TO COMPARE A FIELD AGAINST QUOTES
IFQUOT: HRRZ TE,EMODEA ;SEE WHAT A'S
HRRZ TD,HIVQOT(TE) ;GET SOME KIND OF QUOTE.
SKIPLE COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
XCT CSCHAR(TE) ;YES, GET CONVERTED QUOTE
PUSHJ PP,TSTCOL ;[1004] NEED OTHER COL. SEQ.?
JRST [MOVE TE,EMODEA ;[1004] YES
HLRZ TD,OTHSPC(TE) ;[1004] GET OTHER MODE'S QUOTE
JRST .+1] ;[1004]
JRST IFQHV0 ;GO GENERATE SOME CODE.
;GENERATE CODE TO COMPARE A FIELD AGAINST SYMBOLIC-CHARACTER
IFSYMB: HRRZ TA,ETABLB ;GET MNETAB ITEM
JUMPE TA,IFSPAC ;ERROR, JUST USE SPACES
PUSHJ PP,LNKSET
LDB TE,MN.SCV## ;GET CHARACTER
LDB TD,MN.ESC## ;GET EBCDIC FLAG
JUMPN TD,IFSYME ;ITS AN EBCDIC CHARACTER
HRRZ TD,EMODEA ;SEE WHAT A'S
XCT VLIT6.##(TD) ;CONVERT TO REQUIRED MODE
HRRZ TD,TE ;PUT WHERE EXPECTED
JRST IFQHV0 ;GO GENERATE SOME CODE.
IFSYME: HRRZ TD,EMODEA ;SEE WHAT A'S
XCT VLIT9.##(TD) ;CONVERT TO REQUIRED MODE
HRRZ TD,TE ;PUT WHERE EXPECTED
JRST IFQHV0 ;GO GENERATE SOME CODE.
;GENERATE CODE TO COMPARE A FIELD AGAINST HIGH-VALUES
IFHIV: HRRZ TE,EMODEA
CAILE TE,DSMODE ;IS A SOME KIND OF DISPLAY?
JRST IFHV1 ;NO, GO WORRY OVER NUMBERS.
SKIPL TD,COLSEQ ;[1374] WAS ASCII OR EBCDIC COLL SEQ DECLARED?
JRST IFHIVA ;[1374] NO, CONT
TRNE TD,%AN.EB ;[1374] YES, WAS IT EBCDIC?
MOVEI TE,D9MODE ;[1374] YES, CHANGE MODE OF HIGH-VAL TO EBCDIC
IFHIVA: HLRZ TD,HIVQOT(TE) ;[1374] GET SOME KIND OF HIGH VALUES.
JRST IFQHV0 ;GO GENERATE SOME CODE.
IFHV1: PUSHJ PP,HIVAL##
MOVE EACC,EHIVAL
IFHIV2: TSWT FAINAC ;IS "A" IN THE AC'S?
PUSHJ PP,MXAC. ;NO--GET IT THERE
HRRZ TE,EMODEA
CAIN TE,D2MODE
JRST IFHIV3
MOVE CH,[XWD CAM.+ASINC,AS.MSC]
LDB TE,CONDIT
ROT TE,-^D8
ADD CH,TE
PUSHJ PP,PUT.XA
HRRZ CH,EACC
PUSHJ PP,PUTASN
JRST JFALSE
INTERN HIVQOT ;[547] MAKE INTERN FOR MSCGEN
HIVQOT: XWD 77,2 ;DISPLAY-6 HIGH-VALUES, QUOTE.
XWD 177,42 ;DISPLAY-7 HIGH-VALUES, QUOTE.
XWD 377,177 ;DISPLAY-9 HIGH-VALUES, QUOTE.
;GENERATE CODE FOR 2-WORD COMPARE
IFHIV3: LDB TE,CONDIT
JRST @[EXP IFHV21,IFHV22,IFHV23,IFHV24,IFHV25,IFHV26]-1(TE)
;HERE FOR EQUAL OR NOTEQUAL
IFHV21: IFHV26:
MOVE CH,[CAMN.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
PUSHJ PP,PUTASN
MOVE CH,[CAME.+ASINC+AC1,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
ADDI CH,1
PUSHJ PP,PUTASN
MOVEI TC,AS.DOT+2
TLNN W1,EQUALF
PUSHJ PP,JOUT ;NOT EQUAL
JRST JFALSE
;HERE FOR LESS THAN OR LESS THAN OR EQUAL
IFHV24: IFHV25:
MOVE CH,[CAMGE.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
PUSHJ PP,PUTASN
MOVEI TC,AS.DOT+4
PUSHJ PP,JOUT
MOVE CH,[CAMG.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
PUSHJ PP,PUTASN
MOVE CH,[CAML.+ASINC+AC1,,AS.MSC]
TLNE W1,EQUALF
HRLI CH,CAMLE.+ASINC+AC1
IFHV20: PUSHJ PP,PUTASY
HRRZ CH,EACC
ADDI CH,1
PUSHJ PP,PUTASN
JRST JFALSE
;HERE FOR GREATER THAN OR GREATER THAN OR EQUAL
IFHV22: IFHV23:
MOVE CH,[CAMLE.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
PUSHJ PP,PUTASN
MOVEI TC,AS.DOT+4
PUSHJ PP,JOUT
MOVE CH,[CAML.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
PUSHJ PP,PUTASN
MOVE CH,[CAMG.+ASINC+AC1,,AS.MSC]
TLNE W1,EQUALF
HRLI CH,CAMGE.+ASINC+AC1
JRST IFHV20
;GENERATE CODE TO COMPARE A FIELD AGAINST LOW-VALUES
IFLOV: HRRZ TE,EMODEA
SETZM ESAVAC
CAIG TE,DSMODE
JRST IFQHV1
CAIE TE,FPMODE
CAIN TE,F2MODE
JRST IFLOV2
PUSHJ PP,LOVAL##
MOVE EACC,ELOVAL
JRST IFHIV2
IFLOV2: PUSHJ PP,FPLOV.
MOVE EACC,EFPLOV
JRST IFHIV2
;GENERATE CODE TO COMPARE A DISPLAY FIELD AGAINST QUOTES OR HIGH-VALUES.
;EITHER A QUOTE OR A HI-VALUE IS IN TD.
IFQHV0: MOVEM TD,ESAVAC
;GENERATE CODE TO COMPARE A DISPLAY FIELD AGAINST QUOTES, HIGH-VALUES, OR
;LOW-VALUES.
;CHARACTER TO COMPARE AGAINST IS IN ESAVAC.
IFQHV1: PUSHJ PP,SPECIL
POPJ PP, ;"CAM" GENERATED--EXIT
IFQHV2: PUSHJ PP,SUBSCA
TSWF FASUB;
JRST IFQHV3
MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPA
PUSHJ PP,POOL
MOVE CH,[XWD MOV+ASINC+SAC,AS.MSC]
PUSHJ PP,PUTASY
SKIPN CH,PLITPC
HRRZ CH,ELITPC
IORI CH,AS.LIT
PUSHJ PP,PUTASN
SKIPN PLITPC
AOS ELITPC
IFQHV3: SETZM EAC
MOVSI CH,MOV## ;GENERATE <MOVEI 0,SIZE>
HRRZ TC,ESIZEA
PUSHJ PP,PUT.LA
PUSHJ PP,GETTAG
MOVEM CH,ESAVAC+1
PUSHJ PP,PUTTAG
MOVE CH,[XWD ILDB.+AC2,SXR]
PUSHJ PP,PUTASY
PUSHJ PP,TSTCOL ;[1004] SEE IF WE NEED OTHER COL. SEQ.
JRST [MOVE TC,EMODEA ;[1004] YES
MOVSI CH,LDB.+AC2 ;[1004] NEED TO CONVERT FROM ONE
HRR CH,SUTBL(TC) ;[1004] CHARACTER SET TO THE OTHER
IFE TOPS20,<
TSWT FREENT ;[1004] NO INDIRECT IF /R
>
IFN TOPS20,<
SKIPN RENSW## ;[1004] NO INDIRECT IF /R
>
TLO CH,(@) ;[1004] TURN ON INDIRECT BIT IF NOT /R
PUSHJ PP,PUT.EX ;[1004]
JRST IFQHV4] ;[1004]
SKIPG COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
JRST IFQHV4 ;NO
MOVE CH,[MOV+AC2+ASINC+2,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ TC,EMODEA
MOVE CH,COLSQS(TC) ;GET LITERAL BASE
PUSHJ PP,PUTASN
IFQHV4: LDB TE,CONDIT
CAIE TE,EQ
JRST IFQHV5
SKIPN CH,ESAVAC ;GET COMPARE VALUE
JRST [MOVSI CH,JUMPN.+AC2 ;SIXBIT LOW-VALUES
PUSHJ PP,JFLSEA ;GENERATE JUMPN 2,FALSE
JRST IFQHV7]
HRLI CH,CAIE.+AC2
PUSHJ PP,PUTASY
PUSHJ PP,JFALSE
IFQHV7: HRRZ TA,ESAVAC+1 ;THIS IS A TAG WE ARE ABOUT TO REFERENCE
PUSHJ PP,REFTAG## ;SO REMEMBER THAT
MOVSI CH,SOJG.
HRR CH,ESAVAC+1
JRST PUTASY
SUTBL: EXP SU.S69## ;[1004] SIXBIT TO EBCDIC
EXP SU.S79## ;[1004] ASCII TO EBCDIC
EXP SU.S97## ;[1004] EBCDIC TO ASCII
;GENERATE CODE TO COMPARE A DISPLAY FIELD AGAINST QUOTES, ETC. (CONT'D)
;A "CAM" WOULDN'T DO, AND IT IS NOT "EQUALS".
IFQHV5: MOVSI CH,CAIN.+AC2 ;GENERATE: CAIN 2,<VALUE>
HRR CH,ESAVAC
PUSHJ PP,PUTASY
HRRZ TA,ESAVAC+1 ;GET TAG TO REFERENCE
PUSHJ PP,REFTAG## ; SO OPTIMIZER KNOWS
MOVSI CH,SOJG. ; SOJG 0,%X
HRR CH,ESAVAC+1
PUSHJ PP,PUTASY
LDB TE,CONDIT ;IS IT
CAIE TE,NOTEQ ; 'NOT EQUAL'?
JRST IFQHV6 ;NO
MOVSI CH,JMPLE. ; JUMPLE 0,<FALSE>
JRST JFLSEA
;A "CAM" WOULDN'T DO, AND IT'S NEITHER "EQUALS" NOR "NOT EQUALS".
IFQHV6: SKIPN ESAVAC ;IS THE CONSTANT = 0?
JRST IFQHV8 ;YES, USE JUMPX INSTEAD
MOVSI CH,CAI.+AC2
ROT TE,-^D8
ADD CH,TE
HRR CH,ESAVAC
PUSHJ PP,PUTASY
JRST JFALSE
IFQHV8: MOVSI CH,JUMP.+AC2
LDB TE,CONDIT
TLNN W1,NOTF
TRC TE,CONCMP/100
ROT TE,-^D9
ADD CH,TE
JRST JFLSEA
;GENERATE CODE TO SEE IF A FIELD IS ALPHABETIC
IFALF: MOVE TE, EMODEA
CAILE TE, DSMODE ;IF IT'S NOT DISPLAY,
JRST IFNM3 ; IT'S AN ERROR.
TSWF FANUM ;IS IT NUMERIC?
JRST IFNM3 ;YES--ERROR
;GENERATE CODE TO DO EXTEND IN-LINE
PUSH PP,ALPS.T(TE) ;SAVE EXTEND INSTRUCTION FOR LATER
IFALF1: PUSHJ PP, NB1PAR ;[550] GET BP TO PARAM IN AC5
MOVE TA, [OCTLIT,,1] ;GENERATE OCTAL LITERAL
PUSHJ PP, STASHP ; POOLED, TO HOLD AC4 CONTENTS
HRRZ TA, ESIZEA ;RH OF AC4 HAS SIZE
TLO TA, 400000 ;LH HAS SIGNIFICANCE BIT
PUSHJ PP, POOLIT ;GENERATE AND POOL LITERAL
HRLZI CH, MOV+AC4 ;NOW GENERATE MOVE AC4,LITERAL
PUSHJ PP, PUT.LD ;
SKIPN PLITPC ;BUMP LITERAL COUNT IF NOT POOLED
AOS ELITPC ;
;[550] PUSHJ PP, NB1PAR ;GET BP TO PARAM IN AC5
MOVE CH, [MOVEI.+AC7+ASINC,,AS.CNB] ;GENERATE MOVE OF
PUSHJ PP, PUTASY ;SIZE TO AC7 ALSO
HRRZ CH, ESIZEA ;HALF WORD SIZE ALLOWED
PUSHJ PP, PUTASN ;DONT INCR PC COUNT
MOVSI CH, MOVEI.+AC10 ;NOW GENERATE SETZ AC10,0
PUSHJ PP, PUTASY ;SO NOT TO GET DESTINATION STRING
MOVE TA, [XTNLIT,,1] ;GENERATE THE EXTEND INSTR
PUSHJ PP, STASHP ;POOLED IF POSSIBLE.
POP PP,TA ;GET BACK EXTEND INSTRUCTION
IFE TOPS20,<
TSWF FREENT ;NO INDIRECT IF /R
>
IFN TOPS20,<
SKIPE RENSW## ;NO INDIRECT IF /R
>
TLZ TA, (@) ;SO TURN IT OFF
PUSHJ PP, POOLIT ;GENERATE LITERAL POOLED
PUSHJ PP, PUTASA ;EXTEND INSTR IS IN SECOND SET
MOVSI CH, XTND.##+AC4
PUSHJ PP, PUT.LD ;OUTPUT USING LAST LITERAL (THE MOVST)
SKIPN PLITPC ;BUMP LITERAL COUNT IF NECESSARY
AOS ELITPC
MOVSI CH,SKIPA. ;GENERATE SKIPA
TLNE W1,NOTF ;IF TEST IS FOR NOT ALPHABETIC
PUSHJ PP,PUTASY
JRST JFALSE ;GO TO FALSE BRANCH
ALPS.T: MOVST @ALPS.6## ;SIXBIT
MOVST @ALPS.7## ;SEVEN BIT
MOVST @ALPS.9## ;EBCDIC
;GENERATE CODE TO SEE IF A FIELD IS ALPHABETIC-LOWER
IFLCA: MOVE TE,EMODEA
CAILE TE,DSMODE ;IF IT'S NOT DISPLAY,
JRST IFNM3 ; IT'S AN ERROR.
TSWF FANUM ;IS IT NUMERIC?
JRST IFNM3 ;YES--ERROR
CAIN TE,D6MODE ;THERE IS NO LOWER CASE IN SIXBIT
JRST IFALFZ ;GIVE ERROR AND GENERATE CONSTANT CODE
PUSH PP,ALPL.T(TE) ;PUT EXTEND INST ON STACK FOR LATER
JRST IFALF1 ;JOIN COMMON CODE
ALPL.T: 0 ;SIXBIT - NO LOWER CASE
MOVST @ALPL.7## ;SEVEN BIT
MOVST @ALPL.9## ;EBCDIC
IFUCA: MOVE TE,EMODEA
CAILE TE,DSMODE ;IF IT'S NOT DISPLAY,
JRST IFNM3 ; IT'S AN ERROR.
TSWF FANUM ;IS IT NUMERIC?
JRST IFNM3 ;YES--ERROR
PUSH PP,ALPU.T(TE) ;PUT EXTEND INST ON STACK FOR LATER
JRST IFALF1 ;JOIN COMMON CODE
ALPU.T: MOVST @ALPS.6## ;SIXBIT - SAME AS ALPHABETIC
MOVST @ALPU.7## ;SEVEN BIT
MOVST @ALPU.9## ;EBCDIC
IFALFZ: MOVEI DW,E.805 ;WARN USER
TLC W1,NOTF ;INVERT TEST TO MAKE IT GIVE "CORRECT" RESULT
JRST IFNM5
;GENERATE CODE TO SEE IF A FIELD IS NUMERIC
IFNUM: MOVE TE,EMODEA
CAIN TE,C3MODE ;COMP-3?
SETO TE, ;YES, MAKE INDEX VALID
CAILE TE,DSMODE ;IF IT'S NOT DISPLAY,
JRST IFNM4 ; IT'S ALWAYS NUMERIC, COMPLAIN.
HRRZ CH,ALFNUM(TE) ;GET THE ROUTINE'S EXTAB LINK.
MOVE TA,ETABLA
PUSHJ PP,LNKSET
LDB TE,DA.CLA
CAIN TE,ALPHAB
JRST IFNM3
IFNM2: MOVE TE,ESIZEA
MOVEM TE,ESIZEZ
JRST IFSP3
IFNM3: MOVEI DW,E.211
LDB LN,W1LN
LDB CP,W1CP
JRST FATAL
IFNM4: MOVEI DW,E.212
TLNE W1,NOTF
MOVEI DW,E.213
IFNM5: LDB LN,W1LN
LDB CP,W1CP
PUSHJ PP,WARN
TLNE W1,NOTF
JRST JFALSE
POPJ PP,
;EXTAB LINKS FOR ALPHABETIC AND NUMERIC ROUTINES.
EXP NUM%3## ;COMP-3
ALFNUM: XWD ALF%6##,NUM%6## ;DISPLAY-6.
XWD ALF%7##,NUM%7## ;DISPLAY-7.
XWD ALF%9##,NUM%9## ;DISPLAY-9.
;GENERATE CODE TO SEE IF A FIELD IS POSITIVE
IFPOS: MOVE TE,EMODEA
CAILE TE, DSMODE ;IF IT'S NOT DISPLAY, GO
JRST IFPOS3 ; DO A NUMERIC COMPARISON.
HLRZ CH, POSNEG(TE) ;SELECT THE ROUTINE'S EXTAB LINK.
IFPOS2: MOVE TA,ETABLA
PUSHJ PP,LNKSET
LDB TE,DA.CLA
CAIE TE,NUMERC
JRST IFNM3
JRST IFNM2
IFPOS3: TSWT FAINAC; ;IF THE OPERAND IS IN THE AC'S
CAIN TE, C3MODE ; OR IS COMP-3, GO USE A JUMP.
JRST IFPOS4
HRRZ TE,EMODEA
CAIN TE,D2MODE ;TWO-WORD?
JRST IFPO31 ;YES
PUSHJ PP,SUBSCA
MOVSI CH,SKIPG.
TLNE W1,NOTF
MOVSI CH,SKPLE.
PUSHJ PP,PUT.A
JRST JFALSE
; TWO-WORD COMP, TEST FOR POSITIVE OR NOT POSITIVE
; GENERATE SKIPL <DATA-NAME>
; SKIPG <DATA-NAME>+1
; FOR POSITIVE
; GENERATE SKIPG <DATA-NAME>
; SKIPLE <DATA-NAME>+1
; FOR NOT POSITIVE
IFPO31: PUSHJ PP,SUBSCD
MOVSI CH,SKIPL.
TLNE W1,NOTF
MOVSI CH,SKIPG.
PUSHJ PP,PUT.A
MOVSI CH,SKIPG.
TLNE W1,NOTF
MOVSI CH,SKPLE.
AOS EINCRA
PUSHJ PP,PUT.A
SOS EINCRA
JRST JFALSE
IFPOS4: TSWTS FAINAC; ;IF THE OPERAND ISN'T IN THE
PUSHJ PP, MOVXAC ; [413] AC'S, GO GET IT THERE.
HRRZ TE,EMODEA
CAIE TE,D2MODE
JRST IFPO41 ;ONE-WORD
MOVE CH,[XWD JUMPG.+ASINC,AS.MSC]
TLNE W1,NOTF
MOVE CH,[XWD JUMPL.+ASINC,AS.MSC]
PUSHJ PP,PUT.XB
HRRZI CH,AS.DOT+2
PUSHJ PP,PUTASN
TLNN W1,NOTF
JRST IFPO41
MOVSI CH,JUMPG.
MOVE TE,EAC
ADDI TE,1
DPB TE,CHAC
PUSHJ PP,JFLSEA
IFPO41: MOVSI CH,JMPLE.
TLNE W1,NOTF
MOVSI CH,JUMPG.
IFPOS5: MOVE TE,EAC
DPB TE,CHAC
JRST JFLSEA
;GENERATE CODE TO SEE IT A FIELD IS NEGATIVE
IFNEG: MOVE TE,EMODEA
CAILE TE, DSMODE ;IF IT'S NOT DISPLAY, GO
JRST IFNEG2 ; DO A NUMERIC COMPARISON.
HRRZ CH, POSNEG(TE) ;SELECT THE APPROPRIATE ROUTINE.
JRST IFPOS2
IFNEG2: TSWT FAINAC; ;IF THE OPERAND IS IN THE AC'S
CAIN TE, C3MODE ; OR IS COMP-3, GO USE A JUMP.
JRST IFNEG4
PUSHJ PP,SUBSCA
MOVSI CH,SKIPL.
TLNE W1,NOTF
MOVSI CH,SKPGE.
PUSHJ PP,PUT.A
JRST JFALSE
IFNEG4: TSWTS FAINAC; ;IF THE OPERAND ISN'T IN THE
PUSHJ PP, MOVXAC ; [413] AC'S, GO GET IT THERE.
MOVSI CH,JMPGE.
TLNE W1,NOTF
MOVSI CH,JUMPL.
JRST IFPOS5
;EXTAB LINKS FOR THE POSITIVE AND NEGATIVE ROUTINES.
POSNEG: XWD POS%6##,NEG%6## ;DISPLAY-6.
XWD POS%7##,NEG%7## ;DISPLAY-7.
XWD POS%9##,NEG%9## ;DISPLAY-9.
IFN DBMS,<
;GENERATE CODE FOR "IFDB" OPERATOR
IFDBGN: MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;ANY OPERANDS?
POPJ PP, ;NO, MUST BE A "YECCH"
;PUT "SET-NAME" IN LITERAL POOL
HRRZ CH,ELITPC ;GET LIT LOC
IORI CH,AS.LIT
HRRZM CH,LITNN## ; [437] STORE FOR USE IN BYTE STRING DESCRIPTOR
HRRZ TA,EOPLOC ;GET OPERAND
HRRZ TA,2(TA)
PUSHJ PP,LNKSET ;GET ITS VALTAB ADDR
HRRZI TD,(TA) ;MAKE BYTE PTR FOR ILDB LOOP
MOVSI TB,(POINT 7,(TD),13) ;ILDB PTR TO BYTE 3
LDB TC,[POINT 14,(TD),13] ;GET BYTE COUNT FROM FIRST TWO VALTAB BYTES
HRLM TC,LITNN ; [437] SAVE FOR USE IN BYTE STRING DESCRIPTOR
MOVEI TE,5(TC) ;CONVERT BYTE COUNT TO WORD COUNT
MOVEI TA,6 ;[273]SIX SIXBIT BYTES PER WORD
IDIVM TE,TA
PUSH PP,TA ;SAVE LITERAL INCREMENT
HRLI TA,SIXLIT## ;PUT OUT "SIXLIT,,WORD-COUNT" HEADER
PUSHJ PP,STASHI
POP PP,TA
ADDM TA,ELITPC ;BUMP LITERAL POOL PC
IFDB0: SETZ TA, ;INIT FOR ACCUMULATION OF A SIXBIT WORD
MOVE TE,[POINT 6,TA]
IFDB1: SOJL TC,IFDB2 ;CHECK BYTE COUNT
ILDB CH,TB ;GET VALTAB BYTE
SUBI CH,40 ;CONVERT TO SIXBIT
IDPB CH,TE
TRNN TA,77 ;TA FULL?
JRST IFDB1 ;NO
IFDB2: JUMPE TA,IFDB3 ;ANY REMAINDER?
MOVEM TD,CURVAL## ;[1457] MOVE VALTAB PTR IN CASE VALTAB MOVED
PUSHJ PP,STASHL ;YES, OUTPUT IT
MOVE TD,CURVAL## ;[1457] GET VALTAB PTR BACK, ASSUME IT MOVED
JRST IFDB0
;PUT BYTE STRING DESCRIPTOR IN LITERAL POOL
IFDB3: MOVE TA,[BYTLIT,,2] ;PUT OUT BYTE PTR TO "SET-NAME"
PUSHJ PP,STASHI
HRRZI TA,AS.MSC
PUSHJ PP,STASHL
HRRZ TA,LITNN ; [437] GET BACK BYTE STRING'S ADDR
HRLI TA,(POINT 6,)
PUSHJ PP,STASHL
AOS ELITPC
MOVE TA,[XWDLIT,,2] ;PUT OUT BYTE COUNT
PUSHJ PP,STASHI
MOVEI TA,AS.CNB ;LEFT HF = 0
PUSHJ PP,STASHL
HLLZ TA,LITNN ; [437] RIGHT = BYTE COUNT
HRRI TA,AS.CNB
PUSHJ PP,STASHL
HRRZ CH,ELITPC ;REMEMBER ADDR OF BYTE STRING DESC.
SUBI CH,1 ;BACK UP TO IT
HRRZM CH,LITNN ; [437] SAVE BYTE STRING LITERAL LOCATION
AOS ELITPC ;BUMP LIT POOL PC
;PUT ARG LIST IN LITERAL POOL
MOVE TA,[OCTLIT,,1] ;PUT OUT ARG COUNT WORD
PUSHJ PP,STASHI
MOVSI TA,-2
PUSHJ PP,STASHL
AOS CH,ELITPC ;BUMP PC OVER ARG COUNT
IORI CH,AS.LIT
HRLM CH,LITNN ; [437] REMEMBER ARG LIST ADDR
MOVE TA,[XWDLIT,,2] ;1ST ARG = BYTE STRING DESCRIPTOR ADDR
PUSHJ PP,STASHI
HRLZI TA,(ARGBSD) ;LEFT HF = ARG TYPE
HRRI TA,AS.CNB
PUSHJ PP,STASHL
HRLZ TA,LITNN ; [437] GET ADDR OF BYTE STRING DESC.
TLO TA,AS.LIT
HRRI TA,AS.MSC
PUSHJ PP,STASHL
AOS ELITPC ;BUMP LIT PC
;GET A WORD IN %PARAMS FOR DBCS ROUTINE RETURN VALUE
HRRZ TB,EAS1PC## ;GET DATA PC
AOS EAS1PC
HRRM TB,LITNN ; [437] REMEMBER RET-VALUE ADDR
PUSHJ PP,PUTOC0## ;[372] SET %PARAM TO ZERO
;PUT PTR TO RETURN VALUE LOC IN ARG LIST
MOVE TA,[XWDLIT,,2]
PUSHJ PP,STASHI
HRLZI TA,(ARG1WB) ;LEFT HF = ARG TYPE
HRRI TA,AS.CNB
PUSHJ PP,STASHL
HRLZI TA,(TB) ;RT HF = ADDR OF RET-VALUE
TLO TA,AS.PAR##
HRRI TA,AS.MSC
PUSHJ PP,STASHL
AOS ELITPC
;PUT OUT DBCS SUBROUTINE CALL
; IF SET EMPTY = PUSHJ 17,SETCON
; IF REC MEMBER = PUSHJ 17,RECMEM
; IF REC OWNER = PUSHJ 17,RECOWN
; IF REC MEM/OWN = PUSHJ 17,RECMO
MOVE CH,[ASINC+AC16+MOVEI.,,AS.MSC]
PUSHJ PP,PUTASY ;"MOVEI 16,ARG-LIST"
HLRZ CH,LITNN ; [437] GET ARG LIST ADDR
PUSHJ PP,PUTASN
SETZ TB, ;FIND OUT WHICH DBCS ROUTINE TO CALL
TLNE W1,(GWFL10)
MOVEI TB,1
TLNE W1,(GWFL11)
MOVEI TB,2
TLNE W1,(GWFL12)
MOVEI TB,3
HRRZ CH,IFDBCS(TB) ;GET SELECTED NAME
ANDI CH,77777 ;SET ASSEMBLY EXTAB FLAG
IORI CH,AS.EXT##
PUSHJ PP,GNPSX.## ; [436] "PUSHJ 17,DBCS-ROUTINE"
;NOW TEST RESULT OF SUBROUTINE CALL
MOVE CH,[ASINC+SKIPN.,,AS.MSC] ;ASSUME NOT NOT
TLNE W1,(GWFL15) ;'NOT' FLAG ON?
HRLI CH,ASINC+SKIPE. ;YES
PUSHJ PP,PUTASY
HRRZ CH,LITNN ; [437] GET BACK ADDR OF RET-VALUE LOC
HRLI CH,AS.MSC ;[160] MAKE IT INTO ASY FORMAT
TRO CH,AS.PAR ;[160] PUT IT INTO %PARAMS AREA
PUSHJ PP,PUTASN ;"SKIPN(E) RET-VALUE"
JRST JFALSE ;"JRST FALSE-PATH"
;THEN RETURN TO COBOLE
;EXTAB ADDRESSES OF DBCS ROUTINES
IFDBCS: EXP SETCON##
EXP RECMEM##
EXP RECOWN##
EXP RECMO##
>;END IFN DBMS
;CHECK TO SEE IF A DISPLAY COMPARISON COULD BE A "CAM" COMPARE.
;TRUE IF FIELD IS WORD-CONTAINED.
;ENTER WITH COMPARISON CONSTANT IN "ESAVAC"
;IF FALSE - EXIT TO CALL+2.
;IF TRUE - GENERATE A "CAM" TYPE COMPARISON AND EXIT TO CALL+1.
SPECIL: TSWF FASUB;
JRST CPOPJ1
HLRZ TC,ERESA ;GET RESIDUE OF "A"
MOVE TB,ESIZEA ;AND IT'S SIZE
HRRZ TD,EMODEA ;AND IT'S USAGE
PUSHJ PP,TSTCOL ;[1004] SEE IF WE WANT OTHER COL. SEQ.
JRST .+3 ;[1004] YES, ONLY SPECIAL IF 1 CHAR.
SKIPG COLSEQ## ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
JRST SPECL0 ;NO
CAIE TB,1 ;YES, 1 CHAR. IS OK
JRST CPOPJ1 ;FAILED
PUSH PP,EAC ;SAVE AC INCASE 0
SKIPN EAC ;IF SO
AOS EAC ;USE 1
MOVEI TE,2 ;[1004] IF OTHER COL. SEQ.
SKIPGE COLSEQ ;[1004] WE NEED AC2
MOVEM TE,EAC ;[1004] TO BE ABLE TO DO INDEXING
SPECL0: IMUL TB,BYTE.S(TD) ;COMPUTE SIZE IN BITS
SUB TC,TB ;SUBTRACT THAT FROM RESIDUE
JUMPL TC,CPOPJ1 ;IS "A" WORD-CONTAINED?
CAIN TB,^D36 ;YES--IS IT A FULL WORD?
JRST SPECL1 ;YES
LSH TC,6 ;NO--NEW RESIDUE IS IN "TC"
ADD TB,TC ;NOW RESIDUE AND FIELD SIZE ARE IN "TB"
MOVE TA,[XWD BYTLIT,2];CREATE BYTE POINTER IN LITAB
PUSHJ PP,STASHP
HRRZ TA,EBASEA
PUSHJ PP,STASHQ
LSHC TB,-14
HRR TA,EINCRA
PUSHJ PP,POOLIT
MOVSI CH,LDB.
PUSHJ PP,PUT.LC
SKIPN PLITPC
AOS ELITPC
PUSHJ PP,TSTCOL ;[1004] SEE IF WE NEED OTHER COL. SEQ.
JRST [MOVE TC,EMODEA ;[1004] YES
POP PP,EAC ;[1004] RESTORE ORIGINAL ACC
MOVSI CH,LDB. ;[1004] NEED TO CONVERT FROM ONE
HRR CH,EAC ;[1004]
DPB CH,CHAC ;[1004] LOAD AC FIELD
HRR CH,SUTBL(TC) ;[1004] CHARACTER SET TO THE OTHER
IFE TOPS20,<
TSWT FREENT ;[1004] NO INDIRECT IF /R
>
IFN TOPS20,<
SKIPN RENSW## ;[1004] NO INDIRECT IF /R
>
TLO CH,(@) ;[1004] TURN ON INDIRECT BIT IF NOT /R
PUSHJ PP,PUT.EX ;[1004]
JRST SPECL2] ;[1004]
SKIPG COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
JRST SPECL2 ;NO
HRLZ CH,EAC ;INDEX BY NEW ACC
IOR CH,[MOV+ASINC,,AS.MSC]
POP PP,EAC ;ORIGINAL ACC
PUSHJ PP,PUT.XA ;WRITE IT OUT
MOVE TC,EMODEA ;GET USAGE
MOVE CH,COLSQS##(TC) ;GET LITERAL BASE
PUSHJ PP,PUTASN
JRST SPECL2
SPECL1: PUSHJ PP,SUBSCA
MOVSI CH,MOV
PUSHJ PP,PUT.AA
;[562] NOW WE MUST TEST FOR 6-CHAR SIXBIT ITEM SINCE SIGN GETS IN THE WAY
MOVE TA,ESIZEA ;[562] GET SIZE
HRRZ TC,EMODEA ;[562] GET MODE
CAIN TA,6 ;[562] 6 CHAR?
CAIE TC,D6MODE ;[562] AND SIXBIT?
JRST SPECL2 ;[562] NO
LDB TE,CONDIT ;[562] GET CONDITION
CAIE TE,EQ ;[562] EQUAL
CAIN TE,NOTEQ ;[562] AND NOT EQUAL
JRST SPECL2 ;[562] ARE OK
PUSHJ PP,PUTASA## ;[630] [562] NEED OTHER OPCODE SET
MOVE CH,[TLC.##+ASINC,,AS.CNB] ;[562]
PUSHJ PP,PUT.XA ;[562] COMPLIMENT
MOVEI CH,400000 ;[562] THE HIGH ORDER BIT
PUSHJ PP,PUTASN ;[562]
;[562] COPY THE CODE AT SPECL2 THRU SPECL4
MOVE TA,ESIZEA ;[562] CREATE NEW CONSTANT
MOVE TB,ESAVAC ;[562]
HRRZ TC,EMODEA ;[562]
MOVE TC,BYTE.S(TC) ;[562]
SPECL7: LSH TB,0(TC) ;[562]
IORM TB,ESAVAC ;[562]
SOJG TA,SPECL7 ;[562]
MOVSI TA,(1B0) ;[562] COMPLIMEMT THE CONSTANT
XORM TA,ESAVAC ;[562]
JRST SPECL4 ;[562]
;TRY FOR "CAM" COMPARISON FOR DISPLAY FIELD (CONT'D).
;ITEM IS IN AC'S NOW.
SPECL2: MOVE TA,ESIZEA ;CREATE NEW CONSTANT
MOVE TB,ESAVAC
HRRZ TC,EMODEA
MOVE TC,BYTE.S(TC)
SOJLE TA,SPECL4
SPECL3: LSH TB,0(TC)
IORM TB,ESAVAC
SOJG TA,SPECL3
SPECL4: SKIPN TC,ESAVAC
JRST IFZ21 ;USE JUMPX INSTEAD
TLNE TC,-1
JRST SPECL5
MOVSI CH,CAM.
LDB TE,CONDIT
TLNE W1,NOTF
TRC TE,CONCMP/100
ROT TE,-^D8
ADD CH,TE
PUSHJ PP,PUT.LA
JRST JFALSE
SPECL5: MOVE TA,[XWD OCTLIT,1]
PUSHJ PP,STASHP
MOVE TA,TC
PUSHJ PP,POOLIT
MOVSI CH,CAM.
LDB TE,CONDIT
TLNE W1,NOTF
TRC TE,CONCMP/100
ROT TE,-^D8
ADD CH,TE
PUSHJ PP,PUT.LC
SKIPN PLITPC
AOS ELITPC
; JRST JFALSE ;FALL THRU
;PUT OUT <JRST %NNNNN> ;WHERE %NNNNN IS "ELSE" PATH.
JFALSE: MOVSI CH,JRST.
JFLSEA: HLR CH,W2
ANDCMI CH,7B20
IORI CH,AS.TAG
SKIPN IFEAC ;NEED TO RESET EAC?
JRST JFLSEC ;NO
EXCH CH,IFEAC ;GET VALUE, SAVE ACC
HRRZM CH,EAC ;RESET INCASE "B" LOADED ACCS
MOVE CH,IFEAC ;RESTORE
SETZM IFEAC ;DONE
JFLSEC: HRRZ TA,CH
PUSHJ PP,REFTAG##
JRST PUTASY ;"JRST %NN"
;PUT OUT <JRST .+N> IF "EQUAL" FLAG OFF, <JRST .+N-1> IF "EQUAL"
;FLAG IS ON. ENTER WITH "N" IN ACCUMULATOR "TC".
;SKIP ONE INSTRUCTION UPON RETURN FROM JTRUES, BUT NOT FROM JTRUE.
JTRUES: AOS (PP)
JTRUE: SKIPN CH,IFEAC ;NEED TO RESET EAC?
JRST JTRUE1 ;NO
HRRZM CH,EAC ;YES
SETZM IFEAC
JTRUE1: SKIPE CH,TAGTRU ;ANY TAG FOR TRUE PATH?
JRST JFLSEC ;YES--PUT OUT <JRST %TAG>
HRRZI TC,AS.DOT(TC)
HRRZ TE,EFLAGB ;[1060] IF ZERO TESTING,
CAIE TE,IFZERO ;[1060] TC HAS CORRECT VALUE
JRST JTRUE2 ;[1060] FOR = OR NOT =
TLNN W1,GLCMP ;[1060] IF > OR < , SKIP
JRST JOUT ;[1060]
JTRUE2: TLNN W1,EQUALF ;TRUE IF EQUAL?
JRST JOUT ;NO
SOJA TC,JOUT ;YES
;[717] PUT OUT "JRST FALSE" OR "JRST TRUE" DEPENDING ON ECNTA
JMPOUT: SKIPG TC,ECNTA ;[717] GET COUNT OF PIECES LEFT
JRST JFALSE ;[717] LAST PIECE
HRRZ TE,EFLAGB ;[1060] MOVE B FLAGS TO TE
CAIN TE,IXZERO ;[1060] TEST FOR IFZERO FLAG
JRST JMP2 ;[1060]
TLNE W1,GLCMP ;[1060] IF > OR <, SKIP
JRST JMP2 ;[1060]
IMULI TC,3 ;[1060]
JRST JTRUE ;[1060]
JMP2: IMULI TC,4 ;[1060] [717] MULT. BY 4
AOJA TC,JTRUE ;[717] ADD ONE, AND GENERATE JRST TO TRUE PATH
;PUT OUT THE THREE INSTRUCTION FOR LESS,GREATER,EQUAL
ADDRS3: MOVE TC,ECNTA ;[1317] OFFSET BASE FOR JRSTS IS
IMULI TC,4 ;[1317] NUMBER OF PIECES LEFT TIMES 4
TLNE W1,NOTF ;[1317] UNLESS THIS IS A "NOT"
SETZ TC, ;[1317] THEN BASE = 0
PUSH PP,TC ;[1317] SAVE OFFSET BASE
ADDI TC,3 ;[1317] FIRST OFFSET
TLNE W1,LESSF
PUSHJ PP,JTRUES
PUSHJ PP,JFALSE
POP PP,TC ;[1317] RESTORE OFFSET BASE
ADDI TC,2 ;[1317] SECOND OFFSET BASE
TLNE W1,GREATF
PUSHJ PP,JTRUES
PUSHJ PP,JFALSE
SKIPE ECNTA ;[1317] IF THIS ISN'T THE LAST PART
POPJ PP, ;[1317] DON'T WANT THIRD PART
TLNN W1,EQUALF
JRST JFALSE
POPJ PP,
;COUNT THE NUMBER OF OPERANDS FOR "IF".
;IF < 2 OR > 3, ERROR.
;IF 2, RETURN.
;IF 3, THROW AWAY ALL BUT SECOND AND THIRD AND THEN RETURN.
MAK2OP: MOVEM EACA,EOPNXT
HRRZ TA,EOPLOC
ADDI TA,1
MOVEM TA,CUREOP
PUSHJ PP,BMPEOP ;IS THERE AT LEAST 2?
JRST OPCHK1 ;NO--ERROR
AOS TB,CUREOP ;YES--TB_LOCATION OF SECOND ONE
PUSHJ PP,BMPEOP ;MORE THAN 2?
JRST OPCHK3 ;NO--GO HOME
AOS CUREOP
OPCHK2: PUSHJ PP,BMPEOP
AOSA TC,CUREOP
JRST OPCHK1
OPCHK4: SUBI TC,0(TB)
ADDI TC,-1(TA)
MOVSS TB
HRRI TB,0(TA)
BLT TB,0(TC)
SUB TC,EOPLOC
HRLS TC
ADD TC,EOPLOC
MOVE EACA,TC
JRST OPCHK5
OPCHK3: SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST OPCHK5 ;NO
MOVE TC,CURXSQ## ;GET NUMBER OF EXPRESSION SEEN
SUB TC,LSTXSQ## ;MINUS NUMBER AT LAST IF
SOJN TC,OPCHK5 ;PROBLEM IF ONLY 1
LDB LN,[POINT 13,EXPLNC,28]
JUMPE LN,OPCHK5 ;*** NOT THE REAL FIX, BUT IT WORKS ***
; OTHERWISE SINGLE VARIABLES WILL FAIL
LDB CP,[POINT 8,EXPLNC,35]
PUSH PP,TA
MOVEI TA,%LV.HI
PUSHJ PP,FLG.ES## ;FLAG POSSIBLE VIOLATION (ABREV CONDITIONA)
POP PP,TA
OPCHK5: MOVEM EACA,EOPNXT
MOVEM TA,CUREOP
POPJ PP,
OPCHK1: SWON FERROR;
POPJ PP,
;COUNT NUMBER OF OPERANDS FOR "IFT".
;IF 1, RETURN.
;IF >1, THROW AWAY ALL BUT LAST ONE.
MAK1OP: MOVEM EACA,EOPNXT
HRRZ TA,EOPLOC
ADDI TA,1
MOVEM TA,CUREOP
CAIL TA,(EACA) ;IF NO OPERANDS,
SWONS FERROR ; TROUBLE
PUSHJ PP,BMPEOP ;ONLY 1?
JRST OPCHK3 ;YES--WE'RE DONE
MAK1A: AOS TB,CUREOP
PUSHJ PP,BMPEOP ;ANY MORE?
AOSA TC,CUREOP ;NO
JRST MAK1A ;LOOP
JRST OPCHK4
;SET "A" PARAMETERS TO SHOW THAT IT IS IN AC'S
SETBCX: MOVE TE,EAC
MOVEM TE,EBASEA
SETZM EINCRA
PUSHJ PP,SWAPIT
SWOFF FBSUB;
SWON FBSIGN;
SKIPE EAC
TDCA TE,TE
MOVEI TE,2
MOVEM TE,EAC
POPJ PP,
;SWAP OPERANDS
SWAPIT: PUSHJ PP,SWAPAB
LDB TE,CONDIT ;IS CONDITION "EQUAL"?
CAIE TE,EQ
CAIN TE,NOTEQ ;NO--"UNEQUAL"?
CAIA
TLC W1,GLCMP ;NO--COMPLEMENT THE CONDITION
POPJ PP,
;CHECK TO SEE IF AN ITEM IS EDITED.
;IF SO, USE EXTERNAL SIZE.
SETED: CAIE LN,EBASEA ;SEE IF "A" OR "B"
JRST [SETOM EDEBDB##
SKIPL INPERF ;ALWAYS IF IN PERFORM LOOP CONTROL
SOS EDEBDB ;OTHERWISE ONLY IF DB.ARO IS ON
JRST SETEDA]
SETOM EDEBDA## ;POSSIBLE DEBUG CODE WANTED
SKIPL INPERF ;ALWAYS IF IN PERFORM LOOP CONTROL
SOS EDEBDA ;OTHERWISE ONLY IF DB.ARO IS ON
SETEDA: PUSHJ PP,SETOPN ;SET UP PARAMETERS
HRRZ TE,EMODEX(LN) ;IS IT DISPLAY?
CAILE TE,DSMODE
POPJ PP, ;NO--RETURN
MOVE TC,CUREOP ;YES--GET DATAB FLAG WORD
HRRZ TA,1(TC)
PUSHJ PP,LNKSET
LDB TC,DA.EDT ;IS IT EDITED?
JUMPE TC,CPOPJ ;NO
LDB TE,DA.EXS ;YES--GET EXTERNAL SIZE
MOVEM TE,ESIZEX(LN)
POPJ PP,
; CALL TO MOVGEN TO MOVE "A" INTO ACS
; IF THE OPERAND IS NEGATED THEN MOVE ITS NEGATED VALUE INTO ACS
; MOVE 1-COMP INTO ACS
MOVC1: HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPN TE,MNXAC.## ; [413] NEGATE IT
JRST M1CAC.## ; [413] NOT NEGATED
; MOVE ANY TYPE INTO ACS
MOVXAC: HLRZ TE,OPERND ; [413] GET "A" OPERAND
LDB TE,EOPSGN ; [413] SEE IF NEGATED
JUMPN TE,MNXAC.## ; [413] NEGATE IT
JRST MXAC.## ; [413] NOT NEGATED
;HERE TO SEE IF OPERAND "A" IS IN THE SAME MODE AS PROGRAM COL. SEQ.
;AND CONDITION IS NEITHER "EQUAL" NOR "NOT EQUAL"
;RETURNS +1 IF NOT
; +2 IF YES
TSTCOL: SKIPL TE,COLSEQ ;[1004] ASCII OR EBCDIC SPECIFIED?
JRST CPOPJ1 ;[1004] NO, GIVE SKIP RETURN
TRNN TE,%AN.EB ;[1004] DID USER SAY EBCDIC?
TDZA TE,TE ;[1004] NO, ASSUME ASCII
MOVEI TE,D9MODE+1 ;[1004] YES
ADD TE,EMODEA ;[1004] FORM INDEX
JRST @[EXP CPOPJ1 ;[1004] SIXBIT IN ASCII MODE
EXP CPOPJ1 ;[1004] ASCII IN ASCII MODE
EXP .+1 ;[1004] EBCDIC IN ASCII MODE
EXP .+1 ;[1004] SIXBIT IN EBCDIC MODE
EXP .+1 ;[1004] ASCII IN EBCDIC MODE
EXP CPOPJ1](TE) ;[1004] EBCDIC IN EBCDIC MODE
LDB TE,CONDIT ;[1004] YES, BUT
CAIE TE,EQ ;[1004] EQUAL AND NOT EQUAL
CAIN TE,NOTEQ ;[1004] ARE INVARIANT UNDER
AOS (PP) ;[1004] THIS TRANSFORMATION
POPJ PP, ;[1004]
;IMPROPER CONDITIONS
BADIF: OUTSTR [ASCIZ /Bad "IF" flags
/]
JRST KILLF
BADCOD: OUTSTR [ASCIZ /Bad "IF" usage
/]
POPJ PP,
BADIFT: OUTSTR [ASCIZ /Bad "IFT" flags
/]
JRST KILLF
;GENERATE CODE FOR "ELSE"
ELSEGN: JRST KILLF ;SHOULD NEVER GET HERE
NUMERC==2 ;NUMERIC USAGE
ALPHAB==1 ;ALPHABETIC USAGE
GNENDS==1B27 ;"END SPIF" FLAG IN OPERATOR
LESSF==1B27 ;"LESS" FLAG IN CONDITIONAL OPERATOR
GREATF==1B28 ;"GREATER" FLAG IN CONDITIONAL OPERATOR
EQUALF==1B29 ;"EQUAL" FLAG IN CONDITIONAL OPERATOR
CONCMP==EQUALF!LESSF!GREATF
GLCMP==LESSF!GREATF
GOFALS==1B32 ;"FALSE" OR "TRUE" FLAG IN "IF" OPERATOR
NOTF==1B33 ;"NOT" FLAG IN CONDITIONAL
SWITCH==3B<^D18+^D10> ;"THIS IS FOR HARDWARE-SWITCH" FLAGS IN W1
SWCHON==1B<^D18+^D9> ;"TEST FOR HARDWARE SWITCH ON" FLAG IN W1
CRANGE==1B18 ;"RANGE" FLAG IN CONTAB ENTRY
CNFIGC==1B19 ;"FIG. CONST." FLAG IN CONTAB
EQ==EQUALF/1B29
NOTEQ==<LESSF!GREATF>/1B29
GR==GREATF/1B29
NOTGR==<LESSF!EQUALF>/1B29
LS==LESSF/1B29
NOTLS==<EQUALF!GREATF>/1B29
CONDIT: POINT 3,W1,11 ;CONDITIONAL FLAGS
SWNUM: POINT 6,1(TA),35 ;LOCATION OF SWITCH NUMBER IN MNETAB ENTRY
MNESF: POINT 2,1(TA),2 ;LOCATION OF "ON" & "OFF" FLAGS IN MNETAB
W1SF: POINT 2,W1,10 ;LIKEWISE FOR OPERATOR
EOPSGN: POINT 1,1(TE),6 ; [413] NEGATED OPERAND BY NEGEOP SW IN EXPGEN
EXTERNAL LMASKS,TB.DAT,TB.MNE,ATINVK
EXTERNAL XWDLIT,BYTLIT,D1LIT,D2LIT,OCTLIT,XTNLIT
EXTERNAL ENDIFT,W1LN,W1CP,TCLN,TCCP
EXTERNAL ECTRUE,ECFALS,ECNAME,ECNBP,ECXTRA,ECSTEP,EREMAN,TAGTRU,ECNTA
EXTERNAL EOPLOC,EOPNXT,CUREOP,OPLINE,EHIVAL,ELOVAL,EFPLOV,EMULSZ
EXTERNAL AS.MSC,AS.TAG,AS.CNB,AS.DOT,AS.LIT,SZERA.,EPJPP
EXTERNAL EBASEA,EINCRA,ESIZEA,EDPLA,EMODEA,ERESA,EBYTEA,EFLAGA,ETABLA
EXTERNAL EBASEB,EINCRB,ESIZEB,EDPLB,EMODEB,ERESB,EBYTEB,EFLAGB,ETABLB
EXTERNAL EBASEX,EINCRX,ESIZEX,EDPLX,EMODEX,ERESX,EBYTEX,EFLAGX,ETABLX
EXTERNAL ESAVEA,ESAVEB,ESAVAX,ESAVBX,EBASAX,EBASBX
EXTERNAL ESAVBI,ESVIBX ;[1067]
EXTERNAL ESIZEZ,EAC,BYTE.W,ELITPC,OPERND,BYTE.S,ESAVAC,ESZERA,MAXSIZ
EXTERNAL ELITLO,ELITHI,POWR10,DPWR10,EWORDB,CHAC
EXTERNAL D1MODE,D2MODE,D6MODE,D7MODE,DSMODE,FPMODE,F2MODE,C3MODE,FCMODE,LTMODE,D4MODE
EXTERNAL SKIP.,SKIPE.,SKIPN.,SKIPA.,SKIPG.,SKIPL.,SKPGE.,SKPLE.,JRST.
EXTERNAL JUMP.,JUMPE.,JUMPL.,JUMPN.,JUMPG.,JMPLE.,JMPGE.
EXTERNAL AOJE.,AOJN.,AOJL.,AOJG.
EXTERNAL CAME.,CAMN.,CAML.,CAMLE.,CAMG.,CAMGE.,XTND.,HRRZ.
EXTERNAL MOVM.,MOVEM.,MUL.,MULI.,IMUL.,HRRZI.,SETZB.
EXTERNAL CMP.
EXTERNAL HRLOI.,LDB.,ILDB.,CAI.,CAM.,MOVEI.,CAIE.,CAIN.,SOJG.
EXTERNAL TLNN.,TRNN.,TLNE.,TRNE.,TLO.,MOV
EXTERNAL DA.CLA,DA.EDT,DA.EXS
END