Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/mscgen.mac
There are 21 other files named mscgen.mac in the archive. Click here to see a list.
; UPD ID= 1614 on 5/17/84 at 9:53 AM by HOFFMAN
TITLE MSCGEN FOR COBOL V13
SUBTTL MISCELANEOUS CODE GENERATORS AL BLACKINGTON/CAM/MEM
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, 1987 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
XPNTST==:XPNTST
%%P==:%%P
IFN TOPS20,<SEARCH MONSYM,MACSYM>
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
;EDITS
;NAME DATE COMMENTS
;V13*****************
;MEM 9-JAN-87 [1642] Skip ADJBP if Ref. Mod. starts in first char
;MEM 22-SEP-86 [1627] Fix FIGTYP table
;MJC 09-JAN-86 [1622] Refmod offset byte pointer gereration does not
; work for non-sixbit. Use ADJBP to get offset.
;MJC 18-JUL-85 [1604] SET FLAG ALITSV TO UPDATE CURIRG WHEN XPNLIT
; IS CALLED FOR INSPECT
;MJC 21-JUN-85 [1600] Add code to INITIALIZE to do tables
;JEH 22-MAR-85 [1563] Fix 'set condition-name' code.
;JEH 16-MAY-84 [1535] Ref. Mod. - If phase D gave error, don't
;; give another
;JEH 26-APR-84 [1522] Clean up EOP stack if errors w/ ref. modifiers
;V12*****************
;DAW 30-APR-81 [1127] INSPECT /REPLACING ITEM WITH SPACES GOT
; ?BAD LITAB CODE IF THE ITEM ENDED ON A WORD BOUNDARY.
;DMN 1-APR-80 [1004] MAKE ASCII & EBCDIC COLLATING SEQUENCES WORK.
;DAW 13-SEP-79 [732] FIX "SET" GENERATING BAD CODE SOMETIMES IN COBOL-74
;V12A SHIPPED
; 16-SEP-78 [547] FIX EXAMINE REPLACING HIGH-VALUES BY
;V10*****************
;NAME DATE COMMENTS
; 6-APR-76 [421] EXAMINE REPLACE BY HIGH-VALUES
;ACK 25-MAY-75 DISPLAY-9 CODE FOR EXAMINE.
;********************
;**; EDIT 427 FIX FIELD SIZE FOR EXAMINE REPLACING.
;**; EDIT 243 IF ERROR IN SEARCH ITEM, AVOID EXTRA ERROR MSG HERE.
;**; EDIT 164 SEARCH ALL WITH DEPENDING ITEM FIX
ENTRY INSPGN ;"INSPECT" START
ENTRY INSPTG ;" INSPECT TALLYING"
ENTRY INSPRG ; "INSPECT REPLACING"
ENTRY INSPCG ; "INSPECT CONVERTING"
ENTRY TRCGEN ;"TRACE"
ENTRY SRCHGN ;"SEARCH"
ENTRY SINCGN ;"SINCR"
ENTRY CBPHE ;"COMPILER-BREAK-ON-PHASE.."
ENTRY SETCGN,SETFGN,SETNGN
ENTRY INITGN ;INITIALIZE
ENTRY EVALGN ;"EVALUATE" OPERATOR
ENTRY EVSNGN ;"END SS" Operator for "EVALUATE"
ENTRY EVTFGN ;"TRUE" / "FALSE" OPERATOR FOR "EVALUATE"
ENTRY EVNYGN ;"ANY" OPERATOR FOR "EVALUATE"
ENTRY EVNDGN ;"END EVALUATE" OPERATOR
ENTRY EVSSGN ;PROCESS SELECTION SUBJECT/OBJECT
ENTRY REFMOD ;HANDLE REFERENCE MODIFICATIONS
ENTRY REFM.E ;HANDLE ERRORS W/ REFERENCE MODIFICATIONS
INTERN GETTEM ;ROUTINE TO GET SOME LOCS IN TEMTAB
INTERN MVAUN0 ;MOVE "A" TO UNSIGNED %TEMP
MSCGEN::
SUBTTL "INSPECT" STATEMENT
;MISC CONSTANTS
; The first set of definitions are for bits in the operand word transfered
; to mscgen by cobold.
OP%LEA==1B9
OP%FIR==1B10
OP%IAB==1B13 ;INSPECT AFTER XX BEFORE YY
OP%CHR==1B11
OP%IAF==1B15
OP%EIN==1B12 ;LAST INSPECT ARGUMENT
OP%RPL==1B12
; The second set of definitions are for bits in the argument word transfered
; by MSCGEN to INSPECT. ( All bits are defined in INSPEC.MAC )
AR%CON==1B28 ;INSPECT CONVERTING
AR%EBC==1B30 ;ITEM IS EBCDIC
AR%ASC==1B31 ;ITEM IS ASCII
AR%SEP==1B32 ;ITEM HAS A SEPRATE SIGN
AR%LEA==1B33 ;ITEM HAS A LEADING SIGN
AR%SIN==1B34 ;INSPECTING A SIGNED NUMERIC ITEM
AR%RPL==1B35 ;INSPECT REPLACING
; The third set of definitions are for bits of the operand flag word passed
; by MSCGEN to INSPECT. ( All bits are defined in INSPEC.MAC )
OF%NAR==1B0
OF%LDS==1B1
OF%FIR==1B2
OF%CHR==1B10 ;LOC.3 IS A CHARACTER
OF%CH1==1B11
OF%IBA==1B13
OF%IAF==1B14
ASINC==1B19
AFTBFR==(3B15)
BSI.I: POINT 2,IARG11,31 ;BYTE SIZE INDICATOR OF INSPECTED ITEM
BSI.L1: POINT 2,IOPFLG,5 ;BSI'S FOR LOC.1, LOC.3, LOC.4
BSI.L3: POINT 2,IOPFLG,7 ; 0= SIXBIT, 1= ASCIZ, 2= EBCDIC
BSI.L4: POINT 2,IOPFLG,9 ;
; "START INSPECT" OPERATOR
;1 OPERAND - INSPECT OP-1 TALLYING/REPLACING...
INSPGN: SWOFF FEOFF1 ;TURN OFF FLAGS
MOVEM W1,OPLINE
;RESET POINTERS AND FLAGS TO START INSPECT GENERATION FRESH
SETZM IARG11 ;FIRST WORD OF ARG LIST
SETZM INARGP ;POINTER TO ARGUMENTS
SETZM ITLPTR ;POINTER TO TALLYING ITEMS
SETZM STEMPC ;SAVED TEMP PC
SETZM INSPTF ;"LAST ARG WAS TALLYING" FLAG
;FORGET STUFF IN TEMTAB
MOVE TE,TEMLOC
AOBJN TE,.+1 ;DON'T RETURN "0"
MOVEM TE,TEMNXT
;LOOK AT THE OPERAND (THE INSPECTED ITEM)
HRRZ TC,EOPLOC
ADDI TC,1
MOVEM TC,CUREOP
HRLZM TC,OPERND ;LOOK AT THE OPERAND
PUSHJ PP,SETIED ;SETUP "A" PARAMETERS
TSWF FERROR ;ERRORS YET?
POPJ PP, ;YES, QUIT
HRRZ TA,EMODEA ;GET MODE
CAIG TA,DSMODE ; MUST BE DISPLAY...
JRST INSPG1 ;OK
MOVEI DW,E.554 ;"USAGE MUST BE DISPLAY"
JRST OPNFAT
INSPG1: DPB TA,BSI.I ;SAVE BSI OF INSPECTED ITEM
; SETUP ARG LIST FLAGS
MOVEI TE,AR%RPL ;%REPLF
TXNE W1,OP%RPL ; IF THIS IS AN "INSPECT .. REPLACING..."
IORM TE,IARG11 ;SET FLAG IN ARG LIST
TSWT FASIGN ;SKIP IF SIGNED
JRST INSPG2
LDB TE,[POINT 2,EFLAGA,1] ;GET SIGN FLAGS (%SEPSN,%LEDSN)
CAIN TE,2 ;SEPARATE TRAILING?
JRST [SOS ESIZEA ;YES, PRETEND SIGN ISN'T THERE
JRST INSPG2] ;AND ITEM IS UNSIGNED
DPB TE,[POINT 2,IARG11,33] ;BIT 32=%SEPSN, BIT 33=%LEDSN
MOVEI TE,AR%SIN ;%SIGND
IORM TE,IARG11
INSPG2: HRRZ TE,ESIZEA
CAILE TE,7777 ;SIZE TOO BIG TO FIT IN PARAMETER WORD?
JRST INSPBG ;YES, GIVE UP
HRRZM TE,ESIZEZ ;B1PAR LOOKS AT THIS
SWOFF FASIGN ; MUST TURN THIS OFF, OR B1PAR WILL SET
; SIGN BIT (AND INSP. ROUTINE WILL THINK
; IT'S LENGTH IS +2000 CHARACTERS)
PUSHJ PP,DEPTSA ;SKIP IF IT HAS A DEPENDING ITEM
JRST INSG2A ;NO, JUST CONTINUE
SETOM ONLYEX ;FIRST MAKE SURE SUBSCRIPTS ARE IN %TEMP
PUSHJ PP,SUBSCA
SETZM ONLYEX
MOVEI TE,4 ;SET AC4 = SIZE OF 'A'
PUSHJ PP,SZDPVA
POPJ PP, ;ERRORS, RETURN
SETOM SUBINP ;TELL B1PAR TO KEEP BYTE POINTER SOMEPLACE
; WHERE WE CAN MODIFY IT (NOT LITTAB!)
INSG2A: PUSHJ PP,B1PAR ;DO SUBSCRIPTING
SETZM SUBINP ;CLEAR FLAG (SET ABOVE IF DEPENDING VARIABLE)
TSWF FASUB ;IS IT REALLY SUBSCRIPTED?
JRST INSPG3 ;YES
HRLI EACC,AS.MSC ;LITNN IN RH, AS.MSC IN LH
CAIA ;SKIP
INSPG3: MOVEI EACC,12 ; SUBSCRIPTING DONE, BYTE PTR IN "12"
MOVEM EACC,INSPSL ;STORE LOCATION OF ITS SUBSCRIPT
PUSHJ PP,DEPTSA ;SKIP IF 'A' HAS A DEPENDING ITEM
POPJ PP, ;NO, DONE
;GENERATE A 'DPB' OF THE SIZE INTO THE PARAMETER WORD.
MOVE EACC,INSPSL ;WHERE IS THE SUBSCRIPT?
PJRST DPBDEP ;GENERATE THE "DPB" INTO THE PARAMETER
; (CMNGEN ROUTINE..), THEN RETURN
; ITEM WAS BIGGER THAN 7777 (4096.) CHARACTERS - CAN'T DO IT!
INSPBG: MOVEI DW,E.726 ;TOO BIG TO BE PUT IN A PARAMETER WORD
JRST OPNFAT
SUBTTL "INSPECT TALLYING" OPERATOR
;SAW: ID-2 FOR ID-3 BEFORE/AFTER INITIAL ID-4
;1, 2 OR 3 OPERANDS.
INSPTG: TSWF FERROR ;ERRORS IN THIS INSPECT STATEMENT?
POPJ PP, ;YES, FORGET IT
MOVEM W1,OPLINE
SETOM INSPTF ;SET "LAST ARG WAS TALLYING" FLAG
SETZM IOPFLG ;CLEAR OPERAND FLAGS
MOVE TE,STEMPC ;RESTORE TEMP PC COUNTER
MOVEM TE,ETEMPC
PUSHJ PP,ILINKA ;LINK THIS ARGUMENT TO THE REST
HRRZ TC,EOPLOC ;FIRST OPERAND = TALLYING LOC
ADDI TC,1
MOVEM TC,CUREOP
HRLZM TC,OPERND
MOVEI LN,EBASEA
PUSHJ PP,SETOPN ;SET A:= TALLYING ITEM
TSWF FERROR
POPJ PP, ;RETURN IF ERRORS
TSWT FANUM ;MUST BE NUMERIC
JRST BADTAL
SKIPE EDPLA ;MUST HAVE NO DECIMAL PLACES
JRST BADTL1
;GET A TEMP LOCATION TO "AOS" - TALLY LOC.
MOVEI TE,1
PUSHJ PP,GETEMP
PUSHJ PP,STRTAL ;STORE TALLYING LOC ON LIST
MOVE CH,[SETZM.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,EACC
PUSHJ PP,PUTASN
MOVSS EACC ;GET SET TO STORE TALLY LOC IN THIS ARG
HRRI EACC,AS.MSC
HRRZ TA,CURIRG
ADD TA,TEMLOC
MOVEM EACC,3(TA) ;STORE IT...
;GET THE SEARCH STRING, SETUP LOC.3
TXNE W1,OP%CHR ;TALLYING CHARACTERS?
JRST INSPTC ; YES
PUSHJ PP,BMPEOP
JRST BADOPN
HRRZ TC,CUREOP
HRLZM TC,OPERND ;SETUP AS ARG "A"
PUSHJ PP,STEACC ;SETUP EACC
POPJ PP, ;ERRORS
MOVE TE,CURIRG ; STORE LOC.3
ADD TE,TEMLOC
MOVEM EACC,2(TE)
MOVX TE,OF%CHR ;CHECK FOR CHARACTER VALUE
TLNN EACC,-1
IORM TE,IOPFLG ;YES, SET FLAG
DPB EACA,BSI.L3 ;STORE BSI FOR LOC.3 STRING/CHAR
TLNN EACC,-1 ;NUCLEUS 1 ALLOWS ONLY 1 CHAR
JRST INSPTC ;IT'S ONE CHAR
MOVE TE,ESIZEZ ;SIZE MUST BE ONE
CAIE TE,1
PUSHJ PP,TST.N2## ;SEE IF FIPS FLAGGER REQUESTED
INSPTC: ;FOR "TALLYING CHARACTERS", NO FLAGS HAVE TO BE SET; LOC.3 = 0.
TLNN W1,AFTBFR ;"BEFORE" OR "AFTER" STRING?
JRST INSPTN ;NO
TLC W1,AFTBFR
TLC W1,AFTBFR ;BOTH "AFTER" AND "BEFORE" SPECIFIED
JRST .+4 ;NO
PUSHJ PP,INSPBA
POPJ PP, ;ERRORS SETTING UP LOC1
JRST INSPRN
PUSHJ PP,BMPEOP ;YES, GET IT
JRST BADOPN
HRRZ TC,CUREOP
HRLZM TC,OPERND
PUSHJ PP,STLOC1 ;GET SET TO SETUP LOC.1
POPJ PP, ;(ERRORS)
MOVE TE,ESIZEZ ;GET SIZE OF STRING
CAIE TE,1 ;NUCLEUS 1 ALLOWS ONLY 1 CHAR
PUSHJ PP,TST.N2## ;SEE IF FIPS FLAGGER REQUESTED
MOVE TE,CURIRG
ADD TE,TEMLOC
MOVEM EACC,0(TE) ;STORE LOC.1
DPB EACA,BSI.L1 ;STORE BSI OF AFTER/BEFORE STRING
;SET OTHER OPERAND FLAGS
INSPTN: MOVX TE,OF%LDS
TXNE W1,OP%LEA
IORM TE,IOPFLG ;"LEADING" FLAG
MOVX TE,OF%FIR
TXNE W1,OP%FIR
IORM TE,IOPFLG ;"FIRST" FLAG
MOVX TE,OF%IAF
TXNE W1,OP%IAB
IORM TE,IOPFLG ;"AFTER" FIRST OR ONLY "AFTER"
MOVX TE,OF%IBA
TLC W1,AFTBFR
TLCN W1,AFTBFR ;"AFTER" AND "BEFORE" SPECIFIED ?
IORM TE,IOPFLG ; YES
PUSHJ PP,ISETUP ; GENERATE "SETUP CODE" TO STORE OPERAND FLAGS
;BUMP ARG COUNTER
HLRE TE,IARG11
SOS TE
HRLM TE,IARG11
;IF THIS IS THE LAST ARG, WRITE THE INSPECT OUT AND FINISH UP
TXNE W1,OP%EIN ;SKIP IF THIS IS THE LAST ARG
PJRST FINTLY ;YES, WRITE THE ARGS OUT AND RETURN
MOVE TE,ETEMPC ;NO, ALL DONE, SAVE TEMP PC
MOVEM TE,STEMPC
POPJ PP,
;ROUTINE TO MAKE AN ENTRY IN TEMTAB FOR THIS ARGUMENT
; CALLED FOR BOTH TALLYING AND REPLACING ARGS
ILINKA: MOVEI TA,5 ;GET 5 LOCS IN TEMTAB
PUSHJ PP,GETTEM ; FOR THIS ARGUMENT
MOVEM TA,CURIRG ;SAVE RELATIVE LOC.
HLRZ TB,IARG11 ;WHICH ARGUMENT IS THIS?
JUMPE TB,STRTLA ; FIRST ONE
;LINK IT
HLRZ TE,INARGP ;GET PTR TO LAST ARG.
ADD TE,TEMLOC
MOVEM TA,4(TE) ;STORE PTR IN 5TH WORD
SKIPA
STRTLA: MOVEM TA,INARGP ;RH (INARGP)= PTR TO FIRST
PUSH PP,TA ;SAVE IT
MOVEI TE,2 ;GET 2 TEMP LOCS
TXNE W1,OP%LEA ;IF "LEADING" SEARCH,
MOVEI TE,3 ;GET 3
PUSHJ PP,GETEMP ;%TEMP+NN IN EACC
POP PP,TA
HRRZ TE,TA
ADD TA,TEMLOC
SETZM (TA) ;LOC.1
MOVEM EACC,1(TA) ;LOC.2 = 2-WORD %TEMP BLOCK
SETZM 2(TA) ;LOC.3
SETZM 3(TA) ;LOC.4 OR TALLY.LOC
SETZM 4(TA) ;LINK TO NEXT ITEM
HRLM TE,INARGP ;LH (INARGP)= PTR TO LAST ARG.
POPJ PP, ;RETURN
;ROUTINE TO MAKE AN ENTRY IN THE TALLYING ITEM LINKED LIST.
; EACH ENTRY IS 3 WORDS IN TEMTAB. FIRST WORD POINTS TO THE OPERAND (FOR
; CALL TO SETOPN LATER). 2ND WORD IS AS.TMP+NN (THE "AOS" WORD).
; 3RD WORD = 0 OR RELATIVE LOCATION OF NEXT 3-WORD BLOCK IN TEMTAB.
;
; WHEN THIS ROUTINE IS CALLED, LH(OPERND) POINTS TO THE ACTUAL TALLY ITEM.
;EACC = %TEMP+NN.
STRTAL: MOVEI TA,3 ;GET 3 LOCS IN TEMTAB.
PUSHJ PP,GETTEM
HLRZ TB,IARG11 ;IS THIS IS FIRST ARG?
JUMPE TB,STRTLH ; JUMP IF YES
;LINK LAST ENTRY
HLRZ TE,ITLPTR ;LH (ITLPTR)= LAST ENTRY IN LIST
ADD TE,TEMLOC
MOVEM TA,2(TE) ;MAKE THE 3RD WORD POINT TO THIS ENTRY
SKIPA
STRTLH: MOVEM TA,ITLPTR ;RH (ITLPTR)= FIRST ENTRY IN LIST
HRRZ TE,TA
ADD TE,TEMLOC
MOVEM EACC,1(TE) ; 2ND WORD - %TEMP+NN
SETZM 2(TE) ;CLEAR 3RD WORD FOR NOW
HRLM TA,ITLPTR ;LH (ITLPTR)= LAST ENTRY IN LIST
;
;NOW, TO STORE THE OPERAND! (WHICH MAY BE SUBSCRIPTED), WE HAVE
; TO COPY THE OPERAND WORDS TO A MORE PERMANENT HANG-OUT.
;SO WE'LL USE TEMTAB AGAIN, AND MAKE THE FIRST WORD OF THIS "TALLY"
;ENTRY POINT TO THE BLOCK OF OPERANDS IN TEMTAB.
PUSH PP,TA ;REMEMBER WHERE THIS ENTRY IS
HLRZ TC,OPERND
MOVE TE,1(TC) ;HOW MANY SUBSCRIPTS & STUFF TO FOLLOW?
LDB TA,TESUBC
LSH TA,1 ;= THIS MANY WORDS
ADDI TA,2 ;PLUS TWO FOR THE BASE OPERAND
PUSH PP,TA ;SAVE # WORDS TO COPY
PUSHJ PP,GETTEM
;COPY THE BLOCK
POP PP,TD ;TD= # WORDS TO MOVE, TA = POINTER TO FIRST
POP PP,TE ;TE POINTS TO THE ENTRY WHICH POINTS TO THIS
ADD TE,TEMLOC ; BLOCK!
MOVEM TA,(TE) ;SAVE POINTER TO THE OPERAND
ADD TA,TEMLOC ;MAKE TA = POINTER TO FIRST WORD OF NEW BLOCK
HLRZ TC,OPERND ;START OF BLOCK TO COPY
STRLLP: SOJL TD,STRLPD
MOVE TB,(TC) ;GET A WORD FROM THE OPERAND BLOCK
MOVEM TB,(TA) ; AND STORE IT IN THE TEMTAB BLOCK
AOJA TC,.+1 ;BUMP POINTERS
AOJA TA,STRLLP ; AND LOOP FOR ALL WORDS
STRLPD: POPJ PP,
;ROUTINE TO GENERATE "SETUP CODE" TO STORE OPERAND FLAGS
ISETUP: MOVE TA,CURIRG
ADD TA,TEMLOC
MOVE EACC,1(TA) ;GET %TEMP BLOCK PTR
SKIPN IOPFLG ;IF ALL ZERO, USE "SETZM"
JRST ISTUP1
;GEN "MOVEI 0,FLAGS"
MOVE CH,[MOVEI.+ASINC,,AS.CNB]
PUSHJ PP,PUTASY
HLRZ CH,IOPFLG
PUSHJ PP,PUTASN
;"HRLM 0,%TEMP+NN" ;LH OF FIRST WORD OF TEMP BLOCK
PUSHJ PP,PUTASA
MOVE CH,[HRLM.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
JRST PUTASN
ISTUP1: MOVE CH,[SETZM.+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
JRST PUTASN
;HERE TO WRITE OUT ALL THE TALLY ARGS. PREPARE FOR "REPLACING"
FINTLY: PUSHJ PP,WRTIAG ;WRITE OUT THE ARGS.
;GENERATE "ADD'S" TO INCREMENT THE TALLY ITEMS
SKIPN ITLPTR ;ANY TALLYING ITEMS?
JRST DONATL ;NO!!!
HRRZ TA,ITLPTR ;GET FIRST ONE
GADNXT: PUSH PP,TA ;SAVE IT
PUSHJ PP,GENTAD ;GENERATE THE "ADD" FOR THIS ITEM
POP PP,TA
TSWF FERROR ;ERRORS?
POPJ PP, ;YES, STOP
ADD TA,TEMLOC ;CHECK FOR MORE ITEMS
HRRZ TA,2(TA)
JUMPN TA,GADNXT ;LOOP
DONATL: SETZM INSPTF ;CLEAR "LAST WAS TALLYING" FLAG
SETZM STEMPC ;START TEMPS FRESH
POPJ PP, ;THEN RETURN
;ROUTINE TO GENERATE THE "ADD" FOR THIS TALLYING ITEM
GENTAD: ADD TA,TEMLOC
PUSH PP,TA ;SAVE LOC OF OPERAND FOR "SETOPB"
;FAKE "A" OPERAND
MOVE TB,[INSPA,,EBASEA]
BLT TB,EBASAX
PUSH PP,1(TA) ;SAVE %TEM. INCREMENT FOR A SEC..
MOVE CH,[MOV+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
POP PP,CH
PUSHJ PP,PUTASN ;GEN "MOVE 0,TALLY.LOC"
;SETUP THE REAL "TALLY" ARGUMENT AS THE "B" OPERAND, THEN GENERATE THE ADD
; FROM AC.
POP PP,TA ;RESTORE TA (TOP OF STACK IS NOW RETURN ADDRESS)
HRRZ TC,(TA)
MOVEM TC,TEMADP ;STORE RELATIVE LOCATION OF THE OPERAND
; FOR MATGEN
ADD TC,TEMLOC ;SET IT UP NOW ALSO
HRRM TC,OPERND
PUSH PP,[STOPBE] ;[732] GO HERE IF SETOPB GETS AN ERROR
PUSHJ PP,SETOPB ;[732] SET UP AS "B" OPERAND
POP PP,(PP) ;[732] NO ERRORS, CLEAR ERROR RETURN
SETZM EAC ;REMEMBER NUMBER IS IN AC0
PUSHJ PP,RESG13 ;[732] GEN "ADD"
STOPBE: SETZM TEMADP ;[732] CLEAR RESGEN FLAG
POPJ PP, ;[732] END OF INSPECT CODE GENERATION
JRST RESG13 ;GEN "ADD", THEN POPJ
; A FAKED TALLY LOC. PRETEND IT'S A 1-WORD COMP ITEM, SIZE 10,
;STORED IN AC0.
INSPA: 0 ;EBASEA
0 ;EINCRA
DEC 10 ;ESIZEA
EXP D1MODE ;EMODEA
EXP 0,0,0
;ROUTINE TO WRITE OUT A BUNCH OF ARGS, FOR TALLYING OR REPLACING
WRTIAG: PUSH PP,ELITPC ;SAVE STARTING LITERAL PC
MOVE TA,[XWD XWDLIT,2] ;FIRST WORD OF ARG LIST
PUSHJ PP,STASHP
HLLZ TA,IARG11 ;-NUM ARGS
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
HRLZ TA,IARG11 ;RH= FLAGS
SKIPE TA
HRRI TA,AS.CNB
PUSHJ PP,STASHQ
AOS ELITPC ;UPDATE LITERAL PC
;OUTPUT EACH 2-WORD ARG.
SETOM ALITSV## ;[1604]SET FLAG INCASE XPNLIT IS CALLED
HRRZ TE,INARGP ;LOOK AT FIRST ARG
PUSH PP,TE
JRST FINTL1 ;OUTPUT IT
FINTL2: POP PP,TE
HLRZ TD,INARGP
CAMN TD,TE ;WAS THAT THE LAST ARG?
JRST FINTL3 ;YES
ADD TE,TEMLOC ;NO, FETCH NEXT ONE
MOVE TE,4(TE)
PUSH PP,TE
FINTL1: ADD TE,TEMLOC
MOVEM TE,CURIRG
MOVE TA,[XWD XWDLIT,2]
PUSHJ PP,STASHP
MOVE TE,CURIRG
MOVE TA,0(TE) ;LOC.1
PUSHJ PP,STASHQ
MOVE TE,CURIRG
MOVE TA,1(TE) ;LOC.2
MOVSS TA
HRRI TA,AS.MSC ;%TEMP+NN,,AS.MSC
PUSHJ PP,STASHQ
AOS ELITPC ;ANOTHER WORD IN LITAB
;"WRTIAG" ROUTINE (CONT'D) - WRITE OUT THE INSPECT ARG LIST
MOVE TA,[XWD XWDLIT,2]
PUSHJ PP,STASHP
MOVE TE,CURIRG
MOVE TA,2(TE) ;LOC.3
PUSHJ PP,STASHQ
MOVE TE,CURIRG
MOVE TA,3(TE) ;TALLY LOC
PUSHJ PP,STASHQ
AOS ELITPC
JRST FINTL2 ;LOOP FOR ALL ARGS
FINTL3: SETZM ALITSV ;[1604]RESET XPNLIT FLAG
PUSHJ PP,POOL ;POOLED ARGUMENT LIST!
POP PP,ELITPC ;OK, RESTORE ORIGINAL LITERAL PC
HLRE TE,IARG11 ;HOW MANY ARGS?
MOVMS TE
LSH TE,1
ADDI TE,1 ;TE= # LOCS IN ARG LIST
SKIPN EACC,PLITPC ; SET EACC TO POINT TO START OF ARG LIST
MOVE EACC,ELITPC
SKIPN PLITPC
ADDM TE,ELITPC ;UPDATE LITERAL PC NOW
;GEN "MOVE 12,BYTE.PTR.TO.INSPECTED.ITEM" UNLESS IT'S ALREADY THERE
MOVE TE,INSPSL
CAIN TE,12 ;ALREADY THERE?
JRST FINTL4 ;YES, SKIP THIS
MOVE CH,[MOV+ASINC+SAC,,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,INSPSL
PUSHJ PP,PUTASN
MOVEI TE,12 ;REMEMBER BYTE PTR IS IN AC12 NOW
MOVEM TE,INSPSL
;OUTPUT "MOVEI 16,ARG.LST"
; "PUSHJ PP,INSP."
FINTL4: MOVE CH,[XWD INSP.+ASINC,AS.MSC]
PUSHJ PP,PUTASY
HRRZ CH,EACC
IORI CH,AS.LIT
PJRST PUTASN
SUBTTL "INSPECT REPLACING" OPERATOR
;SAW: ALL/LEADING/FIRST ID-5 BY ID-6 [BEFORE/AFTER ID-7]
; OR: CHARACTERS BY ID-6 [BEFORE/AFTER ID-7]
;1, 2, OR 3 OPERANDS
INSPRG: TSWF FERROR ;ERRORS SEEN YET?
POPJ PP, ;YES, FORGET IT
MOVEM W1,OPLINE
SETZM IOPFLG ;CLEAR OPERAND FLAGS
SKIPN INSPTF ;WERE WE JUST TALLYING?
JRST INSPR0 ;NO, SKIP THIS
PUSHJ PP,FINTLY ; YES, FINISH UP
HRRZS IARG11 ;CLEAR OUT -N ARGS
MOVEI TE,AR%RPL ;"REPLACING" NOW
IORM TE,IARG11 ; SET FLAG IN ARG LIST
SETZM INARGP ;CLEAR PREVIOUS ARG POINTER
MOVE TE,TEMLOC ;ZAP OUT TEMTAB, TOO
AOBJN TE,.+1
MOVEM TE,TEMNXT
JRST INSPR1
INSPR0: MOVE TE,STEMPC ;MORE REPLACING ARGS...
MOVEM TE,ETEMPC
INSPR1: PUSHJ PP,ILINKA ;LINK THIS ARGUMENT TO THE NEXT
HRRZ TC,EOPLOC ;GET SET TO LOOK AT FIRST OPERAND
ADDI TC,1
MOVEM TC,CUREOP
HRLZM TC,OPERND
TXNE W1,OP%CHR ;REPLACING CHARS?
JRST INSPR2 ;YES, SET SEARCH STRING SIZE TO 1
; NO OPERAND IS THERE FOR THE SEARCH STRING!
PUSHJ PP,STEACC ;SETUP SEARCH STRING
POPJ PP, ;?ERRORS
MOVE TA,CURIRG ;GET SET TO STORE LOC.3
ADD TA,TEMLOC
MOVEM EACC,2(TA)
MOVX TE,OF%CHR ;SET "1 CHAR" FLAG IF NECESSARY
TLNN EACC,-1
IORM TE,IOPFLG ;YEAH
DPB EACA,BSI.L3 ;STORE BSI FOR THE STRING
TLNE EACC,-1 ;WAS IT 1 CHAR?
SKIPA TE,ESIZEA ;NO, GET SIZE
MOVEI TE,1
MOVEM TE,SERSIZ ;STORE SIZE
CAIE TE,1 ;NUCLEUS 1 ALLOWS ONLY 1 CHAR
PUSHJ PP,TST.N2## ;SEE IF FIPS FLAGGER REQUESTED
; DONE WITH THE SEARCH STRING...
; SETUP REPLACING STRING
PUSHJ PP,BMPEOP
JRST BADOPN ;?MUST BE THERE
HRRZ TC,CUREOP
HRLZM TC,OPERND
JRST INSPR3
INSPR2: MOVEI TE,1 ;REPLACING CHARACTERS,
MOVEM TE,SERSIZ ; SEARCH SIZE IS 1
INSPR3: PUSHJ PP,STLOC4 ;SETUP LOC.4
POPJ PP, ;ERRORS
MOVE TE,SERSIZ ;GET SIZE OF STRING
CAIE TE,1 ;NUCLEUS 1 ALLOWS ONLY 1 CHAR
PUSHJ PP,TST.N2## ;SEE IF FIPS FLAGGER REQUESTED
MOVE TE,CURIRG
ADD TE,TEMLOC
MOVEM EACC,3(TE) ;STORE LOC.4
DPB EACA,BSI.L4 ;AND BSI FOR IT
MOVX TE,OF%CH1 ;SET "1 CHAR" FLAG IF NECESSARY
TLNN EACC,-1
IORM TE,IOPFLG
;CHECK FOR AFTER/BEFORE STRING
TLNN W1,AFTBFR ;SKIP IF ANY
JRST INSPRN ;NOPE
TLC W1,AFTBFR
TLCE W1,AFTBFR ;BOTH "AFTER" AND "BEFORE" ?
JRST .+4
PUSHJ PP,INSPBA
POPJ PP, ;ERRORS SETTING IT UP
JRST INSPRN
PUSHJ PP,BMPEOP
JRST BADOPN ;?NOT SUPPLIED
HRRZ TC,CUREOP
HRLZM TC,OPERND
PUSHJ PP,STLOC1
POPJ PP, ;?ERRORS SETTING IT UP
MOVE TE,ESIZEZ ;GET SIZE OF STRING
CAIE TE,1 ;NUCLEUS 1 ALLOWS ONLY 1 CHAR
PUSHJ PP,TST.N2## ;SEE IF FIPS FLAGGER REQUESTED
MOVE TE,CURIRG
ADD TE,TEMLOC
MOVEM EACC,0(TE) ;STORE IN LOC.1
DPB EACA,BSI.L1 ; AND STORE BSI
; DONE WITH THE REPLACING STRING AND BEFORE/AFTER STRING...
;SET OPERAND FLAGS
INSPRN: MOVX TE,OF%LDS
TXNE W1,OP%LEA
IORM TE,IOPFLG ;"LEADING"
MOVX TE,OF%FIR
TXNE W1,OP%FIR
IORM TE,IOPFLG ;"FIRST"
MOVX TE,OF%IAF
TXNE W1,OP%IAB
IORM TE,IOPFLG ;"AFTER" SPECIFIED FIRST OR ONLY "AFTER"
MOVX TE,OF%IBA
TLC W1,AFTBFR
TLCN W1,AFTBFR ;BOTH "AFTER" AND "BEFORE" SPECIFIED ?
IORM TE,IOPFLG ;YES
PUSHJ PP,ISETUP ;GENERATE "SETUP CODE" TO STORE OPERAND FLAGS
;BUMP ARG COUNTER
HLRE TE,IARG11
SOS TE
HRLM TE,IARG11
;IF THIS IS THE LAST ARG, WRITE THE INSPECT OUT
TXNE W1,OP%EIN
PJRST WRTIAG ;WRITE OUT THE INSPECT ARGS...
; AND RETURN
MOVE TE,ETEMPC ; SAVE TEMP PC FOR NEXT REPLACING ARG
MOVEM TE,STEMPC
POPJ PP,
; This routine is used to set up the LOC.1 area when both the "AFTER"
; and "BEFORE" phrases have been specified.
INSPBA: SETOM NOPOOL## ;SET NO POOLING FLAG
SETZM INSFLG## ;SET ALL FLAGS TO ZERO
PUSHJ PP,BMPEOP ;GET FIRST OPERAND
JRST BADOPN ; ? MUST BE THERE
HRRZ TC,CUREOP
HRLZM TC,OPERND
HRRZ TA,CUREOP
HRRZM TA,INS1OP## ;SAVE FIRST OPERAND
; Now save the parameters for later use
MOVE TC,ELITPC
MOVEM TC,INS1EC## ;SAVE ELITPC FOR GENERATING BYTE POINTER
MOVE TC,(TA) ;GET THE OPERAND FLAGS
TLNN TC,GNLIT ;LIT. OF FIG. CONST ?
JRST INSBA1 ;NO
SETO TA,
DPB TA,[POINT 1,INSFLG,1]
; Here to generate the first literal or fig const.
PUSHJ PP,INSBA5
POPJ PP, ;IF ERROR EXIT
TLNE EACC,-1 ;FIG. CONT OR 1 WORD LIT?
JRST INSBA1 ;NO
MOVEI TE,1 ;SIZE = 1
MOVEM TE,ESIZEZ
HRL TA,D.LTCD(EACA) ;GET LITAB CODE
HRRI TA,1 ;ONE WORD LITERAL
PUSHJ PP,STASHP
SETZ TA,
DPB EACC,[POINT 6,TA,5
POINT 7,TA,6
POINT 9,TA,8](EACA)
PUSHJ PP,POOLIT
AOS ELITPC ;INCREMENT ELITPC AFTER GENERATING ONE WORD
INSBA1:
; Finished first operand, now for the second operand.
MOVE TC,ELITPC
MOVEM TC,INS2EC##
PUSHJ PP,BMPEOP ;GET SECOND OPERAND
JRST BADOPN
HRRZ TC,CUREOP
HRLZM TC,OPERND
HRRZ TA,CUREOP
HRRZM TA,INS2OP## ;SAVE SECOND OPERAND
MOVE TC,(TA) ;GET OPERAND FLAGS
TLNN TC,GNLIT ;LIT. OR FIG. CONST.
JRST INSBA2 ;NO
SETO TA,
DPB TA,[POINT 1,INSFLG,2]
; Here to generate the second literal of fig. const
PUSHJ PP,INSBA5
POPJ PP, ;IF ERROR EXIT
TLNE EACC,-1 ;FIG. CONST OR ONE WORD LIT. ?
JRST INSBA2 ;NO
MOVEI TE,1 ;SIZE = 1
MOVEM TE,ESIZEZ
HRL TA,D.LTCD(EACA)
HRRI TA,1
PUSHJ PP,STASHP
SETZ TA,
DPB EACC,[POINT 6,TA,5
POINT 7,TA,6
POINT 9,TA,8](EACA)
PUSHJ PP,POOLIT
AOS ELITPC
;Now generate byte pointer to first phrase
INSBA2: MOVE TC,ELITPC
MOVEM TC,INS1BY## ;SAVE ADDRESS TO FIRST BYTE POINTER
LDB TA,[POINT 1,INSFLG,1]
SKIPE TA ;FIRST OPER. A FIG. CONST. OR LIT.?
JRST .+6 ;YES
MOVE TA,INS1OP
MOVEM TA,CUREOP
PUSHJ PP,STEACC ;GENERATE BYTE POINTER TO DATA NAME
POPJ PP, ; IF ERROR EXIT
JRST INSBA3
MOVE EACC,INS1EC
IORI EACC,AS.LIT
PUSHJ PP,STLTLT ;MAKE ANOTHER LITERAL, POINTING TO FIRST OP.
;Now generate byte pointer to second phrase
INSBA3: LDB TA,[POINT 1,INSFLG,2]
SKIPE TA ;SECOND OPER. A FIG. CONST. OR LIT.?
JRST .+6 ;YES
MOVE TA,INS2OP
MOVEM TA,CUREOP
PUSHJ PP,STEACC ;GENERATE BYTE POINTER TO DATA NAME
POPJ PP, ;IF ERROR EXIT
JRST INSBA4
MOVE EACC,INS2EC
IORI EACC,AS.LIT
PUSHJ PP,STLTLT
; Here to set the pointer in LOC.1 to be the first items byte pointer
INSBA4: CAIE TE,1
PUSHJ PP,TST.N2
MOVE TE,INS1BY ;RESTORE ADDRESS TO FIRST BYTE POINTER
IORI TE,AS.LIT
HRL EACC,TE
MOVE TE,CURIRG
ADD TE,TEMLOC
MOVEM EACC,(TE) ;STORE IN LOC.1
DPB EACA,BSI.L1 ; AND STORE BSI
SETZM NOPOOL
JRST CPOPJ1 ;RETURN
INSBA5:
HRRZ TA,CUREOP
MOVE TC,(TA)
TLNE TC,GNFIGC ;FIG. CONST.
JRST STEACC
MOVE TC,CUREOP
MOVEI LN,EBASEA
PUSHJ PP,SETOPN
TSWF FERROR
POPJ PP,
MOVE TD,ESIZEA
CAIN TD,1
JRST STLCL1
MOVEM TD,ESIZEB
MOVEM TD,ESIZEZ
LDB TC,BSI.I ;LOAD MODE OF LITERAL
MOVEM TC,EMODEB ;STORE LITERAL MODE
SETZM LITERR
PUSHJ PP,LITD. ;GENERATE LITERAL
TSWF FERROR
POPJ PP,
SKIPE LITERR
JRST STLCLE
TLO EACC,-1
JRST CPOPJ1
;ROUTINE TO SETUP EACC = LOC.1, EACA= BSI. LOC.1
STLOC1: PUSHJ PP,STEACC
POPJ PP,
TLNE EACC,-1
JRST CPOPJ1 ;OK IF AN ACTUAL STRING
;IT WAS A FIG. CONST. OR A 1-CHAR LIT. STORE THE LITERAL IN LITAB.
MOVEI TE,1 ;ONE CHAR
MOVEM TE,ESIZEZ
HRL TA,D.LTCD(EACA) ;GET LITAB CODE
HRRI TA,1 ;ONE WORD LITERAL
PUSHJ PP,STASHP
SETZ TA,
DPB EACC,[POINT 6,TA,5
POINT 7,TA,6
POINT 9,TA,8](EACA)
PUSHJ PP,POOLIT
SKIPN EACC,PLITPC
MOVE EACC,ELITPC
SKIPN PLITPC
AOS ELITPC
IORI EACC,AS.LIT
PUSHJ PP,STLTLT ;MAKE ANOTHER LITERAL, POINTING TO THAT ONE
JRST CPOPJ1 ;RETURN NOW
;ROUTINE TO MAKE A LITERAL POINTING TO THE LITERAL WE JUST PUT OUT
; AS.LIT+NN IN EACC., SIZE IN ESIZEZ.
;MESSES UP "A"
STLTLT: SWOFF FASUB!FASIGN ;NOT SUBSCRIPTED, OR SIGNED
MOVEM EACC,EINCRA
MOVE TE,[44,,AS.MSC]
MOVEM TE,EBASEA
PUSHJ PP,B1PAR
MOVSS EACC
HRRI EACC,AS.MSC
POPJ PP,
;ROUTINE TO SETUP EACC = LOC.4, EACA= BSI.LOC.4
; IF STRING IS A FIG. CONST, MAKE A STRING OF THEM THE LENGTH OF
;THE LOC.3 STRING (LENGTH STORED IN "SERSIZ")
STLOC4: PUSHJ PP,STEACC
POPJ PP, ;ERRORS
TLNE EACC,-1 ;AN ACTUAL STRING
JRST STLC4A ;YES, CHECK AGAINST PREVIOUS SIZE
JUMPN TD,STLC4F ;JUMP IF STEACC SAYS THIS IS A FIG. CONST.
HRRZ TE,SERSIZ ;1-CHAR LITERAL AS "REPLACING" STRING
CAIN TE,1 ;REPLACING SEARCH STRING 1 CHAR ALSO?
JRST CPOPJ1 ;YES, OK
;GIVE ERROR - ITEM NOT THE RIGHT SIZE
STLC4E: MOVEI DW,E.725 ;"ITEM MUST BE SAME SIZE AS ITEM BEING
JRST OPNFAT ; REPLACED"., THEN GIVE ERROR RETURN
;IT WAS A STRING. CHECK FOR SAME SIZE AS PREVIOUS STRING
STLC4A: MOVE TE,ESIZEA ;GET SIZE OF THIS STRING
CAMN TE,SERSIZ ;SAME SIZE?
JRST CPOPJ1 ;YES, OK
JRST STLC4E ;NO, COMPLAIN
; CONT'D ON NEXT PAGE
;STLOC4 ROUTINE (CONT'D)
;IT WAS A FIG. CONST. STORE LITERAL IN LITAB, UNLESS LENGTH WAS 1 CHAR.
STLC4F: HRRZ TE,SERSIZ ;SIZE TO MAKE IT
CAIN TE,1 ;JUST 1 CHAR ANYWAY?
JRST CPOPJ1 ;YES, LEAVE IT THE WAY IT IS
IDIV TE,BYTE.W(EACA) ;GET TE= # WORDS IN LITAB WE NEED
SKIPE TD
AOS TE
PUSH PP,TE ;SAVE # WORDS IN LITERAL
HRL TA,D.LTCD(EACA)
HRR TA,TE
PUSHJ PP,STASHP
STLC4G: SETZ TA, ;START ANOTHER WORD
MOVE TB,[POINT 6,TA
POINT 7,TA
POINT 9,TA](EACA)
STLC4H: SOSGE SERSIZ ;MORE CHARS TO STORE?
JRST STLC4J ;NO, OUTPUT LAST WORD
IDPB EACC,TB ;STORE BYTE
TLNE TB,760000 ;MORE BYTES LEFT IN WORD?
JRST STLC4H ;YES
PUSHJ PP,STASHQ ;STORE NEXT WORD OF LITERAL
SKIPE SERSIZ ;[1127] Did item end just now?
JRST STLC4G ;[1127] No, GO ON TO NEXT WORD
PUSHJ PP,POOL ;[1127] Pool the literals
JRST STLC4K ;[1127] and finish up
STLC4J: PUSHJ PP,POOLIT ;OUTPUT LAST WORD
STLC4K: POP PP,TE ;[1127] # WORDS IN LITERAL
SKIPN EACC,PLITPC ;NOW GET EACC POINTING TO THE LITERAL
MOVE EACC,ELITPC ; WE JUST MADE
IORI EACC,AS.LIT
SKIPN PLITPC ;UNLESS POOLED..
ADDM TE,ELITPC ;BUMP LITERAL COUNTER
PUSHJ PP,STLTLT ;MAKE A LITERAL, POINTING TO THAT ONE
JRST CPOPJ1
;ROUTINE TO SETUP EACC = LOC.3 OR LOC.4, FROM OPERAND IN "CUREOP" AND "A".
; ALSO RETURNS EACA= BSI OF THE STRING
; PUSHJ PP,STEACC
; <RETURN HERE IF ERRORS>
; <HERE IF OK, EACC AND EACA SETUP>
;
; DOES SUBSCRIPTING IF NECESSARY, BUT ALWAYS LEAVES THE BYTE PTR
;IN %TEMP OR %LIT.
; IF LH(EACC)=0, THEN IT'S A 1-CHAR LITERAL OR FIG. CONST.
; (TD= 0 IF LIT, -1 IF FIG. CONST, IN THIS CASE)
STEACC: HRRZ TA,CUREOP
MOVE TC,0(TA) ;LOOK AT OPERAND FLAGS
TLNN TC,GNLIT ;LIT OR FIG CONST?
JRST STEAC1 ;NO, SET IT UP AS "A"
TLNN TC,GNFIGC ;FIG CONST.?
JRST STLCLT ;NO, LITERAL
TLNN TC,GNFCS!GNFCZ!GNFCQ!GNFCHV!GNFCLV
JRST BADLIT
; GET THE APPROPRIATE CHARACTER IN
;THE MODE OF THE INSPECTED STRING.
LDB EACA,BSI.I ;GET INSPECT STRING BSI
TLNE TC,GNFCS ;SPACE
HRRZ EACC,IFSPCS(EACA)
TLNE TC,GNFCZ ;ZERO
HRRZ EACC,IFZROS(EACA)
TLNE TC,GNFCQ ;QUOTE
HRRZ EACC,HIVQOT(EACA)
TLNE TC,GNFCLV ;LOW-VALUES
MOVEI EACC,0
TLNE TC,GNFCHV ;HIGH-VALUES
HLRZ EACC,HIVQOT(EACA)
SKIPLE COLSEQ ;[1004] PROGRAM COLLATING SEQUENCE = ALPHABET-NAME?
TLNN TC,GNFCLV!GNFCHV ; AND LOW-VALUES OR HIGH-VALUES?
CAIA ;NO
XCT STECOL(EACA) ;YES, GET THE SPECIAL CHARACTER VALUE
SETO TD, ;TD= -1 TO INDICATE FIG. CONST
JRST CPOPJ1 ;GIVE GOOD RETURN
STECOL: HLRZ EACC,PRGCOL+240(EACC) ;SIXBIT
HLRZ EACC,PRGCOL(EACC) ;ASCII
HRRZ EACC,PRGCOL(EACC) ;EBCDIC
STLCLT: MOVE TC,CUREOP ;HAVE A LITERAL, CALL SETOPN
MOVEI LN,EBASEA ; TO FIND SIZE & SETUP FOR LITD.
PUSHJ PP,SETOPN
TSWF FERROR ;IF ERRORS,
POPJ PP, ;TAKE THE ERROR RETURN
MOVE TD,ESIZEA ;WHATEVER SIZE IT IS, IS WHAT IT WILL BE
CAIN TD,1
JRST STLCL1 ;IF 1, GET THE CHAR
MOVEM TD,ESIZEB
MOVEM TD,ESIZEZ
LDB TC,BSI.I ; USE MODE OF INSPECTED STRING
MOVEM TC,EMODEB ; MAKE THE LITERAL IN THAT MODE
SETZM LITERR ;INCASE ERRORS CONVERTING
PUSHJ PP,LITD. ;MAKE THE LITERAL
TSWF FERROR
POPJ PP,
SKIPE LITERR ;IF CONVERSION ERRORS,
JRST STLCLE ; GO COMPLAIN
SWOFF FASIGN!FASUB ;NOT SIGNED, OR SUBSCRIPTED
PUSHJ PP,B1PAR ;GET BYTE PTR IN %TEMP
MOVSS EACC
HRRI EACC,AS.MSC ;EACC POINTS TO THE BYTE PTR IN %TEMP
HRRZ EACA,EMODEA ; EACA= BSI OF THE LITERAL
JRST CPOPJ1
STLCL1: ILDB TE,EBYTEA ;GET ASCII CHAR OF LITERAL
STLCL2: LDB EACA,BSI.I ;GET MODE OF INSPECT STRING
SETZM LITERR ;INCASE ERRORS CONVERTING
XCT VLIT6.(EACA) ;CONVERT
STLCL3: SKIPE LITERR ;ERRORS CONVERTING?
JRST STLCLE ; YEAH, COMPLAIN
HRRZ EACC,TE ;RETURN WITH CHAR IN EACC
SETZ TD, ;TD= 0 TO INDICATE 1-CHAR LITERAL
JRST CPOPJ1 ;GIVE GOOD RETURN
STLCLE: SETZM LITERR ;RESET FLAG FOR NEXT TIME
MOVEI DW,E.329 ;"NON-SIXBIT-CHAR IN LITERAL..."
JRST OPNFAT
; ITEM WAS NOT A LITERAL OR FIG CONST. IT MUST BE A DISPLAY ITEM.
STEAC1: HRRZ TC,CUREOP
LDB TE,[POINT 3,1(TC),20]
CAIE TE,TB.DAT## ;DATA NAME?
JRST STEAC2 ;NO
PUSHJ PP,SETIED ;SETUP AS "A" ITEM, MAY BE EDITED
TSWF FERROR
POPJ PP, ;ERRORS
HRRZ TA,EMODEA
CAILE TA,DSMODE ;MUST BE DISPLAY...
JRST SETLE1 ;?NO, ERROR
TSWF FASIGN ;SIGNED?
JRST [PUSHJ PP,MVAUNS ;MOVE "A" TO UNSIGNED TEMP
TSWF FERROR
POPJ PP, ;RETURN IF ERRORS
JRST .+1]
HRRZ TE,ESIZEA
HRRZM TE,ESIZEZ
MOVEI TE,10 ;SUBSCRIPT WITH AC 10
MOVEM TE,SUSEAC
PUSHJ PP,B1PAR ;GET BYTE PTR IN %LIT OR AC
SETZM SUSEAC
TSWT FASUB ;SKIP IF IN AC
JRST HVEACC ;NO, IN %TEMP (OK)
; MOVE THE BYTE PTR TO A %TEMP.
MOVEI TE,1
PUSHJ PP,GETEMP
MOVE CH,[MOVEM.+AC10+ASINC,,AS.MSC]
PUSHJ PP,PUTASY
MOVE CH,EACC
PUSHJ PP,PUTASN
HVEACC: MOVSS EACC
HRRI EACC,AS.MSC
HRRZ EACA,EMODEA ;EACA= BSI OF THE STRING
JRST CPOPJ1 ;GIVE GOOD RETURN
SETLE1: MOVEI DW,E.554 ;"USAGE MUST BE DISPLAY"
JRST OPNFAT ;GIVE ERROR, AND ERROR RETURN
STEAC2: CAIE TE,TB.MNE## ;LAST CHANCE IS SYMBOLIC-CHARACTER
JRST SETLE1 ;IT ISN'T
HRRZ TA,1(TC) ;SEE IF IT REALLY IS
PUSHJ PP,LNKSET
LDB TE,MN.SYC##
JUMPE TE,SETLE1 ;ITS NOT A SYMBOLIC-CHARACTER
TSWF FERROR ;IF ERRORS,
POPJ PP, ;TAKE THE ERROR RETURN
LDB TE,MN.ESC## ;IS IT EBCDIC?
JUMPN TE,STEAC3 ;YES, THEN CHAR IS IN EBCDIC SEQUENCE
LDB TE,MN.SCV## ;GET CHARACTER
JRST STLCL2 ;LOOKS LIKE A 1-CHAR LITERAL
STEAC3: LDB TE,MN.SCV ;GET CHARACTER
LDB EACA,BSI.I ;GET MODE OF INSPECT STRING
SETZM LITERR ;INCASE ERRORS CONVERTING
XCT VLIT9.##(EACA) ;CONVERT FROM EBCDIC
JRST STLCL3 ;RETURN WITH CHAR IN TE
;ROUTINE TO SETUP "A" PARAMETERS, AND CHECK FOR EDITED ITEMS.
; IF EDITED, USE EXTERNAL SIZE. IF NUMERIC EDITED, TURN OFF FASIGN.
;IF FLAG "NODEPV" IS SET TO -1, AND THE ITEM HAS A DEPENDING VARIABLE,
; PUT OUT A FATAL DIAG AND GIVE ERROR RETURN.
SETIED: MOVEI LN,EBASEA
PUSHJ PP,SETOPN ;SETUP "A" PARAMETERS
TSWF FERROR ;ERRORS?
POPJ PP, ;YES, RETURN RIGHT AWAY
MOVE TC,CUREOP ;CHECK FOR EDITED
MOVE TA,1(TC)
MOVEM TA,INSDAT## ;SAVE DATAB LINK TO CONVERTED DATA ITEM
PUSHJ PP,LNKSET
LDB TE,DA.EDT
JUMPE TE,SETIE1 ;NOT EDITED
LDB TE,DA.EXS ;USE EXTERNAL SIZE
MOVEM TE,ESIZEA
SWOFF FASIGN ;PRETEND IT'S UNSIGNED
SETIE1: SKIPE NODEPV ;SKIP IF 'A' CAN HAVE A DEPENDING VARIABLE
PUSHJ PP,DEPTSA ;IT CAN'T-- SKIP IF IT DOES
POPJ PP, ;NO, RETURN OK
MOVEI DW,E.612 ;"FThis item may not have a depending variable"
PJRST OPNFAT ;PUT OUT DIAG AND POPJ
;ROUTINE TO MOVE "A" TO AN UNSIGNED TEMP.
MVAUNS: LDB TE,BSI.I ;TAKE THIS OPPORTUNITY TO CONVERT THE
; STRING TO INSPECT STRING MODE
; JRST MVAUN0 ;MOVE "A" TO UNSIGNED %TEMP
;ENTER HERE WITH TE= BSI TO CONVERT THE NUMERIC ITEM TO.
MVAUN0: MOVEM TE,EMODEB
MOVE TC,ESIZEA
MOVEM TC,ESIZEB ;SAME SIZE
SKIPGE EFLAGA ;SEPARATE SIGN?
SOS TC,ESIZEB ; YES, ADJUST SIZE
ADD TC,BYTE.W(TE) ;FIND OUT HOW MANY WORDS IN %TEMP WE NEED
SUBI TC,1
IDIV TC,BYTE.W(TE)
HRRZ TE,TC
PUSHJ PP,GETEMP
MOVEM EACC,EINCRB ;SET "B" INCREMENT
MOVE TA,[XWD ^D36,AS.MSC]
MOVEM TA,EBASEB
SETZM EDPLB
SETZM EFLAGB
SWON FBNUM
SWOFF FBSUB!FBSIGN ;"B" IS UNSIGNED, NOT SUBSCRIPTED
MOVE TA,[XWD EBASEB,ESAVEA]
BLT TA,ESAVAX ;SAVE "B" PARAMETERS
TSWT FASUB ;IF "A" SUBSCRIPTED,
JRST MVAUS1 ; SKIP THIS
MOVEI TE,10 ;USE AC10 FOR SUBSCRIPTING
MOVEM TE,SUSEAC
PUSHJ PP,MXX. ;MOVE THE ITEM
SETZM SUSEAC ;AND THEN CLEAR SUSEAC
JRST MVAUS2
MVAUS1: PUSHJ PP,MXX. ; MOVE THE ITEM
MVAUS2: MOVE TA,[XWD ESAVEA,EBASEA]
BLT TA,EBASAX ;RESTORE "A" ITEM
SWOFF FASUB!FASIGN ;NEW "A" IS NEITHER SUBSCRIPTED NOR SIGNED
POPJ PP,
;ROUTINE TO GET SOME LOCS IN TEMTAB
; CALL: TA/ # LOCS TO GET
; PUSHJ PP,GETTEM
; (RETURN HERE WITH TA= RELATIVE TEMTAB ADDRESS OF THE FIRST LOC)
GETTEM:
IFN XPNTST,<
PUSH PP,TA ;SAVE TA
PUSHJ PP,XP1TEM## ;ALWAYS EXPAND BY 1 WORD
POP PP,TA ;RESTORE TA
>
HRRZ CH,TA ;GET # LOCS
HRL CH,CH ;N,,N
ADD CH,TEMNXT ; HIGHEST POSSIBLE TEMLOC
JUMPL CH,GETEM1 ; JUMP IF STILL ROOM
PUSH PP,TA ;NO, SAVE TA
PUSHJ PP,XPNTEM ;GO EXPAND TEMTAB
POP PP,TA ;RESTORE ARG TO THIS ROUTINE..
JRST GETTEM ; AND TRY AGAIN
GETEM1: HRRZ TA,TEMNXT ;FIGURE OUT WHERE WE ARE PUTTING IT
MOVEM CH,TEMNXT ;STORE NEW TEMNXT
HRRZ CH,TEMLOC
SUB TA,CH ;RETURN REL. LOC
POPJ PP,
BADLIT: MOVEI DW,E.123
JRST OPNFAT
BADTAL: MOVEI DW,E.555 ;"CLASS MUST BE NUMERIC"
JRST OPNFAT
BADTL1: MOVEI DW,E.556 ;"CAN NOT HAVE ANY DECIMAL PLACES"
JRST OPNFAT
BADOPN: MOVEI DW,E.214
JRST OPFAT
SUBTTL "INSPECT CONVERTING" OPERATOR
INSPCG: TSWF FERROR ;ERRORS SEEN YET?
POPJ PP, ;YES, FORGET IT
MOVE TA,INSDAT ;RESTORE DATAB LINK TO INSPECTED DATA ITEM
PUSHJ PP,LNKSET
LDB CH,DA.EXS##
HRLI CH,MOVEI.+AC10
PUSHJ PP,PUTASY ;MOVEI 10,SIZE OF INSPECTED ITEM
MOVEI TE,AR%CON ;SET CONVERTING FLAG ON IN FLAG WORD
IORM TE,IARG11
JRST INSPRG ;GENERATE CODE THE SAME FORMAT AS INSPECT
; REPLACING.
SUBTTL GENERATE "TRACE ON/OFF" COMMAND
TRCGEN: SKIPE PRODSW ;IF '/P' TYPED,
POPJ PP, ; NO CODE
MOVE CH,[XWD SETOM.,PTFLG.]
TLNN W1,(<1B9>)
HRLI CH,SETZM.
JRST PUT.EX ;WRITE OUT CODE
SUBTTL GENERATE 'SEARCH' OPERATOR
;THE 'SEARCH' GENERATOR GENERATES THE FOLLOWING CODE.
;IN THE EXAMPLE, THE KEY IS ASSUMED TO BE COMP; APPROPRIATE
;CODE IS GENERATED FOR OTHER USAGES.
;SEARCH ALL:
; SETZM INDEX
; MOVE 0,[POWER OF 2 GREATER THAN TABLE SIZE]
; MOVEM 0,%PARAM
;
; %I: MOVE 0,%PARAM
; IDIVI 0,2
; JUMPE 0,%AE+1
; MOVEM 0,%PARAM
; ADDM 0,INDEX
; JRST %T
;
; %D: MOVE 0,%PARAM
; IDIVI 0,2
; JUMPE 0,%AE+1
; MOVEM 0,%PARAM
; MOVN 0,0
; ADDM 0,INDEX
;
; %T: CAMG 0,DEPENDING-ITEM ;IF 'DEPENDING' CLAUSE PRESENT
; CAILE 0,TABLE-SIZE
; JRST %D
; %AE:
; JRST %X ;PUT OUT BY 'SPIF'
; <AT-END CODE> ;PUT OUT BY OTHER GENERATORS
;
; %X: <KEY COMPARISON> ;SEE BELOW
; .
; .
; <KEY COMPARISON>
;THE 'KEY COMPARISON' IS AS FOLLOWS:
;
; MOVE 0,KEY
; CAMN 0,CONDITION-ITEM
; JRST %E
; CAML 0,CONDITION-ITEM ;'CAMG' IF DESCENDING KEY
; JRST %D
; JRST %I
; %E:
;SEARCH OTHER THAN 'ALL'
;
; %L: MOVE 0,INDEX ;IF VARYING ITEM IS
; MOVEM 0,VARYING-ITEM ; OTHER THAN THE INDEX
; MOVE 0,INDEX
; JUMPLE 0,%AE+1
; CAIG 0,TABLE-SIZE
; %AE:
; JRST %X ;PUT OUT BY 'SPIF'
; <AT-END CODE> ;PUT OUT BY OTHER GENERATORS
;
; %X: <'WHEN' CODE> ;PUT OUT BY 'IF'
; .
; .
; <'WHEN' CODE>
;
; AOS INDEX
; JRST %L
;NOTE THAT, IF A 'DEPENDING' CLAUSE IS INVOLVED, THE 'CAIG' CODE ABOVE IS
; REPLACED BY:
;
; CAMG 0,DEPENDING-ITEM
; CAILE 0,TABLE-SIZE
; SKIPA
SRCHGN: MOVEM W1,OPLINE ;SAVE W1
SETZM SRCFST ;CLEAR
MOVE TE,[XWD SRCFST,SRCFST+1]; WORK
BLT TE,SRCLST ;AREA
MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;IF NO OPERANDS,
POPJ PP, ; FORGET IT
TLO W2,AS.TAG ;BE SURE 'W2' HAS TAG
HRRZ TC,EOPLOC ;GET TO
MOVEI TC,1(TC) ; FIRST OPERAND
MOVSM TC,OPERND
MOVEM TC,CUREOP
MOVE TA,1(TC) ;SAVE
HRRZM TA,SRCIDN ; SEARCH IDENTIFIER
PUSHJ PP,LNKSET ;CONVERT TO ADDRESS
LDB TE,DA.ERR ;[243] SEARCH ITEM IS IN ERROR
JUMPN TE,SRCERR ;[243] YES ERROR
LDB TE,DA.NOC ;IF THIS HAS
JUMPE TE,NOIDX ; NO 'OCCURS', TROUBLE
MOVEM TE,SRCNOC ;SAVE NUMBER OF OCCURENCES
LDB TE,DA.XBY ;GET 'INDEXED BY' ITEM
PUSHJ PP,SRCG60 ;FIND THE CORRECT INDEX
HRRZM TE,SRCIDX ;SAVE IT
JUMPE TE,NOIDX ;IF ZERO--TROUBLE
MOVE TC,CUREOP
MOVEM TE,1(TC) ;REPLACE LINK IN FIRST OPERAND
PUSHJ PP,GETTAG ;GET TAG FOR
HRRZM CH,SRCAE ; 'AT END' PATH LESS 1
TLNE W1,IFALL ;IF 'AL' SEARCH,
JRST SRCG01 ; WE DON'T NEED TAG
PUSHJ PP,GETTAG ;GET TAG FOR
HRRZM CH,SRCLUP ; THE LOOP
PUSHJ PP,PUTTAG ;GIVE IT TO ASSEMBLER
SRCG01: PUSHJ PP,BMPEOP ;STEP TO NEXT OPERAND
JRST SRCG03 ;THERE IS NONE--SO NO 'VARYING'
HRRZ TC,CUREOP ;REMEMBER
HRRM TC,OPERND ; OPERAND ADDRESS
HRRZ TE,1(TC) ;IS IT THE
CAMN TE,SRCIDX ; SEARCH INDEX?
JRST SRCG03 ;YES--NO CODE NEEDED
HLRZ TC,OPERND
PUSHJ PP,SETOPA ;SET UP 'A' TO BE 'INDEXED BY' ITEM
HRRZ TC,OPERND
PUSHJ PP,SETOPB ;SET UP 'B' TO BE 'VARYING' ITEM
TSWT FBNUM ;IF 'B' IS NOT NUMERIC,
JRST NOTNUM ; ERROR
PUSHJ PP,MXX. ;MOVE 'A' TO 'B'
;ANY 'VARYING' HAS BEEN DONE
SRCG03: HLRZ TC,OPERND ;GET BACK TO
MOVEM TC,CUREOP ; 'INDEXED BY' ITEM
TLNE W1,IFALL ;IF IT IS 'SEARCH ALL',
JRST SRCG10 ; GO A DIFFERENT ROUTE
;IT IS NOT 'SEARCH ALL'
PUSHJ PP,SETOPA ;MAKE FISRT OPERAND BE 'A'
SETZM EAC ;USE AC'S 0&1
PUSHJ PP,MXAC. ;PICK UP 'A'
SWON FAINAC ;SET FLAG
MOVSI CH,ASINC+JMPLE. ;GENERATE
HRR CH,SRCAE ; <JUMPLE %AE+1>
LDB TA,[POINT 15,CH,35] ;TAG NUMBER
PUSHJ PP,REFTAG ;REFERENCE IT
PUSHJ PP,PUTASN
HRRZI CH,1
PUSHJ PP,PUTASY
MOVE TA,SRCIDN ;GET LINK TO OCCURRENCE ITEM
PUSHJ PP,LNKSET
LDB CH,DA.DEP ;ANY 'DEPENDING' VARIABLE?
JUMPE CH,SRCG05 ;NO, IF JUMP
;OCCURENCE HAS 'DEPENDING' ITEM
LDB CH,DA.DCR ;NEED TO CONVERT
JUMPE CH,SRCG04 ;NO
HRLI CH,EPJPP
IORI CH,AS.TAG ;PUSHJ PP,%NNN
PUSHJ PP,PUTASY
MOVE CH,[CAMG.+ASINC,,AS.MSC]
PUSHJ PP,PUTASN
MOVEI CH,AS.PAR ;CAMG 0,%PARAM
JRST SRCG07 ;OUTPUT COMPARE
SRCG04: LDB CH,DA.DEP ;REGET IT
ANDI CH,TM.DAT ;CHANGE
IORI CH,AS.DAT ; CODE
HRLI CH,CAMG. ;GENERATE
SRCG07: PUSHJ PP,PUTASY ; <CAMG 0,DEP-VARIABLE>
MOVE CH,[XWD CAILE.,AS.CNB] ;GENERATE
PUSHJ PP,PUTASN ; <CAILE 0,OCCURS>
MOVE TA,SRCIDN
PUSHJ PP,LNKSET
LDB CH,DA.NOC
PUSHJ PP,PUTASY
MOVSI CH,SKIPA.
PUSHJ PP,PUTASY
JRST SRCG06
;OCCURENCE HAS NO 'DEPENDING' ITEM
SRCG05: MOVE CH,[XWD CAIG.,AS.CNB] ;GENERATE
PUSHJ PP,PUTASN ; <CAIG 2,TABLE-SIZE>
MOVE CH,SRCNOC
PUSHJ PP,PUTASY
SRCG06: HRRZ CH,SRCAE ;DEFINE TAG FOR
JRST PUTTAG ; 'AT END' PATH, THEN LEAVE
;SEARCH HAS 'ALL' OPTION
SRCG10: SETOM SRCALL ;SET FLAG FOR 'SINCR'
HRRZ TA,SRCIDN ;GET ADDRESS OF DATAB ENTRY FOR
PUSHJ PP,LNKSET ; SEARCHED ITEM
LDB TE,DA.KEY ;GET AND
MOVEM TE,SRCKYN ; SAVE NUMBER OF KEYS
JUMPE TE,NOKEYS ;IF ZERO--ERROR
HRRZ CH,SRCIDX ;GENERATE
ANDI CH,TM.DAT ; <SETZM INDEX>
IORI CH,AS.DAT
HRLI CH,SETZM.
PUSHJ PP,PUTASY
MOVEI TC,2 ;COMPUTE
SKIPA TE,SRCNOC ; POWER
SRCG11: LSH TC,1 ; OF TWO
CAIG TC,(TE) ; GREATER THAN
JRST SRCG11 ; TABLE SIZE
SETZM EAC ;GENERATE
MOVSI CH,MOV ; <MOVE 0,[POWER OF TWO]>
PUSHJ PP,PUT.LA
MOVE CH,[XWD MOVEM.,AS.MSC];GENERATE
PUSHJ PP,PUTASN ; <MOVEM %PARAM>
HRRZ CH,EAS1PC
IORI CH,AS.PAR
MOVEM CH,SRCPAR
PUSHJ PP,PUTASY
AOS EAS1PC
MOVE CH,[XWD AS.OCT,1] ;PUT OUT <OCT 0> ON AS1FIL
PUSHJ PP,PUTAS1
MOVEI CH,0
PUSHJ PP,PUTAS1
PUSHJ PP,GETTAG ;GET TAG
HRRZM CH,SRC%I ; FOR 'INCREMENT' CODE
PUSHJ PP,PUTTAG
MOVE CH,[XWD SKIPA.+AC1+ASINC,AS.MSC]
PUSHJ PP,PUTASN
MOVE CH,SRCPAR
PUSHJ PP,PUTASY
MOVE CH,[XWD AC1+ASINC+MOVN.,AS.MSC]
PUSHJ PP,PUTASN
MOVE CH,SRCPAR
PUSHJ PP,PUTASY
;SEARCH HAS 'ALL' OPTION (CONT'D)
MOVE CH,[XWD AC1+IDIVI.,2] ;<IDIVI 1,2>
PUSHJ PP,PUTASY
HRRZ CH,SRCAE ;<JUMPE 1,AT-END>
HRLI CH,AC1+ASINC+JUMPE.
LDB TA,[POINT 15,CH,35] ;TAG NUMBER
PUSHJ PP,REFTAG ;REFERENCE IT
PUSHJ PP,PUTASN
HRRZI CH,1
PUSHJ PP,PUTASY
MOVE CH,[XWD AC1+ASINC+MOVMM.,AS.MSC] ;<MOVMM 1,%PARAM>
PUSHJ PP,PUTASN
MOVE CH,SRCPAR
PUSHJ PP,PUTASY
MOVE CH,SRCIDX ;<ADDB 1,INDEX>
ANDI CH,TM.DAT
IORI CH,AS.DAT
HRLI CH,AC1+ADDB.
PUSHJ PP,PUTASY
MOVE TA,SRCIDN ;GET
PUSHJ PP,LNKSET ; TABLE ADDRESS
LDB CH,DA.DEP ;ANY 'DEPENDING' ITEM?
JUMPE CH,SRCG13 ;NO, IF JUMP
LDB CH,DA.DCR ;NEED TO CONVERT
JUMPE CH,SRCG12 ;NO
HRLI CH,EPJPP
IORI CH,AS.TAG ;PUSHJ PP,%NNN
PUSHJ PP,PUTASY
MOVE CH,[CAMG.+AC1+ASINC,,AS.MSC]
PUSHJ PP,PUTASN
MOVEI CH,AS.PAR ;CAMG 1,%PARAM
JRST SRCG15 ;OUTPUT COMPARE
SRCG12: LDB CH,DA.DEP ;REGET IT
ANDI CH,TM.DAT ;YES
IORI CH,AS.DAT ;GENERATE
HRLI CH,AC1+CAMG. ; <CAMG 1,DEPENDING-ITEM>
SRCG15: PUSHJ PP,PUTASY ; PUT INTO ASY FILE AND GO ON [164]
SRCG13: MOVE CH,[XWD AC1+CAILE.,AS.CNB] ;GENERATE
PUSHJ PP,PUTASN ; <CAILE 1,TABLE-SIZE>
MOVE CH,SRCNOC
SRCG14: PUSHJ PP,PUTASY
MOVE CH,SRC%I ;GENERATE
HRLI CH,ASINC+JRST. ; <JRST %I+1>
LDB TA,[POINT 15,CH,35] ;TAG NUMBER
PUSHJ PP,REFTAG ;REFERENCE IT
PUSHJ PP,PUTASN
MOVEI CH,1
PUSHJ PP,PUTASY
JRST SRCG06
;THERE WAS NO 'INDEXED BY' OPTION
NOIDX: MOVEI DW,E.381
JRST NOKYS1
;THERE WERE NO KEYS
NOKEYS: MOVEI DW,E.386
SETZM SRCIDX
NOKYS1: SETZM SRCIDN
JRST OPNFAT
SRCERR: SETZM SRCIDN ; CLEAR SEARCH ITEM [243]
SWON ERROR. ; SET ERROR SWITCH [243]
POPJ PP, ;[243]
;FIND THE CORRECT INDEX.
;ENTER WITH HLDTAB LINK TO FIRST ITEM OF 'INDEXED BY' CLAUSE IN 'TE'.
;EXIT WITH DATAB LINK TO INDEX IN 'TE' (ZERO IF ERROR).
SRCG60: ANDI TE,LMASKS ;THROW AWAY ANY CODE IN LINK
JUMPE TE,SRCG67 ;IF ZERO, NO LINK
MOVE TA,TE ;GET
ADD TA,HLDLOC ; ADDRESS
HRRZM TA,CURHLD
LDB TD,HL.LNK ;DOES THIS
CAME TD,SRCIDN ; ITEM POINT TO THE TABLE?
JRST SRCG66 ;NO--TROUBLE
PUSH PP,CUREOP ;SAVE CUREOP
PUSHJ PP,BMPEOP ;ANY OTHER OPERAND?
JRST SRCG63 ;NO--THEREFORE NO 'VARYING'
HRRZ TC,CUREOP ;YES--SAVE ADDRESS OF THAT OPERAND
POP PP,CUREOP ;RESTORE CUREOP
HRRZ TC,1(TC) ;GET LINK TO VARYING ITEM
SRCG62: LDB TE,HL.NAM ;IS THIS THE DESIRED INDEX?
IORI TE,TC.DAT
CAIN TE,(TC)
POPJ PP, ;YES
ADDI TA,2 ;NO--STEP DOWN TO NEXT HLDTAB ITEM
HRRZ TD,HLDNXT ;ARE WE
CAIL TA,(TD) ; OUT OF HLDTAB?
JRST SRCG64 ;YES--USE FIRST INDEX
LDB TD,HL.COD ;NO--IS THIS
TRZ TD,700 ;*** TEMP, CLEAN UP AFTER CLEANC ***
CAIE TD,HL.XBY ; 'INDEXED BY' ITEM?
JRST SRCG64 ;NO--USE FIRST INDEX
LDB TD,HL.LNK ;IS IT POINTING
CAMN TD,SRCIDN ; TO THE TABLE?
JRST SRCG62 ;YES--LOOP
JRST SRCG64 ;NO--USE FIRST INDEX
;THE FIRST INDEX IS TO BE USED
SRCG63: POP PP,CUREOP ;RESTORE CUREOP
SRCG64: MOVE TA,CURHLD
LDB TE,HL.NAM
IORI TE,TC.DAT
POPJ PP,
;FIND CORRECT INDEX (CONT'D).
;ERROR--RETURN ZERO IN TE
SRCG66: MOVEI TE,0
SRCG67: POPJ PP,
SUBTTL GENERATE 'SINCR' OPERATOR
SINCGN: MOVEM W1,OPLINE ;SAVE W1
SKIPE SRCALL ;WAS SEARCH AN 'ALL'?
JRST SINC10 ;YES
SKIPN CH,SRCIDX ;GET INDEX-NAME
POPJ PP, ;IF ZERO--QUIT
ANDI CH,TM.DAT
IORI CH,AS.DAT
HRLI CH,AOS.
PUSHJ PP,PUTASY
SKIPN CH,SRCLUP ;GET TAG FOR LOOP
POPJ PP, ;IF NONE, FORGET IT
HRLI CH,JRST.
LDB TA,[POINT 15,CH,35] ;GET TAG NUMBER
PUSHJ PP,REFTAG ;REFERENCE IT
JRST PUTASY ; <JRST LOOPTAG>
;SEARCH WAS 'ALL'
SINC10: MOVE EACA,EOPNXT
CAMN EACA,EOPLOC ;IF NO OPERANDS,
POPJ PP, ; QUIT
SKIPE TA,SRCIDN ;IF TROUBLE WITH
SKIPN SRCKYN ; SEARCH
POPJ PP, ; QUIT
PUSHJ PP,LNKSET ;SET 'TA'
ADDI TA,DA.RKL ; TO BE
HRRZM TA,SRCKYL ; ADDRESS OF FIRST ENTRY
SETZM SRCFLG
;COUNT THE OPERANDS.
;ONE MAY BE IN AC'S.
MOVE TC,EOPLOC
MOVEI TC,1(TC)
HRRZM TC,CUREOP
MOVEI TB,1
SINC12: MOVE TD,1(TC)
TLNN TD,GNNOTD
JRST SNC12A
HRRZ TD,0(TC)
CAILE TD,17
JRST SNC12A
PUSHJ PP,PUTEMP
HRRM EACC,0(TC)
SNC12A: PUSHJ PP,BMPEOP
JRST SNC12C
AOS TC,CUREOP
AOJA TB,SINC12
SNC12C: MOVEM TB,SRCOPN ;SAVE IT
SINC13: MOVE TC,EOPLOC ;START AT TOP
MOVEI TC,1(TC) ; OF EOPTAB
HRRZM TC,CUREOP
SWOFF FEOFF1
JRST SINC15
SINC14: PUSHJ PP,BMPEOP ;STEP DOWN TO NEXT OPERAND
JRST SINC16 ;NO MORE--SOME KIND OF ERROR
AOS TC,CUREOP
SINC15: SKIPN (TC) ;WAS THAT OPERAND DONE BEFORE?
JRST SINC14 ;YES--TRY NEXT
MOVSM TC,OPERND ;NO--SAVE THE LOCATION
HRRZ TA,1(TC) ;IS IT
LDB TE,LNKCOD ; A
CAIN TE,TB.CON ; CONDITION-NAME?
JRST SINC18 ;YES
HRRZ TE,@SRCKYL ;NO--IS IT
CAIN TE,(TA) ; THE CURRENT KEY?
JRST SINC26 ;YES
PUSHJ PP,BMPEOP ;NO--STEP TO SECOND OF CONDITION PAIR
JRST BADEOP ;NONE--ERROR FROM PHASE D
AOS TC,CUREOP ;IS THAT
HRRZ TA,1(TC) ; THE
HRRZ TE,@SRCKYL ; CURRENT
CAIE TE,(TA) ; KEY?
JRST SINC14 ;NO--STEP TO NEXT OPERAND
JRST SINC27 ;YES
;WE HAVE LOOKED THROUGH ALL OPERANDS AND HAVEN'T FOUND THE KEY
SINC16: AOS SRCFLG ;BUMP ERROR FLAG
SINC17: SOSG SRCKYN ;ANY MORE KEYS?
JRST SINC20 ;NO
AOS SRCKYL ;YES--STEP TO NEXT KEY
JRST SINC13 ; AND LOOK FOR THAT
;WE FOUND A CONDITION NAME
SINC18: PUSHJ PP,LNKSET ;GET ADDRESS
LDB TE,CO.DAT ;GET ASSOCIATED DATA-NAME
HRRZ TD,@SRCKYL ;IS IT THE
CAIE TE,(TD) ; CURRENT KEY?
JRST SINC14 ;NO
SKIPN SRCFLG ;YES--ANY HIGHER KEYS NOT MENTIONED?
JRST SINC33 ;NO--OK
SINC19: MOVEI DW,E.382 ;YES--PUT OUT DIAG
PUSHJ PP,OPNFAT
JRST SINC34
;NO MORE KEYS -- PUT OUT DIAG FOR EACH REMAINING CONDITION
SINC20: MOVE TC,EOPLOC
MOVEI TC,1(TC)
MOVEM TC,CUREOP
SINC21: SETZM OPERND
SKIPN 0(TC) ;HAS OPERAND BEEN USED?
JRST SINC24 ;YES
MOVE TA,1(TC) ;NO--
LDB TE,LNKCOD ; IS IT
CAIE TE,TB.CON ; CONDITION-NAME?
JRST SINC22 ;NO
MOVEI DW,E.384 ;YES
PUSHJ PP,OPNFAT
JRST SINC24
SINC22: TLNN TA,GNNOTD
MOVEM TC,OPERND
PUSHJ PP,BMPEOP ;STEP DOWN TO SECOND OPERAND
JRST BADEOP ;OOPS!
AOS TC,CUREOP
MOVE TE,1(TC)
TLNN TE,GNNOTD
MOVEM TC,OPERND
MOVEI DW,E.383
SKIPN TC,OPERND
JRST SINC23
PUSH PP,CUREOP
MOVEM TC,CUREOP
PUSHJ PP,OPNFAT
POP PP,CUREOP
JRST SINC24
SINC23: PUSHJ PP,OPFAT
SINC24: PUSHJ PP,BMPEOP ;IF NO MORE OPERANDS,
POPJ PP, ; WE ARE DONE
AOS TC,CUREOP ;LOOP THROUGH
JRST SINC21 ; ALL OPERANDS
;FIRST OPERAND OF A PAIR IS CURRENT KEY
SINC26: PUSHJ PP,BMPEOP ;GET SECOND ONE
JRST BADEOP ;NONE--PHASE D ERROR
AOS TC,CUREOP
HRRM TC,OPERND
JRST SINC28
;SECOND OPERAND OF A PAIR IS CURRENT KEY
SINC27: HRRM TC,OPERND
MOVSS OPERND
SINC28: SWOFF FEOFF1 ;CLEAR FLAGS
HLRZ TC,OPERND
MOVEM TC,CUREOP
SKIPE SRCFLG ;IF MORE MAJOR KEYS NOT MENTIONED,
JRST SINC31 ; ERROR
MOVEI LN,EBASEA
PUSHJ PP,SETOPN
HRRZ TC,OPERND
MOVEI LN,EBASEB
PUSHJ PP,SETOPN
TSWT FERROR
PUSHJ PP,SINC50 ;GENERATE COMPARISONS
SINC30: HLRZ TD,OPERND
SETZM (TD)
HRRZ TD,OPERND
SETZM (TD)
MOVNI TD,2
ADDB TD,SRCOPN
JUMPG TD,SINC17
POPJ PP,
SINC31: MOVEI DW,E.382
PUSHJ PP,OPNFAT
JRST SINC30
;PRODUCE CODE FOR CONDITION-NAME TEST
SINC33: HRRM TD,1(TC) ;PUT DATAB LINK IN OPERAND
HRRZM TA,CURCON ;SAVE ADDRESS OF CONTAB ENTRY
LDB TE,CO.NVL ;GET NUMBER OF VALUES
JUMPE TE,SINC34 ;IF NONE, FORGET IT
MOVE TD,2(TA) ;IF
TLNN TD,1B18 ; RANGE
CAIE TE,1 ; OR MORE THAN ONE VALUE
JRST SINC35 ; ERROR
MOVEI LN,EBASEA
PUSHJ PP,SETOPN
MOVE TA,CURCON ;IS VALUE
MOVE TE,2(TA) ; A FIGURATIVE
TRNE TE,1B19 ; CONSTANT?
JRST SINC37 ;YES
MOVE TE,[XWD EBASEA,EBASEB]
BLT TE,EBASBX
HLRZ TE,2(TA)
ANDI TE,77777
IORI TE,AS.TAG
HRLI TE,^D36
MOVEM TE,EBASEB
SETZM EINCRB
TSWF FANUM ;IF 'A' IS NUMERIC,
SWONS FBNUM!FBSIGN ; THEN 'B' IS SIGNED NUMERIC
SWOFF FBSIGN!FBNUM
SWOFF FBSUB
SNC33A: TSWT FERROR ;IF WE HAVEN'T HAD TROUBLE,
PUSHJ PP,SINC50 ; GENERATE COMPARISONS
SINC34: HLRZ TE,OPERND
SETZM (TE)
SOS TD,SRCOPN
JUMPG TD,SINC17
POPJ PP,
;ONLY ONE VALUE ALLOWED FOR CONDITION NAME
SINC35: MOVEI DW,E.385
PUSHJ PP,OPNFAT
JRST SINC34
;IT IS CONDITION-NAME WITH VALUE OF FIG. CONST.
SINC37: HLRZ TC,OPERND ;SET BOTH OPERANDS TO BE
HRRM TC,OPERND ; IN SAME PLACE
LDB TE,[POINT 6,2(TA),7];GET FIG. CONST. FLAGS
LSH TE,1 ;LEAVE ROOM FOR 'ALL' FLAG
TRZE TE,1B29 ;WAS IT 'ALL'?
TRO TE,1 ;YES
TRO TE,1B20!1B21!1B22
DPB TE,[POINT 16,(TC),15]
MOVEI LN,EBASEB
PUSHJ PP,SETOPN
JRST SNC33A
;PUT OUT COMPARISON CODE
SINC50: MOVE TE,[XWD EBASEA,ESAVSC] ;SAVE PARAMETERS
BLT TE,ESVSCX
;SAVE "A" AND "B" ABS. LOCATIONS FOR EBYTEX, INCASE TABLES EXPAND
HRRZ TE,EBYTEA
HRRZ TD,VALLOC##
SUB TE,TD
PUSH PP,TE ;SAVE "A"
HRRZ TE,EBYTEB##
SUB TE,TD
PUSH PP,TE ;SAVE "B"
TLZ W1,777774 ;CREATE
TLO W1,IFNEQ ; 'IF NOT EQUAL'
PUSHJ PP,GETTAG ;GET TAG FOR 'EQUAL' PATH
MOVEM CH,SRC%E
HRL W2,CH
PUSH PP,SW
PUSH PP,OPERND
PUSHJ PP,IFGNZC ;GENERATE 'IF NOT EQUAL'
POP PP,OPERND
POP PP,SW
MOVS TE,[XWD EBASEA,ESAVSC];RESTORE
BLT TE,EBASBX ; PARAMETERS
;RESTORE "A" AND "B" ABS. LOC OF EBYTEX
POP PP,TE ;"B"
ADD TE,VALLOC##
HRRM TE,EBYTEB
POP PP,TE ;"A"
ADD TE,VALLOC
HRRM TE,EBYTEA
TLZ W1,777774 ;CREATE
SKIPGE @SRCKYL ; EITHER
TLOA W1,IFLESS ; 'IF LESS' OR
TLO W1,IFGRT ; 'IF GREATER'
HRL W2,SRC%I
PUSHJ PP,IFGNZC ;GENERATE 'IF LESS' OR 'IF GREATER'
MOVE CH,SRC%I ;GENERATE
HRLI CH,JRST.+ASINC ; <JRST <DECREMENT CODE>>
LDB TA,[POINT 15,CH,35]
PUSHJ PP,REFTAG ;REFERENCE THE TAG
PUSHJ PP,PUTASN
MOVEI CH,1
PUSHJ PP,PUTASY
MOVE CH,SRC%E ;DEFINE
JRST PUTTAG ; 'EQUAL' TAG AND LEAVE
SUBTTL COMPILER-BREAK-ON-PHASE "X" (X=E,G, OR O)
CBPHE:
IFN DEBUG,<
HRRZ TC,EOPLOC ;FIRST OPERAND
ADDI TC,1 ;POINT TO IT
MOVEM TC,CUREOP ;STORE IN CUREOP
PUSHJ PP,SETOPA ;SETUP AS OPERAND "A", DON'T RETURN IF ERRORS
ILDB TA,EBYTEA ;WHICH PHASE?
CAIN TA,"E"
JRST GOCBE ;E
OUTSTR [ASCIZ/?COMPILER-BREAK-IN-PHASE "G" or "O" not implemented
/]
POPJ PP, ;IGNORE
GOCBE: OUTSTR [ASCIZ/[$CBE]
/]
$CBE:: POPJ PP, ;RETURN
>;END IFN DEBUG
SUBTTL SET condition-name TO TRUE
SETCGN: MOVEM W1,OPLINE ;SAVE LN&CP OF OPERATOR
HRRZ TC,EOPLOC
ADDI TC,1
MOVE EACA,EOPNXT
CAIL TC,(EACA) ;ANY OPERANDS AT ALL?
JRST BADEOP ;NO, ERROR
MOVEM TC,CUREOP
SETCD1: SWOFF FEOFF1 ;TURN OFF MOST FLAGS
SETZM EAC
MOVE TA,1(TC)
LDB TE,LNKCOD
CAIE TE,TB.CON ;IS IT A CONDITION-NAME?
JRST NOTCON ;NO, ERROR
PUSHJ PP,LNKSET ;YES, POINT TO CONTAB
LDB TA,CO.DAT## ;GET DATAB LINK
JUMPE TA,SETCD2 ;JUST INCASE OF ERROR
;movgen expects entries for at least two operands on eop stack.
;Phase D has made one entry for the condition-name. This has
;to be moved down in eoptab so the source operand can be build first,
;and it has to be modified to be a datab operand, not a contab operand.
;First, compute the size of the contab operand and move it.
MOVE TE,1(TC) ;[1564] GET SECOND WORD OF OPERAND
LDB TE,TESUBC ;[1564] GET NUMBER OF SUBSCRIPTS
IMULI TE,2 ;[1564] TIMES 2 WORDS PER SUB
ADDI TE,2 ;[1564] PLUS 2 WORDS FOR THE OPERAND
MOVE TA,EOPNXT ;[1564] END OF CURRENT EOP STACK
MOVE TB,TA ;[1564]
ADD TB,[2,,2] ;[1564] NEW END OF EOP STACK
MOVEM TB,EOPNXT ;[1564]
MOVEM TB,EACA ;[1564]
SETCD5:
POP TA,TC ;[1564] POP OFF CONTAB ENTRY
MOVEM TC,(TB) ;[1564] PLACE IT TWO WORDS LOWER
SOS TB ;[1564]
SOJG TE,SETCD5 ;[1564]
;Build dummy operand on eop stack for the source in the move, which is the
;literal stored in %PARAM equal to the 88 level value.
;
;operand word one = %param entry for condition-name value
SETCD6: MOVE TB,CUREOP ;[1564] STILL POINTS TO CONDITION-NAME
HRRZ TA,1(TB) ;[1564] GET THE CONTAB LINK
MOVEM TA,CURCON ;[1564] SAVE IT
PUSHJ PP,LNKSET ;[1564] ABSOLUTIZE IT
LDB TD,CO.FIG ;[1564] IS VALUE A FIGURATIVE CONSTANT?
JUMPN TD,SETCD7 ;[1564] YES
LDB TD,CO.TAG ;[1564] GET THE %PARAM TAG
IORI TD,AS.TAG ;[1564] MARK IT AS A TAG
HRLI TD,22000 ;[1564] SET 'IN PARAM' (GNPAR) AND GNNOTD
MOVEM TD,(TB) ;[1564]
;operand word two = size, mode, nbr of decimal places, and 'not-datab' flag
MOVSI TD,GNOPNM ;[1564]
LDB TA,CO.DAT ;[1564]
MOVEM TA,CURDAT ;[1564]
PUSHJ PP,LNKSET ;[1564]
LDB TC,DA.USG ;[1564] GET DESTINATION USAGE
DPB TC,[POINT 4,TD,13] ;[1564]
LDB TC,DA.INS ;[1564] GET DESTINATION SIZE
DPB TC,ACSIZE## ;[1564]
LDB TC,DA.NDP## ;[1564] GET DESTINATION DEC. PLACES
HRR TD,TC ;[1564]
TLO TD,GNNOTD ;[1564] SET NOT DATAB FLAG
MOVEM TD,1(TB) ;[1564] OVERWRITE WORD 2 OF OPERAND
JRST SETCD8 ;[1564] NOW FIX UP DESTINATION EOP ENTRY
;[1564] source is a figurative constant
FIGVAL: HRLZI TE,GNFCLV ;[1564] SET BIT FOR LOW-VALUES,
HRLZI TE,GNFCHV ;[1564] HIGH-VALUES,
HRLZI TE,GNFCQ ;[1564] QUOTES,
JFCL ;[1627]
HRLZI TE,GNFCZ ;[1564] ZEROS,
JFCL ;[1627]
JFCL ;[1627]
JFCL ;[1627]
HRLZI TE,GNFCS ;[1564] SPACES
FIGTYP: POINT 5,2(TA),7 ;[1564]
SETCD7: LDB TC,CO.DAT ;[1564] GET DATAB LINK
MOVEM TC,CURDAT ;[1564] AND SAVE IT
SETZ TC, ;[1564]
TLO TC,400000 ;[1564] SET OPERAND BIT
TLO TC,GNLIT!GNFIGC ;[1564] SET LITERAL!FIGURATIVE CONSTANT BITS
LDB TD,FIGTYP ;[1564] GET TYPE OF FIGURATIVE CONSTANT
LSH TD,-1 ;[1627]
XCT FIGVAL(TD) ;[1564] SET FLAG IN TE
IOR TC,TE ;[1564] MAP IT INTO TC
LDB TD,CO.ALL## ;[1564] IS 'ALL' SET?
SKIPE TD ;[1564]
TLO TC,GNALL ;[1564] YES
MOVEM TC,(TB) ;[1564] FIRST WORD OF OPERAND
SETZM 1(TB) ;[1564] SECOND WORD OF OPERAND
;[1564] now fix up eop entry for destination
SETCD8: MOVE TC,CUREOP ;[1564]
ADDI TC,2 ;[1564]
MOVEM TC,CUREOP ;[1564] NOW POINTS TO NEW OPERAND
MOVE TD,(TC) ;[1564] WORD 1 OF OPERAND
MOVE TA,CURDAT ;[1564]
HRRM TA,1(TC) ;[1564] REPLACE CONTAB WITH DATAB LINK
PUSHJ PP,LNKSET ;[1564]
LDB TB,DA.LKS## ;[1564] IS IT IN THE LINKAGE SECTION?
SKIPE TB ;[1564]
TLO TD,(LKSFLG) ;[1564] YES, SET FLAG
LDB TB,DA.USG ;[1564] GET THE USAGE MODE
DPB TB,[POINT 4,TD,13] ;[1564]
MOVEM TD,(TC) ;[1564]
MOVEI LN,EBASEB ;SET IT UP AS "B" OPERAND
PUSHJ PP,SETOPN
TSWF FERROR ;IF ERROR
JRST SETCD2 ;TRY NEXT OPERAND
MOVE TE,[EBASEB,,EBASEA]
BLT TE,EBASAX## ;MAKE "A" AND "B" THE SAME
MOVE TA,CURCON ;[1564] point to contab link
PUSHJ PP,LNKSET
LDB TE,CO.FIG## ;IS IT A FIGCON?
JUMPN TE,SETCD9 ;YES
LDB TE,CO.TAG## ;NO, GET TAG VALUE
IORI TE,AS.TAG## ;ADD TAG CODE
HRLI TE,44 ;LEFT JUSTIFIED
MOVEM TE,EBASEA ;FOR CONDITION-VALUE
SETCD3: SETZM EINCRA ;NO INCREMENT
TSWF FBNUM ;IF "B" IS NUMERIC
SWON FANUM ;MAKE "A" NUMERIC
TSWF FBSIGN ;IF "B" IS SIGNED
SWON FASIGN ;MAKE "A" SIGNED
HRRZ TA,EOPLOC ;[1564] GET A-OP ADDRESS
AOS TA ;[1564]
HRL TA,CUREOP ;[1564] GET B-OP ADDRESS
MOVSM TA,OPERND ;[1564] STORE IN OPERND FOR MOVGEN AND SUBSCR
PUSHJ PP,MXX.## ;DO THE MOVE
;Always only one operand, if more in the source statement, each
;will be followed by its own operator
SETCD2: POPJ PP, ;[1564] DONE
;[1564]SETCD2: PUSHJ PP,BMPEOP ;STEP UP TO NEXT ONE
;[1564] POPJ PP, ;NO MORE
;[1564] MOVE TC,CUREOP
;[1564] JRST SETCD1 ;YES, GO PROCESS IT
;NOT A CONDITION-NAME
NOTCON: MOVEI DW,E.804
PUSHJ PP,OPNFAT
JRST SETCD2
SETCD9: SETZM EBASEA ;SET FOR FIGCON
SETZM ESIZEA ;SIZE DOESN'T MATTER
MOVEI TE,FCMODE##
MOVEM TE,EMODEA ;SET MODE
SETZ TD,
LDB TE,CO.SP##
SKIPE TE
MOVEI TD,1 ;FOUND SPACE
LDB TE,CO.ZRO##
SKIPE TE
MOVEI TD,2 ;FOUND ZERO
LDB TE,CO.QT##
SKIPE TE
MOVEI TD,3 ;FOUND QUOTE
LDB TE,CO.HV##
SKIPE TE
MOVEI TD,4 ;FOUND HIGH-VALUE
LDB TE,CO.LV##
SKIPE TE
MOVEI TD,5 ;FOUND LOW-VALUE
MOVEM TD,EFLAGA
JRST SETCD3 ;DO THE MOVE
SUBTTL SET switch TO ON
SETNGN: MOVEM W1,OPLINE ;SAVE LN&CP OF OPERATOR
HRRZ TC,EOPLOC
ADDI TC,1
MOVE EACA,EOPNXT
CAIL TC,(EACA) ;ANY OPERANDS AT ALL?
JRST BADEOP ;NO, ERROR
MOVEM TC,CUREOP
SETON1: SWOFF FEOFF1 ;TURN OFF MOST FLAGS
SETZM EAC
MOVE TA,1(TC)
LDB TE,LNKCOD
CAIE TE,TB.MNE## ;IS IT A MNEMONIC-NAME?
JRST SETON3 ;NO, ERROR
PUSHJ PP,LNKSET ;YES, POINT TO MNETAB
LDB TE,MN.SWT## ;MAKE SURE WE HAVE A SWITCH VALUE
JUMPE TE,SETON3 ;NO, GIVE ERROR
LDB CH,MN.SWN## ;GET SWITCH NUMBER
HRLI CH,MOVEI.+AC16
PUSHJ PP,PUTASY ;MOVEI 16,SWITCH-NUMBER
MOVEI CH,SSW.ON##
PUSHJ PP,PUT.PJ## ;PUSHJ 17,SSW.ON##
SETON2: PUSHJ PP,BMPEOP ;STEP UP TO NEXT ONE
POPJ PP, ;NO MORE
MOVE TC,CUREOP
JRST SETON1 ;YES, GO PROCESS IT
;NOT A SWITCH
SETON3: MOVEI DW,E.290
PUSHJ PP,OPNFAT
JRST SETON2
SUBTTL SET switch TO OFF
SETFGN: MOVEM W1,OPLINE ;SAVE LN&CP OF OPERATOR
HRRZ TC,EOPLOC
ADDI TC,1
MOVE EACA,EOPNXT
CAIL TC,(EACA) ;ANY OPERANDS AT ALL?
JRST BADEOP ;NO, ERROR
MOVEM TC,CUREOP
SETOF1: SWOFF FEOFF1 ;TURN OFF MOST FLAGS
SETZM EAC
MOVE TA,1(TC)
LDB TE,LNKCOD
CAIE TE,TB.MNE ;IS IT A MNEMONIC-NAME?
JRST SETOF3 ;NO, ERROR
PUSHJ PP,LNKSET ;YES, POINT TO MNETAB
LDB TE,MN.SWT## ;MAKE SURE WE HAVE A SWITCH VALUE
JUMPE TE,SETOF3 ;NO, GIVE ERROR
LDB CH,MN.SWN## ;GET SWITCH NUMBER
HRLI CH,MOVEI.+AC16
PUSHJ PP,PUTASY ;MOVEI 16,SWITCH-NUMBER
MOVEI CH,SSW.OF##
PUSHJ PP,PUT.PJ## ;PUSHJ 17,SSW.OF##
SETOF2: PUSHJ PP,BMPEOP ;STEP UP TO NEXT ONE
POPJ PP, ;NO MORE
MOVE TC,CUREOP
JRST SETOF1 ;YES, GO PROCESS IT
;NOT A SWITCH
SETOF3: MOVEI DW,E.290
PUSHJ PP,OPNFAT
JRST SETOF2
SUBTTL INITIALIZE identifier ...
INITGN: MOVEM W1,OPLINE ;Save LN&CP of operator
HRRZ TC,EOPLOC ;Set up CUREOP
ADDI TC,5 ;[1600] Skip two dummy DATAB and VALTAB entries
MOVEM TC,CUREOP
MOVE EACA,EOPNXT
TLNE W1,OPM.IZ## ;REPLACING clause?
JRST INITRP ;Yes, somewhat harder case
CAIL TC,(EACA) ;Any operands at all?
JRST BADEOP ;No, error
SETZM ETABLA ;Used as flag to show no "A" operand
INITG2: MOVE TA,1(TC)
HRRZM TA,INZDAT## ;Save top level data item
LDB TE,LNKCOD
CAIE TE,TB.DAT##
JRST NOTDAT## ;Not a datab
HRLZM TA,CURDAT ;We need table link later
PUSHJ PP,LNKSET ;Point to datab entry
LDB TB,DA.ERR##
JUMPN TB,INITGX ;Give up if error found
LDB TB,DA.DLL## ;[1600] Is there a depending clause?
JUMPN TB,INITDP ;[1600] at a lower level?
LDB TB,DA.OCC ;[1600] Is this an occurs item?
SKIPE TB ;[1600] No OK
LDB TB,DA.DEP## ;[1600] depending on this level?
JUMPE TB,INIG2A ;[1600] No - OK
INITDP: MOVEI DW,E.856 ;[1600] Yes -- Can't Initialize it
JRST INIG2E ;[1600] Give error
INIG2A: LDB TB,DA.SUB ;[1600] Subscript needed?
JUMPE TB,INIG2B ;[1600] No - Skip check
PUSH PP,TA ;[1600] Save TA
PUSHJ PP,INSUBS ;[1600] Count the number of subscripts needed
PUSHJ PP,CNTSUB ;[1600] Go count given subscripts
POP PP,TA ;[1600] Restore TA
CAMN TB,SUBNUM## ;[1600] The same?
JRST INIG2B ;[1600] Yes - continue
MOVEI DW,E.250 ;[1600] No - wrong number of subscripts
INIG2E: PUSHJ PP,OPNFAT ;[1600] Give error
JRST INITGX ;[1600] Give up on this one
INIG2B: LDB TB,DA.SON## ;[1600]Is this an elementary item?
JUMPE TB,[PUSHJ PP,INITGE ;Yes
PUSHJ PP,NOTMV1 ;Not MOVEable, skip return
PUSHJ PP,INITG6 ;Do MOVE
JRST INITGX] ;See if any more
INITG3: MOVE TA,TB ;Get son
HRLZM TA,CURDAT ;We need table link later
PUSHJ PP,LNKSET
LDB TB,DA.SON## ;Is this one elementary?
JUMPN TB,INITG3 ;No, try again
PUSHJ PP,INITGE ;Yes, initialize this item
JRST INITG4 ;Ignore
PUSH PP,CURDAT ;[1600] save curdat from subscr
PUSHJ PP,INITG6 ;Do the MOVE
POP PP,CURDAT ;[1600] get curdat back
INITG4: HLRZ TA,CURDAT ;Get datab link back incase something moves
PUSHJ PP,LNKSET ;[1600] Get table address back
INITG5: LDB TB,DA.BRO## ;[1600] Get brother link
LDB TC,DA.FAL## ;Might be father link
JUMPE TC,INITG3 ;OK, its another brother
CAMN TB,INZDAT ;Are we back at original data item?
JRST INITGX ;Yes
MOVE TA,TB ;No, back up one
HRLZM TA,CURDAT ;[1600] Save the pointer for later
PUSHJ PP,LNKSET ;[1600] Get table address
LDB TC,DA.OCC ;[1600] Is it a table?
SKIPE TC ;[1600]
PUSHJ PP,INITOC ;[1600] Yes - Go init the table
JRST INITG4
;[1600] Define a macro to push entries in to EOPTAB when building operands
;[1600] for calling MOVGEN. Both A and B must be ACs.
DEFINE PUSHOP (A,B)< ;[1600] Push B onto EOPTAB using pointer A
MOVEM B,(A) ;[1600] Save the data
AOBJN A,.+2 ;[1600] Point to the next one
PUSHJ PP,EOPFUL ;[1600] Get more space if it overflowed
> ;[1600] End define PUSHOP
;[1600]Here to generate code to initialize the second and subsequent
;[1600]occurences of a table. The first occurence is copied to each of
;[1600]the remaining occurences. The code is generated as follows.
;[1600] MOVEI 0,number_of_occurences-1 ;Init the loop counter
;[1600] MOVEI 1,2 ;move to subscript 2 first
;[1600] MOVE 1,-GENERATED-INITIALIZE-COUNTER- ;used by move code
;[1600] %n |
;[1600] {Call MOVGEN to generate:
;[1600] MOVE table(1...1) TO table(1...1,-GENERATED-INITIALIZE-COUNTER-)}
;[1600] |
;[1600] AOS -GENERATED-INITIALIZE-COUNTER- ;next subscript
;[1600] SOJG 0,%n ;loop to the last subscript
;[1600]The VALTAB entery (1) and DATAB entry (-GENERATED-INITIALIZE-COUNTER-)
;[1600]are provided by phase D as operands to INITIALIZE.
;[1600]
;[1600]Note: This algorithm has a known side effect when the REPLACING clause
;[1600] is used. The standard states that items not of the replacing
;[1600] type will be uneffected. If a table occurence contains items
;[1600] not of the replacing type then the group move used by this
;[1600] algorithm will effect these items. The value of all items is
;[1600] set to the value of the first occurence. It is assumed that
;[1600] that in most cases a table containing valuable data will not
;[1600] be initialized and that strait COBOL code can be used to aviod
;[1600] this side effect when it does appear. If this side effect is
;[1600] required to be fixed then a new algorithm must be used for the
;[1600] replacing case that does not use the group move. The INITOC
;[1600] routine could be replaced for the replacing case with a routine
;[1600] that would generate elementary moves inside nested loops. Each
;[1600] nest of the loop would count off one of the required subscripts
;[1600] through its range. Only one set of nested loops would be needed
;[1600] if the elementary moves are placed at the proper place in the
;[1600] set of nested loops. The DATAB entrys would be generated in
;[1600] phase D after counting the number of subscripts that would be
;[1600] needed. Walk the DATAB tree saving occurs and items of the
;[1600] replacement type in HLDTAB. Clean entrys form HLDTAB when
;[1600] no entrys of the correct type are found. Walk down the HLDTAB
;[1600] entrys generating looping code and elementary moves as needed
;[1600] and saving the loop target tags in HLDTAB. This algorithm
;[1600] was not elaborated in this PCO because the side effect did not
;[1600] seem serious enough to require the necessary coding effort.
;[1600] It is included here in case of future need.
INITOC: PUSH PP,CURDAT ;[1600] Save DATAB pointer
PUSH PP,CUREOP ;[1600] Save where we are working
;[1600]Count the number of subscripts needed
;[1600]subtract the number that we were given in phase D.
PUSHJ PP,INSUBS ;[1600]count the levels of subscripts
PUSHJ PP,CNTSUB ;[1600]Get the number of subscripts given
MOVE TA,SUBNUM ;[1600]Get the level count back
SUB TA,TB ;[1600]The number of valtab entries needed
MOVEM TA,VSUBS## ;[1600]Save it for later
;[1600]Save the end of EOPTAB
MOVE TD,EOPNXT ;[1600]the current end
MOVEM TD,EOPHLD## ;[1600]so we can clean up later
;[1600]Gen MOVEI 0,number_of_occurrences - 1 for the loop counter
SETZM EAC ;[1600]Restart AC counter
HLRZ TA,CURDAT ;[1600]Get the saved curdat
PUSHJ PP,LNKSET ;[1600]Convert the relative address
LDB TB,DA.NOC ;[1600]How many we need to do
SOS TB ;[1600]Less one
JUMPE TB,INITO6 ;[1600]OCCURS 1 TIMES - this code not needed
MOVSI CH,MOV## ;[1600]Gen <MOVEI 0,DA.NOC-1>
HRRZ TC,TB ;[1600]Get DA.NOC from TB
PUSHJ PP,PUT.LA ;[1600]Put it into the ASYFIL
;[1600]Gen MOVEI 1,2 to initialize the subscript counter
AOS EAC ;[1600]Next AC
MOVSI CH,MOVEI. ;[1600]Use a MOVEI
HRRI CH,2 ;[1600]Start with the second occurence
MOVE TB,EAC ;[1600]Use this AC
DPB TB,CHAC## ;[1600]Put it in CH
PUSHJ PP,PUTASY## ;[1600]Gen MOVEI 1,2
;[1600]Gen MOVEM 1,-GENERATED-INITIALIZE-COUNTER-
;[1600] This counter is used in the move code as a subscript.
MOVE TC,EOPLOC ;[1600]Off set from the top of EOP
HRRZ TB,2(TC) ;[1600]get the DATAB entry passed from D
MOVEM TB,EBASEA ;[1600]set up as 'A'
HRRZI TC,1(TC) ;[1600]Point to EOP for the init counter
HRLZM TC,OPERND ;[1600]Store it for the setopn code
HRRZI LN,EBASEA ;[1600]Set up as "A" for the PUT.AA call
PUSHJ PP,SETOPN ;[1600]Set up "A"
MOVSI CH,MOVEM. ;[1600]A move to memory instruction
PUSHJ PP,PUT.AA## ;[1600] MOVEM 1,-GENERATED-INITIALIZE-COUNTER-
SOS EAC ;[1600]Give AC back
;[1600]Put a tag here so that we can do the move again.
INITO5: PUSHJ PP,GETTAG ;[1600]Get a tag for the loop
JUMPE CH,INITO5 ;[1600]Can't use tag 0
MOVEM CH,OCCTAG## ;[1600]Save the tag number
PUSHJ PP,PUTTAG## ;[1600]The tag goes here
;[1600]Set up EOPTAB entrys to call MOVGEN
;[1600]create the "from" datab entry and put it in EOPTAB
MOVE TD,EOPNXT ;[1600]the current end
AOBJN TD,INITO7 ;[1600]point to empty spot
PUSHJ PP,EOPFUL ;[1600]Full- Expand EOPTAB
INITO7: SETZM TB ;[1600]Start with zero. Use DPB to set fields
PUSHOP TD,TB ;[1600]Save it in EOPTAB
MOVE TA,TD ;[1600]point at the entry being built
SOS TA ;[1600]which is one back
SETOM TB ;[1600]To set some flags
DPB TB,EO.IDO## ;[1600]Set operand bit
HRRZI TB,%US.DS ;[1600]Usage is display for group move
DPB TB,EO.USG## ;[1600]Set usage
HRRZ TC,CUREOP ;[1600]Point to the current item
HLRZ TB,1(TC) ;[1600]The size of the given subscripts
ADD TB,VSUBS ;[1600]Plus the added VALTAB entrys
HRLZ TB,TB ;[1600]Put it in the left half
HLR TB,CURDAT ;[1600]the datab entry
PUSHOP TD,TB ;[1600]Put it in EOPTAB
;[1600]add the VALTAB =1 enterys as needed
MOVE TC,EOPLOC ;[1600]get the start of this operator
MOVE TA,VSUBS ;[1600]Get the number of dummy "1" subscr
JUMPE TA,INITO4 ;[1600]Don't need any
INITO1: MOVE TB,3(TC) ;[1600]just the flag of the VALTAB entry
PUSHOP TD,TB ;[1600]Put it in EOPTAB
MOVE TB,4(TC) ;[1600]The VALTAB offset provided by phase D.
PUSHOP TD,TB ;[1600]Put it in EOPTAB
SOJN TA,INITO1 ;[1600]Loop till done
;[1600]Copy the given subscipts given in phase D so that
;[1600]they can be used for the group move.
INITO4: MOVEM TD,EOPNXT ;[1600]Save the pointer
PUSHJ PP,BLTEOP ;[1600]Copy the given subscripts
;[1600]Set up EBASEA
INITO3: HRRZ TC,EOPHLD ;[1600]Point to the A operand
AOS TC ;[1600]Starts one past the old end of EOPTAB
HRLZM TC,OPERND ;[1600]Start of the A operand in EOPTAB
MOVEI LN,EBASEA ;[1600]Set up A operand
PUSHJ PP,SETOPN ;[1600]Set up EBASEA flags and check subscripts
MOVE TD,EOPNXT ;[1600]Get the EOPTAB pointer back
HRRM TD,OPERND ;[1600]Start of the B operand in EOPTAB
;[1600]create the "to" DATAB entry (copy "from" entry)
MOVE TA,EOPHLD## ;[1600]Offset from the old end of EOPTAB
MOVE TB,1(TA) ;[1600]Get the first of the two word
PUSHOP TD,TB ;[1600]Put it in EOPTAB
MOVE TB,2(TA) ;[1600]The same for the second word
PUSHOP TD,TB ;[1600]Put it in EOPTAB
;[1600]get the DATTAB for the counter from COBOLD
MOVE TC,EOPLOC ;[1600]so we can offset from here
MOVE TB,1(TC) ;[1600]The DATAB entry form cobold
PUSHOP TD,TB ;[1600]Put it in EOPTAB
MOVE TB,2(TC) ;[1600]-GENERATED-INITIALIZE-COUNTER-
;[1600]put it into EOPTAB as the last subscript
PUSHOP TD,TB ;[1600]Put it in EOPTAB
;[1600]add n-1 VALTAB=1 entrys
MOVEM TD,EOPNXT ;[1600]Put the updated pointer back
HRRZ TC,CUREOP ;[1600]Point to the current item
HLRZ TB,1(TC) ;[1600]The size of the given subscripts
ADD TB,VSUBS ;[1600]Plus the added VALTAB entrys
SOS TB ;[1600]Less one
JUMPE TB,INITO2 ;[1600]Only one subscript - skip this
HRLI TC,5(TA) ;[1600]address of second VALTAB entry
PUSHJ PP,BLTEP1 ;[1600]Go copy the subscripts to EOPNXT
;[1600]finish set up of ESIZEB
INITO2: HRRZ TC,OPERND ;[1600]Get the start of B back
MOVEI LN,EBASEB ;[1600]Point to B
PUSHJ PP,SETOPN ;[1600]Set up B operand
;[1600]call MOVGEN to generate one group move.
PUSHJ PP,GRPMOV ;[1600]Should be a group move
PUSHJ PP,MXX. ;[1600]The general move routine
;[1600]Gen AOS -GENERATED-INITIALIZED-COUNTER-
;[1600] to point at the next subscript to initialize
MOVE TC,EOPLOC ;[1600]Get the counter entry
HRRZ TB,2(TC) ;[1600]The DATAB entry
MOVEM TB,EBASEA ;[1600] for ebasea
HRRZI TC,1(TC) ;[1600]Set up a pointer into EOPTAB
HRLZM TC,OPERND ;[1600]point at -GEN..COUNTER-
HRRZI LN,EBASEA ;[1600]use -GEN..COUNTER- in the instruction
PUSHJ PP,SETOPN ;[1600]set it up as A temporarily
MOVSI CH,AOS.## ;[1600]GEN <AOS -GENERATED-INITIALIZE-COUNTER->
PUSHJ PP,PUT.A## ;[1600]Call to generate OP EBASEA
;[1600]Gen SOJG 0,%n to jump back to the group move if all of the
;[1600] occurrences have not been initialized.
HRRZ TA,OCCTAG ;[1600]Get the saved tag
PUSHJ PP,REFTAG## ;[1600]I am using the tag here
MOVSI CH,SOJG.## ;[1600]GEN SOJG AC,OCCTAG
MOVE TE,EAC ;[1600]Use this AC
DPB TE,CHAC ;[1600] for the test
HRR CH,OCCTAG ;[1600]Jump back to saved tag
PUSHJ PP,PUTASY ;[1600]Put the instruction into ASYFIL
;[1600]All done. Restore the things we stepped on.
INITO6: MOVE TD,EOPHLD ;[1600]Get the old eopnxt
MOVEM TD,EOPNXT ;[1600] and put it back
POP PP,CUREOP ;[1600] Get saved pointer back
POP PP,CURDAT ;[1600] Restore Father pointer
POPJ PP, ;[1600] initialize the occurs
;[1600]Count the number of subscripts needed by MOVGEN to generate
;[1600]a move to the DATAB item in CURDAT.
;[1600]Return the count in SUBNUM.
INSUBS: HLRZ TA,CURDAT ;[1600]count from here
PUSHJ PP,LNKSET ;[1600]get the absolute address
SETZM SUBNUM## ;[1600]Start with zero subscripts
LDB TB,DA.OCC## ;[1600]occurs on this level?
SKIPE TB ;[1600]no - start with 0
AOS SUBNUM ;[1600]yes - start with 1
INSUB2: LDB TA,DA.OCH## ;[1600]is there one above?
SKIPN TA ;[1600]jump if so
POPJ PP, ;[1600]done
AOS SUBNUM ;[1600]bump count
PUSHJ PP,LNKSET ;[1600]Get the address
JRST INSUB2 ;[1600]loop for more
;[1600]Count the number of subscripts passed in EOPTAB from phase D.
;[1600]CUREOP points to the subscripted data item.
;[1600]The count is returned in TB and GSUB.
CNTSUB: SETZM GSUB## ;[1600]Start with zero given subscripts
MOVE TC,CUREOP ;[1600]Point to the current item
HLRZ TA,1(TC) ;[1600]initialize the counter
JUMPN TA,CNTSB1 ;[1600]Subscripts?
SETZM TB ;[1600]No
POPJ PP, ;[1600]done
CNTSB1: ADDI TC,2 ;[1600]Point to the next one
MOVE TB,(TC) ;[1600]Get the flags
TLNE TB,GNLIT ;[1600]Is it a dataname?
JRST CNTSB2 ;[1600]No - skip adder check
HLRZ TB,1(TC) ;[1600]Get the flag
JUMPE TB,CNTSB2 ;[1600]Is there an adder?
ADDI TC,2 ;[1600]Yes - bump past it
SOS TA ;[1600]And count it
CNTSB2: AOS GSUB ;[1600]No - bump the count
SOJG TA,CNTSB1 ;[1600]Loop till done
HRRZ TB,GSUB ;[1600]Put the result in TB
POPJ PP, ;[1600]Done
;[1600] Here to expand EOPTAB
EOPFUL: PUSHJ PP,XPNEOP## ;[1600]Call the table expanding routine
HLRZ TE,EOPHLD ;[1600]get saved size
SUBI TE,^D20 ;[1600]The table was expanded by 20
HRLM TE,EOPHLD ;[1600]so update it
HLRZ TE,TD ;[1600]get the EOPTAB stack pointer
SUBI TE,^D20 ;[1600]Update it too
HRLM TE,TD ;[1600]put it back
HLRE TE,EOPNXT ;[1600]Was that enough?
JUMPGE TE,EOPFUL ;[1600]NO - jump back and do it again
POPJ PP, ;[1600]done
;[1600] Here to copy a set of subscripts from one part of EOPTAB to
;[1600] EOPNXT. Enter with CUREOP pointing to the from location or
;[1600] at BLTEP1 with TC pointing to the source and TB holding the size
;[1600] of the block to be moved.
BLTEOP: HRRZ TE,CUREOP ;[1600]Start of an item from phase D
HLRZ TB,1(TE) ;[1600]The size of the subscripts given
JUMPE TB,CPOPJ ;[1600]None - Don't need to do the BLT
HRLI TC,2(TE) ;[1600]The first subscript starts here
BLTEP1: ;[1600]Enter here with TB and TC set up
HRR TC,EOPNXT ;[1600]Put the copy here
LSH TB,1 ;[1600]Two words per subscript entry
HRL TB,TB ;[1600]2*subnum,,2*subnum
ADDB TB,EOPNXT ;[1600]Point to the end of the copy area
HLRE TE,EOPNXT ;[1600]Must check for EOPTAB overflow
SKIPL TE ;[1600]No - OK
PUSHJ PP,EOPFUL ;[1600]Overflow - Go expand EOPTAB
HRRZ TB,TB ;[1600]Zero left half
SOS TB ;[1600]The last subscript goes here
BLT TC,(TB) ;[1600]Copy the subscripts
POPJ PP, ;[1600]Done
;Here to do a MOVE
INITG6: PUSH PP,CUREOP ;[1600]Save the item we are working on
PUSHJ PP,INITEL ;[1600]Set up subscripts
SETZ TB, ;[1600]Zero out the pointer to "A"
HRLM TB,OPERND ;[1600]"A" is not in EOPTAB
LDB TB,DA.CLA
CAIN TB,%CL.NU ;Is "B" numeric or numeric-edited?
SKIPA TB,[EXP IXZERO] ;Yes, store zero
MOVEI TB,IXSPAC ;No, store spaces
MOVEM TB,EFLAGA ;Fake as much as we need of "A"
;Copy code from MOVGEN to handle edited items
LDB TE,DA.EDT ;Is it edited
LDB TD,DA.BWZ## ; Or BLANK
IORI TE,(TD) ; WHEN ZERO?
JUMPE TE,INIG6C ;[1600]No
MOVEI TD,EDMODE## ;Yes, set new mode
HRRM TD,EMODEB
LDB TE,DA.CLA ;Is it
CAIN TE,%CL.NU ; Numeric?
SWON FBNUM ;Yes
INIG6C: PUSHJ PP,MFCX.## ;[1600]Call MOVGEN at Move Figurative Constant.
MOVE TD,EOPHLD ;[1600]Get the old eopnxt
MOVEM TD,EOPNXT ;[1600] and put it back
POP PP,CUREOP ;[1600]get saved pointer back
POPJ PP, ;[1600]
;Here to get next data item
INITGX: PUSHJ PP,BMPEOP ;Step up to next one
POPJ PP, ;No more
MOVE TC,CUREOP
JRST INITG2 ;Process it
;Here to see if current elementary item is eligible for MOVE
;[1600]If the elementary item has an occurs clause then initialize it.
;Enter with TA = datab link
;[1600]Return .+1 if MOVE cannot be done or an occurs item was initialized.
;Return .+2 if MOVE could be done.
INITGE: SWOFF FEOFF1 ;Turn off flags
SETZM EAC
LDB TB,DA.OCC##
JUMPN TB,INITG1 ;[1600]Indexed elementary special case
LDB TB,DA.USG##
CAIN TB,%US.IN
POPJ PP, ;Ignore if usage is INDEX
LDB TB,DA.LVL##
CAIN TB,LVL.66 ;Ignore level 66 items also
POPJ PP,
LDB TB,DA.RDF##
JUMPN TB,CPOPJ ;Also REDEFINED item
LDB TB,DA.NAM##
ANDI TB,077777
CAMN TB,FLRADD##
POPJ PP, ;Also ignore FILLER
AOS (PP) ;[1600]Set for OK return
LDB TB,DA.SUB ;[1600]Do we need a subscript?
SKIPE TB ;[1600]If so
POPJ PP, ;[1600]Not the simple case - exit
MOVE TC,CUREOP ;However EOPTAB is not correct
MOVE TA,CURDAT
HLRM TA,1(TC) ;So fake it to point to current datab
HRRZM TC,OPERND ;Incase MOVGEN needs it
MOVEI LN,EBASEB
PUSH PP,CUREOP ;[1600]Save the pointer
PUSHJ PP,SETOPN## ;Return with "B" operand set up
POP PP,CUREOP ;[1600]Get it back
POPJ PP, ;[1600] Return
;[1600] Here for the special case of an occurs clause with a picture clause
;[1600] In this case the elementary item and the occurrences of it are
;[1600] here and the plus 1 return is taken
INITG1: MOVE W1,OPLINE ;[1600]Get operator back
TLNE W1,OPM.IZ ;[1600]Replacing clause?
JRST INITR1 ;[1600]Initialize with the replacing item
PUSH PP,CURDAT ;[1600]Save curdat
PUSHJ PP,INITG6 ;[1600]Init the first one
POP PP,CURDAT ;[1600]Get curdat back
PJRST INITOC ;[1600]Do the rest of them
INITR1: PUSHJ PP,INITRA ;[1600]Set up "A"
SETOM REPFLG ;[1600]Flag that an item was found
PUSHJ PP,INIMV ;[1600]INIT the first one
PJRST INITOC ;[1600]Go do the rest
;[1600]Here to set up subscripts for an elementary move
;[1600]If subscripts are needed to generate a MOVE to the current item
;[1600]then provide a subscript of (1,...,1) for MOVGEN
;[1600]Otherwize return.
INITEL: MOVE TD,EOPNXT ;[1600]the current end
MOVEM TD,EOPHLD## ;[1600]so we can clean up later
HLRZ TA,CURDAT ;[1600]Get the DATAB pointer to be sure
PUSHJ PP,LNKSET ;[1600]Get the absolute address
LDB TB,DA.SUB## ;[1600]Does this item need a subscript?
JUMPE TB,INIEL4 ;[1600]no - clean up and exit
PUSH PP,TA ;[1600]Save the datab pointer
;[1600]Count the number of subscripts needed
;[1600]subtract the number that we were given
PUSHJ PP,INSUBS ;[1600]count levels of subscripts for curdat
PUSHJ PP,CNTSUB ;[1600]count the subscripts from phase D
MOVE TA,SUBNUM ;[1600]get the count back
SUB TA,TB ;[1600]The number of valtab entries needed
MOVEM TA,VSUBS ;[1600]Save it for later
;[1600]Save the end of EOPTAB
MOVE TD,EOPNXT ;[1600]in case td was stepped on
AOBJN TD,INIEL5 ;[1600]point to empty spot
PUSHJ PP,EOPFUL ;[1600]Full- Expand EOPTAB
;[1600]set the pointer to the B operand for movgen
INIEL5: HRRM TD,OPERND ;[1600]Start of the B operand in EOPTAB
;[1600]create the "to" datab entry and put it in EOPTAB
SETZM TB ;[1600]Start with zero. Use DPB to set fields
PUSHOP TD,TB ;[1600]Save it in EOPTAB
MOVE TA,CUREOP ;[1600]get the line number of this item
LDB TC,EO.LN## ;[1600]from the EOPTAB entry
MOVE TA,TD ;[1600]point at the entry being built
SOS TA ;[1600]which is one back
SETOM TB ;[1600]To set some flags
DPB TB,EO.IDO## ;[1600]Set operand bit
HRRZI TB,%US.DS ;[1600]Usage is display for group move
DPB TB,EO.USG## ;[1600]Set usage
DPB TC,EO.LN## ;[1600]LN for truncation warnings
HRRZ TC,CUREOP ;[1600]Point to the current item
HLRZ TB,1(TC) ;[1600]The size of the given subscripts
ADD TB,VSUBS ;[1600]Plus the added VALTAB entrys
HRLZ TB,TB ;[1600]Put it in the left half
HLR TB,CURDAT ;[1600]the datab entry
PUSHOP TD,TB ;[1600]Put it in EOPTAB
;[1600]add the VALTAB =1 enterys as needed
HRRZ TC,EOPLOC ;[1600]Offset from here
MOVE TA,VSUBS ;[1600]Get the count of subscripts back
JUMPE TA,INIEL2 ;[1600]Don't need any
INIEL1: MOVE TB,3(TC) ;[1600]just the flag of the VALTAB entry
PUSHOP TD,TB ;[1600]Put it in EOPTAB
MOVE TB,4(TC) ;[1600]The VALTAB offset provided by phase D.
PUSHOP TD,TB ;[1600]Put it in EOPTAB
SOJN TA,INIEL1 ;[1600]Loop till done
;[1600]copy the given subscripts
INIEL2: MOVEM TD,EOPNXT ;[1600]Save the counter
PUSHJ PP,BLTEOP ;[1600]Copy the given subscripts
;[1600]Set up EBASEB etc
INIEL3: HRRZ TC,OPERND ;[1600]get the EOPTAB pointer
MOVEI LN,EBASEB ;[1600]Set up "B"
PUSHJ PP,SETOPN ;[1600]Set it up
;[1600]Restore the absolute DATAB pointer saved on the stack
POP PP,TA ;[1600]get the datab pointer back
INIEL4: POPJ PP, ;[1600]go do the move
;Here for INITIALIZE identifier REPLACING ...
INITRP: CAIL TC,-4(EACA) ;Do we have at least 3 operands?
JRST BADEOP ;No, error
HRRZ TB,(EACA) ;[1600]Size of the replacing item
HRRZ TA,(EACA) ;[1600]Save it for the check
AOS TB ;[1600]Plus one for the size entry
LSH TB,1 ;[1600]Two words per entry
HRL TB,TB ;[1600]Do the left half too
SUB EACA,TB ;[1600]Adjust the pointer
HLRZ TB,(EACA) ;[1600]Get the entry count
CAME TB,TA ;[1600]The same?
JRST BADEOP ;[1600]NO - Must be bad ref. mod.
MOVEM EACA,REPSAV# ;[1600]Save it for later
;Check to see that last item matches REPLACING clause
MOVE TB,-1(EACA) ;Get first word of GENFIL pair
LDB TA,[POINT 3,OPLINE,11] ;Get index
CAILE TA,OP%NED## ;Is it legal?
JRST NOTMTC ;No, so it doesn't match
TLNN TB,GNLIT ;Is it a literal?
JRST INITRD ;No
XCT [TLNN TB,GNNUM ;NUMERIC
TLNE TB,GNNUM ;ALPHABETIC
TLNE TB,GNNUM ;ALPHANUMERIC
TLNE TB,GNNUM ;ALPHANUMERIC-EDITED
TLNN TB,GNNUM]-1(TA) ;NUMERIC-EDITED
JRST NOTMTC ;Does not match
JRST INITR2 ;OK
INITRD: MOVE TA,(EACA) ;Get DATAB link
PUSHJ PP,LNKSET
LDB TB,DA.SON## ;Is it a group item?
JRST INITR2 ;Yes, then its always legal
LDB TB,DA.CLA## ;Get class
CAIL TB,%%CL ;Should never happen
JRST NOTMTC
LDB TC,DA.EDT## ;Get edited flag
SKIPE TC
ADDI TB,%%CL ;TB = DA.CLA+<%%CL*DA.EDT>
LDB TA,[POINT 3,OPLINE,11] ;Get index again
XCT [CAIE TB,%CL.NU ;NUMERIC
CAIE TB,%CL.AB ;ALPHABETIC
CAIE TB,%CL.AN ;ALPHANUMERIC
CAIE TB,%CL.AN+%%CL ;ALPHANUMERIC-EDITED
CAIE TB,%CL.NU+%%CL]-1(TA) ;NUMERIC-EDITED
JRST NOTMTC ;Does not match
; JRST INITR2 ;OK
;Here when the sending item is OK
INITR2: SETZM REPFLG## ;[1600] Flag no items initialized
MOVE TC,CUREOP
MOVE TA,1(TC)
HRRZM TA,INZDAT ;Save top level data item
LDB TE,LNKCOD
CAIE TE,TB.DAT
JRST NOTDAT ;Not a datab
HRLZM TA,CURDAT ;We need table link later
PUSHJ PP,LNKSET ;Point to datab entry
LDB TB,DA.ERR##
JUMPN TB,INITRX ;Give up if error found
LDB TB,DA.DLL## ;[1600] Is there a depending clause?
JUMPN TB,INIRDP ;[1600] at a lower level?
LDB TB,DA.OCC ;[1600] Is this an occurs item?
SKIPE TB ;[1600] No OK
LDB TB,DA.DEP## ;[1600] depending on this level?
JUMPE TB,INIR2A ;[1600] No - OK
INIRDP: MOVEI DW,E.856 ;[1600] Yes -- Can't Initialize it
JRST INIR2E ;[1600] Give error
INIR2A: LDB TB,DA.SUB ;[1600] Subscript needed?
JUMPE TB,INIR2B ;[1600] No - Skip check
PUSH PP,TA ;[1600] Save the DATAB pointer
PUSHJ PP,INSUBS ;[1600] Count the number of subscripts needed
PUSHJ PP,CNTSUB ;[1600] Count the subscripts given
POP PP,TA ;[1600] Restore the saved DATAB pointer
CAMN TB,SUBNUM## ;[1600] The same?
JRST INIR2B ;[1600] Yes - continue
MOVEI DW,E.250 ;[1600] No - wrong number of subscripts
INIR2E: PUSHJ PP,OPNFAT ;[1600] Give error
JRST INITRX ;[1600] Give up on this one
INIR2B: LDB TB,DA.SON## ;[1600]Is this an elementary item?
JUMPE TB,INITRE ;Yes
;Loop for group item
INITR3: MOVE TA,TB ;Get son
HRLZM TA,CURDAT ;We need table link later
PUSHJ PP,LNKSET
LDB TB,DA.SON## ;Is this one elementary?
JUMPN TB,INITR3 ;No, try again
LDB TB,DA.CLA## ;Get class
LDB TC,DA.EDT## ;Get edited flag
SKIPE TC
ADDI TB,%%CL ;TB = DA.CLA+<%%CL*DA.EDT>
MOVE W1,OPLINE ;Set up W1 again
LDB TC,[POINT 3,OPLINE,11] ;Get index again
XCT [CAIN TB,%CL.NU ;NUMERIC
CAIN TB,%CL.AB ;ALPHABETIC
CAIN TB,%CL.AN ;ALPHANUMERIC
CAIN TB,%CL.AN+%%CL ;ALPHANUMERIC-EDITED
CAIN TB,%CL.NU+%%CL]-1(TC) ;NUMERIC-EDITED
PUSHJ PP,INITGE ;Yes, initialize this item
JRST INITR4 ;Ignore
PUSHJ PP,INITRA ;Set up "A"
SETOM REPFLG ;[1600] Flag that one was found
PUSHJ PP,INIMV ;[1600] Do the MOVE
INITR4: HLRZ TA,CURDAT ;Get datab link back incase something moves
PUSHJ PP,LNKSET ;[1600] Get table address back
INITR5: LDB TB,DA.BRO## ;[1600] Get brother link
LDB TC,DA.FAL## ;Might be father link
JUMPE TC,INITR3 ;OK, its another brother
CAMN TB,INZDAT ;Are we back at original data item?
JRST INITRX ;Yes
MOVE TA,TB ;No, back up one
HRLZM TA,CURDAT ;[1600] Save the pointer for later
PUSHJ PP,LNKSET ;[1600] Get table address
LDB TC,DA.OCC ;[1600] Is it an occurs table?
SKIPE TC ;[1600]
SKIPN REPFLG ;[1600] Don't init if no items found
SKIPA ;[1600]
PUSHJ PP,INITOC ;[1600] Yes - Go init the table
JRST INITR4 ;[1600] Go do next brother or father
;Set up last operand as "A", we do this everytime just for safety
INITRA: MOVEI LN,EBASEA
HRRZ TC,REPSAV ;[1600]Get pointer to REPLACING item
SUBI TC,1 ;Point to last operand
HRLM TC,OPERND ;For MOVGEN
PUSHJ PP,SETOPN ;Set up as "A"
JRST GRPMOV## ;Test for group move
;First operand (source) is elementary, we need extra tests in this case
INITRE: LDB TB,DA.CLA## ;Get class
CAIL TB,%%CL ;Should never happen
JRST NOTMTC
LDB TC,DA.EDT## ;Get edited flag
SKIPE TC
ADDI TB,%%CL ;TB = DA.CLA+<%%CL*DA.EDT>
LDB TC,[POINT 3,OPLINE,11] ;Get index again
XCT [CAIE TB,%CL.NU ;NUMERIC
CAIE TB,%CL.AB ;ALPHABETIC
CAIE TB,%CL.AN ;ALPHANUMERIC
CAIE TB,%CL.AN+%%CL ;ALPHANUMERIC-EDITED
CAIE TB,%CL.NU+%%CL]-1(TC) ;NUMERIC-EDITED
JRST NOTMTC ;Does not match
PUSHJ PP,INITGE ;Setup for the MOVE
JRST [PUSHJ PP,NOTMOV ;Not MOVEable
JRST INITRX]
PUSHJ PP,INITRA ;Set up "A"
PUSHJ PP,INIMV ;[1600]Do the MOVE
JRST INITRX ;[1600]See if any more
;[1600]Here to move the replacing item
INIMV: PUSH PP,CUREOP ;[1600]Save current EOPTAB
PUSHJ PP,INITEL ;[1600]Set up subscripts for B
PUSH PP,CURDAT ;[1600]save curdat
PUSHJ PP,MXX.## ;[1600]Call MOVGEN
POP PP,CURDAT ;[1600]restore curdat
MOVE TD,EOPHLD ;[1600]Get the saved EOPTAB pointer
MOVEM TD,EOPNXT ;[1600]Return the EOPTAB space used
POP PP,CUREOP ;[1600]Restore the pointer
POPJ PP, ;[1600]
;Here to get next data item
INITRX: PUSHJ PP,BMPEOP ;Step up to next one
POPJ PP, ;No more
MOVE TC,CUREOP
MOVE EACA,REPSAV ;[1600]Get the start of the replacing item
CAIL TC,-2(EACA) ;But is this the last operand?
POPJ PP, ;Yes, so we are done
JRST INITR2 ;No, process it
NOTMTC: MOVEI DW,E.211 ;Does not match class
PUSHJ PP,OPNFAT
JRST INITRX
NOTMV1: AOS (PP) ;Set for skip return
NOTMOV: MOVEI DW,E.819 ;Not eligible for MOVE
PUSHJ PP,OPNFAT
JRST INITRX
;;; NOTE: If you exit from a code generating module with a POPJ PP, you
;;; will wind up in COBOLE at location GO + 2. The instruction there
;;; will diddle the stack to point to location ENTERS, which is the next
;;; location in the code, and then it will fall through to it. After
;;; this, the code at ENTERS will save the current value of EOPLOC and
;;; reset the pointer ETEMPC to TEMTAB. If you exit with a JRST COMEBK,
;;; you bypass that code and you have the old values of EOPLOC and ETEMPC.
EVALGN: ;EVALUATE operator
;EVALUATE takes a set of selection subjects and compares them to a
;series of sets of selection objects. To do this, the operands describing
;the selection subjects are stored in a table and are later retrieved
;and put in EOPTAB so IFGEN can compare them against selection objects.
;The table is built within HLDTAB, and deleted when processing is complete.
;If the selection subject is an arithmetic expression, the result is in an
;accumulator. EVALUATE will move it to a location in %PARAM and adjust its
;operand.
;
;HLDTAB WD 1 [ Nbr of Selection Statements (SS's)
; table WD 2 [ Nbr of operand words ,, %PARAM offset
; WD 3 - N [ Operand from EOPTAB
;
; WD N+1 [ Size of entry ,, %PARAM offset
;
; EVSSTM contains the relative offset of the above
; table in HLDTAB
; EASSAV is used to build the descriptor (word 2)
; before it is placed in table
SETOM EVALSN## ;Set flag to say we are doing EVALUTE
SETZM EVSSCT## ;Zero count of SS's
SETZM EVWHSN## ; and haven't seen WHEN yet.
SETZM EVTFOP## ;Init EVTRUE seen flag
SETZM EVQWIK## ;Reset subscript check switch
; Get a location in HLDTAB to serve as a counter of Selection Subjects
MOVE TA,[CD.HLD,,1] ;Get 1 word in HLDTAB
PUSHJ PP,GETENT## ;Get its address - in TA
HLRZM TA,EVSSTM## ;Saves its address
SETZM (TA) ;Zero it out
POPJ PP, ;Exit
EVSNGN: ;END SS Operator for EVALUATE
SETOM EVWHSN## ;set 'WHEN' seen flag
MOVE TA,EVSSTM ;address of table in HLDTAB
ADD TA,HLDLOC ;make it absolute
HRRZ TA,(TA) ;get count of SS's
MOVEM TA,EVSSCT ;store it
SETZM EVSOCT## ;Initialize counter
SETZM EVSOCN## ;Reset count of SO's for current 'WHEN'
POPJ PP, ;
;Handle TRUE/FALSE
; If selection subject, store zero (false) or ones (true) in %PARAM table
; If selecton object, generate SKIPE %PARAM (false) or SKIPN %PARAM (true)
; followed by a JRST to next selection set
EVTFGN: ;TRUE / FALSE operator for EVALUATE
TXNN W1,EVSSBT ;Selection Subject?
JRST EVTFSO ;No - Selection Object
EVTFSS:
MOVE CH,EAS1PC ;Get a %PARAM loc for TRUE /FALSE value
MOVEM CH,EASSAV## ;Save its address for tabulating below
AOS EAS1PC ;Increm %Param counter
IORI CH,AS.PAR ;Flag the loc as %Param
HRRZM CH,EVTFPT## ;Save aside in case TRUE
PUSHJ PP,PUTOC0## ; and fill it with octal zeroes
MOVE CH,[ASINC+SETOM.##,,AS.MSC] ; Set up instruction
TXNE W1,EVFABT ;"False" flag on?
HRLI CH,SETZM.##+ASINC ;Yes, change to zero
PUSHJ PP,PUTASY ;Put it out to asy file
HRRZ CH,EVTFPT## ;Get to %Param flag
PUSHJ PP,PUTASN ; and update the instruction with it.
EVTFTA: ;Count and tabulate this SS
HRRZ TA,HLDLOC ;Form address of select stmt counter
ADD TA,EVSSTM ;
AOS (TA) ;Increment it
MOVE TA,[CD.HLD,,1] ;Get another HLDTAB entry for ss
PUSHJ PP,GETENT ; descriptor
HRRZ TB,EASSAV## ;Get its %Param address
MOVEM TB,(TA) ; and save it in HLDTAB location
POPJ PP, ;
EVTFSO:
;T/F selection object, verify SS was also T/F or conditional expression
PUSHJ PP,EVHLDT ;Puts address of corresponding SS in CURHLD
JUMPE TB,EVTFS1 ;Zero size implies TRUE/FALSE or condition
MOVEI DW,E.840 ; otherwise - error
JRST OPFAT## ;
EVTFS1: MOVE CH,[XWD SKIPE.##+ASINC,AS.MSC] ;
TXNN W1,EVFABT ;
HRLI CH,SKIPN.##+ASINC ;
PUSHJ PP,PUTASY ;
MOVE TA,CURHLD ;CURHLD contains address of SS descriptor
HRRZ CH,(TA) ;
HRLI CH,AS.MSC ;
TRO CH,AS.PAR ;
PUSHJ PP,PUTASN ;
MOVSI CH,JRST.## ;JRST to next SO set if they aren't equal
HLR CH,W2 ;
ANDCMI CH,7B20 ;
IORI CH,AS.TAG ;
PUSHJ PP,PUTASY ;
HLRZ TA,W2 ;
PUSHJ PP,REFTAG ;
JRST COMEBK ;Don't wipe out EOPTAB
EVNYGN: ;ANY operator for EVALUATE
; Since any test passes for the Selection Object "ANY", we don't need to
; generate any comparison code for it. We only need to advance the pointers
; into the table built within HLDTAB
PUSHJ PP,EVHLDT ;Update HLDTAB pointers
POPJ PP,
;if selection subject, store operand from EOPTAB in HLDTAB
;if selection object, put corresponding selection subject's
; operand in EOPTAB so IFGEN can compare them
EVSSGN: TXNN W1,EVSSBT ;Selection subject or object?
JRST EVSOGN ; Object - go put it in AC1
HRRZ TA,HLDLOC## ;
ADD TA,EVSSTM ;Relative offset of table
AOS (TA) ;Increment SS count
;If LH of W2 contains a tag, then conditional expression was scanned
; IFGEN has already compared the operands and put out the
; JUMPN %N for the false case, we have to set ones to %PARAM+n
; for the TRUE case, declare the false tag, %N, and setzm to %PARAM+n
; for the FALSE case.
HLRZ TA,W2 ;TRUE/FALSE tag
JUMPE TA,EVSGNN ;if nothing there, not conditional expression
MOVE CH,[ASINC+SETOM.##,,AS.MSC] ;Set ones to %PARAM+n for TRUE
PUSHJ PP,PUTASY ;
MOVE CH,EAS1PC ;Reserve next %PARAM location
MOVEM CH,EASSAV ;Save offset for HLDTAB descriptor
AOS EAS1PC ;Increment PARAM counter
IORI CH,AS.PAR ;
PUSHJ PP,PUTASN ;
PUSHJ PP,PUTOC0 ;
MOVSI CH,SKIPA.## ;Generate SKIPA to jump over
PUSHJ PP,PUTASY ; SETZM for false case
HRRZ CH,TA ;FALSE tag was passed in W2
PUSHJ PP,PUTTAG## ;Declare it
MOVE CH,[ASINC+SETZM.##,,AS.MSC] ;Zero out %PARAM
PUSHJ PP,PUTASY ; area for false case
MOVE CH,EASSAV ;
IORI CH,AS.PAR ;
PUSHJ PP,PUTASN ;
EVSGNN:
;reserve HLDTAB space for section subject operand and desciptor
MOVE TB,EOPNXT ;End of last operand in EOPTAB
MOVE TD,TB ;
SUB TD,(TD) ;Now have start of last operand
MOVEM TD,CUREOP ;Save address to retreive it later
POP TB,TA ;Get size of last operand
MOVEM TB,EOPNXT ;Reset EOPNXT
HRLM TA,EASSAV ;Save size of entry
AOS TA ;Get an extra word for entry descriptor
HRLI TA,CD.HLD ;
PUSHJ PP,GETENT ;GETENT wipes out most temp AC's
;move operand on EOPTAB (set up by EXPRGN) to HLDTAB
HLRZ TE,EASSAV ;Size of operand
CAIE TE,2 ;2-word operand?
JRST EVSGN1 ;No, must be subscripted, save as is
HRRZ TD,CUREOP ;Save operand offset in EOPTAB
HRRZ TC,(TD) ;TC contains word 1 of EOPTAB entry - W1
MOVE TD,1(TD) ;TD contains word 2 - W2
TLNE TD,GNNOTD ;Is operand in an AC?
CAILE TC,17 ;
JRST EVSGN1 ;No
;if operand is pointing to a field in an accumulator, store the field
; in %PARAM and modify its operand to point there
LDB TC,ACMODE## ; get mode of operand
CAIE TC,D4MODE## ; is it 4 words?
JRST EVSGN3 ; no
SETZ CH, ; yes, make it 2 wd floating point
PUSHJ PP,PUT.16## ; generate 'MOVEI 16,0'
MOVEI CH,FLT.42## ;
PUSHJ PP,PUT.PJ ; generate 'PUSHJ PP,FLT.42'
MOVEI TC,F2MODE ;
DPB TC,ACMODE## ; change mode in operand description
MOVE TC,CUREOP ; get EOP offset
MOVEM TD,1(TC) ; store new operand description
EVSGN3: HRRZ CH,EAS1PC ;claim %PARAM space to store result
HRRM CH,EASSAV ;save address
AOS EAS1PC ;just get 1 word for now
PUSHJ PP,PUTOC0 ;reserve it
MOVEI TC,1 ;Default to 1 word, then adjust as
MOVE CH,[MOVEM.##+AC0+ASINC,,AS.MSC] ; necessary
LDB TD,ACMODE## ;ACMODE = POINT 4,TD,3
CAIE TD,D2MODE## ; 2-word decimal?
CAIN TD,F2MODE## ; or 2-word floating point?
MOVEI TC,2 ;Set size to 2
CAIN TC,1 ;Is it still 1-word?
JRST EVSGN ;Yes, continue
PUSHJ PP,PUTOC0 ; else reserve another word
AOS EAS1PC ;
PUSHJ PP,PUTASA ; and use alternate code set
MOVE CH,[DMOVM.##+AC0+ASINC,,AS.MSC] ; and do DMOVEM
EVSGN: PUSHJ PP,PUTASY ;
HRRZ CH,EASSAV## ;Get address in %PARAM
IORI CH,AS.PAR## ;Mark as in %PARAM
PUSHJ PP,PUTASN ;Set up destination of MOVE/DMOVEM
;adjust operand so now describes a %PARAM field and not an AC
EVSGN0: MOVSI TC,22000 ;Set 'in %PARAM' bit, GNPAR, and GNNOTD
HRR TC,EASSAV ;%PARAM offset
TRO TC,AS.PAR ;
MOVE TD,EOPNXT ;Get end of EOPTAB
SUB TD,[1,,1] ;Back up to word 1 of operand
MOVEM TC,(TD) ;Have now adjusted operand on EOPTAB
EVSGN1: ;put descriptor into HLDTAG
HLRZ TE,EASSAV ;Get size of entry
MOVN TE,TE ;TE contains -(operand size)
MOVE TB,EOPNXT ;
HLRS TA ;Set up TA as HLDTAB stack ptr
SUB TA,[1,,1] ;Back up one for PUSH
ADD TA,HLDLOC ;Make it absolute
MOVE TC,EASSAV ;[operand size,,%PARAM address]
PUSH TA,TC ;Put SS descriptor in HLDTAB
EVSGN2: POP TB,TC ;Pop operand off of EOPTAB
PUSH TA,TC ;Push it onto HLDTAB
AOJL TE,EVSGN2 ;Increment size count and loop
MOVEM TB,EOPNXT ;Reset EOPNXT
POPJ PP, ;
EVSOGN: ;process selection object
;if SO is a condition-name, make sure the corresponding SS
; is either a T/F or another conditional expression
HLRZ TA,W2 ;conditional expression?
JUMPE TA,EVSOG1 ;no
PUSHJ PP,EVHLDT ;get HLDTAB operand address
HLRZ TB,0(TA) ;Get size of operand
JUMPE TB,EVSOG ;Zero implies SS is also T/F or condition
MOVEI DW,E.840 ;
TXNE W1,EVCDBT ;
JRST OPNFAT ;Put out error message,
JRST OPFAT## ; wherever possible
EVSOG: PUSHJ PP,PUTASA ;Set up instruction for
MOVSI CH,SETO.## ; SETO AC0,
PUSHJ PP,PUTASY ;
MOVSI CH,SKIPA. ; SKIPA
PUSHJ PP,PUTASY ;
HLRZ CH,W2 ; Declare tag for false case
PUSHJ PP,PUTTAG ;
PUSHJ PP,PUTASA ;
MOVSI CH,SETZ.## ; SETZ AC0,
PUSHJ PP,PUTASY ;
MOVE CH,[CAME.##+ASINC,,AS.MSC] ;CAME AC0, %PARAM+n
PUSHJ PP,PUTASY ;
MOVE TA,CURHLD ;Get address of SS operand
HRRZ CH,(TA) ;%PARAM table offset
HRLI CH,AS.MSC ;
TRO CH,AS.PAR ;
PUSHJ PP,PUTASN ;
POPJ PP, ;
;SO is an identifier, literal, figurative constant, or arithmetic expression
;pop operand from HLDTAB onto EOPTAB and fall back into IFGEN
EVSOG1: MOVE TE,EOPNXT ;
PUSHJ PP,EVHLDT ;Get address of SS entry in HLDTAB
JUMPE TB,EVSG.E ;Any operand there? no = error
MOVE TD,TB ;TB contains size of operand
HRLS TB ;
ADD TA,TB ;TA contains address of end of operand
EVSOG2: POP TA,TC ;Pop off of HLDTAB
SKIPL EVQWIK ;Haven't range tested subscripts yet
JRST EVSOG3 ;
SKIPGE TC ;If it's word one of an operand
TXO TC,GNEVSB ; set flag
EVSOG3: PUSH TE,TC ;Push onto EOPTAB
SOSLE TD ;Decrement size count
JRST EVSOG2 ;
PUSH TE,TB ;Push on operand size, [size,,size
MOVEM TE,EOPNXT ;Reset EOPNXT
JRST COMEBK ;
EVSG.E: MOVEI DW,E.839 ;No operand for selection subject,
JRST OPNFAT## ; were expecting T/F or condition-name
;put absolute address of selection subject entry in TA, its size in TB
EVHLDT: MOVE TA,EVSSTM ;Offset of SS entries in HLDTAB
AOS TA ;Forward one to first descriptor
ADD TA,EVSOCN ;Word count of previous SS entries
ADD TA,HLDLOC ;Make offset absolute
MOVEM TA,CURHLD ;Save it address
HLRZ TB,(TA) ;Get size of current operand
TXNE W1,EVTHRB ;If in 'THRU' clause,
POPJ PP, ; don't advance pointers yet
ADDM TB,EVSOCN ;Add to word count of previous entries
SKIPLE EVQWIK ;If finished one pass,
SETOM EVQWIK ; set flag negative
AOS EVSOCN ;Add one for descriptor word
AOS TC,EVSOCT ;Add one to count of SO's processed
CAMGE TC,EVSSCT## ;Is this the last SO?
POPJ PP, ;No
SETZM EVSOCN ;Yes, reset counters
SETZM EVSOCT ;
SKIPGE TC,EVQWIK ;If negative,
POPJ PP, ; exit
MOVEI TC,1 ;
MOVEM TC,EVQWIK ;Set to ONE => finishing one pass
POPJ PP, ;
EVNDGN: ;END EVALUATE operator
SETZM EVALSN## ;Reset EVALUATE phase flags
SETZM EVWHSN##
SETZ TC, ;
MOVE TA,EVSSTM ;Get starting offset within HLDTAB
HRLS TA ;
ADD TA,HLDLOC ;Now absolute
EVNDG1: ADD TA,[1,,1] ;Now pointing at descriptor
HLRZ TB,(TA) ;Get number of operand words
HRLS TB ;
ADD TA,TB ;Pointing to last operand word
AOS TC ;Add one to 'nbr of entries' count
CAMGE TC,EVSSCT## ;Are we at the end?
JRST EVNDG1 ;No, loop back 'til find last one
CAME TA,HLDNXT ;Are we at the current end of HLDTAB
POPJ PP, ;No, someone put something beyond
MOVE TA,EVSSTM ;Get original offset
SUBI TA,1 ;Back up one
HRLS TA ;
ADD TA,HLDLOC ;
MOVEM TA,HLDNXT ;Reset HLDNXT
POPJ PP,
;Use results from EXPRGN to modify operand on EOP table to provide
;offset and length reference modifiers
REFMOD: MOVE TA,EOPNXT ;any operands?
CAMN TA,EOPLOC ;
POPJ PP, ;no, exit
MOVE TA,(TA) ;Get last word in EOPTAB
HLRZ TB,TA ;If it's a size word from EXPRGN
HRRZ TC,TA ;
CAMN TC,TB ; then left matches rigth
JRST REFM01 ;Equal, should be good operand
MOVEI DW,E.851 ;No, then EXPGEN ran into trouble
PUSHJ PP,OPFAT ;
POPJ PP, ;
REFM01: MOVE TA,CUREOP ;get start of operand
MOVEM TA,CURHLD ; (set up by EXPGRN)
HRRZ TA,1(TA) ;
LDB TB,LNKCOD## ;get table code
CAIN TB,CD.VAL ;is it a literal?
JRST REFM02 ;yes, convert it
SWON FERROR ;no, error for now
CAIN TA,100001 ;[1522] Is operand the dummy?
POPJ PP, ;[1522] Expgen caught error
TXNE W1,RFMERR ;[1535] Did phase d give an error?
POPJ PP, ;[1535] Yes, don't give another
MOVEI DW,E.848 ;
PUSHJ PP,REFM.E ;
JRST REFM06 ;
REFM02: MOVE TE,[XWD EBASEA,ESAVEA] ;save current operand, the verb we're
BLT TE,ESAVAX ;in the middle of may have just set it up
MOVEI LN,EBASEA ;
MOVE TC,CUREOP ;
PUSHJ PP,SETOPN## ;set up ref mod. operand
PUSHJ PP,CONVNL## ;convert it to integer value (returned in TC)
MOVE TA,EDPLA ;
MOVE TE,[XWD ESAVEA,EBASEA] ;restore original operand
BLT TE,EBASAX ;
SKIPN TA ;
JRST REFM04 ;
MOVEI DW,E.96 ;Don't allow decimal places
PUSHJ PP,REFM.E ;
REFM04: TSWT FLNEG ;
JUMPG TC,REFM06 ;
MOVEI DW,E.841 ;Can't provide negative/zero offsets
PUSHJ PP,REFM.E ;
SWON FERROR ;
REFM06: MOVE TA,EOPNXT ;
POP TA,TB ;
HRRZS TB ;size of last operand on stack
REFM20: POP TA,TE ;pop it off
SOJG TB,REFM20 ;
MOVEM TA,EOPNXT ;reset end of stack pointer
TSWF FERROR ;[1522] Have we already encountered an error?
POPJ PP, ;[1522] Return w/o figuring modifiers
REFM21: POP TA,TB ;[1522]
CAMGE TA,EOPLOC ;[1522] Loop reading EOP table entries
POPJ PP, ;[1522] Exit, there's nothing to mod
JUMPGE TB,REFM21 ; until finding the one
TXNN TB,GNREFM ; that has been reference modified
JRST REFM21 ;
TLNE TB,GNFIGC ;
JRST REFM21 ;
AOBJP TA,KILL## ;[1522]
MOVEM TA,CUREOP ;save its offset
MOVE TA,1(TA) ;
LDB TB,LNKCOD ;get operand's table code
CAIN TB,CD.DAT ;data?
JRST REFM22 ;yes, continue
MOVEI DW,E.101 ;no, error
TXNE W1,RFMLEN ;
JRST REFM22 ;don't give it twice
PUSHJ PP,REFM.E ;
REFM22: PUSHJ PP,LNKSET ;
LDB TB,DA.INS## ;get operand's size
MOVE TD,TC ;
TXNE W1,RFMLEN ;if modifying length,
MOVE TB,RMLEN ; offset specified has already reduced it some
CAML TB,TC ;still within range of data item?
JRST REFM24 ;yes
MOVEI TD,1 ;no, give error
TSWF FERROR ;If others errors have been given,
JRST REFM24 ; this one probably isn't right
MOVEI DW,E.842 ;
TXNE W1,RFMLEN ;
MOVEI DW,E.844 ;
PUSHJ PP,REFM.E ;
REFM24: TXNE W1,RFMLEN ;modifying length?
JRST REFM40 ; continue at REFM40
LDB TE,DA.USG ;get data usage mode
SUBI TE,1 ;decrement it
CAIG TE,DSMODE## ;is it a DISPLAY mode
JRST REFM26 ;yes
MOVEI DW,E.843 ;no, error
PUSHJ PP,REFM.E ;
REFM26: SUBI TD,1 ;reduce offset by one
SUB TB,TD ;subtract it from field width
MOVEM TB,RMLEN## ;store as extent of adjusted field
SETZ TB, ;[1622] Zero out AC to build byte pointer
MOVE TC,BYTE.S##(TE) ;[1622] Get byte size
DPB TC,[POINT 6,TB,11] ;[1622] Put it in S field in TB
LDB TC,DA.RES## ;[1622] Get P field for first byte of field
DPB TC,[POINT 6,TB,5] ;[1622] Put it in TB
SKIPN TD ;[1642] Are we starting at first chr in field?
SKIPA TD,TB ;[1642] Yes, we already have what we need
ADJBP TD,TB ;[1622] Adjust the pointer by offset
TSWT FERROR ;[1622] Don't touch RMOFF if error
HRLZM TD,RMOFF ;[1622] Stash away the word offset
LDB TC,[POINT 6,TD,5] ;[1622] Pick up new P field
TSWT FERROR ;[1622] Don't touch RMOFF if error
HRRM TC,RMOFF ;[1622] Put it in offset word
MOVE TA,CUREOP ;get current operand
HLRZ TB,1(TA) ;LH of word two contains subscript count
ADDI TB,2 ;increment it by two to account
HRLM TB,1(TA) ; for ref modifiers
MOVE TA,EOPNXT ;get current end of EOP stack
HRRZ TC,(TA) ;get rh
HLRZ TD,(TA) ;get lh
CAMN TC,TD ;if equal,
POP TA,TB ; need to get rid of [size,,size
REFM28: TSWF FERROR ;[1522]
POPJ PP, ;[1522]
MOVE TD,RMOFF ;get offset
PUSH TA,TD ;store on stack
PUSH TA,TD ; (two words expected for all entries)
MOVE TD,RMLEN ;get length
PUSH TA,TD ;store on stack
PUSH TA,TD ;
REFM29: MOVEM TA,EOPNXT ;reset end of stack pointer
POPJ PP, ;
REFM40: MOVE TA,EOPNXT ;get end of stack
TSWF FERROR ;if error,
POPJ PP, ;
MOVE TA,CUREOP ;get modified operand
HLRZ TB,1(TA) ;get subscript count
ASH TB,1 ;double it
HRRZS TA ;
ADD TA,TB ;add count to offset
MOVEM TD,0(TA) ;replace length set up when offset
AOS TA ; formed with length explicitly
MOVEM TD,0(TA) ; specified
POPJ PP, ;
REFM.E: PUSH PP,TA ;save some AC's
PUSH PP,TB ; so can try to continue routine
PUSH PP,TC ;
SETZ TA, ;build negative
TLO TA,100000 ; offset and length
MOVEM TA,RMOFF## ;
MOVEM TB,RMLEN## ;
MOVE TC,CURHLD ;points to reference modifier
CAIE DW,E.101 ;
CAIN DW,E.843 ;
MOVE TC,CUREOP ;points to modified operand
MOVE TC,0(TC) ;
REF.E2: LDB CP,TCCP## ;
LDB LN,TCLN## ;
PUSHJ PP,FATAL## ;put out error message
POP PP,TC ;restore AC's
POP PP,TB ;
POP PP,TA ;
POPJ PP, ;
SUBTTL CONSTANTS AND EXTERNALS
IFLESS==1B27 ;'LESS' FLAG FOR 'IF' OPERATOR
IFGRT==1B28 ;'GREATER' FLAG FOR 'IF' OPERATOR
IFNEQ==3B28 ;'NOT EQUAL' FLAG FOR 'IF' OPERATOR
IFALL=1B27 ;'ALL' FLAG IN SEARCH OPERATOR
EXTERN AS.CNB,AS.MSC,AS.LIT,AS.PAR,AS.TAG,AS.XWD,AS.DAT,AS.OCT
EXTERN TM.DAT,TC.DAT
EXTERN GETTAG,PUTTAG,REFTAG
EXTERN BMPEOP,CUREOP,BADEOP,EBASEA,EINCRA,EOPLOC,EOPNXT,CURDAT
EXTERN LNKSET,OPERND,OPLINE,OPNFAT,OPFAT,PUTASN,PUTASY,PUTASA,PUT.EX,PUT.LA
EXTERN SETOPA,SETOPB,SETOPN,NOTNUM,LNKCOD
EXTERN D6MODE,D7MODE,D9MODE,DSMODE,D1MODE
EXTERN ESIZEA,EBYTEA,EMODEA,EDPLA,EFLAGA,ESIZEB,EDPLB,EMODEB,EFLAGB
EXTERN EBASEB,EINCRB,EBASBX,EBASAX,ESAVEA,ESAVAX
EXTERN EPJPP,POOL,ELITPC,PLITPC,XWDLIT,BYTLIT,STASHP,STASHQ,POOLIT
EXTERN PRODSW,PTFLG.,EAC,NODEPV,SUBINP
EXTERN ESIZEZ,ETABLA
EXTERN DA.ERR,DA.XBY,DA.NOC,DA.EXS,DA.EDT,DA.CLA,DA.DEP,DA.DCR,DA.KEY,DA.RKL
EXTERN HIVQOT,D.LTCD,BYTE.W,IFSPCS,IFZROS
EXTERN MBYTPA,VLIT8.,VLIT6.,LITERR,LITD.
EXTERN SUBSCA
EXTERN SUSEAC ;WHERE TO PUT SUBSCRIPTED BYTE PTR
EXTERN MXX.,MXAC.
EXTERN TEMLOC,TEMNXT,XPNTEM
EXTERN INSP.
EXTERN IARG11,IOPFLG,INARGP,ITLPTR,CURIRG,INSPTF,INSPSL,TEMADP,SERSIZ
EXTERN STEMPC,ETEMPC
EXTERN DEPTSA,ONLYEX,B1PAR,SZDPVA,DPBDEP
EXTERN TESUBC
EXTERN COLSEQ,PRGCOL
EXTERN RESG13 ;ROUTINE IN MATGEN TO STORE RESULT
EXTERN MOV,MOVEM.,SETZM.,MOVEI.,HRLM.,SETOM.,JMPLE.,CAMG.,CAILE.,CAIG.,SKIPA.
EXTERN IDIVI.,MOVN.,JUMPE.,MOVMM.,ADDB.,JRST.,AOS.,DPB.
EXTERN CPOPJ,CPOPJ1
EXTERN PUTAS1,EAS1PC
EXTERN PUTEMP,GETEMP
EXTERN SRCFST,SRCLST,SRCIDN,SRCNOC,SRCIDX,SRCLUP,SRCAE,SRCALL,SRCKYN,SRCPAR
EXTERN SRCFLG,SRCKYL,SRCOPN,SRC%I,SRC%E
EXTERN HL.LNK,HL.COD,HL.XBY,HL.NAM
EXTERN LMASKS,HLDLOC,HLDNXT,CURHLD
EXTERN TB.CON,CURCON,CO.DAT,CO.NVL
EXTERN ESAVSC,ESVSCX
EXTERN IFGNZC
EXTERN COMEBK
END