Trailing-Edge
-
PDP-10 Archives
-
BB-H506E-SM
-
cobol/source/mscgen.mac
There are 21 other files named mscgen.mac in the archive. Click here to see a list.
; UPD ID= 3504 on 4/30/81 at 3:17 PM by WRIGHT
TITLE MSCGEN FOR COBOL V12C
SUBTTL MISCELANEOUS CODE GENERATORS AL BLACKINGTON/CAM
SEARCH COPYRT
SALL
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
SEARCH P
XPNTST==:XPNTST
%%P==:%%P
;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
TWOSEG
.COPYRIGHT ;Put COPYRIGHT statement in .REL file.
RELOC 400000
SALL
IFN ANS68,<ENTRY EXAMGN ;"EXAMINE">
IFE ANS68,<ENTRY INSPGN ;"INSPECT" START
ENTRY INSPTG ;" INSPECT TALLYING"
ENTRY INSPRG ; "INSPECT REPLACING"
>;END IFE ANS68
ENTRY TRCGEN ;"TRACE"
ENTRY SRCHGN ;"SEARCH"
ENTRY SINCGN ;"SINCR"
IFN CSTATS,<
ENTRY METGEN ;"METER--JSYS"
>
ENTRY CBPHE ;"COMPILER-BREAK-ON-PHASE.."
INTERN GETTEM ;ROUTINE TO GET SOME LOCS IN TEMTAB
INTERN MVAUN0 ;MOVE "A" TO UNSIGNED %TEMP
MSCGEN::
SUBTTL GENERATE CODE FOR "EXAMINE"
IFN ANS68,<
EXAMGN: SWOFF FEOFF1 ;TURN OFF FLAGS
MOVEM W1,OPLINE
HRRZ TC,EOPLOC
ADDI TC,1
MOVEM TC,CUREOP
HRLZM TC,OPERND
MOVEI LN,EBASEA ;SET UP "A" PARAMETERS
PUSHJ PP,SETOPN
TSWF FERROR ;ANY ERRORS YET?
POPJ PP, ;YES--QUIT
HRRZ TA,EMODEA
CAIG TA,DSMODE
JRST EXMGN2
;ITEM TO BE EXAMINED IS NOT DISPLAY--ERROR
MOVEI DW,E.211
JRST OPNFAT
;ITEM TO BE EXAMINED IS DISPLAY
EXMGN2: PUSHJ PP,SUBSCA ;CALL SUBSCRIPTOR, IF NECESSARY
TSWF FASUB ;IS IT SUBSCRIPTED?
JRST EXMGN3 ;YES
MOVE TA,[XWD BYTLIT,2]
PUSHJ PP,STASHP
PUSHJ PP,MBYTPA
PUSHJ PP,POOL
MOVE CH,[XWD ASINC+EXAM.,AS.MSC]
PUSHJ PP,PUTASY
SKIPN CH,PLITPC
HRRZ CH,ELITPC
IORI CH,AS.LIT
PUSHJ PP,PUTASN
SKIPN PLITPC
AOS ELITPC
JRST EXMGN4
EXMGN3: MOVE CH,[XWD EXAM.,SXR]
PUSHJ PP,PUTASY
;PUT OUT THE XWD WHICH FOLLOWS THE UUO
EXMGN4: MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTASY
MOVE TA,CUREOP ;[427] GET CURRENT OPERATOR
MOVE TA,1(TA) ;[427] SET UP TABLE ADDRESS
PUSHJ PP,LNKSET ;[427] DO IT
LDB CH,DA.EXS ;[427] GET EXTERNAL SIZE FOR EXAMINE
HRLZ CH,CH ;[427] INSTEAD OF INTERNAL SIZE FROM SETOPN
TSWF FANUM ;IS IT NUMERIC?
TLO CH,1B18 ;YES--SET FLAG
HRRI CH,AS.CNB
LDB TA,[POINT 4,W1,12]
DPB TA,[POINT 4,CH,5]
PUSHJ PP,PUTASN
HRLI CH,0
PUSH PP,CH ;SAVE PARAMETER
PUSHJ PP,EXMGN8
DPB TB,[POINT 9,(PP),8]
TLNN W1,REPLAC
JRST EXMGN6
PUSHJ PP,EXMGN8
DPB TB,[POINT 9,(PP),17]
EXMGN6: POP PP,CH ;GET PARAMETER BACK
HRRI CH,AS.CNB
PUSHJ PP,PUTASN
TLNN W1,TALYNG
POPJ PP,
MOVE CH,[XWD MOVEM.,TALLY.]
JRST PUT.EX
;LOOK AT TALLYING OR REPLACING LITERAL.
;EXIT WITH VALUE OF LITERAL IN 'TB'.
EXMGN8: PUSHJ PP,BMPEOP ;GO TO NEXT OPERAND
JRST BADOPN ;THERE WASN'T ONE--ERROR
MOVE TA,ETABLA ;FIND DATAB ENTRY
PUSHJ PP,LNKSET
HRRZM TA,CURDAT
MOVE TB,CUREOP
HRRZ TD,EMODEA
MOVE TC,0(TB)
TLNN TC,GNFIGC
JRST EXMGN9
TLNN TC,GNFCS!GNFCZ!GNFCQ!GNFCHV!GNFCLV
JRST BADLIT
TLNE TC,GNFCS ;SPACE?
MOVEI TB," "
TLNE TC,GNFCZ ;ZERO?
MOVEI TB,"0"
TLNE TC,GNFCQ ;QUOTE?
MOVEI TB,42
TLNE TC,GNFCLV ;LOW-VALUE?
MOVEI TB,0
TLNE TC,GNFCHV ;HIGH-VALUE?
MOVEI TB,177
JRST EXMG9A
EXMGN9: MOVE TA,1(TB) ;IS IT A SIZE 1 LITERAL?
PUSHJ PP,LNKSET
LDB TC,[POINT 7,(TA),6]
CAIE TC,1
JRST BADLIT ;NO--ERROR
LDB TB,[POINT 7,(TA),13] ;YES--PICK UP VALUE OF LITERAL
EXMG9A: TSWF FANUM ;IS FIELD NUMERIC?
JRST EXGN10 ;YES
MOVE TA,CURDAT
LDB TC,DA.CLA ;NO--ALPHABETIC?
CAIN TC,1
JRST EXGN12 ;YES
EXMG9B: CAIN TB,177 ;[547] ALLOW HIGH-VALUES
JRST EXMG9H ;[547] GO TO HIGH-VALUES RETURN
JUMPE TB,CPOPJ ;[547] ALLOW LOW VALUES, GO LOW-VALUES RETURN
CAIE TD,D6MODE
JRST EXMG9I ;NOT SIXBIT, GO SEE WHAT IT IS.
CAIGE TB,140
CAIGE TB,40
JRST BADMOD
EXMG9C: SUBI TB,40
POPJ PP,
;"HIGH-VALUES" -- CONVERT TO HIGH-VALUES IN THE RIGHT MODE.
EXMG9H: HLRZ TB,HIVQOT##(TD) ;[547] GET HIGH-VALUES IN THE RIGHT MODE
POPJ PP, ;[547] AND RETURN.
EXMG9I: CAIE TD,D9MODE ;IS IT DISPLAY-9?
POPJ PP, ;NO, MUST BE DISPLAY-7.
EXCH TB,TE ;SET UP TO CONVERT TO DISPLAY-9.
PUSHJ PP,VLIT8. ;GO CONVERT THE CHAR.
EXCH TB,TE ;RESTORE THE AC'S.
POPJ PP, ;AND RETURN.
EXGN10: CAIG TB,"9" ;"A" IS NUMERIC--IS THE LITERAL?
CAIGE TB,"0"
JRST BADCLS ;NO
JRST EXMG9B ;YES
EXGN12: CAIG TB,"Z" ;"A" IS ALPHABETIC--IS THE LITERAL?
CAIGE TB,"A"
CAIN TB," "
JRST EXMG9B
;ERROR ROUTINES
BADCLS: MOVEI DW,E.211
JRST OPNFAT
BADMOD: MOVEI DW,E.210
JRST OPNFAT
>;END IFN ANS68, EXAMINE CODE
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
;MISCELLANEOUS CONSTANTS
REPLAC==(1B12)
TALYNG==(1B13)
ASINC==1B19
SUBTTL "INSPECT" STATEMENT
IFE ANS68,<
;MISC CONSTANTS
F.CHAR==(1B11)
AFTBFR==(3B15)
F.AFT==(1B15)
F.FIR==(1B10)
F.LEA==(1B9)
F.EIN==(1B12)
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,1B35 ;%REPLF
TLNE W1,REPLAC ; 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,1B34 ;%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
TLNE W1,F.CHAR ;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)
MOVSI TE,(1B10) ;CHECK FOR CHARACTER VALUE
TLNN EACC,-1
IORM TE,IOPFLG ;YES, SET FLAG
DPB EACA,BSI.L3 ;STORE BSI FOR LOC.3 STRING/CHAR
IFN ANS74,<
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
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)
IFN ANS74,<
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: MOVSI TE,(1B1)
TLNE W1,F.LEA
IORM TE,IOPFLG ;"LEADING" FLAG
MOVSI TE,(1B2)
TLNE W1,F.FIR
IORM TE,IOPFLG ;"FIRST" FLAG
MOVSI TE,(1B3)
TLNE W1,F.AFT
IORM TE,IOPFLG ;"AFTER" FLAG
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
TLNE W1,F.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
TLNE W1,F.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,1B35 ;"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
TLNE W1,F.CHAR ;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)
MOVSI TE,(1B10) ;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
IFN ANS74,<
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
IFN ANS74,<
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
MOVSI TE,(1B11) ;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
PUSHJ PP,BMPEOP
JRST BADOPN ;?NOT SUPPLIED
HRRZ TC,CUREOP
HRLZM TC,OPERND
PUSHJ PP,STLOC1
POPJ PP, ;?ERRORS SETTING IT UP
IFN ANS74,<
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: MOVSI TE,(1B1)
TLNE W1,F.LEA
IORM TE,IOPFLG ;"LEADING"
MOVSI TE,(1B2)
TLNE W1,F.FIR
IORM TE,IOPFLG ;"FIRST"
MOVSI TE,(1B3)
TLNE W1,F.AFT
IORM TE,IOPFLG ;"AFTER"
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
TLNE W1,F.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,
;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: LDB EACA,BSI.I ;GET MODE OF INSPECT STRING
ILDB TE,EBYTEA ;GET ASCII CHAR OF LITERAL
SETZM LITERR ;INCASE ERRORS CONVERTING
XCT VLIT6.(EACA) ;CONVERT
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
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
;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)
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
>;END IFE ANS68 AND "INSPECT" STATEMENT CODE GEN.
;ENTER HERE WITH TE= BSI TO CONVERT THE NUMERIC ITEM TO.
MVAUN0: MOVEM TE,EMODEB
MOVE TC,ESIZEA
MOVEM TC,ESIZEB ;SAME SIZE
IFN ANS74,<
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,
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 "METER--JSYS" COMMAND
IFN CSTATS,<
METGEN: HRRZ TC,EOPLOC
HRRZ CH,2(TC) ;PICK UP THE NUMBER
HRLI CH,MOVEI.+AC16 ;"MOVEI 16,NUMBER"
PUSHJ PP,PUTASY
MOVE CH,[EPJPP,,METER.] ;"PUSHJ PP,METER."
PJRST PUT.EX ;DONE
>;END IFN CSTATS
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 ; SEARCH ITEM IS IN ERROR [243]
JUMPN TE,SRCERR ; YES ERROR [243]
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
IFN ANS74,<
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
IFN ANS74,<
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
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
IFN CSTATS,<
EXTERN METER.
>;END IFN CSTATS
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.
IFN ANS68,<
EXTERN EXAM.,TALLY.
>;END IFN ANS68
EXTERN TEMLOC,TEMNXT,XPNTEM
IFN ANS74,<
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
>;END IFN ANS74
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
END