Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/mscgen.mac
There are 21 other files named mscgen.mac in the archive. Click here to see a list.
; UPD ID= 1521 on 2/2/84 at 6:05 PM by HOFFMAN
TITLE MSCGEN FOR COBOL V13
SUBTTL MISCELANEOUS CODE GENERATORS AL BLACKINGTON/CAM
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984 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
;V12*****************
;NAME DATE COMMENTS
;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.
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: 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
PUSH PP,1(TC) ;SAVE ORIGINAL CONTAB ENTRY
HRRM TA,1(TC) ;FAKE OPERAND TO POINT TO DATAB
MOVEI LN,EBASEB ;SET IT UP AS "B" OPERAND
PUSHJ PP,SETOPN
MOVE TC,CUREOP ;RESTORE TC
POP PP,1(TC) ;PUT CONTAB LINK BACK
TSWF FERROR ;IF ERROR
JRST SETCD2 ;TRY NEXT OPERAND
MOVE TE,[EBASEB,,EBASEA]
BLT TE,EBASAX## ;MAKE "A" AND "B" THE SAME
HRRZ TA,1(TC) ;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
PUSHJ PP,MXX.## ;DO THE MOVE
SETCD2: PUSHJ PP,BMPEOP ;STEP UP TO NEXT ONE
POPJ PP, ;NO MORE
MOVE TC,CUREOP
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,1 ; to point to first item
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.SON## ;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
PUSHJ PP,INITG6 ;Do the MOVE
INITG4: HLRZ TA,CURDAT ;Get datab link back incase something moves
INITG5: PUSHJ PP,LNKSET ;Get table address back
LDB TB,DA.BRO## ;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 and try again
JRST INITG5
;Here to do a MOVE
INITG6: 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,MFCX. ;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
JRST MFCX.## ;Call MOVGEN
;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 elememtary item is eligible for MOVE
;Enter with TA = datab link
;Return .+1 if MOVE cannot be done
;Return .+2 if MOVE could be done.
INITGE: SWOFF FEOFF1 ;Turn off flags
SETZM EAC
LDB TB,DA.OCC##
JUMPN TB,CPOPJ ;Ignore indexed data items
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
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
AOS (PP) ;Set for OK return
JRST SETOPN## ;Return with "B" operand set up
;Here for INITIALIZE identifier REPLACING ...
INITRP: CAIL TC,-2(EACA) ;Do we have at least 2 operands?
JRST BADEOP ;No, error
;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: 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,INITGX ;Give up if error found
LDB TB,DA.SON ;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"
PUSHJ PP,MXX.## ;Do the MOVE
INITR4: HLRZ TA,CURDAT ;Get datab link back incase something moves
INITR5: PUSHJ PP,LNKSET ;Get table address back
LDB TB,DA.BRO## ;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 and try again
JRST INITR5
;Set up last operand as "A", we do this everytime just for safety
INITRA: MOVEI LN,EBASEA
HRRZ TC,EOPNXT
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,MXX.## ;Do the MOVE
; JRST INITRX ;See if any more
;Here to get next data item
INITRX: PUSHJ PP,BMPEOP ;Step up to next one
POPJ PP, ;No more
MOVE TC,CUREOP
MOVE EACA,EOPNXT
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 modifier 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
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
REFM21: SOS TA ;continue through rest of EOP stack
MOVE TB,0(TA) ; searching for operands
JUMPGE TB,REFM21 ; until finding the one
TXNN TB,GNREFM ; that has been reference modified
JRST REFM21 ;
TLNE TB,GNFIGC ;
JRST REFM21 ;
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
IDIV TD,BYTE.W##(TE) ;divide it by bytes/word
TSWT FERROR ;if error don't adjust offset (err rtn sets it)
HRLZM TD,RMOFF ; else put increment value in LH of offset
IMUL TC,BYTE.S##(TE) ;multiply remainder by byte size
LDB TD,DA.RES## ;get current byte residue
SUB TD,TC ;subtract offset from it
JUMPGE TD,REFM27 ;if positive, still in same word
ADDI TD,44 ;if negative, add 44 bits
HLRZ TC,RMOFF ;
AOS TC ; and bump the word offset by one
TSWT FERROR ;
HRLM TC,RMOFF ;
REFM27: TSWT FERROR ;if error, don't adjust offset
HRRM TD,RMOFF ;save in RH of offset to adjust byte pointers
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: 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