Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/cobold.mac
There are 14 other files named cobold.mac in the archive. Click here to see a list.
; UPD ID= 1612 on 5/17/84 at 9:52 AM by HOFFMAN
TITLE COBOLD FOR COBOL V13
SUBTTL PROCEDURE DIV. SYNTAX SCAN W.NEELY/CAM/SEB/MEM
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984, 1985 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
TOPS20==:TOPS20
IFN TOPS20,< SEARCH MACSYM,MONSYM>
IFE TOPS20,< SEARCH MACTEN,UUOSYM>
DBMS==:DBMS
DBMS6==:DBMS6
DEBUG==:DEBUG
MCS==:MCS
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
SALL
RELOC 400000
;EDITS
;NAME DATE COMMENTS
;V13*****************
;MEM 4-NOV-85 [1635] Stop putting out an extra start expression
; operator for IF FOO(1:2) EQUALS BAR(1:2)
;MEM 16-OCT-86 [1631] Add error recovery for when we have dummy datab
; entry
;MJC 15-JUL-85 [1602] Fix NEXT SENTENCE broken by edit 1541
;MJC 21-JUN-85 [1600] Implement INITIALIZE for tables
;MJC 4-APR-85 [1573] Fix edit 1556. Make a PCA7BA that is PCA7B
; with out the FPERWD
;MJC 26-MAR-85 [1566] Zero INPTAG when done with it in pa199.
;JEH 22-MAR-85 [1564] Fix 'set condition-name' code.
;KWS 21-MAR-85 [1563] Make sure that the report writer check
;; the NO REWIND bit also.
;JEH 20-MAR-85 [1562] In the ref. mod. routines, if current
;; operator is zero, check 'implop' field
;; that 'IF' uses for storing op codes.
;JEH 20-MAR-85 [1561] If reference modification is being done
;; within the scope of an IF statement then
;; save the open parenthesis count and
;; restore it when the modifications are done.
;MJC 22-JAN-85 [1556] Remove code that allowed SEARCH ... WHEN to
;; ignore extraneous periods.
;MJC 30-NOV-84 [1553] Rework PA823. to do END-XXX scope termination
;; by popping from the node stack
;MJC 10-AUG-84 [1541] Make IF-END and ELSE define tags without using
;; NXTSEN.
;JEH 16-MAY-84 [1535] If error w/ ref. mod. expression, put out
;; expected op code, but with error bit set
;JEH 14-MAY-84 [1527] Skip warning test if 'GENERATE data-name'
;; instead of 'GENERATE report-name'
;JEH 26-APR-84 [1522] Let expression scanner handle errors with
; reference modifiers
;JEH 14-FEB-84 [1514] Shut off AMRGN. flag while comparing PRVTOK
;V12B****************
;JEH 02-MAY-83 [1466] Give error on WRITE ADV/POS if not ASCII file
;DMN 28-Apr-83 [1465] Fix edit 1354 to use DKEYSZ rather than KEYRLN.
;RLF 19-APR-83 [1460] Give error message when key is subcripted.
;SMI 8-Dec-82 [1443] Test for no decimal places in COMP field.
;DMN 9-Nov-82 [1431] Fix bug caused by edits 1046 and 1104 to DBMS FIND with INDEX item.
;JEH 7-May-82 [1354] Wrong alternate key selected if multiple keys are
; defined with the same starting location.
;RLF 1-OCT-82 [1412] Make RETAIN do RETAIN NEXT so LSU works
; for ISAM Sequential access
;DMN 5-Mar-82 [1343] 68274 converter does not convert NOTE into a comment.
;DMN 15-Feb-82 [1340] 68274 converter does not flag NOT Abbrev. Combined Relation Conditions.
;RJD 29-Jan-82 [1334] Supersedes edits 1322 and 1326.
;WTK 18-Dec-81 [1326] Fix edit 1322 breaking of CREF listings.
;WTK 8-Oct-81 [1322] Check last paragraph for ending in unconditional goto.
;JSM 3-Aug-81 [1313] Check for IF <cond> paragraph-name.
;JSM 24-Jun-81 [1311] Bad placement of diag. 179 in listing.
;V12B****************
;DAW 6-Feb-81 [1117] Make fig. constants work correctly when
; "UNSTRING delimited by fig-const."
;JSM 21-Jan-81 [1114] Fix edit 1035 to bypass SUB-SCHEMA error message if no INVOKE seen.
;CLRH 17-Dec-80 [1104] More of edit 1046, patch to edit 675.
;DAW 5-Nov-80 [1070] Fix MOVE CORRESPONDING when items are subscripted.
;JSM 24-Oct-80 [1062] Fix fatal error on NOTE with COPY REPLACING.
;DAW 25-AUG-80 [1050] BAD CODE GEN FOR NESTED IF..I-O VERB..IF..
;CLRH 12-AUG-80 [1046] IN FIND RSE3, IDENTIFIER-2 MUST BE 1-WORD COMP.
;CLRH 10-JUL-80 [1035] FIX DBMS "IF" TO CHECK THAT USERNAME IS IN SUBSCHEMA
;DMN 2-JUL-80 [1033] TURN OFF COPY REPLACING FLAGS DURING ERROR RECOVERY.
;CLRH 18-JUN-80 [1026] MOVE CURRENCY STATUS FOR RECORD REQUIRES RECORD.
;JSM 2-APR-80 [1005] MAKE IF OR SEARCH ILLEGAL IN WHEN CLAUSE OF SEARCH VERB
;LEM 22-FEB-80 [772] MAKE DA.CLA EXTERNAL
;DAW 31-JAN-80 [765] FIX "NULL TABLE LINK" IF UNSTRING ITEM HAS
; MORE THAN ONE SUBSCRIPT.
;DAW/CLRH 9-JAN-80 [757] DON'T ALLOW OPEN OF A SORT FILE
;DAW [744] FIX EDITS 707/670
;V12*****************
;DAW 7-MAY-79 [707] FIX EDIT 670 - IT BROKE NESTED IF'S.
;DMN 4-APR-79 [675] CHECK FIND RSE 3 SYNTAX THAT COULD LOOK LIKE FIND RSE 5
;JSM 28-MAR-79 [670] FIX NESTED IF . ELSE PROBLEM
;DMN 20-MAR-79 [665] RECOVER CORRECTLY FROM PROCEDURE DIVISION MIS-SPELLED
;DAW 28-FEB-79 [645] FIX ERROR RECOVERY IN SORT STATEMENT; ALSO
;;; ADD RESTRICTION TO "MERGE" STATEMENT TO NOT ALLOW SUBSCRIPTING
;DMN 28-JAN-79 [631] DON'T USE ARG2 AT PA258. THUS PREVENTING CATASTROPHE IN PHASE D
;DMN 12-DEC-78 [612] INITIALIZE FNOSUB AT THE START OF PHASE D (THIS WAS IN THE BWR FILE)
;DAW 11-OCT-78 [574] DON'T SET BIT 1 FOR USER-NAME EXTERNAL ENTRY (BIT WENT AWAY)
;EHM 17-SEP-78 [552] GIVE ERROR IF DECLAR. & NO END DECLARITIVES
;EHM 04-MAY-78 [535] FIX EDIT [273] FOR IF SET NOT EMPTY
;EHM 29-MAR-78 [532] FIX [511] TO PROCESS ERRORS CORRECTLY
;V11*****************
;SSC 28-SEPT-77 ADDED ACTIONS TO SUPPORT DBMS-V6 ENHANCEMENTS (AFTER PA321.)
;EHM 19-SEP-77 [511] MAKE NESTED SEARCH STATMENTS WORK
;VR 19-APR-77 [467] SET LN, CP AND RIGHT DIAG. MESSAGE FOR
; STATEMENT: GO TO -(NUMBER)
;EHM 28-JAN-77 [461] FIX TALLY FOR RECORD-NAME IN WRITE CAUSES CRASH
;EHM 17-JAN-77 [460] FIX THIS STATEMENT CANNOT BE REACHED AFTER SEARCH ALL
;VR 17-DEC-76 [455] FLAG SORT KEYS NOT DEFINED IN SD STATEMENT AS FATAL ERROR
;SSC 2-AUG-76 ADD DBMS S. U. ACTIONS
; 8-AUG-76 [435] FIX DECLARITIVES IN DBMS PROG SO THAT DBMS SECTION GOES AROUND IT
; 6-APR-76 [420] FIX FOR MISSING PERIOD ON OPEN STATEMENT
; 24-MAR-76 [413] FIX SEARCH MIXED WITH IF
; 30-JAN-76 [405] FIX QUALIFICATION OF SUBSCRIPTS
;GPS MAR-12-75 ADDED CODE TO COMPUTE LENGTH OF SU TABLES
;DBT MAR-7-75 REMOVE CANCEL ERROR MESSAGE WHICH CREPT BACK IN
;SSC MAR-5-75 PLACED 6A EDIT %316 DIRECTLY INTO V10
;GPS 12/23/74 ADD SIMULTANEOUS UPDATE
;DBT 12/1/74 CHANGE DA96. TO DA96.D TO AVOID ONESEG PROBLEM
;********************
; EDIT 363 FIX RECOVERY IF TOO MANY LEVELS OF SUBSCRIPTING.
; EDIT 362 RECOVER FROM ERROR IN SEARCH STATEMENT.
; EDIT 353 FIX DBMS IF STATEMENT WITH UNDEFINED VARIABLE TO FLAG CORRECT PLACE.
; EDIT 336 FIX FIND5 FROM GENERATING BAD ARG BLOCK FOR RECORD NAMES
; LONGER THAN 12 CHARS WHEN OPTIONAL WORD 'RECORD' NOT USED
; EDIT 333 ALLOW TALLY AS A SUBSCRIPT TO BE ADDED TO SUBTRACTED FROM
; EDIT 327 PUT IN GENERATED AFTER DECLARATIVES.
; EDIT 324 SET DECLARATIVE SWITCH IF PROGRAM HAS DECLARATIVES.
; EDIT 314 FIX RECOVERY IN A COMPUTE STATEMENT HAVING AN UNDEFINED VARIBLE.
; EDIT 313 DBMS- FIX IF STATEMENT ERROR MESSSAGE OHAVING UNDEFINED VARIABLE IN WORD FOLLOWING THE "IF ".
; EDIT 312 FIXSTATEMENTS FOLLOWING A GO TO PARAGRAPH.
; EDIT 307 FIX CANCEL
; EDIT 276 CHECK FOR RECORD NAME FOR WRITE, DELETE, REWRITE AND RELASE VERBS
; EDIT 273 DBMS FIX. ROUNED UP FOR ASCII WORD SIZE IS WRONG
; EDIT 271 FIX CATASTROPHE IN PHASE D IF NO PARA NAME IMMEDIATELY AFTER SECTION NAME
; EDIT 265 ALLOW FIG CONSTANT "ZERO" FOR PERFORM LITERALS
; EDIT 262 FIXES HANLDING OF UNDEFINED SUBSCRIPT
; EDIT 261 FIXES CHECKING OF NAMTAB TABLE WHEN ITS END IS REACHED [261]
; EDIT FIX RELEASE AND RETURN SO THAT PARMS ARE ONLY IN SORT FILE [257]
; EDIT 250 ALLOW TALLY TO BE A SUBSCRIPT
; EDIT 246 FIX MULTIPLE CALL "SUB".
; EDIT 244 FLAGS AS ERROR AN ELSE FOLLWING A PERIOD.
; EDIT 242 ALLOWS SUBCRIPTING FOR ITEMS WITH FILE NAME QUALIFIERS.
; EDIT 240 FIXES QUALIFICATION PROBLEM OF DATA NAMES USUALLY IN SEARCHES
; EDIT 222 /ACK FIX NULL TABLE LINK PROBLEM FOR CORRESPONDING OPTION
; AND FOR PERFORM VARYING'S.
; EDIT 214 CHANGE FATAL TO WARNING IF MORE THAN 6 CHARS IN SUBPROGRAM NAME
; EDIT 172 FIXES EDIT 151 UNBALL PAREN CHECK DONE TOO SOON (AT SUB EXPRESSION LEVEL).
; EDIT 171 MAKES ENTER COBOL EQUIVALENT TO CALL.
; EDIT 137 GIVE ERROR MESSAGE IF SUBSCRIPT IS IN LINKAGE
; SECTION OR IF SUBSCRIPT IS SUBSCRIPTED.
; EDIT 165 FIXES COMPILER LOOP IF RIGHT PAREN MISSING FOR SUBSCRIPTED DATA-NAME.
; EDIT 155 FIXES "ADDRESS CHECK..." WHEN SORT FILE SHARES SAME BUFFER AREA
; EDIT 151 FIXES UNBALL PARENTHESIS PROBLEM IN COMPUTE STATEMENT
; EDIT 111 FIXES COMPILER LOOP FOR SEARCH ALL.. AT END STOP RUN-- STATEMENT
; EDIT 110 OPEN STATEMENT DOES NOT GIVE PERIOD ASSUMED MESSAGE IF A
; PERIOD IS MISSING AND STATEMENT IS LAST ONE IN A PARA.
ENTRY COBOLD
INTERN PASU8.,PASU9.,PASU6.,PASU66,PASU60,PASU61
INTERN PASU64,PASU63,PASU62,PASU4.,PASU7.,PASU41
INTERN PASU45,PASU40,PASU44,PASU42,PASU5.,PASU2.
INTERN PASU21,PASU20,PASU3.,PASU39,PASU38,PASU36
INTERN PASU34,PASU31,PASU37,PASU35,PASU30,PASU33
INTERN PASU1.,PASU19,PASU18,PASU17,PASU14,PASU10
INTERN PASU16,PASU12,PASU15,PASU13,PASU11
EXTERN FI.ORG, FI.RTC, FI.SKY,FI.ERR,FI.NXT
EXTERN FILLOC,FILNXT,CURFIL,LNKSET
EXTERN DA.USG,DA.INS,DA.LOC,DA.RES
EXTERN KILL
EXTERN FI.FAM,USELOC
EXTERN AK.DLK,AK.FLK
EXTERN DTREE
EXTERN SURRTM,SURRT.,SUEQTM,SUEQT.,SUFBTM,SUFBT.
EXTERN BUFFER,BUFCTR,CPOPJ,CPOPJ1
EXTERN PASU4T,SU30F1,SU30F2,SU30FG,SU8CNT,SU8FLG
EXTERN SU8SVA,SU8SVB,SU8SVC
EXTERN DWLNCP,WORDLN,WORDCP
EXTERN INUPRG
COBOLD: SETFAZ D;
MOVE NODPTR,INDPTR##
IFN DEBUG,<
MOVE TE,CORESW##
SWOFF FNDTRC;
TRNE TE,TRACEP ;TRACE PD NODES?
SWON FNDTRC; ;YES
>
SETZM PROGST## ;CLR FIRST PARA ADDR
SETZM DECLR.## ; [324] CLR DECLARITIVES IN PROG SWTICH
SETZM MAXDBC## ;CLEAR MAX. DEBUG-CONTENT SIZE
SETZM SPFNIO## ;Clear "Special-IF" flag
HRRZI TA,STRTD.## ;FIRST PD NODE
PUSH NODPTR,TA
PUSHJ PP,SQURL.## ;BEGIN
OUTSTR [ASCIZ "COBOLD--lost; too many POPJ's
"]
JRST KILL
SUBTTL PROCEDURE DIVISION ACTIONS
INTER. PA0.
PA0.: POP NODPTR,NODE ;POP UP CURRENT NODE
IFN DEBUG,<PUSHJ PP,PTPOP.##> ;IF TRACING, LIST NODE POPING UP TO
POPJ PP,
;ADVANCE TO NEXT WORD
;SAME AS IA0.G IN COBOLB - KEEP SEPARATE TO AID LOCALITY
INTER. PA0.G
PA0.G: SWOFF FREGWD ;CLR REGET WORD FLAG
PJRST GETITM ;GET NEXT ITEM
INTER. PA1.
PA1.: MOVE SAVPTR,ISVPTR## ;INITIALIZE PD POINTER
SWOFF FNOTF!UNCONT!INDECL!FARITH!FEXPR!FNOSUB ;[612]
SETZM OPRTR##
MOVE TA,[OPRTR,,OPRTR+1]
; BLT TA,ARG3##+1
; SETZM NSBSC1##
; MOVE TA,[XWD NSBSC1,SBSCR1]
BLT TA,SBSCR3##+4*MAXSUB-1
SETZM CURSEC
SETZM LSTPRI##
SETZM PRIOR##
SETZM IFLVL##
SETZM SPFLVL##
SETZM NQUAL##
SETZM ELEVEL##
SETZM CLEVEL##
SETZM TOPLVL##
SETZM NXTSNT##
SETZM IMPLOP##
SETZM IMPLOP+1
SETZM SCPTRM## ;[1553] END-XXX SCOPE TERMINATOR
SETZM INPTAG## ;[1566] ZERO THE IN-LINE PERORM TAG
SETZM INIDAT## ;[1600] Initialize DATTAB pointer
SETZM INIVAL## ;[1600] Initialize VALTAB pointer
SETZM TBLOCK
MOVE TA,[XWD TBLOCK,TBLOCK+1]
IFL MAXSUB-6,<
BLT TA,TBLOCK+24
>
IFGE MAXSUB-6,<
BLT TA,TBLOCK+MAXSUB*4
>
SETZM VARBLK##
MOVE TA,[XWD VARBLK,VARBLK+1]
BLT TA,VARLST## ;ZERO ALL VARBLK
HRRZ TA,SECLOC##
SETZM 1(TA)
HRLZI TB,1(TA)
HRRI TB,2(TA)
BLT TB,^D200(TA)
SETZM USES##
MOVE TA,[XWD USES,USES+1]
BLT TA,USES+USES.L##-1
;28-OCT-80 /DAW: This shrinking of VALTAB to save space used to
;be possible until version 12B, when subscript parsing was implemented
;in PHASE C. PHASE E must be able to look at constant subscript values
;stored in VALTAB in PHASE C.
; MOVE TA,VALLOC##
; MOVEM TA,VALNXT##
SETZM 1(TA)
SETZM ARGLST##
MOVE TA,[XWD ARGLST,ARGL2##]
BLT TA,ARGL2+13
JRST PA219.
;HERE ON USE PROCEDURES TO TEST FOR FIPS FLAGGER
;PA2U.1 ON FIRST FILE NAME, PA2U.2 ON SUBSEQUENT ONES
INTER. PA2U.1
PA2U.1: PUSHJ PP,PA2.
SKIPN FLGSW ;WANT FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,ARG1
ADD TA,FILLOC
LDB TB,FI.ORG ;GET FILE ORGANIZATION
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H ;INDEXED
0](TB)
PJRST FLG.ER## ;FLAG IF ILLEGAL
INTER. PA2U.2
PA2U.2: PUSHJ PP,PA2.
SKIPN FLGSW ;WANT FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,ARG1
ADD TA,FILLOC
LDB TB,FI.ORG ;GET FILE ORGANIZATION
MOVE TA,[%LV.HI ;SEQUENTIAL
%LV.HI ;RELATIVE
%LV.H ;INDEXED
%LV.HI](TB)
PJRST FLG.ER## ;FLAG IF ILLEGAL
INTER. PA2.8
PA2.8: FLAGAT 8
JRST PA2.
;FLAG THE NOT BEFORE A CONDITIONAL
INTER. PA2.NT
PA2.NT: PUSHJ PP,TSTNOT ;SEE IF WE SHOULD FLAG PREVIOUS NOT
SKPNAM
INTER. PA2.HI
PA2.HI: FLAGAT HI
SKPNAM
INTER. PA2.
PA2.: TLNE W1,GWLIT ;IS ITEM A LITERAL?
JRST PA2.L ;YES
TLZN W1,GWNOT ;IS ITEM IN NAMTAB?
JRST PA2.R ;YES
PUSHJ PP,BLDNAM## ;NO--PUT IT IN
HLRS TA
DPB TA,[POINT 15,W2,15]
PA2.R: TLZ W1,004000 ;'ROUNDED' BIT
DMOVEM W1,ARG1## ;SAVE ITEM
POPJ PP,
PA2.L: LDB TB,GWVAL ;NO. OF CHARACTERS
JUMPN TB,PA2.L1 ;NULL LITERAL?
EWARNW E.183 ;YES
MOVE TA,[BYTE (7)7,7,7]
MOVEM TA,LITVAL## ;CREATE A DUMMY
HRRZI TB,3
PA2.L1: MOVEM TB,TBLOCK## ;SAVE SIZE
ADDI TB,2+4 ;COUNT PLUS ROUNDING
IDIVI TB,5 ;NO. OF WORDS REQUIRED
HRRZI TA,(TB)
HRLI TA,CD.VAL ;VALTAB CODE
PUSHJ PP,GETENT## ;GET VALTAB ENTRY
HLR W1,TA ;UPDATE ITEM
HRRZ TD,TBLOCK ;COUNTER
DPB TD,[POINT 14,(TA),13] ;STORE COUNT
MOVE TB,[POINT 7,LITVAL] ;'GET' POINTER
MOVSI TC,(POINT 7,0(TA),13) ;'PUT' POINTER
PA2.Q: SOJL TD,PA2.R
ILDB TE,TB ;GET CHARACTER
IDPB TE,TC ;SAVE
JRST PA2.Q
TSTNOT: SKIPN FLGSW ;DO WE WANT FIPS FLAGGER?
POPJ PP, ;NO
EXCH LN,NOTLN## ;SWAP CURRENT POINTERS
EXCH CP,NOTCP##
MOVEI TA,%LV.HI ;FLAG AS IN NUC 2
PUSHJ PP,FLG.ES##
EXCH LN,NOTLN
EXCH CP,NOTCP
POPJ PP,
INTER. PA3.
PA3.: TSWTZ UNCONT;
JRST PA3.A
HLRZ TA,CURPAR##
JUMPE TA,PA3.A
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT##
HLRZ TA,CURSEC##
JUMPE TA,PA3.A
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT
PA3.A: MOVE TA,ARG1+1
SETZM OPRTR
DPB TA,OP.LNC## ;LN, CP
HRRZI TA,100 ;OP CODE FOR SECTION OPERATOR
PUSHJ PP,SETOP3
LDB TA,[POINT 15,ARG1+1,15]
HRRZI TB,CD.PRO ;PROTAB CODE
PUSHJ PP,FNDLNK## ;LOOK FOR PROTAB LINK
JRST PA3.P ;NONE FOUND
PA3.L: LDB TC,PR.SEC## ;PARAGRAPH/SECTION FLAG FROM PROTAB
JUMPE TC,PA3.E ;DUPLICATE SECTION NAME
PUSHJ PP,FNDNXT## ;NO--TRY AGAIN
JRST PA3.P ;NO MORE
JRST PA3.L ;TEST THIS ENTRY
PA3.P: TLO W2,GWDEF ;PUT DEFINING REFERENCE IN CREF FILE
LDB TA,[POINT 20,ARG1+1,35] ;USE LN&CP FOR THE NAME --
DPB TA,[POINT 20,W2,35] ; NOT THE PERIOD AFTER IT
MOVE TA,[NAMWRD,,NAMWRD+1] ;MOVE SECTION NAME BACK TO NAMWRD
SETZM NAMWRD##
BLT TA,NAMWRD+4
LDB TA,[POINT 15,ARG1+1,15]
HRRZ TB,NAMLOC##
ADDI TA,1(TB)
HRLI TA,(POINT 6,0)
MOVE TB,[POINT 6,NAMWRD]
PA3.X: HRRZ TC,.JBREL## ;SEE IF LAST ENTRY ENDED ON A K BOUNDARY
CAIG TC,(TA) ;IF SO, THATS THE END OF NAMTAB
JRST PA3.Y ;YES
ILDB TC,TA
TRNN TC,60 ;FINISHED YET?
JRST PA3.Y ;YES
IDPB TC,TB
JRST PA3.X
PA3.Y: PUSHJ PP,PUTCRF## ;INDICATE THAT SECT-NAME IS HERE DEFINED
MOVE TA,[XWD CD.PRO,SZ.PRO]
PUSHJ PP,GETENT ;GET AN ENTRY IN PROTAB
PUSHJ PP,PA4SUB ;STORE PTR TO PROTAB ENTRY
MOVE TC,LSTPRI ;PRIORITY OF LAST SECTION
MOVE TD,PRIOR ;PRIORITY OF NEW SECTION
CAMGE TC,SEGLIM## ;LAST SECTION NON-RESIDENT?
CAML TD,SEGLIM ;NO --- IS NEW ONE?
CAIN TC,(TD) ;ONE OR BOTH NON-RESIDENT
JRST PA3.P1 ;BOTH RESIDENT OR IN SAME SEGMENT
MOVE TE,ARG1
MOVEM TE,TBLOCK+21
MOVE TE,ARG1+1
MOVEM TE,TBLOCK+22 ;SAVE ARG1
MOVE TE,OPRTR
MOVEM TE,TBLOCK+23
MOVE TE,OPRTR+1
MOVEM TE,TBLOCK+24 ;AND OPERATOR
MOVEM TA,TBLOCK+20 ;PROTAB POINTER FOR NEW SECTION
SETZM OPRTR
SETZM OPRTR+1
SKIPN TA,CURSEC
JRST PA3.P0
LDB TB,PR.TUT ;IF SECTION ENDED WITH UNCONDITIONAL
JUMPN TB,PA3.P0 ;TRANSFER, SPECIAL GO NOT NEEDED
PUSHJ PP,PA25. ;CREATE 'GO TO' OPERATOR
HLRZ TA,TBLOCK+20 ;NEW SECTION PROTAB POINTER
HRRZM TA,ARG1 ;PUT IN OPERAND
SETO TB,
DPB TB,OP.CLN## ;SET SPECIAL FLAG SO THAT EXITS WILL
;BE GENERATED BEFORE THIS GO
PUSHJ PP,PA21. ;OUTPUT OPERAND
PUSHJ PP,PA22. ;AND OPERATOR
PA3.P0: MOVSI TA,104000
DPB W2,[POINT 20,TA,35]
HRRZI TB,104 ;SEGMENT BREAK OPERATOR
PUSHJ PP,PUTGEN
MOVE TE,TBLOCK+21
MOVEM TE,ARG1
MOVE TE,TBLOCK+22
MOVEM TE,ARG1+1
MOVE TE,TBLOCK+23
MOVEM TE,OPRTR
MOVE TE,TBLOCK+24
MOVEM TE,OPRTR+1
MOVE TA,TBLOCK+20
PA3.P1: MOVEM TA,CURSEC ;CURRENT SECTION
SETZM CURPAR ;NO CURRENT PARAGRAPH YET
HRRZ TE,SECLOC
HRRZI TE,1(TE)
HRLI TE,TD
MOVEM TE,PNTR
MOVE TD,PRIOR
CAMGE TD,SEGLIM ;IS CURRENT SECTION RESIDENT?
SETZ TD, ;YES
ASH TD,1 ;PRIORITY*2
SKIPE TA,@PNTR##
JRST PA3.P2 ;THIS SEGMENT WAS SEEN BEFORE
HLLZ TA,CURSEC
HLRS TA ;PROTAB POINTER FOR CURRENT SECTION
MOVEM TA,@PNTR ;SET UP AS BOTH FIRST AND LAST SECTION OF
;THIS PRIORITY
MOVE TB,GENWRD##
HRRZI TD,1(TD)
MOVEM TB,@PNTR ;INITIAL BLOCK OF THIS PRIORITY
MOVE TA,CURSEC
JRST PA3.Q
PA3.P2: MOVEM TD,TBLOCK+15
PUSHJ PP,LNKSET
MOVE TB,GENWRD
DPB TB,PR.GNW##
HLRZ TB,CURSEC
MOVE TD,TBLOCK+15
HRRM TB,@PNTR
MOVE TA,CURSEC
PA3.Q: HLRZM TA,ARG1 ;SET UP OPERAND TABLE LINK
LDB TB,[POINT 15,ARG1+1,15]
IORI TB,CD.PRO*1B20 ;TABLE TYPE CODE
MOVSM TB,(TA)
SETO TB,
DPB TB,PR.DEF## ;SET DEFINED BIT
TSWF INDECL;
DPB TB,PR.DFD## ;DEFINED IN DECLARATIVES
HRRZ TC,PRIOR
DPB TC,PR.PRI## ;PRIORITY
HLRZ TB,(TA) ;NAMTAB REL. ADDR.
ANDI TB,077777
HRRI TA,(TB)
MOVEM TA,TBLOCK ;SAVE PUTLNK PARAMETER
PUSHJ PP,PUTLNK## ;PUT ENTRY IN CHAIN
MOVE TA,[XWD CD.FLO,SZ.FLO]
PUSHJ PP,GETENT
SETO TB,
DPB TB,FL.PND## ;PROCEDURE-NAME DEFINITION FLAG IN FLOTAB
TSWF INDECL;
DPB TB,FL.RDC## ;REFERENCED IN DECLARATIVES
HLRZ TB,TBLOCK ;PROTAB ENTRY REL. ADDR.
DPB TB,FL.PRO## ;PUT PROTAB LINK IN FLOTAB
DPB W2,FL.LNC## ;PUT NAMTAB POINTER, LN, CP IN FLOTAB
MOVEM TA,CURFLO##
HLRZ TA,TBLOCK
PUSHJ PP,LNKSET## ;GET ADDRESS OF PROTAB ENTRY
HLRZ TB,CURFLO
DPB TB,PR.FLO## ;LINK PROTAB TO FLOTAB
LDB TB,PR.DFD ;IF DEFINED IN DECLARATIVE SECTION
JUMPN TB,CPOPJ ;DON'T SET DEBUGGING LINK
LDB TB,PR.SEC
JUMPN TB,CPOPJ ;ONLY DEBUG PROCEDURES
SKIPE TB,DEBALP ;DEBUGGING ALL PROCEDURES?
DPB TB,PR.DEB## ;YES, SET LINK
POPJ PP,
PA3.E: SETO TC,
DPB TC,PR.MDF## ;MULTIPLY DEFINED
EWARNW E.171
JRST PA3.P
INTER. PA4.
PA4.: TSWTZ UNCONT;
JRST PA4.B
HLRZ TA,CURPAR
JUMPE TA,PA4.B
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT
PA4.B: LDB TA,[POINT 15,ARG1+1,15]
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK
JRST PA4.P ;NONE FOUND
PA4.L: LDB TD,PR.LSC## ;SECTION LINK
LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPE TC,PA4.C ;THIS IS A SECTION
HLRZ TC,CURSEC ;PARAGRAPH
CAIN TC,(TD) ;IN CURRENT SECTION?
JRST PA4.E ;YES--ERROR
PA4.A: PUSHJ PP,FNDNXT ;MORE PROTAB ENTRIES FOR THIS NAME?
JRST PA4.P ;NO
JRST PA4.L
PA4.C: HRRZ TC,CURSEC ;CHECK TO SEE WHETHER
HLRZ TC,(TC) ;CURRENT SECTION HAS THE
HLRZ TB,(TA) ;SAME NAME AS THIS PARAGRAPH
ANDI TB,077777 ;NAMTAB POINTER OF THIS ENTRY
ANDI TC,077777 ;NAMTAB POINTER OF CURRENT SECTION
CAIE TB,(TC) ;SAME NAME AS THIS PARAGRAPH.
JRST PA4.A ;NO, LOOK FOR MORE
MOVEI TA,OPYECC ;YES, PREVENT MORE ERRORS
PUSHJ PP,SETOP3
EWARNJ E.658 ;WARN USER
PA4.E: SETO TC,
DPB TC,PR.MDF
EWARNW E.172
PA4.P: TLO W2,GWDEF ;PUT DEFINING REFERENCE IN CREF FILE
LDB TA,[POINT 20,ARG1+1,35] ;USE LN&CP FOR THE NAME --
DPB TA,[POINT 20,W2,35] ; NOT THE PERIOD AFTER IT
PUSHJ PP,PUTCRF
MOVE TA,[XWD CD.PRO,SZ.PRO]
PUSHJ PP,GETENT ;GET ENTRY
PUSHJ PP,PA4SUB ;SAVE PTR TO PROTAB ENTRY
MOVEM TA,TBLOCK+1 ;SAVE ADDRESS
PUSHJ PP,PA3.Q ;SET IT UP
MOVE TA,TBLOCK+1
HLRZ TB,CURSEC ;REL. ADDR. OF CURRENT SECTION PROTAB ENTRY
DPB TB,PR.LSC ;SECTION LINK
SETO TB,
DPB TB,PR.SEC ;SET PARAGRAPH BIT
MOVEM TA,CURPAR ;SET UP CURRENT PARAGRAPH POINTER
POPJ PP,
;Here to check the very last paragraph for an unconditional GO TO
PA4.Z: TSWTZ UNCONT
POPJ PP,
HLRZ TA,CURPAR
JUMPE TA,CPOPJ
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.TUT
POPJ PP,
;SAVE PTR TO PROTAB ENTRY
; AND SAVE INITIAL SECTION OR PARA NAME FOR START CODE
PA4SUB: MOVEM TA,CURPRO## ;SAVE PROTAB PTR
TSWT INDECL ;IN DECLARATIVES?
SKIPE PROGST ;INITIAL PARA NAME SAVED ALREADY?
POPJ PP, ;YES
HLRZ TB,TA ;GET THE PROTAB LINK
XORI TB,600000 ;CONVERT D-E TABLE CODE TO F-G CODE (4 BECOMES 2)
HRRM TB,PROGST ;SAVE ADDR OF INITIAL PROC NAME
POPJ PP,
INTER. PA5.
PA5.: SETZ TA,
EXCH TA,PRIOR ;PRIOR_0
MOVEM TA,LSTPRI
POPJ PP,
INTER. PA6.
PA6.: FLAGAT LI
TLNN W1,GWLIT ;IS ITEM A LITERAL?
JRST PA6.E ;NO
TLNN W1,GWNLIT ;IS ITEM A NUM. LIT.?
JRST PA6.E ;NO
TLNE W1,GWDP ;IS IT INTEGER?
JRST PA6.E ;NO
LDB TB,GWVAL
MOVEM TB,CTR## ;LENGTH
HRRZI TA,LITVAL ;LOCATION
PUSHJ PP,GETVAL##
JUMPL TC,PA6.E ;NEGATIVE
CAILE TC,143 ;99. IS MAXIMUM
HRRZI TC,143
CAMGE TC,SEGLIM ;IS THIS RESIDENT?
TDZA TC,TC ;YES
SETOM NRESSN## ;NO, SIGNAL NON-RESIDENT SECTION SEEN
MOVEM TC,PRIOR
POPJ PP,
PA6.E: MOVE TC,LSTPRI
MOVEM TC,PRIOR
EWARNJ E.25
INTER. PA7.
PA7.: HLRZ TA,CURSEC
JUMPE TA,CPOPJ ;NO SECTION LINK
PUSHJ PP,LNKSET
HRRZ TC,PRIOR
DPB TC,PR.PRI ;PUT PRIORITY IN PROTAB ENTRY
POPJ PP,
INTER. PA8.
PA8.: HRRZI TA,16 ;[*DMN*] USE OP CODE (NEVER OUTPUT)
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.USE##
SETZM INUPRG ;NO LONGER IN A USE PROCEDURE FOR A
; REPORT GROUP
POPJ PP,
INTER. PA9.
PA9.: SETO TA,
DPB TA,OP.AFT## ;SET AFTER BIT
POPJ PP,
INTER. PA10.
PA10.: SETZ TA,
DPB TA,OP.AFT ;SET BEFORE BIT
POPJ PP,
INTER. PA11.
PA11.: HRRZI TA,75 ;ERROR USE
JRST SETOP3
INTER. PA14.
PA14.: FLAGAT NS
SETO TA, ;SET ERROR-PROCEDURE-ON-OPEN BIT
DPB TA,OP.OPN##
POPJ PP,
INTER. PA18.
PA18.: HRRZI TA,2
DPB TA,OP.USE ;I-O USE
POPJ PP,
INTER. PA19.
PA19.: HRRZI TA,0
DPB TA,OP.USE ;INPUT USE
POPJ PP,
INTER. PA20.
PA20.: HRRZI TA,1 ;OUTPUT USE
DPB TA,OP.USE
POPJ PP,
INTER. PA20X.
PA20X.: FLAGAT HI
SETO TA, ;EXTEND USE
DPB TA,OP.XTD##
POPJ PP,
INTER. PA21.R
PA21.R: SKIPN REFCON## ;IS IT CALL BY CONTENTS?
JRST PA21. ;NO
MOVSI TB,4000 ;SET ROUNDED BIT IN ARG1
IORM TB,ARG1 ;FOR CALL BY CONTENTS
SKPNAM
INTER. PA21.
PA21.: SETZM TBLOCK+7 ;FLAG SAYS THIS IS NOT A SUBSCRIPT
PA21.0: HRRZ TB,ARG1 ;R. H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
SKIPN TB ;IF THERE IS AN ARG, CONTINUE
SKIPN TE,RMFLG## ;IF NOT REFERENCE MODIFYING, CONTINUE
JRST PA21.G ;
;Ref. Mod. - this may appear unusual here, but most verbs expect to
;put out an operand. If that operand is being reference modified,
;the Ref. Mod. routines put it out and follow it with modifiers,
;then resume the interrupted verb's scan. Rather than modify every
;verb's tree structure, a flag is set and the original verb's op code
;restored and its scan continued.
DMOVE TB,RMOPR## ;RESTORE ORIGINAL VERB
DMOVEM TB,OPRTR ;
SETZM RMFLG## ;ZERO RM FLAG
HRRZI TB,2 ;[1600]
ADDM TB,REPSUB ;[1600]Ref. mod uses two entrys
POPJ PP, ;EXIT
PA21.G: MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
AND TA,[XWD 3,777777] ;LN, CP
TLO TA,400000 ;SET OPERAND BIT
TLNN TD,GWLIT ;IS ITEM A LITERAL?
JRST PA21.A ;NO
SETZM NSBSC1
TLO TA,GNLIT ;YES--SET LITERAL BIT
TLNE TD,GWASCI ;IS ITEM 'PURE' ASCII?
TLO TA,020000 ;YES -- SET BIT
TLNE TD,GWNLIT ;IS ITEM A NUMERIC LITERAL?
TLO TA,GNNUM ;YES--SET NUMERIC LITERAL BIT
JUMPE TB,PA21.E
PA21.B: TLNE TD,GWALL ;'ALL' ITEM?
TLO TA,GNALL ;YES--SET ALL BIT
SETZM ARG1
SETZM ARG1+1
JRST PUTGEN ;OUTPUT ARG1
PA21.A: TLNN TD,GWFIGC ;IS ITEM A FIGURATIVE CONSTANT?
JRST PA21.C ;NO
SETZM NSBSC1
TLO TA,GNLIT!GNFIGC ;YES---SET FIGURATIVE CONSTANT BIT
HLRZ TC,TD
ANDI TC,777 ;YES--GET VALUE
SETZ TE,
CAIN TC,HIVAL.
HRLZI TE,GNFCHV ;HIGH-VALUE(S)
CAIN TC,LOVAL.
HRLZI TE,GNFCLV ;LOW-VALUE(S)
CAIN TC,QUOTE.
HRLZI TE,GNFCQ ;QUOTE(S)
CAIN TC,ZERO.
HRLZI TE,GNFCZ ;ZER0((E)S)
CAIN TC,SPACE.
HRLZI TE,GNFCS ;SPACE(S)
IOR TA,TE ;SET APPROPRIATE BITS
JRST PA21.B
PA21.C: TLNE TD,004000 ;ROUNDED?
TLO TB,GNROUN ;YES
TLNN TE,400000 ;FLOTAB ENTRY?
JRST PA21.D ;NO
TLO TB,100000 ;YES--SET BIT IN OPERAND WORD
PA21.F: SETZM NSBSC1
JRST PUTFT
PA21.D: HRRZI TC,(TD) ;TABLE LINK
JUMPE TC,PA21.E ;NULL
LSH TC,-17 ;TABLE TYPE CODE
CAIN TC,CD.CON ;CONTAB?
JRST PUTFT ;YES, DON'T CLR NSBSC1
CAIE TC,CD.DAT ;DATAB?
JRST PA21.F ;NO--OUTPUT AS IS
MOVEM TA,TBLOCK
MOVEM TB,TBLOCK+1
MOVEM TD,TBLOCK+2
MOVEM TE,TBLOCK+3
HRRZ TA,TB ;LINK
PUSHJ PP,LNKSET ;ABS. ADDR. OF DATAB ENTRY
MOVE TC,TA ;ENTRY ADDRESS
MOVE TA,TBLOCK
MOVE TB,TBLOCK+1
MOVE TD,4(TC) ;WORD 5 OF DATAB ENTRY
TRNE TD,100 ;LINKAGE SECTION
TLO TA,(LKSFLG) ;YES
TLNE TD,100000 ;SYNC LEFT?
TLO TA,010000 ;YES
TLNE TD,040000 ;SYNC RIGHT?
TLO TA,004000 ;YES
TLNE TD,000010 ;JUST RIGHT?
TLO TA,001000 ;YES
TLO TA,002000 ;SET NUMERIC BIT
TLNE TD,400000 ;NOT NUMERIC
TLNE TD,200000 ;SKIP IF NUMERIC
TLZ TA,002000 ;TURN OFF NUMERIC BIT
TRNE TD,400000 ;DD ERROR?
TLO TB,400000 ;YES
MOVE TD,RMFLG ;
TRZE TD,400000 ;
TXO TA,GNREFM ;bit to signify operand is RM'ed
MOVEM TD,RMFLG ;don't do it twice
EXCH TA, TC ;PUT DATAB OFFSET IN TA & SAVE TC.
LDB TD, DA.USG## ;PICK UP THE ITEM'S USAGE.
EXCH TA, TC ;PUT THINGS BACK THE WAY THEY WERE.
DPB TD, [POINT 4,TA,13] ;PUT THE USAGE IN THE FIRST GENFIL WORD.
PUTFT: SKIPN TBLOCK+7 ;DOING A SUBSCRIPT?
JRST PUTFT0 ;NO
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2 ;4 WORDS EACH
SKIPN SBSCR1##+2(TD) ;DOES IT HAVE AN ADDITIVE?
JRST PUTFT0 ;NO
MOVEI TC,1 ;ASSUME +
SKIPGE SBSCR1(TD)
MOVEI TC,2 ;NO, -
DPB TC,[POINT 2,TB,11] ;STORE ADDITIVE OPERATOR
PUTFT0: SETZM ARG1
SETZM ARG1+1
HRRZI TC,(TB)
JUMPE TC,PA21.E
SKIPN TD,NSBSC1 ;NUMBER OF SUBSCRIPTS
JRST PUTGEN
HRRZM TD,TBLOCK+6
MOVNI TC,MAXSUB ;ALSO COUNT ADDITIONS TO SUBSCRIPTS
MOVSI TC,(TC)
PUTFT3: SKIPE SBSCR1+2(TC) ;THIS SUBSCRIPT HAVE AN ADDITIVE?
AOJ TD, ;YES
ADDI TC,3 ;AIM AT NEXT SUBSCRIPT
AOBJN TC,PUTFT3
DPB TD,[POINT 6,TB,17]
ADDM TD,REPSUB ;[1600]Ref. mod + subscripts + additives
PUSHJ PP,PUTGEN
PUTFT1: SOSGE TD,TBLOCK+6
JRST PUTFT2
ASH TD,2
HRLZI TC,SBSCR1(TD)
HRRI TC,ARG1
BLT TC,ARG1+1
SETZM NSBSC1
AOS TBLOCK+7 ;TELL PA21. WE ARE DOING A SUBSCRIPT
PUSHJ PP,PA21.0
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2
SKIPN TA,SBSCR1+2(TD) ;IS THERE AN ADDITIVE?
JRST PUTFT1 ;NO
MOVE TB,SBSCR1+3(TD) ;YES, GET 2ND WORD OF ADDITIVE
MOVEM TA,ARG1
MOVEM TB,ARG1+1
PUSHJ PP,PA21.
JRST PUTFT1
PUTFT2: MOVE TA,[XWD NSBSC1,SBSCR1]
MOVEI TB,MAXSUB*4-1
BLT TA,SBSCR1(TB)
POPJ PP,
PA21.E: OUTSTR [ASCIZ /PA21.: null table link
/]
HRRZI TA,105 ;'YECCH' OP CODE
PUSHJ PP,SETOP3
EWARNJ E.263
; THIS ROUTINE OUTPUTS THE OPERATOR. IT ALSO CHECKS
;FOR STATEMENTS THAT CAN'T BE REACHED
INTER. PA22.
PA22.: LDB TC,OP.OP2## ;OP CODE
CAIN TC,105 ;YECCH?
JRST PA22.A ;YES
CAIE TC,26 ;ENDIF OPERATOR?
JRST PA22.Z
PA22.A: SWOFF UNCONT;
JRST PA22.C
PA22.Z: TSWT UNCONT;
JRST PA22.B
CAIE TC,15 ;END DECLARATIVES
CAIN TC,20 ;IF <, ETC.
JRST PA22.C ; ARE LEGAL
CAIG TC,50 ;COMPUTE ARITHMETIC OPERATOR?
JRST PA22.Q ;NO
CAIG TC,57
JRST PA22.C ;YES
; /DAW 8-MAR-79: IF A DISPLAY (OP CODE 61) FOLLOWS A STOP RUN
;IT DOESN'T GET FLAGGED. OPEN,CLOSE, AND SEVERAL MORE ALSO WOULDN'T
;GET FLAGGED. THE TEST FOR TYPE=PERIOD IS MADE AT THE END OF PARSING
;THESE STATEMENTS, THEREFORE IT SUCCEEDS!.
; SINCE IT IS DIFFICULT TO FIGURE OUT WHERE COMMENTING
;OUT THE CHECKING OF AC "TYPE" MIGHT CAUSE PROBLEMS, I LEFT THE TEST FOR
;"WHEN" IN.. HOPEFULLY NOTHING WILL BREAK!!
; CAIE TYPE,PRIOD. ;PERIOD OK
CAIN TYPE,WHEN. ;ARE WE LOOKING AT A "WHEN"?
JRST PA22.C ;YES - ITS LEGAL
CAIL TC,70 ;COMPUTE OPERATOR?
CAILE TC,73
JRST PA22.Q ;NO
JRST PA22.C
PA22.Q: LDB LN,OP.LN##
LDB CP,OP.CP##
HRRZI DW,E.188 ; % THIS STATEMENT CANNOT BE REACHED
PUSHJ PP,WARN##
LDB TC,OP.OP2
PA22.B: CAIE TC,30 ;IS IT 'GO'?
JRST PA22.D ;NO
LDB TC,OP.CLN ;SPECIAL TYPE?
JUMPN TC,PA22.C ;YES
SKIPN EVALFL ;IF IN EVALUATE, DON'T TURN ON
SWON UNCONT;
PA22.C: MOVE TA,OPRTR ;OUTPUT
MOVE TB,OPRTR+1 ;OP
SETZM OPRTR
SETZM OPRTR+1
JRST PUTGEN
PA22.D: CAIE TC,40 ;'STOP'?
JRST PA22.C ;NO
LDB TB,OP.RUN## ;'RUN'?
JUMPE TB,PA22.C ;NO
SKIPN EVALFL ;IF IN EVALUATE, DON'T TURN ON
SWON UNCONT;
JRST PA22.C
INTER. PA23.
PA23.: SWON FARITH;
SWOFF FRTST!FNOCPY ;[1033] TURN OFF COPY REPLACING FLAGS
PA23.1: PUSHJ PP,SKPSRC##
TSWF FEOF;
JRST PA23.X
CAIE CP,7
JRST PA23.1
PA23.2: PUSHJ PP,SKPSRC
TSWF FEOF;
JRST PA23.X
CAIL CP,^D12
JRST PA23.1
CAIN CH," "
JRST PA23.2
PA23.X: SWOFF FARITH;
SWON FREGCH;
SKPNAM
INTER. PA23.Z
PA23.Z: SWOFF FREGWD ; [312] MAKE SURE WE DON'T REGET BAD WORD
PUSHJ PP,GETITM##
SKPNAM
INTER. PA24.
PA24.: CAIE TYPE,ELSE. ;[1005][1553] ENCOUNTERED 'ELSE'?
SKIPE SCPTRM## ;[1553] OR END-XXX?
SETZM SWHEN## ;[1005] YES, TERM. SEARCH WHEN, IF ACTIVE
SKPNAM
INTER. PA24.R
PA24.R: SWON FREGWD;
POPJ PP,
INTER. PA24.S
PA24.S: FLAGAT 8
JRST PA24.
INTER. PA25.
PA25.: HRRZI TA,30 ;'GO TO' OP CODE
JRST SETOP
INTER. PA26.F
PA26.F: FLAGAT HI
SKPNAM
INTER. PA26.
PA26.: SKIPN ARG1
SKIPE ARG1+1
PUSHJ PP,PA21. ;PUT OUT ARG1 IF NOT NULL
PUSHJ PP,PA22. ;PUT OUT OP
HLRZ TA,CURPAR
JUMPE TA,PA26.E
PUSHJ PP,LNKSET ;PROTAB ENTRY OF CURRENT PARAGRAPH
SETO TB,
DPB TB,PR.ALT## ;SET ALTERABLE FLAG IN PROTAB
POPJ PP,
PA26.E: OUTSTR [ASCIZ /PA26.: no PROTAB link for paragraph name
/]
EWARNW E.262
JRST KILL
INTER. PA27.
PA27.: PUSHJ PP,PA21.
PUSHJ PP,PA24.
HRRZI NODE,PD153.##
MOVEM NODE,(NODPTR)
HRRZI NODE,PD157.##
PUSH NODPTR,NODE
HRRZI NODE,PD395F##
PUSH NODPTR,NODE
POPJ PP,
;ONLY 1 ITEM BEFORE DEPENDING ON CLAUSE
INTER. PA27A.
PA27A.: FLAGAT 8
PUSHJ PP,PA21.
HRRZI NODE,PD153.##
MOVEM NODE,(NODPTR)
HRRZI NODE,PD157.##
PUSH NODPTR,NODE
HRRZI NODE,PD395G##
PUSH NODPTR,NODE
POPJ PP,
;SEE IF WE WERE PROCESSING A CONDITIONAL FOR 'IF' OR WHETHER WE WERE
; JUST DOING AN ORDINARY DATA NAME.
INTER. PA28.
PA28.: MOVE TB, [XWD PD643A##,PD669.##]
JRST PA28.1+1 ;GET TRACE RIGHT
INTER. PA28.1
PA28.1: MOVE TB, [XWD PD643A##,PD714.##]
HRRZ TA, ARG1 ;GET THE TABLE LINK.
LSH TA, -17 ;ISOLATE THE TABLE CODE.
CAIN TA, CD.CON ;IS IT CONTAB?
JRST PA0. ;YES, POP UP TO THE NODE WE
; PUSHED DOWN FROM.
; IT WASN'T A CONDITIONAL - TRY TO FAKE OUT SQUIRL.
HLRZM TB, (NODPTR) ;PRETEND WE WERE AT PD643A
HRRZM TB, -1(NODPTR) ; AND HAD PUSHED DOWN FROM
; PD669 OR PD714.
SKIPN RMFLG## ;IF REF MODIFYING, THIS HAS BEEN DONE
PJRST PA111. ;GO PUT OUT INITIAL GENFIL CODE
; FOR "EXPR" OPERATOR.
POPJ PP, ;JUST EXIT
INTER. PA30.
PA30.: HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
SETZM ATGFLG## ;CLEAR ADD TO FLAG
MOVEI TA,OPADDT ;'ADD TO' OP CODE
JRST SETOP
INTER. PA31.
PA31.: SETOM ATGFLG ;SIGNAL ADD TO SEEN
POPJ PP,
INTER. PA33.
PA33.: SKIPE ATGFLG ;HAVE WE HAVE ALREADY SEEN "TO"?
JRST PA34.A ;YES, ITS -8x OPTIONAL "TO"
MOVEI TA,OPADD ;NO, SET 'ADD' OP CODE
JRST SETOP3
PA34.A: FLAGAT 8
MOVEI TA,OPADTG ;SIGNAL SPECIAL "ADD TO GIVING"
JRST SETOP3
INTER. PA34.
PA34.: HRRZI TA,11 ;'RESULT' OP CODE
SKIPN RMFLG ;If Ref. Modding,
JRST SETOP1
PUSHJ PP,SETOP1 ; set up op code
DMOVE TB,OPRTR ; then store it
DMOVEM TB,RMOPR ;
POPJ PP, ;
INTER. PA35.
PA35.: MOVE TA,ARG1
TLO TA,004000 ;SET 'ROUNDED' BIT
MOVEM TA,ARG1
POPJ PP,
INTER. PA36.
PA36.: SETO TA,
DPB TA,OP.SZE##
PUSHJ PP,PA22.
HRRZI TA,23 ;'SPECIAL IF' OP CODE
PUSHJ PP,SETOP2
SETO TA,
DPB TA,OP.SZE
JRST PA90.A
INTER. PA37.
PA37.: HRLZI TA,026000 ;ENDIF
SETZM EWFLG## ;[1553] Turn off when seen flag
HRRZI TB,26
DPB W2,[POINT 20,TA,35]
PUSHJ PP,PUTGEN
HRRZ TA,IFLVL
ADD TA,SPFLVL
HRRZ TC,ARGL2-1(TA) ;F-TARGET FOR CURRENT LEVEL
HLRM TC,ARGL2-1(TA) ;CLEAR ENTRY
PUSHJ PP,P127.A ;DEFINE TAG
PUSH PP,TA ;[1130] GET AN AC TO WORK WITH
HRRZ TA,IFLVL ;[1130] GET VALUE OF IF LEVEL
CAILE TA,0 ;[1130] CAN'T GO NEGATIVE
SOS IFLVL
POP PP,TA ;[1130] GIVE BACK AC
SWOFF UNCONT;
POPJ PP,
INTER. PA38.
PA38.: SETO TA,
DPB TA,OP.UPO## ;SET 'UPON' BIT
POPJ PP,
INTER. PA43.
PA43.: HRRZI TA,60 ;'ACCEPT' OP CODE
JRST SETOP
INTER. PA45.
PA45.: HRRZI TA,34 ;'ALTER' OP CODE
JRST SETOP
INTER. PA47.
PA47.: MOVE TA,ARG1
EXCH TA,ARG2##
MOVEM TA,ARG1
MOVE TA,ARG1+1
EXCH TA,ARG2+1
MOVEM TA,ARG1+1
MOVE TA,[XWD NSBSC1,TBLOCK]
BLT TA,TBLOCK+MAXSUB*4
MOVE TA,[XWD NSBSC2,NSBSC1]
BLT TA,SBSCR1+MAXSUB*4-1
MOVE TA,[XWD TBLOCK,NSBSC2##]
BLT TA,SBSCR2##+MAXSUB*4-1
POPJ PP,
INTER. PA49.
PA49.: HRRZI TA,62 ;'OPEN' OP CODE
MOVEM TYPE,CURVRB ;Store it in case 'UNAVAIL'
JRST SETOP1
INTER. PA50.
PA50.: SETZM SU8CNT ;COUNT FILES INCASE FIPS FLAGGER
PA50A.: HRRZI TA,63 ;'CLOSE' OP CODE
JRST SETOP1
INTER. PA51.
PA51.: SETO TA,
DPB TA,OP.REE## ;SET 'REEL' BIT
PA51.A: ;
HRRZ TA,CURFIL ;
LDB TE,FI.RMS ;CHECK IF RMS FILE AND GIVE WARNING IF SO
CAIN TE,0 ; IS NOT, JUST RETURN
POPJ PP,
HRRZI DW,E.853 ;GIVE NOT SUPPORTED MESSAGE
PUSHJ PP,WARN## ;
POPJ PP, ;
INTER. PA52.
PA52.: SETO TA,
DPB TA,OP.LCK## ;SET 'LOCK' BIT
SKIPN FLGSW## ;FIPS FLAGGER WANTED?
POPJ PP, ;NO
MOVE TA,ARG1 ;GET FILE TABLE
ADD TA,FILLOC
LDB TB,FI.ORG ;GET FILE ORGANIZATION
IFN %ACC.S,<
CAIE TB,%ACC.S ;ONLY SEQUENTIAL IS SPECIAL
POPJ PP,
>
IFE %ACC.S,<
JUMPN TB,CPOPJ
>
MOVEI TA,%LV.HI ;SEQUENTIAL
PJRST FLG.ES## ;FLAG IF ILLEGAL
INTER. PA52A.
PA52A.: FLAGAT HI
SETO TA,
DPB TA,OP.REM## ;SET 'FOR REMOVAL' BIT
JRST PA51.A ;
INTER. PA53.
PA53.: FLAGAT HI
SETO TA,
DPB TA,OP.NRW## ;SET 'NO REWIND' BIT
JRST PA51.A ;
INTER. PA54.
PA54.: HRRZI TA,57 ;'CEND' OP CODE
SWOFF FARITH;
JRST SETOP1
INTER. PA54A
PA54A: SKIPG CLEVEL ; [172] ARE ALL PARENTHESIS CLOSED?
JRST PA54A1 ; [172] YES OK
PA54A2: EWARNW E.261 ; [172] NO
SOSLE CLEVEL ; [172]
JRST PA54A2 ; [172] TELL HIM ABOUT ALL UNBALANCED ONES
PA54A1: SETZM CLEVEL ; [172] CLEAR PAREN COUNT
SETZM ELEVEL ; [172] CLEAR BALANCE COUNT
JRST PA54. ; [172] FINISH UP
INTER. PA55.
PA55.: HRRZI TA,61 ;'DISPLAY' OP CODE
JRST SETOP
INTER. PA57.
PA57.: HRRZI TA,13 ;'DIVBY' OP CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP
INTER. PA58.
PA58.: HRRZI TA,10 ;'DIVIDE' OP CODE
JRST SETOP3
INTER. PA59.
PA59.: HRRZI TA,106 ;NO-OP OP CODE
JRST SETOP
INTER. PA61.
PA61.: HRRZI TA,42 ;'INSPECT' OP CODE
JRST SETOP
INTER. PA62.
PA62.: HRRZI TA,156 ;GET "TALLYING" OPERATOR
MOVEM TA,SVINSO## ; SAVE NEXT OPERATOR
POPJ PP,
INTER. PA64.
PA64.: SETO TA,
DPB TA,OP.LEA##
POPJ PP,
INTER. PA65.
PA65.: SETO TA,
DPB TA,OP.CHR##
POPJ PP,
INTER. PA65A.
PA65A.: PUSHJ PP,PREA ;ONLY 1 AFTER CLAUSE ALLOWED
SETO TA,
DPB TA,OP.IAF##
LDB TA,OP.IBF##
SKIPE TA ;"BEFORE" SPECIFIED PRIOR TO "AFTER"
POPJ PP, ;YES
SETO TA,
DPB TA,OP.IAB## ;INSPECT "AFTER" XXX "BEFORE" YYY
POPJ PP,
INTER. PA65B.
PA65B.: PUSHJ PP,PREB ;ONLY 1 BEFORE CLAUSE ALLOWED
SETO TA,
DPB TA,OP.IBF##
POPJ PP,
PREB: LDB TA,OP.IBF## ;ANY PREVIOUS "BEFORE" CLAUSE
JUMPN TA,PREBAE ; FOR THIS ARGUMENT?
POPJ PP,
PREA: LDB TA,OP.IAF## ;ANY PREVIOUS "AFTER" CLAUSE
JUMPN TA,PREBAE ; FOR THIS ARGUMENT?
POPJ PP,
PREBAE: EWARNJ E.724 ;"Only one 'BEFORE' and 'AFTER' clause allowed"
INTER. PA66.
PA66.: SETO TA,
DPB TA,OP.RPL##
SKPNAM
INTER. PA66A.
PA66A.: HRRZI TA,157 ;"REPLACING" OPERATOR
MOVEM TA,SVINSO## ;SAVE IT
POPJ PP,
INTER. PA67.
PA67.: SETO TA,
DPB TA,OP.FIR##
POPJ PP,
INTER. PA68.
PA68.: HRRZI TA,31 ;'GO DEPENDING' OP CODE
JRST SETOP
INTER. PA69.
PA69.: FLAGAT 8
HRRZI TA,OPINSC ;'INSPECT CONVERTING' OP CODE
MOVEM TA,SVINSO##
JRST PCA92.
INTER. PA70.
PA70.: HRRZI TA,1 ;'MOVE' OP CODE
; JRST SETOP
;HERE TO SET UP OPERATOR WORDS
SETOP: SETZM ARG1
SETZM ARG1+1
SETOP1: SETZM OPRTR
SETOP2: DPB W2,OP.LNC
SETOP3: DPB TA,OP.OPC##
DPB TA,OP.OP2
POPJ PP,
INTER. PA72.
PA72.: HRRZI TA,7 ;'MULTIPLY BY' OP CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP
INTER. PA73.
PA73.: HRRZI TA,6 ;'MULTIPLY GIVING' OP CODE
SKIPN RMFLG## ;If Ref. Modding
JRST SETOP3
PUSHJ PP,SETOP3 ; set up op code
DMOVE TB,OPRTR ; then store it
DMOVEM TB,RMOPR## ;
POPJ PP, ;
INTER. PA74.
PA74.: MOVE TB,OP.INP##
PA74.A: HRRZI TA,62 ;'OPEN' OP CODE
LDB TC,OP.LNC
SETZM OPRTR
DPB TC,OP.LNC
PUSHJ PP,SETOP3
SETO TA,
DPB TA,TB
POPJ PP,
INTER. PA75.
PA75.: MOVE TB,OP.OUT##
JRST PA74.A
INTER. PA76.
PA76.: MOVE TB,OP.INO##
JRST PA74.A
INTER. PA77.
PA77.: HRRZ TA,ARG1
JUMPE TA,CPOPJ
PUSHJ PP,LNKSET
LDB TB,OP.INO
SETO TC,
XCT [POPJ PP,
DPB TC,FI.INO## ;OPEN INPUT
DPB TC,FI.OUO## ;OPEN OUTPUT
DPB TC,FI.IOO##](TB) ;OPEN I-O
POPJ PP,
INTER. PA78.
PA78.: SETZ TA,
DPB TA,OP.NRW ;CLEAR NO REWIND BIT
POPJ PP,
INTER. PA79.
PA79.: SETO TA,
DPB TA,OP.NRW ;SET NO REWIND BIT
POPJ PP,
INTER. PA79E.
PA79E.: SETO TA,
DPB TA,OP.EXT## ;SET EXTEND BIT
POPJ PP,
INTER. PA79R.
PA79R.: SETO TA,
DPB TA,OP.REV## ;SET REVERSED BIT
DPB TA,OP.NRW ;AND SET NO REWIND BIT
POPJ PP,
INTER. PA80.
PA80.: HRRZI TA,64 ;'READ' OP CODE
SETZM REINTO## ;CLR READ INTO FLAG
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP1
INTER. PA81.
PA81.: HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.ATE## ;'AT END'
JRST PA90.A
INTER. PA81Q.
PA81Q.: SKIPLE AS7482 ;WANT COBOL-8x?
EWARNW E.829 ;YES, WARN USER
SKPNAM
INTER. PA81P.
PA81P.: FLAGAT HI
HRRZ TA,CURFIL
LDB TA,FI.LCP## ;SEE IF LINAGE CLAUSE SPECIFIED
SKIPN TA ;YES, OK
EWARNW E.752 ;NO, IT SHOULD BE
HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.EOP## ;'AT END OF PAGE'
JRST PA90.A
INTER. PA82.
PA82.: HRRZI TA,43 ;'SET TO' OP CODE
JRST SETOP
INTER. PA83.
PA83.: HRRZI TA,45 ;'SET UP BY' OP CODE
JRST SETOP3
INTER. PA84.
PA84.: HRRZI TA,44 ;'SET DOWN BY' OP CODE
JRST SETOP3
;SET UP WRITE OP-CODE
INTER. PA85.
PA85.: HRRZI TA,65 ;'WRITE' OP CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP1
;SET UP DELETE OP-CODE
INTER. PA85D.
PA85D.: HRRZI TA,122 ;DELETE OP-CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP1
;SET UP REWRITE OP-CODE
INTER. PA85R.
PA85R.: HRRZI TA,66 ;REWRITE OP-CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP1
INTER. PA86.
PA86.: SETO TA,
DPB TA,OP.BAD## ;'BEFORE ADVANCING'
JRST PA87.1 ;[1466] CHECK RECORDING MODE
INTER. PA87.
PA87.: SETO TA,
DPB TA,OP.AAD## ;'AFTER ADVANCING'
PA87.1: SKIPN TA,CURFIL ;[1466]
POPJ PP,
LDB TB,FI.ERM## ;[1466] GET EXTERNAL REC. MODE
LDB TA,FI.RM2## ;WAS ONE REALLY DECLARED?
CAIE TB,%RM.7B ;[1466] IS IT ASCII?
SKIPN TA ;ZERO => NONE DECLARED
POPJ PP, ;[1466] OK - EXIT
EWARNJ E.365 ;[1466] NO, ERROR
INTER. PA88.
PA88.: FLAGAT NS
SETZI TA, ;WHOPS, MAKE THAT POSITIONING INSTEAD OF ADVANCING.
DPB TA, OP.ADV## ;CLEAR ADVANCING.
SETOI TA,
DPB TA, OP.PSG## ;SET POSITIONING.
POPJ PP,
;WRITE RECORD ADVANCING PAGE.
INTER. PA89.
PA89.: PUSHJ PP,PA2.
HRRZ TB,ARG1 ;R. H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
TLZ TA,777774 ;LN, CP
TLO TA,400000 ;SET OPERAND BIT
SETZM NSBSC1
SETZM ARG1
SETZM ARG1+1
HLRZ TB,TD
ANDI TB,777 ;GET VALUE
JRST PUTGEN ;OUTPUT ARG1
INTER. PA90.
PA90.: HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.INK## ;'INVALID KEY'
PA90.A: PUSHJ PP,GETTAG##
ANDI CH,077777
JUMPE CH,PA90.A ;%0 NOT ALLOWED
DPB CH,OP.TRG##
AOS TA,SPFLVL
ADD TA,IFLVL
CAILE TA,IF.DEP ;ARGL2 OVERFLOW?
JRST PA90.B ;YES
HRLZM CH,ARGL2-1(TA)
PUSHJ PP,PA22.
JRST PA820. ;STORE VERB FOR MATCHING END-XXX
PA90.B: EWARNW E.323
JRST PA133. ;GIVE UP
INTER. PA91.
PA91.: HRRZI TA,5 ;'SUBTRACT FROM' OP CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP
INTER. PA94.
PA94.: HRRZI TA,32 ;'PERFORM' OP CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
SETZM PERFAB## ;DEFAULT TO PERFORM BEFORE TEST
JRST SETOP1
INTER. PA95.
PA95.: HRRZI TA,33 ;'PERFORM TIMES' OP CODE
SKIPN RMFLG ;If Ref. Modding,
JRST SETOP3
PUSHJ PP,SETOP3 ; set up op code
DMOVE TB,OPRTR ; then save off new op code
DMOVEM TB,RMOPR ;
POPJ PP, ;
INTER. PA96.
PA96.: FLAGAT HI
SKIPN ARG2
SKIPE ARG2+1
JRST PA96.A
PUSHJ PP,PA159.
JRST .+2
PA96.A: PUSHJ PP,PA47.
SETZM NVARY##
SETZM VARBLK
MOVE TA,[XWD VARBLK,VARBLK+1]
; BLT TA,VARLST
; SETZM VARTAG##
; MOVE TA,[XWD VARTAG,VARTAG+1]
BLT TA,VARTAG##+6
PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
HRRZM CH,VARTAG ;%S
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
MOVE TA,[XWD OPRTR,SAVPRF##]
BLT TA,SAVPRF+5
POPJ PP,
INTER. PA97.
PA97.: AOS TA,NVARY
CAIG TA,MXPERF
POPJ PP,
EWARNJ E.156 ;ONLY THREE VARYINGS ALLOWED
INTER. PA98.
PA98.: HRRZ TA,NVARY ;WE HAD SEEN 'VARYING'. NOW WE SAW 'FROM'
; SO WE SAVE WHAT TO VARY IN VARBLK.
CAILE TA,MXPERF
POPJ PP, ;IGNORE FURTHER VARYINGS
HRRZI TA,-1(TA)
IMULI TA,VARSIZ## ;SIZE OF ONE OCCURANCE OF VARBLK
MOVE TB,ARG1 ;INDEX
MOVEM TB,VARBLK(TA) ;SAVE SUBJECT
MOVE TB,ARG1+1
MOVEM TB,VARBLK+1(TA)
HRRZI TB,VARSSB##(TA)
HRLI TB,NSBSC1
BLT TB,VARIVL-1(TA) ;SAVE THE SUBSCRIPTS
PA98.X: SETZM NSBSC1 ;CLR SUBSCRIPT STORE
MOVE TB,[XWD NSBSC1,NSBSC1+1]
BLT TB,NSBSC1+MAXSUB*4
POPJ PP,
INTER. PA99.
PA99.: HRRZ TA,NVARY ;WE HAD SEEN 'FROM'. NOW WE SAW 'BY'
; SO SAVE THE INITIAL VALUE IN VARBLK.
CAILE TA,MXPERF
POPJ PP, ;IGNORE FURTHER VARYINGS
HRRZI TA,-1(TA)
IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVE TB,ARG1 ;ORIGINAL VALUE OF INDEX
MOVEM TB,VARIVL##(TA) ;SAVE INITIAL VALUE
MOVE TB,ARG1+1
MOVEM TB,VARIVL+1(TA)
HRRZI TB,VARSIV##(TA)
HRLI TB,NSBSC1
BLT TB,VARSIN-1(TA) ;SAVE THE SUBSCRIPTS
JRST PA98.X ;CLR SUBSCRIPT STORE & RETURN
INTER. PA100.
PA100.: HRRZ TA,NVARY ;HAD SEEN A 'BY'. NOW WE SAW AN 'UNTIL'
; SO SAVE THE INCREMENT IN VARBLK.
CAILE TA,MXPERF
POPJ PP,
SETOM IFPERF## ;SIGNAL ITS PERFORM LOOP CONTROL
SUBI TA,1
IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVE TB,ARG1
MOVEM TB,VARINC##(TA) ;INCREMENT
MOVE TB,ARG1+1
MOVEM TB,VARINC+1(TA)
HRRZI TB,VARSIN##(TA)
HRLI TB,NSBSC1
BLT TB,VARNXT##-1(TA) ;SAVE THE SUBSCRIPTS
PUSHJ PP,GETTAG
ANDI CH,077777
HRRZ TC,NVARY
LSH TC,1
HRRZM CH,VARTAG(TC)
HRLZI TB,(CH)
JRST P198.D ;OUTPUT 'TAGNAM' OP CODE
INTER. PA101.
PA101.: HRRZ TA,NVARY
CAILE TA,MXPERF
JRST PA37.
MOVE CH,INPTAG## ;Get tag generated by inline perform
JUMPE CH,PA101A ;If no tag, must not be inline perform
;The following code generates the same code as PA101A. The difference
;between this and PA101A, is that the tag number for the next statement
;is incremented by one. Two calls to GETTAG are executed at PA833. with
;the first tag being the starting address of the statements within the
;perform, and the second tag for the next statement.
ANDI CH,077777
HRRZ TA,NVARY
LSH TA,1
HRRZM CH,VARTAG-1(TA)
AOS VARTAG-1(TA)
PUSHJ PP,PA103A ;GENERATE JUMPTO OP CODE
SETZM INPTAG
JRST PA37.
PA101A: PUSHJ PP,GETTAG
ANDI CH,077777
HRRZ TA,NVARY
LSH TA,1
HRRZM CH,VARTAG-1(TA)
PUSHJ PP,PA103A ;GENERATE JUMPTO OP CODE
JRST PA37.
INTER. PA102X
PA102X: PUSHJ PP,PA821. ;PUT CURRENT RESERVED WORD ON TEMTAB STACK
SKPNAM
INTER. PA102.
PA102.: SETZM OPRTR+1
CAIE TYPE,UNTIL. ;[1005] WAS IT UNTIL?
CAIN TYPE,WHEN. ;[1005] WAS IT 'WHEN'?
JRST PA102A ;[1005] BYPASS TEST FOR 'WHEN' ACTIVE
CAIE TYPE,UNTIL.+AMRGN. ;SAME TEST AS ABOVE BUT ALLOW
CAIN TYPE,WHEN.+AMRGN. ; VERB TO BE IN "A" MARGIN
JRST PA102A ;YES, BYPASS TEST FOR 'WHEN' ACTIVE
SKIPE SWHEN## ;[1005] 'WHEN' ALREADY ACTIVE?
EWARNW E.632 ;[1005] GIVE ERROR MSG
PA102A: SETZM ERSKIP## ;Clear "Error caused us to skip to next period"
HRRZI TA,20 ;'IF' OP CODE
SKIPE IFPERF## ;SEE IF ITS PERFORM LOOP CONTROL
HRRZI TA,25 ;YES, 'IF' OP CODE FOR PERFORM VARYING UNTIL
JRST SETOP1
INTER. PA103.
PA103.: SWOFF UNCONT;
;[1541] SKIPN CH,NXTSNT
PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
;[1541] HRRZM CH,NXTSNT
PA103A: HRLZI TB,(CH)
HRRI TB,74 ;JUMPTO OP CODE
JRST P198.E
INTER. PA103N ;[1602]Duplicate PA103. for NEXT SENTANCE
PA103N: SWOFF UNCONT ;[1602]No GOTOs
SKIPN CH,NXTSNT ;[1602]Already defined?
PUSHJ PP,GETTAG ;[1602]Then don't get a new one
ANDI CH,077777 ;[1602]
JUMPE CH,.-2 ;[1602]Can't use tag zero
HRRZM CH,NXTSNT ;[1602]Save it for when we find a period
HRLZI TB,(CH) ;[1602]
HRRI TB,74 ;[1602]JUMPTO OP CODE
JRST P198.E ;[1602]
INTER. PA104.
PA104.: SWOFF FNOTF;
SETZM ARGLST##
MOVE TA,[XWD ARGLST,ARGLST+1]
BLT TA,ARGLST+IF.DEP-1
SETZM TOPLVL
SETZM TRMLVL##
SKIPE FLGSW ;FIPS FLAGGER REQUIRED?
SKIPN IFLVL ;AND NESTED?
TRNA ;NO
PUSHJ PP,TST.HI ;YES, TEST AT HIGH-INTERMEDIATE LEVEL
AOS TA,IFLVL
ADD TA,SPFLVL ;ARGL2 OVERFLOW?
CAIG TA,IF.DEP
POPJ PP,
JRST PA90.B ;YES
INTER. PA106.
PA106.: FLAGAT HI
SKPNAM
INTER. PA107.
PA107.: TSWC FNOTF;
SETZM TOPLVL
DMOVEM LN,NOTLN ;SAVE LOCATION OF "NOT"
POPJ PP,
INTER. PA111.
PA111.: MOVE TA,TOPLVL
MOVEM TA,ELEVEL
MOVE TB,CLEVEL
SUB TB,TA
MOVEM TB,CLEVEL
SWON FEXPR+FARITH
HRRZI TA,72 ;'EXPRESSION' OP CODE
PUSHJ PP,SETOP0
HRLZI TA,070000
DPB W2,[POINT 20,TA,35]
HRRZI TB,70 ;'(' OP CODE
CAIA
PUSHJ PP,PUTGEN
SOSL TOPLVL
JRST .-2
SETZM TOPLVL
POPJ PP,
;OUTPUT CODES FOR "AND"
INTER. PA118.
PA118.: PUSHJ PP,SETCTR ;# OF LEVELS FROM HERE UP
P118.2: ADD TB,CLEVEL ;(TB STILL CONTAINS VALUE OF CTR)
HRRZ TB,ARGLST(TB) ;ANY TAG THERE?
JUMPN TB,P118.1 ;YES
SOSLE TB,CTR ;NO, FINISHED ALL ENTRIES ABOVE THIS LEVEL?
JRST P118.2 ;NOT YET
PUSHJ PP,PA129. ;NONE FOUND. NORMAL "AND".
JRST SETCTR ;RETURN WITH CTR SET UP
P118.1: AOS CLEVEL
PUSHJ PP,PA130. ;INVERTED "AND". GOIF-TRUE ONE LEVEL UP.
SOS CLEVEL
PUSHJ PP,SETCTR
P118.3: PUSHJ PP,PA127. ;OUTPUT ALL FALSE TAGS
SOSL CTR
JRST P118.3
MOVE TB,CLEVEL ;DEFINE F-TARGET AT THIS LEVEL
HRLZ TB,ARGLST(TB) ;ONE THERE ALREADY?
JUMPN TB,P118.4 ;YES
P118.5: PUSHJ PP,GETTAG ;NO, GET ONE
ANDI CH,077777
JUMPE CH,P118.5
MOVE TB,CLEVEL
HRRM CH,ARGLST(TB)
P118.6: HRLZ TB,CH
P118.4: HRRI TB,74 ;OUTPUT JUMPTO
HRLI TA,074000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
JRST SETCTR ;RETURN WITH CTR SET UP
;OUTPUT CODES FOR "OR"
INTER. PA119.
PA119.: PUSHJ PP,SETCTR ;# OF LEVELS FROM HERE UP
P119.2: ADD TB,CLEVEL ;(TB STILL CONTAINS VALUE OF CTR)
HLRZ TB,ARGLST(TB) ;ANY TAG THERE?
ANDI TB,077777
JUMPN TB,P119.1 ;YES
SOSLE TB,CTR ;NO, FINISHED ALL ENTRIES ABOVE THIS LEVEL?
JRST P119.2 ;NOT YET
PUSHJ PP,PA130. ;NONE FOUND. NORMAL "OR".
JRST SETCTR ;RETURN WITH CTR SET UP
P119.1: PUSHJ PP,PA129. ;INVERTED "OR".
PUSHJ PP,SETCTR
P119.3: PUSHJ PP,PA131. ;OUTPUT ALL TRUE TAGS
SOSL CTR
JRST P119.3
MOVE TB,CLEVEL ;DEFINE T-TARGET AT THIS LEVEL
HLLZ TB,ARGLST(TB) ;ONE THERE ALREADY?
JUMPN TB,P118.4 ;YES
P119.5: PUSHJ PP,GETTAG ;NO, GET ONE
ANDI CH,077777
JUMPE CH,P119.5
MOVE TB,CLEVEL
HRLM CH,ARGLST(TB)
JRST P118.6
; "AND" IN IF-STATEMENT
;DEFINE FALSE-TARGET AT THIS LEVEL,
;OUTPUT GOIF-FALSE,
;AND OUTPUT TRUE-TARGET TAGS AT HIGHER LEVELS.
INTER. PA120.
PA120.: FLAGAT HI
HRRZ TA,CLEVEL
SKIPGE TA,ARGLST(TA) ;NOT FLAG ON?
JRST P121.0 ;YES
P120.0: PUSHJ PP,PA118. ;OUTPUT AND CODES
P120.1: PUSHJ PP,PA131. ;OUTPUT T-TAGS AT HIGHER LEVELS
SOSLE CTR
JRST P120.1
P120.2: MOVEI TA,OPIF ;[1635] This indicates to PCA94A that we had
MOVEM TA,OPRTR+1 ;[1635] an AND or OR following an IF
SKIPN TA,TRMLVL ;COMING DOWN FROM HIGHER LEVEL?
POPJ PP, ;NO
P120.3: ADD TA,CLEVEL ;YES
MOVE TB,ARGLST(TA) ;CLEAR NOT BIT AT ALL UPPER LEVELS
TLZ TB,400000
MOVEM TB,ARGLST(TA)
SOSE TA,TRMLVL
JRST P120.3
POPJ PP,
; "OR" IN IF-STATEMENT
;DEFINE TRUE-TARGET AT THIS LEVEL (FALSE-TARGET IF NOT FLAG IS ON),
;OUTPUT GOIF-TRUE
;AND OUTPUT FALSE-TARGET TAGS AT THIS AND HIGHER LEVELS
INTER. PA121.
PA121.: FLAGAT HI
HRRZ TA,CLEVEL
SKIPGE TA,ARGLST(TA) ;NOT FLAG ON?
JRST P120.0 ;YES
P121.0: PUSHJ PP,PA119. ;OUTPUT OR CODES
P121.1: PUSHJ PP,PA127. ;OUTPUT F-TAGS
SOSL CTR
JRST P121.1
JRST P120.2
INTER. PA122.
PA122.: SOSGE CLEVEL
EWARNJ E.261 ;UNBALANCED PARINS
AOS TRMLVL
POPJ PP,
INTER. PA123.
PA123.: SKIPG EVALFL ;LOOKING FOR IMPERATIVE STMT IN EVALUATE?
JRST P123.0 ; NO
MOVE TB,IMPLOP ;SELECTION SUBJ/OBJ
MOVEM TB,EVLNCP## ;STORE LN, CP FOR EVALUATE OP CODE
P123.0: SKIPG CLEVEL ;ALL PARINS CLOSED?
JRST P123.3 ;YES
P123.4: EWARNW E.261 ;NO
SOSLE CLEVEL
JRST P123.4 ;TELL HIM ABOUT ALL OF THEM
P123.3: PUSHJ PP,PA118. ;OUTPUT AND CODES
P123.1: PUSHJ PP,PA131. ;OUTPUT ALL TRUE-TAGS
SOSL CTR
JRST P123.1
HRRZ TA,ARGLST
HRRZ TB,IFLVL
ADD TB,SPFLVL
HRRZM TA,ARGL2-1(TB)
SETZM CLEVEL
SETZM TOPLVL
SETZM ARGLST
MOVE TA,[XWD ARGLST,ARGLST+1]
BLT TA,ARGLST+13
HRRZI TB,76 ;END-CONDITION OP CODE
PUSHJ PP,P198.E
JRST PA0.
SETCTR: MOVEI TB,IF.DEP-1 ;MAX LENGTH OF ARGLST - 1
SUB TB,CLEVEL ;LESS WHERE WE ARE NOW
MOVEM TB,CTR ;EQUALS PART OF LIST TO CHECK
POPJ PP,
INTER. PA125.
PA125.: HRRZI TA,52 ;'CSUB' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.UNM## ;UNARY MINUS
JRST PA22.
INTER. PA126.
PA126.: TSWF FEXPR;
JRST P126.A
AOS TA,CLEVEL
CAILE TA,IF.DEP ;ARGLST OVERFLOW?
JRST P126.B ;YES
AOS TOPLVL
SETZ TB,
TSWFZ FNOTF;
HRLZI TB,4B20
HLLZ TC,ARGLST-1(TA) ;NOT ON AT LOWEL LEVEL?
TLZ TC,377777
XOR TB,TC ;IF SO, COMPLEMENT NOT AT CURRENT LEVEL
MOVEM TB,ARGLST(TA)
POPJ PP,
P126.A: AOS ELEVEL
HRRZI TA,70 ;'(' OP CODE
SETOP0: PUSHJ PP,SETOP1
JRST PA22.
P126.B: EWARNW E.324
JRST PA133.
;OUTPUT FALSE-TARGET TAG AT LEVEL=CLEVEL+CTR
INTER. PA127.
PA127.: HRRZ TA,CLEVEL ;DESIRED LEVEL
ADD TA,CTR
HRRZ TC,ARGLST(TA) ;F-TARGET
HLRM TC,ARGLST(TA) ;CLEAR ENTRY
P127.A: ANDI TC,077777 ;GET TARGET TAG
JUMPE TC,CPOPJ ;NONE THERE
SKIPE PERFAB ;ARE WE IN PERFORM ... WITH TEST AFTER?
HRRM TC,PERFAB ;YES, NEEDED FOR VARYING CASE
HRLZ TB,TC
JRST P198.D ;TAGNAM OP CODE
INTER. PA128.
PA128.: SOSGE ELEVEL
JRST P128.A
P128.Q: HRRZI TA,71 ;')' OP CODE
JRST SETOP0
P128.A: SETZM ELEVEL
PUSHJ PP,PA24.
PUSHJ PP,PA132.
JRST PA0.
;DEFINE FALSE-TARGET
INTER. PA129.
PA129.: HRRZ TA,CLEVEL ;TAG THERE ALREADY?
HRRZ TC,ARGLST(TA)
ANDI TC,077777
JUMPN TC,P129.A ;YES
PUSHJ PP,GETTAG ;NO, GET A NEW ONE
ANDI CH,077777
JUMPE CH,.-2
HRRZ TA,CLEVEL ;OUTPUT GOIF-FALSE
HRRZ TC,ARGLST(TA)
IOR TC,CH
HRRM TC,ARGLST(TA)
P129.A: MOVE TA,[XWD IMPLOP,OPRTR]
BLT TA,OPRTR+1
SETO TA, ;'GO TO IF FALSE' FLAG
JRST P130.B
;DEFINE TRUE-TARGET
INTER. PA130.
PA130.: HRRZ TA,CLEVEL ;TAG THERE ALREADY?
HLRZ TC,ARGLST(TA)
ANDI TC,077777
JUMPN TC,P130.A ;YES
PUSHJ PP,GETTAG ;NO, GET A NEW ONE
ANDI CH,077777
JUMPE CH,.-2
HRRZ TA,CLEVEL ;PUT IT ON THE LIST AT THIS LEVEL
HLRZ TC,ARGLST(TA)
IOR TC,CH
HRLM TC,ARGLST(TA)
P130.A: MOVE TA,[XWD IMPLOP,OPRTR]
BLT TA,OPRTR+1
SETZ TA, ;'GO TO IF TRUE' FLAG
P130.B: DPB TA,OP.FLS##
DPB TC,OP.TRG ;TARGET TAG
MOVSI TA,OPM.IF## ;GET COMPLEMENT MASK
TSWFZ FNOTF ;NOT SEEN ALSO
XORM TA,OPRTR ;YES, SWAP TEST
PUSHJ PP,PA22. ;OUTPUT OPCODE
MOVE TC,CLEVEL
SKIPGE ARGLST(TC) ;IF NOT ON AT THIS LEVEL
POPJ PP, ;LEAVE IT ALONE
MOVSI TC,4 ;ELSE
ANDCAM TC,IMPLOP ;TURN NOT OFF FOR ABREV. LIST
POPJ PP,
;OUTPUT TRUE-TARGET TAG AT LEVEL=CLEVEL+CTR
INTER. PA131.
PA131.: HRRZ TA,CLEVEL ;AIM AT DESIRED LEVEL
ADD TA,CTR
HLRZ TC,ARGLST(TA) ;T-TARGET
HRRZI TB,(TC) ;CLR TAG FROM ENTRY
ANDI TB,7B20
HRLM TB,ARGLST(TA)
JRST P127.A ;OUTPUT TAG
INTER. PA132.
PA132.: MOVE TA,ELEVEL
ADDM TA,CLEVEL
SOSGE ELEVEL
JRST .+3
PUSHJ PP,P128.Q
JRST .-3
SETZM ELEVEL
HRRZI TA,73 ;'END EXPRESSION' OP CODE
SWOFF FEXPR+FARITH
HRRZ TB,CLEVEL
SKIPGE TC,ARGLST+1(TB)
SWON FNOTF;
JRST SETOP0
INTER. PA133.
PA133.: HRRZI DW,E.306
PUSHJ PP,PA133S
;9-FEB-81 /DAW: Add two SETZM's to clear "IF" levels
; if the program gets a syntax error. (Otherwise the compiler
; gets very confused since IFLVL is non-zero at the start of
; the next statement!).
SETZM IFLVL ;Don't leave these up-in-the-air.
SETZM SPFLVL ; . .
HRRZI DW,E.307
P133EX: SWOFF FREGWD;
PUSHJ PP,GETITM
TSWF FEOF;
JRST PA24.
JRST PA148.
;[1062] Avoid fatal errors on NOTE with COPY REPLACING
;[1062] turn off replacing because NOTE text is simply dumped
;[1062] to the output text buffer instead of parsed.
;[1062] Both flags will be turned on by RPLTST for next input
;[1062] Cobol library COPY member which is subject to REPLACING.
PA133S: SWOFF FRTST!FNOCPY ;[1062] [1033] TURN OFF COPY REPLACING FLAGS
SETOM ERSKIP## ;Set parse flag that says we skipped to
; next period
;22-AUG-79 /DAW HOPEFULLY THE NEXT TWO LINES OF CODE WILL
; IMPROVE ERROR RECOVERY SO IF PERIOD IS SEEN AT THE WRONG
; TIME, THE NEXT TOKEN WILL BE PARSED AS IF IT WERE THE START
; OF A STATEMENT.. THE COMPILER USED TO SKIP THE PARSING OF THE
; NEXT STATEMENT.
CAIN TYPE,PRIOD. ;IF ALREADY AT PERIOD, DON'T DO ANYTHING
JRST P133.X
SWON FARITH;
P133.1: PUSHJ PP,SKPSRC
TSWF FEOF;
JRST P133.X
CAIN CP,7
JRST P133.3 ;START OF NON-CONTINUATION LINE
P133.2: CAIN CH,"."
JRST P133.5 ;PERIOD IN B-MARGIN
CAIE CH," "
JRST P133.1 ;JUST A CHARACTER
MOVE TA,SAVBLN##
JUMPE TA,P133.4 ;IF 0, SAVBLN NOT IN USE
MOVEM TA,BLNKLN##
MOVE TA,SAVBCP##
MOVEM TA,BLNKCP##
P133.4: PUSHJ PP,SKPSRC
CAIN CP,7
JRST P133.3 ;A-MARGIN
CAIE CH," "
JRST P133.2
JRST P133.4 ;ANOTHER IN A STRING OF BLANKS
P133.3: PUSHJ PP,SKPSRC ;GET CHARACTER IN THE A-MARGIN
TSWF FEOF;
JRST P133.X
CAIL CP,^D12
JRST P133.2 ;NOW IN B-MARGIN
CAIN CH," "
JRST P133.3 ;A SPACE
CAIL CH,"0"
CAILE CH,"9"
SKIPA ;NOT A DIGIT
JRST P133.E ;POSSIBLY A PROCEDURE-NAME
CAIL CH,"A"
CAILE CH,"Z"
JRST P133.2 ;SOME GARBAGE IN A-MARGIN--TREAT AS B-MARGIN
P133.E: PUSHJ PP,DE125.
SWON FREGCH;
P133.X: SWOFF FARITH;
POPJ PP,
P133.5: PUSHJ PP,SKPSRC
CAIE CH," "
JRST P133.1
SWOFF FNEEDS;
JRST P133.X ;PERIOD FOLLOWED BY SPACE
INTER. PA134.
PA134.: HRRZI TA,40 ;'STOP' OP CODE
JRST SETOP1
PA135.: SETO TA,
DPB TA,OP.RUN ;SET 'RUN' BIT IN OPERATOR
POPJ PP,
PA137.: MOVE TA,ARG1+1
DPB TA,OP.LNC ;PUT LN, CP IN OPERATOR
HRRZI TA,101 ;OP CODE FOR PARAGRAPH OPERATOR
JRST SETOP3
INTER. PA138.
PA138.: TSWF UNCONT;
JRST A831AP
PUSHJ PP,PA25.
MOVE TA,OPRTR
MOVE TB,OPRTR+1
TLO TA,200
PUSHJ PP,PUTGEN
A831AP: SKIPN CURSEC ;ANY SECTIONS?
JRST PA138A ;NO --- THEN NO SEGMENT BREAK, ALL RESIDENT
MOVSI TA,104000
DPB W2,[POINT 20,TA,35]
HRRZI TB,104 ;SEGMENT BREAK
PUSHJ PP,PUTGEN
PA138A: MOVE TA,GENWRD ;SAVE WORD NUMBER OF
MOVEM TA,ARG2 ;ENDIT OPERATOR
MOVE TA,[XWD 377003,777607]
HRRZI TB,377 ;ENDIT OPERATOR
PUSHJ PP,PUTGEN
IFE TOPS20,<
CLOSE GEN,2 ;CLOSE OUTPUT SIDE
>
IFN TOPS20,<
PUSHJ PP,PUTGN1## ;Write out last partial buffer
PUSHJ PP,CLSGEN## ; And close file
>
SETZM CURPAR
SETZM CURSEC
HRRZ TA,FLOLOC## ;BEGINNING OF FLOTAB
AOJA TA,P138Z1 ;NOW POINTS TO ENTRY PROPERLY
;ENTER ROUTINE TO CLEAR UP
P138FZ: HRRZ TA,CURFLO
ADDI TA,SZ.FLO ;NEXT ENTRY
P138Z1: HRRZ TB,FLONXT## ;FIRST UNUSED PROTAB ENTRY
CAILE TA,(TB)
JRST FLODN
HRRZM TA,CURFLO
LDB TB,FL.TAG## ;Is it a link to TAGTAB ?
JUMPN TB,P138FZ ;If so, skip it
LDB TB,FL.PND ;PROCEDURE-NAME DEFINITION FLAG
JUMPE TB,P138F2 ;NOT PROCEDURE-NAME DEFINITION
LDB TA,FL.PRO ;PROTAB LINK
PUSHJ PP,LNKSET ;GET ABS. ADDR.
HRRZ TB,CURFLO ;FLOTAB ENTRY ABS. ADDR.
HRL TA,(TB) ;PUT PROTAB REL. ADDR. IN TA L. H.
LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPE TC,P138F1 ;JUMP IF SECTION
MOVEM TA,CURPAR ;SAVE LINK OF CURRENT PARAGRAPH
JRST P138FZ ;GET NEXT ENTRY
P138F1: SETZM CURPAR ;THIS ENTRY IS A SECTION
MOVEM TA,CURSEC ;SAVE LINK OF CURRENT SECTION
JRST P138FY
P138F2: LDB TB,FL.QUA## ;QUALIFIED ENTRY?
JUMPN TB,PF2Q ;YES
PUSHJ PP,RESLVU ;NO --- RESOLVE
JRST PF2
PF2Q: PUSHJ PP,RESLVQ ;RESOLVE QUALIFIED ENTRY
PF2: MOVEM TA,SAVETA##
LDB TA,FL.PRO
JUMPE TA,PF2.1
PUSHJ PP,LNKSET
LDB TB,PR.MDF
JUMPN TB,MDF138
LDB TB,PR.DEF
JUMPE TB,P138FY ;NOT DEFINED
PF2.1: MOVE TA,SAVETA
LDB TB,FL.SAL## ;SUBJECT OF ALTER?
JUMPE TB,PF3 ;NO
MOVEM TA,SAVETA ;SAVE FLOTAB ENTRY ADDRESS
LDB TA,FL.PRO ;PROTAB LINK
MOVEM TA,TBLOCK+17 ;SAVE IT
JUMPE TA,P138FZ ;ENTRY WAS NOT RESOLVED
PUSHJ PP,LNKSET
LDB TB,PR.ALT ;ALTERABLE?
JUMPN TB,P138FZ ;YES --- CONTINUE
HRRZI DW,E.113 ;DIAGNOSTIC 113.
E138: MOVE TA,SAVETA
LDB LN,FL.LN## ;LINE NUMBER
LDB CP,FL.CP## ;CHARACTER POSITION
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
PUSHJ PP,FATAL##
>
P138FY: SETZM TBLOCK+17
JRST P138FZ
MDF138: HRRZI DW,E.187 ;DIAGNOSTIC 187.
JRST E138
PF3: LDB TB,FL.OAL## ;OBJECT OF ALTER?
JUMPE TB,PF6 ;NO
LDB TA,FL.PRO
JUMPE TA,PF3E ;ENTRY WAS NOT RESOLVED
PUSHJ PP,LNKSET ;ADDRESS OF OBJECT'S PROTAB ENTRY
LDB TB,PR.PRI ;PRIORITY OF OBJECT
MOVEM TB,TBLOCK+16 ;SAVE
MOVE TA,TBLOCK+17
JUMPE TA,P138FZ ;NO SUBJECT SAVED
PUSHJ PP,LNKSET ;ADDRESS OF SUBJECT'S PROTAB ENTRY
SETO TD,
HRRZ TC,TBLOCK+16 ;PRIORITY OF OBJECT
LDB TB,PR.PRI ;PRIORITY OF SUBJECT
CAME TB,TC ;SAME AS THAT OF OBJECT?
JRST PF5 ;NO
DPB TD,PR.ARS## ;ALTERED TO SAME SEGMENT
JRST P138FY
PF5: DPB TD,PR.ANR## ;ALTERED TO DIFFERENT SEGMENT
JRST P138FY
PF6: LDB TB,FL.OPF## ;OBJECT OF PERFORM?
JUMPE TB,P138FY ;NO
LDB TA,FL.PRO
JUMPE TA,P138FY ;ENTRY WAS NOT RESOLVED
PUSHJ PP,LNKSET
SETO TB,
DPB TB,PR.EXR## ;SET EXIT REQUIRED BIT
JRST P138FY
PF3E: PUSHJ PP,P138FE
JRST P138FY
RESLVU: LDB TA,FL.NAM## ;NAMTAB POINTER
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK ;IS THERE A PROTAB LINK FOR THIS NAME?
JRST P138FE ;N0--UNDEFINED
SETZM TBLOCK+2 ;PTR TO PARAGRAPH IN THIS SECTION
SETZM TBLOCK+3 ;PTR TO PARAGRAPH IN ANOTHER SECTION
SETZM TBLOCK+4 ;PTR TO SECTION OF THIS NAME
SETZM TBLOCK+5 ;0 UNLESS MORE THAN ONE PARAGRAPH OF
;THIS NAME IN OTHER SECTIONS
P138F8: MOVEM TB,CURPRO ;SAVE LINK FOUND
HRRZ TA,TB
LDB TC,PR.SEC ;SECTION/PARAGRAPH FLAG
JUMPN TC,P138F3 ;JUMP IF PARAGRAPH
SKIPE TBLOCK+4 ;HAVE WE SEEN A SECTION BEFORE?
JRST P138E1 ;YES---ERROR
MOVEM TB,TBLOCK+4 ;NO, SAVE THIS LINK
JRST P138F5
P138F3: LDB TD,PR.LSC ;SECTION LINK FROM PROTAB ENTRY
HRLS TD ;PUT LINK ALSO IN LEFT HALF
XOR TD,CURSEC
TLNE TD,777777 ;IS IT THE CURRENT SECTION?
JRST P138F4 ;NO
SKIPE TBLOCK+2 ;IS THERE A PARAGRAPH OF THIS NAME
;IN THE CURRENT SECTION?
JRST P138E2 ;YES---ERROR
MOVEM TB,TBLOCK+2 ;NO, SAVE LINK
JRST P138F5
P138F4: SKIPE TBLOCK+3 ;PARAGRAPHS OF THIS NAME IN OTHER SECTS?
SETOM TBLOCK+5 ;YES--SET FLAG WORD
MOVEM TB,TBLOCK+3 ;SAVE LINK
P138F5: PUSHJ PP,FNDNXT ;FIND ANOTHER PROTAB LINK
JRST .+2 ;NO--NOW EVALUATE
JRST P138F8 ;YES---PROCESS
HRRZ TA,CURFLO ;FLOTAB ENTRY ABS. ADDR.
SKIPN TC,TBLOCK+2 ;PARAGRAPH IN CURRENT SECTION?
JRST P138F6 ;NO
SKIPE TBLOCK+4 ;YES--WAS THERE A SECTION OF THIS NAME?
JRST P138E3 ;YES---ERROR
P138F7: HLRS TC ;GET LINK IN RIGHT HALF
DPB TC,FL.PRO ;AND PUT IN FLOTAB
POPJ PP,
P138F6: SKIPE TC,TBLOCK+4 ;ANY SECTION OF THIS NAME?
JRST P138F7 ;YES---PUT IN FLOTAB
SKIPN TC,TBLOCK+3 ;NO--ANY PARAGRAPHS IN OTHER SECTIONS?
JRST P138E4 ;NO---ERROR
SKIPE TBLOCK+5 ;MORE THAN 1 PARAGRAPH OF THIS NAME?
JRST P138E2 ;YES---ERROR
JRST P138F7 ;NO--PUT IN FLOTAB
P138E1: HRRZI DW,E.178
P138EE: HLRS TC
HRRZ TA,CURFLO ;[1311] FLOTAB ENTRY ADDRESS
DPB TC,FL.PRO ;ASSUMED MEANING
P138EF: LDB LN,FL.LN ;GET LINE NUMBER AND
LDB CP,FL.CP ;CHARACTER POSITION FROM FLOTAB
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
PUSHJ PP,FATAL
>
MOVE TA,CURFLO
POPJ PP,
P138E2: HRRZI DW,E.179
JRST P138EE
P138E3: HRRZI DW,E.180
JRST P138EE
P138E4: HRRZI DW,E.181
JRST P138EE
P138FE: MOVE TA,[SIXBIT /UNDEF;/]
MOVEM TA,NAMWRD
SETZM NAMWRD+1
SETZM NAMWRD+2
SETZM NAMWRD+3
SETZM NAMWRD+4
PUSHJ PP,TRYNAM##
JRST FE1381
MOVEM TA,CURNAM##
HLRZS TA
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK
JRST FE1382
HRRZ TA,CURFLO
HLRS TB
DPB TB,FL.PRO
HRRZI DW,E.181
JRST P138EF
FE1381: PUSHJ PP,BLDNAM
MOVEM TA,CURNAM
FE1382: MOVE TA,[XWD CD.PRO,SZ.PRO]
PUSHJ PP,GETENT
HLRM TA,CURNAM
HLRZ TB,CURNAM ;NAMTAB POINTER
ANDI TB,077777
IORI TB,CD.PRO*1B20
HRLZM TB,(TA)
HLRZ TB,TA
HRRZ TA,CURFLO
DPB TB,FL.PRO
MOVS TA,CURNAM
PUSHJ PP,PUTLNK
MOVE TA,CURFLO
HRRZI DW,E.181
JRST P138EF
FLODN: HRRZ TC,SECLOC
ADDI TC,1
HRLI TC,TD
MOVEM TC,PNTR
SETZB TD,TBLOCK ;WILL HOLD WORD NUMBER OF LOWEST SEGMENT
SETZM TBLOCK+1 ;R. H. POINTS TO LAST SECTION OF MOST RECENT SEGMENT
P138S1: MOVE TA,@PNTR ;GET SEGTAB ENTRY
JUMPE TA,P138S9 ;NOTHING FOR THIS SEGMENT
SKIPE TBLOCK ;ANYTHING AT ALL SEEN BEFORE?
JRST P138S2 ;YES
ADDI TD,1
MOVE TB,@PNTR ;GENFIL BLOCK FOR THIS SEGMENT
MOVEM TB,TBLOCK
MOVEM TA,TBLOCK+1
AOJA TD,P138S3
P138S2: MOVEM TD,TBLOCK+2
EXCH TA,TBLOCK+1 ;NEW 'LAST SEGMENT SEEN' POINTER
PUSHJ PP,LNKSET
MOVE TD,TBLOCK+2
ADDI TD,1
MOVE TB,@PNTR ;GENFIL WORD NUMBER FOR NEW SEGMENT
DPB TB,PR.GNW ;INTO OLD SECTION PROTAB ENTRY
AOJA TD,P138S3
P138S9: ADDI TD,2
P138S3: CAIG TD,306 ;198.
JRST P138S1
SKIPE TBLOCK ;SKIP IF NO SEGMENTS
JRST P138S4
MOVEI TA,100
HRLM TA,PROGST##
JRST PRODN
P138S4: HRRZ TB,TBLOCK
JUMPN TB,.+2
HRRZI TB,100
HRLM TB,PROGST ;BLOCK NUMBER OF LOWEST SEGMENT IN PROGST L.H.
MOVE TA,TBLOCK+1
JUMPE TA,PRODN
PUSHJ PP,LNKSET
MOVE TB,ARG2 ;ENDIT WORD NUMBER
DPB TB,PR.GNW ;PUT IN LAST SECTION OF LAST SEGMENT
PRODN: PUSHJ PP,CLEAND## ;CLEAN UP AFTER THE PHASE
PUSHJ PP,CLENTA## ;CLEAN UP TABLES
ENDFAZ D
RESLVQ: HRRZ TA,CURFLO
ADDI TA,SZ.FLO ;QUALIFICATION ENTRY ADDRESS
LDB TA,FL.NAM ;NAMTAB POINTER OF QUALIFIER
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK ;FIND PROTAB LINK
JRST P138QE ;THERE IS NONE
P138Q2: LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPE TC,P138Q3 ;JUMP IF THIS IS A SECTION
PUSHJ PP,FNDNXT ;FIND NEXT ENTRY
JRST P138QE ;NO MORE
JRST P138Q2
P138Q3: MOVEM TB,TBLOCK+6 ;SAVE LINK TO SECTION PROTAB ENTRY
HRRZ TA,CURFLO
LDB TA,FL.NAM ;NAMTAB POINTER FOR QUALIFIED ITEM
HRRZI TB,CD.PRO
PUSHJ PP,FNDLNK ;FIND A PROTAB ENTRY FOR IT
JRST P138QE ;NONE
P138Q4: LDB TC,PR.SEC ;PARAGRAPH/SECTION FLAG
JUMPN TC,P138Q6 ;JUMP IF PARAGRAPH
P138Q5: PUSHJ PP,FNDNXT ;ANY MORE ENTRIES?
JRST P138QE ;NO--COULD NOT RESOLVE IT
JRST P138Q4 ;YES--TEST IT
P138Q6: LDB TD,PR.LSC ;GET SECTION LINK FOR THIS PARAGRAPH
HLRZ TC,TBLOCK+6 ;GET LINK TO QUALIFIER ENTRY
CAME TC,TD ;ARE THEY THE SAME?
JRST P138Q5 ;NO--TRY FURTHER
HLRS TB
HRRZ TA,CURFLO ;SET UP TA
DPB TB,FL.PRO ;RESOLVED IT
P138Q7: MOVE TA,CURFLO
MOVE TB,TA
ADD TB,[XWD SZ.FLO,SZ.FLO]
MOVEM TB,CURFLO ;SET UP CURFLO TO IGNORE QUALIFIER ENTRY
POPJ PP,
P138QE: PUSHJ PP,P138FE
JRST P138Q7
INTER. PA140.
;[12B] SPECIAL IFS THAT DON'T NEED THE PHASE E HLDTAB ENTRY
; GENERATED FOR THEM.
PA140.: SKIPG SPFLVL
POPJ PP, ;NO SPIF ACTIVE
SETOM SPFNIO## ;SPECIAL IF, NOT FOR I-O
SKPNAM ;CONTINUE AT PA139.
INTER. PA139.
PA139.: SKIPG SPFLVL
POPJ PP, ;NO SPIF ACTIVE
SKIPN REINTO ;'INTO' SEEN?
JRST PA139A ;NO
PUSHJ PP,GETTAG ;GET A TAG SO 'AT END' SKIPS 'INTO' CODE
ANDI CH,077777
JUMPE CH,.-2
PUSH PP,CH ;SAVE IT FOR A MINUTE
HRLZI TB,(CH) ;OUTPUT A JUMP TO THIS TAG
HRRI TB,74
HRLI TA,074000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
PUSHJ PP,PUTGEN
PA139A: MOVE TA,SPFLVL
ADD TA,IFLVL
HLLZ TB,ARGL2-1(TA) ;TARGET FOR SPIF
JUMPE TB,P139.E
HRLM TB,ARGL2-1(TA) ;REMOVE ENTRY
HRLZI TA,102000 ;TAGNAM OP CODE
HRRI TB,102
PUSHJ PP,PUTGEN
P139.X: SOS SPFLVL
SWOFF UNCONT;
HRRZI TA,26 ;'ENDIF' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.SPI## ;SPECIAL IF
MOVE TA,SPFNIO## ;SEE IF SPECIAL IF, NOT I-O
DPB TA,OP.SPN## ; SEE FLAG IN OPERAND
SETZM SPFNIO## ;CLEAR FLAG
SKIPN REINTO ;'INTO' SEEN?
JRST PA22. ;NO
PUSHJ PP,PA22. ;OUTPUT THE ENDIF
POP PP,CH ;GET BACK THAT TAG
PA139X: HRLZI TB,(CH) ;OUTPUT TAGNAM
HRRI TB,102
HRLI TA,102000
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN
P139.E: SKIPN ARGL2-1(TA)
JRST P139.F
OUTSTR [ASCIZ /PA139.: ENDSPIF encountered, but ENDIF expected
/]
TRNA
P139.F: OUTSTR [ASCIZ /PA139.: ENDSPIF encountered, but ARGL2 entry null
/]
EWARNW E.260
JRST KILL
INTER. PA141.
PA141.: SETO TA,
DPB TA,OP.MAC## ;SET 'MACRO' BIT
POPJ PP,
INTER. PA143.
PA143.: SETZ TA,
DPB TA,OP.COB## ;SET 'COBOL' FLAG
POPJ PP,
INTER. PA143A
PA143A: PUSHJ PP,PA143. ; SET UP COBOL FLAG [171]
JRST PA248A ; GO SET UP CALL OPERAND [171]
INTER. PA145A
PA145A:
IFN DBMS,<
SKIPN SCHSEC## ;IS THIS A DBMS PROGRAM?
EWARNW E.431 ;NO, DECL IS IN WRONG PLACE
>
SKPNAM ;PROCEED AS NORMAL
INTER. PA145.
PA145.: SETOM DECLR. ; [324] SET DECLARATIVES IN PROGRAM
DPB LN,[POINT 13,DECLR.,28] ;[552] SAVE LINE NUMBER
DPB CP,[POINT 7,DECLR.,35] ;[552] AND CHAR. POS.
SWON INDECL
HRRZI TA,14 ;[435] SET DECLARITIVES START OP CODE
JRST PA147A
INTER. PA147.
PA147.: SWOFF INDECL
HRRZI TA,15 ;[435] END DECLARITIVES OP CODE
PA147A: PUSHJ PP,SETOP ;[435] SET UP OPERAND
;AT "DECLARATIVES" OR "END DECLARATIVES":
SETZM INUPRG ; WE'RE NOT IN A USE PROCEDURE FOR A
;REPORT GROUP RIGHT NOW.
JRST PA22. ;[435] PUT INTO GENFIL
INTER. PA148.
PA148.: SWON FPERWD!FREGWD ;RETURN PERIOD
POPJ PP,
INTER. PA148A ;[1556] IF IT IS A PERIOD
PA148A: SWOFF FPERWD!FREGWD ;[1556] GET THE NEXT TOKEN
POPJ PP, ;[1556]
INTER. PA149.
PA149.: SWOFF FREGWD;
POPJ PP,
INTER. PA150.
PA150.: MOVE TA,FL.OGO## ;OBJECT OF GO
FLENT.: MOVEM TA,PNTR
MOVE TA,[XWD CD.FLO,SZ.FLO]
PUSHJ PP,GETENT ;GET A FLOTAB ENTRY
MOVEM TA,CURFLO
SETO TB,
DPB TB,PNTR ;SET TYPE OF ENTRY FLAG
TSWF INDECL;
DPB TB,FL.RDC ;REFERENCED IN DECLARATIVES
MOVE TB,ARG1+1 ;GETSRC W2
DPB TB,FL.NLC## ;NAMTAB POINTER, LN, CP
TLO TB,400000 ;SET FLOTAB REFERENCE BIT
MOVEM TB,ARG1+1 ;IN OPERAND
HLRM TA,ARG1 ;PUT FLOTAB POINTER IN OPERAND
POPJ PP,
INTER. PA151.
PA151.: MOVE TA,ARG1
MOVEM TA,TBLOCK+23
MOVE TA,ARG1+1
MOVEM TA,TBLOCK+24
SETZM ARG1
SETZM ARG1+1
POPJ PP,
INTER. PA152.
PA152.: MOVE TA,TBLOCK+23
MOVEM TA,ARG1
MOVE TA,TBLOCK+24
MOVEM TA,ARG1+1
POPJ PP,
INTER. PA153.
PA153.: HRRZ TA,CURFLO
SETO TB,
DPB TB,FL.QUA##
POPJ PP,
INTER. PA154.
PA154.: MOVE TA,FL.SAL ;'SUBJECT OF ALTER'
JRST FLENT.
INTER. PA155.
PA155.: MOVE TA,FL.OAL## ;'OBJECT OF ALTER'
JRST FLENT.
INTER. PA156.
PA156.: MOVE TA,FL.SPF## ;'SUBJECT OF PERFORM'
JRST FLENT.
INTER. PA157.
PA157.: MOVE TA,FL.OPF## ;'OBJECT OF PERFORM'
JRST FLENT.
INTER. PA158.
PA158.: MOVE TA,FL.DEB## ;'OBJECT OF USE FOR DEBUGGING'
JRST FLENT.
INTER. PA159.
PA159.: MOVE TA,ARG1+1
TLNN TA,400000 ;FLOTAB ENTRY?
POPJ PP, ;NO
HRRZ TA,ARG1
ANDI TA,077777
HRRZ TB,FLOLOC
ADDI TA,(TB) ;POINTS TO FLOTAB ENTRY FOR ARG1
SETO TB,
DPB TB,FL.OPF ;'OBJECT OF PERFORM' FLAG
POPJ PP,
INTER. PA160.
PA160.: MOVE TA,OPRTR
MOVEM TA,TBLOCK
MOVE TA,OPRTR+1
MOVEM TA,TBLOCK+1
PUSHJ PP,PA22.
MOVE TA,TBLOCK
MOVEM TA,OPRTR
MOVE TA,TBLOCK+1
MOVEM TA,OPRTR+1
POPJ PP,
INTER. PA161.
PA161.: HRRZ TA,CURDAT ;GET DATA-RECORD SPECIFIED
LDB TB,DA.RPW ;GET RPWTAB LINK
SKIPE TB ;IS THERE AN RPWTAB LINK
EWARNW E.787 ;YES, MUST BE DEFINED IN REPORT SECTION, ERROR
POPJ PP,
INTER. PA162.
PA162.: HRRZ TA,CURFIL ;GET CURRENT FILE ENTRY
LDB TB,FI.ONE##
SKIPE TB ;IS THERE AN RD SEEN FOR THIS FILE ?
EWARNW E.787 ;YES, GENERATE ERROR
POPJ PP,
INTER. PA163F
PA163F: FLAGAT HI
SKPNAM
INTER. PA163.
PA163.: TLNE W1,40000 ;SIGNED?
EWARNW E.25 ;[467] YES
LDB TE,GWVAL ;SIZE
MOVE TA,[XWD NAMWRD,NAMWRD+1]
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TB,[POINT 6,NAMWRD]
MOVE TA,[POINT 7,LITVAL]
PA163A: ILDB TC,TA
SUBI TC,40 ;CONVERT TO SIXBIT
IDPB TC,TB
SOJG TE,PA163A
TLZ W2,GWDEF ;ENTER REF. TO NUMERIC PARA. NAME
PUSHJ PP,PUTCRF ; IN CREF TABLE
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM ;NOT FOUND
HRRZ W1,(TA)
HLRZS TA
DPB TA,[POINT 15,W2,15]
DMOVEM W1,ARG1
POPJ PP,
INTER. PA164.
PA164.: MOVSI TA,GWALL ;SET 'ALL' BIT IN ARG1
IORB TA,ARG1
POPJ PP,
INTER. PA165.
PA165.: HRRZI TA,105 ;'YECCH!' OPERATOR
PUSHJ PP,SETOP3
PUSHJ PP,PA22.
SETZM ARG1
SETZM ARG1+1
SETZM NQUAL
POPJ PP,
INTER. PAYECC
PAYECC: HRRZI TA,105 ;SET OPERATOR TO 'YECCH'
JRST SETOP3 ; AND RETURN
INTER. PA166.
PA166.: HRRZI TA,4 ;'SUBTRACT' OP CODE
JRST SETOP3
INTER. PA168.
PA168.: HRRZI TA,12 ;'REMAIN' OP CODE
JRST SETOP
INTER. PA169.
PA169.: HRRZI TA,47 ;'ENTER' OP CODE
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
JRST SETOP1
INTER. PA170.
PA170.: SETZM GOTQUA##
SKIPN TA,NQUAL
JRST P170.1
LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB POINTER
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK
JRST P170.0 ;MAY BE CONDITION-NAME
PA170A: HLRM TB,QUALT##
PUSHJ PP,DOQUAL
JRST PA170B
SKIPE GOTQUA
JRST P170.2 ;INSUFFICIENT QUALIFICATION
HRRZM TA,GOTQUA ;TA CONTAINS QUALT ON RETURN
PA170B: PUSHJ PP,LNKSET
PUSHJ PP,FNDNXT## ;FIND THE NEXT ITEM WITH THE SAME
; NAME IN THE CURRENT TABLE.
SKIPA TB,SAVE1## ;NO MORE IN THIS TABLE.
JRST PA170A ;GO SEE IF THIS NAME WORKS.
CAIE TB,CD.CON ;IF IT WAS CONTAB, WE'RE THROUGH.
JRST P170.0 ;GO LOOK AT CONTAB.
PA170C: SKIPN TA,GOTQUA ;ANY FOUND?
JRST P170.1 ;NO
PA170O: HLL TA,QUALT
MOVEM TA,ARG1
HRLM TA,CURDAT ;PUT RELATIVE OFFSET IN LH OF CURDAT
PUSHJ PP,LNKSET ;GET ABSOLUTE OFFSET
HRRM TA,CURDAT ;STORE IT IN RH OF CURDAT
MOVE TA,QUALT+1
MOVEM TA,ARG1+1
SETZM NQUAL
POPJ PP,
P170.0: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB POINTER
HRRZI TB,CD.CON
PUSHJ PP,FNDLNK
JRST PA170C ;NO CONTAB LINK
JRST PA170A
P170.1: HRRZI DW,E.104 ;NOT DEFINED
JRST PA170F ;HOP AROUND THE TWO LDB'S AT PA170E BECAUSE
; QUALT+1 CONTAINS ZEROES WHEN THE DATA
; FIELD IS NOT DEFINED
P170.2: HRRZI DW,E.60
PA170E: LDB LN,[POINT 13,QUALT+1,28]
LDB CP,[POINT 7,QUALT+1,35]
PA170F:
IFN DEBUG,<
HRRZ TA,OPRTR + 1 ;IF OP CODE REPLACED,
CAIE TA,OPYECC ; THEN ERROR ALREADY GIVEN
PUSHJ PP,WARN
>
IFE DEBUG,<
HRRZ TA,OPRTR + 1 ;IF OP CODE REPLACED,
CAIE TA,OPYECC ; THEN ERROR ALREADY GIVEN
PUSHJ PP,FATAL
>
MOVEI TA,<CD.DAT>B20+1 ;ASSUME DUMMY DATAB ENTRY
MOVEM TA,QUALT
DPB LN,[POINT 13,QUALT+1,28] ;CARRY THIS LN AND CP BECAUSE THIS
DPB CP,[POINT 7,QUALT+1,35] ;IS ALL WE HAVE FOR A NOT DEFINED
;ITEM
JRST PA170O
DOQUAL: HRRZI TA,1
HRRZM TA,CURQUA## ;CURRENT ENTRY NUMBER-1
HRRZ TA,QUALT
JUMPE TA,NOPOP
HRLZM TA,CURDAT##
PUSHJ PP,LNKSET
HRRM TA,CURDAT
HRRZ TC,CURQUA
DQULUP: CAML TC,NQUAL
JRST DOOUT
NXTPOP: PUSHJ PP,GETPOP ;FIND FATHER OF CURDAT ITEM
JRST NOPOP ;FOUND NONE
MOVEM TA,CURDAT ;SAVE FATHER LINK
LDB TB,DA.NAM## ;FATHER'S NAMTAB LINK
HRRZ TC,CURQUA
LSH TC,1
LDB TD,[POINT 15,QUALT+1(TC),15] ;NAMTAB LINK OF ITEM SOUGHT
CAME TB,TD ;ARE THEY THE SAME?
JRST NXTPOP ;NO --- TRY HIGHER
HLRM TA,QUALT(TC) ;PUT LINK IN QUALT ENTRY
AOS TC,CURQUA
JRST DQULUP ;CHECK FOR MORE QUALIFIERS
DOOUT: AOS (PP) ;SKIP RETURN
NOPOP: MOVE TA,QUALT
POPJ PP,
GETPOP: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,[POINT 3,CURDAT,2]
CAIN TB,CD.DAT
JRST NXTTRY ;DATAB ITEM
CAIE TB,CD.CON
POPJ PP,
LDB TA,CO.DAT## ;CONTAB ITEM FATHER LINK
JUMPN TA,GOTFA ;NOT NULL
POPJ PP,
NXTTRY: LDB TB,DA.FAL## ;FATHER/BROTHER FLAG
JUMPN TB,ISFAL ;FATHER
LDB TA,DA.BRO## ;GET BROTHER LINK
JUMPE TA,CPOPJ ;NULL
PUSHJ PP,LNKSET
JRST NXTTRY
ISFAL: LDB TA,DA.POP## ;GET FATHER LINK
JUMPE TA,CPOPJ ;NULL
GOTFA: HRRZM TA,TBLOCK
LDB TB,LNKCOD## ;COULD BE AN RPW LINK
JUMPE TB,GOTRPW ;MAYBE
GOTFA1: PUSHJ PP,LNKSET
GOTFA2: HRL TA,TBLOCK
POP PP,TE
JRST 1(TE)
GOTRPW: HRRZI TC,(TA)
HRRZ TA,CURDAT ;SEE IF LINE- OR PAGE-COUNTER BIT ON
LDB TB,DA.LPC##
JUMPE TB,GOTRP1 ;NO, MUST BE A FILTAB LINK
HRRZ TA,RPWLOC ;YES, GET RPWTAB ADDRESS
ADDI TA,(TC)
JRST GOTFA2
GOTRP1: HRRZI TA,(TC) ;RESTORE TA
JRST GOTFA1
INTER. PA171.
PA171.: HRRZ TC,NQUAL
LSH TC,1
CAIL TC,144 ;SIZE OF TABLE
EWARNJ E.190 ;TOO MANY QUALIFIERS
DMOVE TB,ARG1
DMOVEM TB,QUALT(TC)
SETZM ARG1
SETZM ARG1+1
AOS NQUAL
POPJ PP,
INTER. PA172.
PA172.: HRRZI TB,CD.EXT
LDB TA,[POINT 15,W2,15]
PUSHJ PP,FNDLNK
JRST P172.A ;NOT FOUND
HLRM TB,W1
HLRM TB,ARG1
SKIPN PRIOR
POPJ PP,
HRRZ TA,W1
PUSHJ PP,LNKSET
MOVE TB,1(TA)
TLO TB,NR.EXT ;[574]
MOVEM TB,1(TA)
POPJ PP,
P172.A: MOVE TA,[XWD CD.EXT,SZ.EXT]
PUSHJ PP,GETENT
HLRM TA,W1
HLRM TA,ARG1
LDB TB,[POINT 15,W2,15]
IORI TB,500000
MOVSM TB,(TA)
SKIPN PRIOR ;[574] SKIP IF SECTION PRIORITY NOT ZERO
TDZA TB,TB ;[574] NOT EXTERNAL--GET 0 AND SKIP
MOVSI TB,NR.EXT ;[574] SET EXTERNAL BIT
MOVEM TB,1(TA)
LDB TB,[POINT 15,W2,15]
HRR TA,TB
JRST PUTLNK
INTER. PA173.
PA173.: MOVEI TC,5 ;MULTIPLY-ING FACTOR
LDB TA,OP.USE
IMUL TC,TA ;GET OFFSET FOR OPEN MODE
LDB TB,OP.OPC
MOVE TE,OPRTR ;GET OPERATOR FLAGS
CAIE TB,66 ;USE FOR DEBUGGING?
CAIE TB,75 ;NO, IS IT ERROR USE
JRST P173.X ;DEBUGGING OR NOT ERROR USE
; JRST P173.B ;ERROR USE
;ERROR USE (OR FILE-SPECIFIC)
;FILEN OPEN: TE/ 4
;FILEN: TE/ 0
;EXTEND: TE/ 10
P173.B: CAIN TA,3 ;EXTEND OR FILE-SPECIFIC
TLNE TE,10 ; IF BIT ON ALSO, IT IS EXTEND
SKIPA ;AN ERROR USE, TC HAS OFFSET
JRST P173.C ;SPECIFIC FILE
;ERROR USE, NOT SPECIFIC FILE
SKIPE TB,USES(TC)
JRST P173.E ;CONFLICTS WITH PREVIOUS USE
HLRZ TD,CURSEC
HRRZM TD,USES(TC)
P173.X: SETZM ARG1
SETZM ARG1+1
POPJ PP,
;FILE-SPECIFIC USE PROCEDURE
P173.C: HRRZ TA,ARG1
JUMPE TA,P173.X ;?NOTHING THERE..??
PUSHJ PP,LNKSET ;GET PTR TO IT
LDB TD,FI.ERR ;IS ONE ALREADY DEFINED?
JUMPN TD,P173.E ;YES, COMPLAIN
HLRZ TD,CURSEC ;NO, DEFINE IT
DPB TD,FI.ERR
LDB TB,[POINT 1,OPRTR,15] ;GET ERROR-ON-OPEN BIT
DPB TB,FI.ENT## ;IF ON, SET IT IN FILTAB
JRST P173.X ;RETURN
P173.E: MOVEM TB,TBLOCK
MOVEM TE,TBLOCK+1
MOVEM TA,TBLOCK+2
MOVE TA,CURSEC
LDB TA,PR.FLO
ADD TA,FLOLOC
LDB LN,FL.LN
LDB CP,FL.CP
HRRZI DW,E.505
PUSHJ PP,FATAL
MOVE DW,TBLOCK
PUSHJ PP,PUTERA##
MOVE TE,TBLOCK+1
MOVE TA,TBLOCK+2
POPJ PP,
INTER. PA174.
PA174.: SETO TA,
DPB TA,OP.IN2## ;'INTO'
SETOM REINTO ;REMEMBER 'INTO' SEEN FOR 'AT END'
POPJ PP,
INTER. PA174N
PA174N: SETO TA,
DPB TA,OP.NXT## ;'NEXT'
SKIPN FLGSW ;WANT FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;READ ... KEY IS
INTER. PA174K
PA174K: FLAGAT H
MOVE TA,CURFIL ;MAKE SURE THIS FILE IS AN INDEXED FILE
LDB TB,FI.ORG
CAIE TB,%ACC.I
JRST P174KE ;NO, GIVE ERROR
LDB TB,FI.FAM ;MAKE SURE ACCESS MODE IS NOT SEQUENTIAL
CAIN TB,%FAM.S
JRST P174KF ;SEQ ACCESS MODE, CAN'T DO THIS
LDB TB,OP.NXT## ;HE BETTER NOT HAVE SAID "READ.. NEXT RECORD.."
JUMPN TB,P174KG ; ELSE COMPLAIN
SETO TA,
DPB TA,OP.KIS## ;"KEY IS"
POPJ PP, ;'KEY' IS DATA-NAME
P174KE: EWARNW E.626 ;"FILE MUST BE INDEXED"
JRST PAYECC ;SET OPR TO "YECCH"
P174KF: EWARNW E.740 ;"KEY IS" ONLY ALLOWED WHEN FAM IS NOT SEQ
JRST PAYECC ;SET OPR TO "YECCH"
P174KG: EWARNW E.714 ;'NOT ALLOWED WITH READ NEXT'
JRST PAYECC ;SET OPR TO "YECCH"
;HERE WHEN READ THE (POSSIBLY QUALIFIED) "KEY IS.." DATANAME.
; CHECK TO SEE IF IT IS ONE OF THE POSSIBLE KEYS IN THIS FILE.
; IF SO, PUT THE NUMBER IN THE GENFIL AS [-1 + KEY-NUMBER]
INTER. PCAKIS
PCAKIS: PUSH PP,CURFIL ;SAVE THE REAL "CURFIL"
PUSHJ PP,FNDFIL ;FIND FILE WHICH CONTAINS THE RECORD NAME
JRST PCAKS1 ;?NOT FOUND.. GIVE ERROR
POP PP,TB ;RESTORE CURFIL
CAME TB,CURFIL ;IS IT THE CORRECT FILE?
JRST PCAKS2 ;NO, GIVE ERROR
HRRZ TC,ARG1 ;TC:= DATANAME IN QUESTION
MOVE TA,TC ;[1460] CALL LINKSET
PUSHJ PP,LNKSET ;[1460] AND FIND OUT IF
LDB TB,DA.SUB ;[1460] THE KEY IS SUBSCRIPTED,
JUMPN TB,PCAKS5 ;[1460] IF SO, GIVE FATAL ERROR
MOVEI TB,1 ;ASSUME IT'S PRIMARY KEY
MOVE TA,CURFIL ;LOOK AT DEFINED KEYS OF THIS FILE
LDB TD,FI.RKY## ;CHECK TO SEE IF IT'S THE PRIMARY KEY
JUMPE TD,PAYECC ;(IF RECORD KEY IS NULL, PROGRAM HAS ERRORS,
; DON'T TRY TO GENERATE CODE FOR "START")
CAMN TD,TC ;DID HE SAY "KEY IS PRIMARY-KEY"?
JRST PCAKS3 ;YES, GO WRITE IT OUT
LDB TA,FI.ALK## ;MAYBE AN ALTERNATE KEY..?
JUMPE TA,PCAKS4 ;NO, GIVE ERROR
ADD TA,AKTLOC##
HRRZ TA,TA ;GET RH ONLY
PCKS2A: LDB TD,AK.DLK ;GET DATAB LINK
ADDI TB,1 ;BUMP KEY NUMBER
CAMN TD,TC ;IS THIS IT?
JRST PCAKS3 ;YES, GO WRITE OUT KEY NUMBER
ADDI TA,SZ.AKT ;NO, LOOK AT NEXT ALTERNATE KEY
HRRZ TE,AKTNXT## ; (TO SEE IF WE FELL OFF END)
CAML TA,TE ;DID WE FALL OFF END OF TABLE?
JRST PCAKS4 ;YES, DATANAME IS NOT A VALID KEY
LDB TD,AK.FLK ;GET FILE LINK
HLRZ TE,CURFIL
CAME TD,TE ;SAME FILE?
JRST PCAKS4 ;NO, NOT A VALID KEY
JRST PCKS2A ;TRY AGAIN
;WRITE KEY OUT, TB = KEY NUMBER
PCAKS3: SETO TA, ;FIRST WORD IN TA
JRST PUTGEN ;OUTPUT TO GENFIL AND POPJ
PCAKS1: POP PP,CURFIL ;RESTORE OLD CURFIL
JRST PCAKS4 ;GIVE ERROR
PCAKS2: MOVEM TB,CURFIL ;RESTORE REAL CURFIL
PCAKS4: LDB CP,[POINT 7,ARG1+1,35] ;POINT AT DATANAME
LDB LN,[POINT 13,ARG1+1,28]
MOVEI DW,E.741 ;"KEY DATANAME NOT IN CORRECT FILE"
PUSHJ PP,FATAL
JRST PAYECC ;SET OPR TO "YECCH"
PCAKS5: LDB CP,[POINT 7,ARG1+1,35] ;[1460] POINT AT THE
LDB LN,[POINT 13,ARG1+1,28] ;[1460] KEY WITH ERROR
MOVEI DW,E.760 ;[1460] AND GIVE THE
PUSHJ PP,FATAL ;[1460] MESSAGE THAT IT
JRST PAYECC ;[1460] CAN'T BE SUBSCRIPTED.
INTER. PA175.
PA175.: SKIPN TA,CURFIL##
POPJ PP,
LDB TB, OP.ADV## ;ADVANCING ON?
TRNE TB, 1
SKIPA TB, FI.ADV## ;YES.
MOVE TB, FI.PSN## ;NO, MUST BE POSITIONING THEN.
SETOI TC,
DPB TC, TB ;SET THE APPROPRIATE FLAG.
POPJ PP,
INTER. PA176.
PA176.: SETO TA,
DPB TA,OP.FRM## ;'FROM'
POPJ PP,
;"START"
INTER. PA177.
PA177.: FLAGAT HI
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
HRLM LN,DWLNCP ;SAVE LN
HRRM CP,DWLNCP ;,,CP
HRRZI TA,67 ;[68] 'SEEK' OR [74] 'START' OP CODE
JRST SETOP1
;HERE IF "START <PRIOD.>" SEEN
INTER. PA177A
PA177A: HLRZ LN,DWLNCP ;GET SAVED "LN"
HRRZ CP,DWLNCP ;GET SAVED "CP"
DMOVEM LN,WORDLN ;SAVE FOR "WARN"
EWARNJ E.730 ;"RESERVED WORD.. MAY NOT BE USED AS PARA. NAME"
INTER. PA178.
PA178.: HRRZI TA,51 ;'CADD' OP CODE
JRST SETOP0
INTER. PA179.
PA179.: HRRZI TA,52 ;'CSUB' OP CODE
JRST SETOP0
INTER. PA180.
PA180.: HRRZI TA,53 ;'CMUL' OP CODE
JRST SETOP0
INTER. PA181.
PA181.: HRRZI TA,54 ;'CDIV' OP CODE
JRST SETOP0
INTER. PA182.
PA182.: HRRZI TA,55 ;'CEXP' OP CODE
JRST SETOP0
INTER. PA183.
PA183.: MOVEI TE,OP%ALF##
P183.A: SETZM OPRTR+1
HRRZI TA,22 ;'IFT' OP CODE
PUSHJ PP,SETOP1
DPB TE,OP.IFT## ;STORE INDEX VALUE
JRST P189.A
INTER. PA184.
PA184.: MOVEI TE,OP%NUM##
JRST P183.A
INTER. PA185N
PA185N: PUSHJ PP,TSTNOT ;SEE IF WE SHOULD FLAG PREVIOUS NOT
SKPNAM
INTER. PA185.
PA185.: FLAGAT HI
MOVEI TE,OP%POS##
JRST P183.A
INTER. PA186N
PA186N: PUSHJ PP,TSTNOT ;SEE IF WE SHOULD FLAG PREVIOUS NOT
SKPNAM
INTER. PA186.
PA186.: FLAGAT HI
MOVEI TE,OP%NEG##
JRST P183.A
INTER. PA187R
PA187R: PUSHJ PP,TSTNOT ;SEE IF WE SHOULD FLAG PREVIOUS NOT
SKPNAM
INTER. PA187S
PA187S: FLAGAT 8
JRST PA187C
INTER. PA187N
PA187N: PUSHJ PP,TSTNOT ;SEE IF WE SHOULD FLAG PREVIOUS NOT
SKPNAM
INTER. PA187.
PA187.: FLAGAT HI
PA187C: SKIPG EVALFL ;Scanning for imp. stmt in or out of EVALUATE?
JRST PA187D ; Yes
SWON FREGWD ; No, selection subj/obj, turn on REGET WORD
JRST PA0. ; and exit
PA187D: TLNN W1,GWRESV
JRST P187.E
LDB TA,GWVAL##
CAIE TA,ZERO.
JRST P187.E
MOVEI TE,OP%ZER##
JRST P183.A
P187.E: PUSHJ PP,PA165. ;"YECCH"
SOS IFLVL ;COME DOWN ONE LEVEL OF IF
EWARNW E.86
JRST PA0. ;POP UP ONE BRANCH IN TREE
INTER. PA188.
PA188.: PUSHJ PP,PA102A ;'IF' OP CODE
SETO TA,
DPB TA,OP.GRT## ;'GREATER' FLAG
JRST P189.A
INTER. PA189.
PA189.: PUSHJ PP,PA102A ;'IF' OP CODE
SETO TA,
DPB TA,OP.LES## ;'LESS' OP CODE
P189.A: TSWTZ FNOTF;
TDZA TA,TA
SETO TA,
HRRZ TB,CLEVEL
HLRZ TC,ARGLST(TB)
TRNE TC,400000
TRC TA,1
DPB TA,OP.NOT##
MOVE TA,[XWD OPRTR,IMPLOP]
BLT TA,IMPLOP+1
SETZM IFPERF ;CLEAR PERFORM LOOP CONTROL FLAG
POPJ PP,
INTER. PA190.
PA190.: PUSHJ PP,PA102A ;'IF' OP CODE
SETO TA,
DPB TA,OP.EQU## ;'EQUALS' OP CODE
JRST P189.A
;HERE FOR NOT GREATER, NOT LESS, NOT EQUALS
INTER. PA188N
PA188N: TSWC FNOTF ;COMPLEMENT NOT FLAG
PUSHJ PP,PA102A ;'IF' OP CODE
SETO TA,
DPB TA,OP.LES ;NOT 'GREATER' OP CODE
DPB TA,OP.EQU ;...
JRST P189.A
INTER. PA189N
PA189N: TSWC FNOTF ;COMPLEMENT NOT FLAG
PUSHJ PP,PA102A ;'IF' OP CODE
SETO TA,
DPB TA,OP.GRT ;NOT 'LESS' OP CODE
DPB TA,OP.EQU ;...
JRST P189.A
INTER. PA190N
PA190N: TSWC FNOTF ;COMPLEMENT NOT FLAG
PUSHJ PP,PA102A ;'IF' OP CODE
SETO TA,
DPB TA,OP.GRT ;NOT 'EQUALS' OP CODE
DPB TA,OP.LES ;...
JRST P189.A
INTER. PA191.
PA191.: FLAGAT HI
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
HRRZI TA,50 ;'COMPUTE' OP CODE
SWON FARITH;
JRST SETOP1
INTER. PA192.
PA192.: PUSHJ PP,PA103.
MOVEI TC,IF. ;[1553] UNWIND TERM STACK TO AN IF
PUSHJ PP,PA824. ;[1553] CLEAN UP TERM STACK
SETZM EWFLG## ;[1553] Turn off when seen flag
HRRZ TA,IFLVL ;[1541] MOVE P192.A
ADD TA,SPFLVL
HRRZ TC,ARGL2-1(TA) ;F-TARGET
HRRM CH,ARGL2-1(TA) ;[1541]SAVE NEW ELSE TAG
JRST P127.A ;DEFINE IT
;[1541] DUPLICATE PA192. FOR P192.A BECAUSE IT DOESN'T NEED THE EDIT
P192.A: HRRZ TA,IFLVL ;[1541]
ADD TA,SPFLVL ;[1541]
HRRZ TC,ARGL2-1(TA) ;[1541]F-TARGET
HLRM TC,ARGL2-1(TA) ;[1541]ZERO OUT ENTRY
JRST P127.A ;[1541]DEFINE IT
INTER. PA193.
PA193.: HRLZ TB,NXTSNT
SETZM NXTSNT
JUMPE TB,CPOPJ
JRST P198.D ;DEFINE SENTENCE TAG
INTER. PA194.
PA194.: SETZM OPRTR+1
HRRZI TA,21 ;'IFC' OP CODE
PUSHJ PP,SETOP1
JRST P189.A
INTER. PA195.
PA195.: MOVE TE,OP.ON##
P195.A: SETZM OPRTR+1
HRRZI TA,21
PUSHJ PP,SETOP1
MOVE TB,TBLOCK
DPB TB,OP.SWT##
P195.B: SETO TA,
DPB TA,TE
JRST P189.A
INTER. PA196.
PA196.: MOVE TE,OP.OFF##
JRST P195.A
INTER. PA197.
PA197.: SETZM TBLOCK
SETZM OPRTR+1
HRRZI TA,76 ;CLREOP
PUSHJ PP,SETOP0
TLNE W1,GWNLIT
TLNE W1,GWDP
EWARNJ E.25
LDB TB,GWVAL
HRRZM TB,CTR
HRRZI TA,LITVAL
PUSHJ PP,GETVAL
CAIL TC,0
CAILE TC,43
EWARNJ E.243
MOVEM TC,TBLOCK
POPJ PP,
;PERFORM ... UNTIL condition
INTER. PA198.
PA198.: FLAGAT HI
SKIPN ARG2
SKIPE ARG2+1
JRST P198.A ;PERFORM ... THRU ...
PUSHJ PP,PA159. ;PERFORM ...
P198.A: SETZM UNTTAG ;MAKE SURE ZERO INCASE WE DON'T NEED IT
SKIPE PERFAB ;IF TEST AFTER
JRST P198.F ;DON'T GENERATE GOTO, JUST FALL THROUGH
PUSHJ PP,GETTAG
ANDI CH,077777
JUMPE CH,.-2
HRRZM CH,UNTTAG##
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
P198.F: PUSHJ PP,GETTAG
SETZM PERFAB ;CLEAR JUST IN CASE
ANDI CH,077777
JUMPE CH,P198.F ;[1566]WAS .-2
HRLZI TB,(CH)
HRRZM CH,UNTTAG+1
PUSHJ PP,P198.D ;OUTPUT 'TAGNAM' OP CODE
SKIPN ARG2
SKIPE ARG2+1
JRST P198.B ;PERFORM ... THRU ...
PUSHJ PP,PCA25.
JRST P198.C
P198.B: PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
P198.C: HRLZ TB,UNTTAG
JUMPE TB,CPOPJ ;DON'T GENERATE IF NOT WANTED
P198.D: HRRI TB,102 ;'TAGNAM' OP CODE
P198.E: SETZ TA,
DPB TB,[POINT 9,TA,8]
DPB LN,[POINT 13,TA,28]
DPB CP,[POINT 7,TA,35]
JRST PUTGEN##
INTER. PA199.
PA199.: SKIPN CH,INPTAG ;Is this an inline perform until ?
JRST PA199A ;If not must be PERFORM para-name UNTIL
ANDI CH,077777
HRRZM CH,UNTTAG
SETZM INPTAG ;[1566]Zero the in-line perf. tag
AOS UNTTAG
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
PUSHJ PP,P192.A ;IMPLICIT 'ELSE'
HRLZ TB,UNTTAG+1
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
PUSHJ PP,PA37.
JRST P198.C ;OUTPUT TAG
;PA199A Is the same as PA199 except that it does not increment the tag
;numbers, an it also generates tags ( PA833. does this for the other case )
PA199A: PUSHJ PP,GETTAG
ANDI CH,077777
HRRZM CH,UNTTAG
HRLZI TB,(CH)
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
PUSHJ PP,P192.A ;IMPLICIT 'ELSE'
HRLZ TB,UNTTAG+1
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
PUSHJ PP,PA37.
JRST P198.C ;OUTPUT TAG
;Here for end of PERFORM VARYING
INTER. PA200.
PA200.: MOVE TA,NVARY
CAILE TA,MXPERF
HRRZI TA,MXPERF
MOVEM TA,MVARY##
MOVE TA,[XWD SAVPRF,OPRTR]
BLT TA,ARG2+1
PUSHJ PP,PA21. ;procedure-name-1
PUSHJ PP,PA47.
SKIPN ARG1
SKIPE ARG1+1
PUSHJ PP,PA21. ;procedure-name-2
PUSHJ PP,PA22. ;PERF operator
SKIPLE AS7482 ;WANT ANS-8x?
JRST Q200. ;YES
P200.A: SOSGE TA,NVARY
POPJ PP,
CAILE TA,MXPERF-1
JRST P200.A ;MORE THAN MAXIMUM SEEN
IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVSI TB,VARBLK(TA) ;SUBJECT
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARSSB(TA)
HRRI TB,NSBSC1
BLT TB,NSBSC1+MAXSUB*4
MOVSI TB,VARINC(TA) ;SECOND ARG
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARSIN(TA) ;SUBSCRIPTS
HRRI TB,NSBSC2
BLT TB,NSBSC2+MAXSUB*4
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA30. ;'ADDTO' OPERATOR
PUSHJ PP,PA22.
PUSHJ PP,PA34. ;'RESULT' OPERATOR
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
HRRZ TA,NVARY
LSH TA,1
HRLZ TB,VARTAG+2(TA)
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
SKIPG TA,NVARY
JRST P200.B
LSH TA,1
HRLZ TB,VARTAG+1(TA)
PUSHJ PP,P198.D ;OUTPUT 'TAGNAM' OP CODE
PUSHJ PP,PA70. ;'MOVE' OPERATOR
HRRZ TA,NVARY
IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVSI TB,VARBLK(TA) ;SUBJECT
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARSSB(TA) ;SUBSCRIPTS
HRRI TB,NSBSC1
BLT TB,NSBSC1+MAXSUB*4
MOVSI TB,VARIVL(TA) ;SECOND ARG
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARSIV(TA) ;SUBSCRIPTS
HRRI TB,NSBSC2
BLT TB,NSBSC2+MAXSUB*4
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST P200.A
;Code is similar to P200.A except that identifier-2 is augmented before
;identifier-5 is set. ANS-74 has this the other way.
Q200.: SOSGE TA,NVARY
POPJ PP,
CAILE TA,MXPERF-1
JRST Q200. ;MORE THAN MAXIMUM SEEN
;Here to augment current identifier
Q200.A: IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVSI TB,VARBLK(TA) ;SUBJECT
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARSSB(TA)
HRRI TB,NSBSC1
BLT TB,NSBSC1+MAXSUB*4
MOVSI TB,VARINC(TA) ;SECOND ARG
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARSIN(TA) ;SUBSCRIPTS
HRRI TB,NSBSC2
BLT TB,NSBSC2+MAXSUB*4
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA30. ;'ADDTO' OPERATOR
PUSHJ PP,PA22.
PUSHJ PP,PA34. ;'RESULT' OPERATOR
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
MOVE TA,NVARY
ADDI TA,1
CAMN TA,MVARY ;IS THIS THE INNERMOST IDENTIFIER?
JRST Q200.C ;YES, THEN NOTHING TO RESET
;Here to reset next higher identifier
Q200.B: PUSHJ PP,PA70. ;'MOVE' OPERATOR
HRRZ TA,NVARY
ADDI TA,1
IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVSI TB,VARBLK(TA) ;SUBJECT
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARSSB(TA) ;SUBSCRIPTS
HRRI TB,NSBSC1
BLT TB,NSBSC1+MAXSUB*4
MOVSI TB,VARIVL(TA) ;SECOND ARG
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARSIV(TA) ;SUBSCRIPTS
HRRI TB,NSBSC2
BLT TB,NSBSC2+MAXSUB*4
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
Q200.C: HRRZ TA,NVARY
LSH TA,1
HRLZ TB,VARTAG+2(TA)
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
SKIPG TA,NVARY ;ANYMORE TO DO?
JRST P200.B ;NO
LSH TA,1
HRLZ TB,VARTAG+1(TA)
PUSHJ PP,P198.D ;OUTPUT 'TAGNAM' OP CODE
SOS TA,NVARY
JRST Q200.A ;LOOP FOR NEXT CONTROL ITEMS
P200.B: HRLZ TB,VARTAG ;%S
PUSHJ PP,P198.D ;OUTPUT 'TAGNAM' OP CODE
SETZB TA,NVARY
P200.C: CAML TA,MVARY
JRST P200.D
PUSHJ PP,PA70. ;'MOVE' OPERATOR
HRRZ TA,NVARY
IMULI TA,VARSIZ ;SIZE OF ONE OCCURANCE OF VARBLK
MOVSI TB,VARBLK(TA) ;SUBJECT
HRRI TB,ARG1
BLT TB,ARG1+1
MOVSI TB,VARSSB(TA) ;SUBSCRIPTS
HRRI TB,NSBSC1
BLT TB,NSBSC1+MAXSUB*4
MOVSI TB,VARIVL(TA) ;SECOND ARG
HRRI TB,ARG2
BLT TB,ARG2+1
MOVSI TB,VARSIV(TA) ;SUBSCRIPTS
HRRI TB,NSBSC2
BLT TB,NSBSC2+MAXSUB*4
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA22.
AOS TA,NVARY
JRST P200.C
P200.D: SKIPE TB,PERFAB ;ARE WE IN PERFORM ... WITH TEST AFTER?
CAMN TB,[-1] ;AND HAVE TAG TO GO TO?
JRST P200.E ;NO
HRLZ TB,TB ;YES, GET TAG
SETZM PERFAB ;CLEAR JUST IN CASE
TRNA
P200.E: HRLZ TB,VARTAG+2 ;%C1
HRRI TB,74 ;'JUMPTO' OP CODE
PUSHJ PP,P198.E
HRLZ TB,VARTAG+1 ;%Z
HRRI TB,102
DPB TB,[POINT 9,TA,8]
JRST PUTGEN
INTER. PA201.
PA201.: MOVE TA,ARG2 ;SAVE
MOVEM TA,HROUND## ; "ROUND" FLAG
SETZM CORRSP+12
SETO TA,
DPB TA,OP.COR##
MOVE TA,[XWD OPRTR,CORRSP+10]
BLT TA,CORRSP+11
MOVE TA,[XWD CORRSP+6,OPRTR]
BLT TA,OPRTR+1
HRRZ TA,ARG1
JUMPE TA,P201.X
LDB TB,LNKCOD
CAIE TB,CD.DAT
JRST P201.X
HRLZM TA,CORRSP##
PUSHJ PP,LNKSET
HRRM TA,CORRSP
LDB TB,DA.SON
JUMPE TB,P201E1 ;CANNOT BE ELEMENTARY
HRRZ TA,ARG2
JUMPE TA,P201.X
LDB TB,LNKCOD
CAIE TB,CD.DAT
JRST P201.X
HRLZM TA,CORRSP+1
PUSHJ PP,LNKSET
HRRM TA,CORRSP+1
LDB TB,DA.SON
JUMPE TB,P201E1
MOVE TB,ARG1+1
MOVE TA,ARG2+1
DMOVEM TB,CORRSP+4
DMOVE TB,CORRSP
DMOVEM TB,CORRSP+2 ;'LEFT' AND 'RIGHT' OPERANDS
MOVE TA,[XWD NSBSC1,CORRSP+.CORLS] ;[1070]
BLT TA,CORRSP+.CORLS+<MAXSUB*4>+1 ;[1070]
MOVE TA,[XWD NSBSC2,CORRSP+.CORRS] ;[1070]
BLT TA,CORRSP+.CORRS+<MAXSUB*4>+1 ;[1070]
P201.1: MOVE TA,CORRSP+2
LDB TA,DA.SON
JUMPE TA,P201E2 ;SHOULDN'T BE POSSIBLE
HRLZM TA,CORRSP+2
PUSHJ PP,LNKSET
HRRM TA,CORRSP+2 ;'LEFT'_SON('LEFT')
P201.3: LDB TB,DA.LVL##
CAIN TB,76
JRST P201.2 ;IGNORE 66 LEVEL ITEMS
LDB TB,DA.OCC##
JUMPN TB,P201.2 ;IGNORE ITEMS WITH OCCURS CLAUSES
LDB TB,DA.RDF##
JUMPN TB,P201.2
LDB TB,DA.NAM
ADD TB,NAMLOC
HLRZ TC,(TB) ;L. H. OF NAMTAB ENTRY HEADER
ANDI TC,07777
CAIN TC,FILLE.
JRST P201.2 ;IGNORE FILLER
MOVE TA,CORRSP+3
LDB TA,DA.SON##
JUMPE TA,P201.2
HRLZM TA,CORRSP+3
PUSHJ PP,LNKSET
HRRM TA,CORRSP+3
P201.5: LDB TB,DA.LVL
CAIN TB,76
JRST P201.4
LDB TB,DA.OCC
JUMPN TB,P201.4
LDB TB,DA.RDF
JUMPN TB,P201.4
LDB TB,DA.NAM
HRRZI TD,(TB)
ADD TB,NAMLOC
HLRZ TC,(TB)
ANDI TC,077777
CAIN TC,FILLE.
JRST P201.4
HRRZ TA,CORRSP+2
LDB TB,DA.NAM
CAIE TB,(TD)
JRST P201.4 ;NOT THE SAME NAME
LDB TB,DA.SON ;SON OF 'LEFT'
HRRZ TA,CORRSP+3
LDB TC,DA.SON ;SON OF 'RIGHT'
JUMPE TB,.+2 ;'LEFT' IS ELEMENTARY
JUMPN TC,P201.1 ;NEITHER IS ELEMENTARY
IORI TB,(TC)
JUMPE TB,P201.O ;BOTH ELEMENTARY
LDB TC,OP.OPC
CAIE TC,1
JRST P201.2 ;NOT 'MOVE' --- BOTH MUST BE ELEMENTARY
P201.O: MOVE TA,CORRSP+2
HLRZM TA,ARG1
MOVE TC,CORRSP+4
MOVEM TC,ARG1+1
MOVE TA,CORRSP+3
HLR TA,HROUND ;GET POSSIBLE "ROUND" FLAG
MOVSM TA,ARG2
MOVEM TC,ARG2+1
MOVE TA,[XWD CORRSP+.CORLS,NSBSC1] ;[1070]
BLT TA,NSBSC1+<MAXSUB*4> ;[1070]
MOVE TA,[XWD CORRSP+.CORRS,NSBSC2] ;[1070]
BLT TA,NSBSC2+<MAXSUB*4> ;[1070]
PUSHJ PP,PA21. ;'LEFT'
LDB TB,OP.OPC
CAIE TB,1
JRST P201O1 ;NOT 'MOVE'
PUSHJ PP,PA47.
PUSHJ PP,PA21.
MOVE TA,[XWD OPRTR,CORRSP+6]
BLT TA,CORRSP+7 ;SAVE OPERATOR
P201O2: PUSHJ PP,PA22.
MOVS TA,[XWD OPRTR,CORRSP+6]
BLT TA,OPRTR+1
AOS CORRSP+12
JRST P201.4
P201O1: MOVE TA,[XWD OPRTR,CORRSP+6]
BLT TA,CORRSP+7
PUSHJ PP,PA22.
PUSHJ PP,PA47.
MOVE TB,CORRSP+5 ;GET CORRECT LINE & CHAR POS. OF 2ND
MOVEM TB,ARG1+1 ; GROUP ARG IN CASE OF ERROR
PUSHJ PP,PA21.
MOVE TA,[XWD CORRSP+10,OPRTR]
BLT TA,OPRTR+1
JRST P201O2 ;OUTPUT 'RESULT'
P201.4: HLRZ TB,CORRSP+3 ;'RIGHT'
HLRZ TC,CORRSP+1
CAIN TB,(TC)
JRST P201.X ;FINISHED
PUSHJ PP,FNDBRO
JRST P201.6 ;NO BROTHER
HRLZM TB,CORRSP+3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CORRSP+3
JRST P201.5
P201.6: HLRZ TB,CORRSP+3
HLRZ TC,CORRSP+1
CAIN TB,(TC)
JRST P201.X
PUSHJ PP,FNDPOP
JRST P201.X
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST P201.X
HRLZM TB,CORRSP+3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CORRSP+3
P201.2: HLRZ TB,CORRSP+2 ;'LEFT'
HLRZ TC,CORRSP
CAIN TB,(TC)
JRST P201.X
PUSHJ PP,FNDBRO
JRST P20121
HRLZM TB,CORRSP+2
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CORRSP+2
JRST P201.3
P20121: HLRZ TB,CORRSP+2
HLRZ TC,CORRSP
CAIN TB,(TC)
JRST P201.X
PUSHJ PP,FNDPOP
JRST P201.X
HLRZ TC,CORRSP
CAIN TB,(TC)
JRST P201.X
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST P201.X
HRRZI TA,(TB)
HRLZM TB,CORRSP+2
PUSHJ PP,LNKSET
HRRM TA,CORRSP+2
JRST P201.6
P201.X: SKIPE CORRSP+12
JRST P201X1
LDB LN,OP.LN
LDB CP,OP.CP
HRRZI DW,E.105 ;NO CORRESPONDING ELEMENTS
PUSHJ PP,WARN
P201X1: SETZM OPRTR
MOVE TA,[XWD OPRTR,OPRTR+1]
BLT TA,ARG2+1
POPJ PP,
P201E1: LDB LN,OP.LN
LDB CP,OP.CP
HRRZI DW,E.265
JRST FATAL
P201E2: OUTSTR [ASCIZ /PA201.: internal compiler error
/]
JRST KILL
;ENTER WITH TB= DATAB LINK TO ITEM
;RETURNS .+1 IF NO FATHER
;RETURNS .+2 WITH TB= DATAB LINK TO FATHER
FNDPOP: JUMPE TB,CPOPJ
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
POPJ PP,
HRRZI TA,(TB)
POP.1: HRRZM TA,TBLOCK
PUSHJ PP,LNKSET
LDB TB,DA.FAL
JUMPE TB,POP.2 ;BROTHER LINK
LDB TB,DA.POP
POP PP,TE
JRST 1(TE)
POP.2: LDB TA,DA.BRO
JUMPN TA,POP.1
POPJ PP,
FNDBRO: JUMPE TB,CPOPJ
LDB TC,[POINT 3,TC,20]
CAIE TC,CD.DAT
POPJ PP,
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,DA.FAL
JUMPN TB,CPOPJ
LDB TB,DA.BRO
JUMPE TB,CPOPJ
POP PP,TE
JRST 1(TE)
;[257] THIS ROUTINE FINDS THE FILE WHICH CONTAINS THE GIVEN RECORD NAME
FNDFIL: SETZM CURFIL ; [275] CLEAR FILENAME
HRRZ TB,ARG1 ; [275] GET ITEM
JUMPE TB,CPOPJ ; [275] NONE - ERROR
LDB TC,[POINT 3,TB,20]; [275] GET TYPE OF ITEM
CAIN TC,CD.FIL ; [275] IS IT A FILE-NAME?
JRST FIL.F ; [275] YES GO IT
CAIN TC,CD.DAT ; [275] IS ITEM A DATA-NAME?
FIL.A: PUSHJ PP,FNDPOP ; [275] GET FATHER OF DATA-ITEM
POPJ PP, ; [275] NONE- DATA ITEM NOT IN A FILE-ERROR RETURN
LDB TC,[POINT 3,TB,20]; [275] GET TYPE OF FATHER
CAIN TC,CD.DAT ; [275] IF FATHER IS A DATA NAME
JRST FIL.A ; [275] THEN LOOP TO GET NEXT FATHER
CAIE TC,CD.FIL ; [275] IS FATHER A FILE-NAME
POPJ PP, ; [275] NO NOT A FILE OR DATA NAME- ERROR EXIT
FIL.F: HRLZM TB,CURFIL ; [275] STORE THE FILE NAME RELATIVE ADDRESS
HRRZI TA,(TB) ; [275] NOW GET ITS REAL
PUSHJ PP,LNKSET ; [275] ADDRESS
HRRM TA,CURFIL ; [275] STORE FILENAME ADDRESS
JRST CPOPJ1 ; [257] FOUND --SKIP RETURN
INTER. PA202.
PA202.: MOVE TA,[XWD OPRTR,CORRSP+6]
BLT TA,CORRSP+7
POPJ PP,
INTER. PA203.
PA203.: PUSHJ PP,PA34.
SETO TA,
DPB TA,OP.SZE
POPJ PP,
INTER. PA204.
PA204.: SETZM OPRTR
DPB LN,OP.LN
DPB CP,OP.CP
HRRZI TA,23 ;'SPIF' OPERATOR
PUSHJ PP,SETOP3
SETO TA,
DPB TA,OP.SZE
DPB TA,OP.COR
JRST PA90.A
INTER. PA205I
PA205I: ;Compute nbr of subscripts field needs
SKIPE RMFLG## ;If we already started to scan a ref modifier,
JRST P205.E ; can't nest subcripts or ref mods
PUSHJ PP,PA170. ;Fix up entries in QUALT table
HRRZ TA,ARG1 ;Field's DATAB link
LDB TB,LNKCOD
CAIN TB,CD.DAT ;DATAB?
JRST P205.0 ;Yes
CAIE TB,CD.CON ;CONTAB?
JRST [SETZ TB, ;Probably an error
JRST P205.2] ;Return zero
PUSHJ PP,LNKSET
LDB TA,CO.DAT## ;Get DATAB link
P205.0: PUSHJ PP,LNKSET ;
SOS TA ;[1631]Dummy entry is at 1+@datloc
CAMN TA,DATLOC ;[1631]IS IT THE DUMMY ENTRY?
JRST P205.3 ;[1631]YES - error
AOS TA ;[1631]Restore TA
LDB TB,DA.SUB ;Is the item subscripted?
JUMPE TB,P205.2 ;No, zero counter
TDZA TB,TB ;Initialize TB
P205.1: PUSHJ PP,LNKSET ;Get DATAB entry address
LDB TC,DA.OCC## ;Is there an OCCURS at this level?
SKIPE TC ;No
AOS TB ;Yes, bump counter
LDB TA,DA.OCH## ;Link to occurs at higher level?
JUMPN TA,P205.1 ;Yes
P205.2: HRRM TB,NBRSUB## ;No, store final count
POPJ PP, ;
P205.E: EWARNW E.561 ;Cannot be subscripted
P205.3: PUSHJ PP,PCA12. ;[1631]Skip to period
JRST PA0. ;Pop up one node
INTER. PA205.
PA205.: SETZM NSBSC1
MOVE TA,[XWD NSBSC1,SBSCR1] ;SBSCR1=NSBSC1+1
MOVEI TB,MAXSUB*4-1 ;CLEAR OUT SUBSCRIPT INFO BLOCK
BLT TA,SBSCR1(TB) ; . .
SKIPN NBRSUB ;If field can't have subscripts,
JRST PA0. ; pop back up and scan ref modders
MOVE TA,[XWD ARG1,ARG3##]
BLT TA,ARG3+1
PA205A: TSWF FNOSUB ;FIELD IS SUBSCRIPTABLE,
EWARNW E.275 ; BUT USED WHERE SUBSCRIPTS NOT ALLOWED
POPJ PP,
INTER. PA206A
PA206A: HRRZ TA,ARG1 ; [405] GET SUBSCRIPT RELATIVE DATAB ADDRESS
PUSHJ PP,LNKSET ; [405] GET IS REAL ADDRESS
MOVEM TA,CURDAT ; [405] NOW STORE IT
LDB TB,DA.SUB## ;[137] IS SUBSCRIPTED ITEM SUBSCRIPTED ?
SKIPE TB ;[137] ERROR IF SO
EWARNW E.495 ;[137] ERROR MESSAGE
SKPNAM ;[137] OK GO ON
INTER. PA206.
PA206.: AOS TA,NSBSC1
CAILE TA,MAXSUB
JRST [MOVEI TA,MAXSUB ; [363] RESTORE TO MAXIMUM
MOVEM TA,NSBSC1 ; [363] LIMIT
EWARNJ E.277] ; [363] TOO MANY SUBSCRIPTS.
ASH TA,2
HRRZI TA,SBSCR1-4(TA)
HRRZI TB,1(TA)
HRLI TA,ARG1
BLT TA,(TB)
CAIE TYPE,PLUS. ; if subscript is followed
CAIN TYPE,MINUS. ; by a relative index
POPJ PP, ; don't leave yet
MOVE TB,NBRSUB ;nbr of subs field requires
CAMLE TB,NSBSC1 ;nbr of subs scanned
POPJ PP, ;still expect more
PUSHJ PP,PA220. ;put out what's found
SETOM RMFLG## ;
JRST PA0. ;pop back up and check for ref modders
INTER. PA207.
PA207.: FLAGAT HI
SETZM SRTMRG## ;SIGNAL ITS SORT NOT MERGE
SKIPE FLGSW## ;ARE WE CHECKING FIPS LEVEL?
SKIPN ESRTSN## ;YES, ONLY ONE SORT ALLOWED UNLESS HIGH LEVEL
SOSA ESRTSN ;OK, BUT SIGNAL SEEN ONE
PUSHJ PP,FLG.H## ;TEST AT HIGH LEVEL
HRRZI TA,110 ;'SORT'
SWON FNOSUB ;SUBSCRIPTING NOT ALLOWED
JRST SETOP1
INTER. PA207A
PA207A: FLAGAT H
SETOM SRTMRG ;SIGNAL ITS MERGE
SWON FNOSUB; ;[645] SUBSCRIPTING NOT ALLOWED
HRRZI TA,117 ;'MERGE'
JRST SETOP1
INTER. PA207C
PA207C: FLAGAT H
MOVEI TA,107 ;COLLATING SEQUENCE
JRST SETOP1
INTER. PA208.
PA208.: HRRZI TA,111 ;'KEY'
JRST SETOP1
INTER. PA209.
PA209.: PUSHJ PP,PA208.
SETO TA,
DPB TA,OP.ASC## ;'ASCENDING KEY'
POPJ PP,
INTER. PA210.
PA210.: MOVEI TA,112 ;'INPUT PROCEDURE' OP CODE
JRST SETOP1
INTER. PA211.
PA211.: MOVEI TA,113 ;'OUTPUT PROCEDURE' OP CODE
JRST SETOP1
INTER. PA212F
PA212F: SKIPL SRTMRG ;ONLY CHECK MULTIPLE FILES ON SORT
FLAGAT H
SKPNAM
INTER. PA212.
PA212.: HRRZI TA,115 ;'USING'
JRST SETOP1
INTER. PA213S
PA213S: FLAGAT 8 ;EXTENSION FOR COBOL-82
SKPNAM
INTER. PA213.
PA213.: HRRZI TA,114 ;'GIVING'
JRST SETOP1
INTER. PA214.
PA214.: HRRZI TA,116 ;'ENDSRT'
SWOFF FNOSUB ;TURN SUBSCRIPTING BACK ON
JRST SETOP0
INTER. PA215.
PA215.: HRRZ TA,ARG1
JUMPE TA,CPOPJ
LDB TB,LNKCOD
CAIE TB,CD.FIL
POPJ PP,
PUSHJ PP,LNKSET
LDB TB,OP.OPC
CAIE TB,115 ;'USING'
JRST P215.A
SETO TB,
DPB TB,FI.INO
JRST P215.B
P215.A: CAIE TB,114 ;'GIVING'
POPJ PP,
SETO TB,
DPB TB,FI.OUO
P215.B: LDB TB,FI.DSD##
JUMPE TB,CPOPJ
LDB CP,[POINT 7,ARG1+1,35]
LDB LN,[POINT 13,ARG1+1,28]
HRRZI DW,E.291
JRST FATAL
INTER. PA216.
PA216.: PUSHJ PP,PCA83. ; [257] CHECK THAT RECORD IS 01 OR 77 LEVEL
PUSHJ PP,FNDFIL ; [257] GO GET ASSOC FILE
JFCL ; [257] WILL CATCH ERROR IN IOGEN PHASE E
JRST PCA5G. ;TEST TO SEE IF FIPS FLAGGER WANTED
INTER. PA217.
PA217.: SETO TB,
DPB TB,OP.USI##
PUSHJ PP,PA21.
PUSHJ PP,PA22.
SETZM OPRTR+1
SETZM REFCON## ;Initialize to CALL BY REFERENCE
HRRZI TA,46 ;'USING'
JRST SETOP1
INTER. PA218.
PA218.: FLAGAT NS
LDB TE,GWLN## ;LINE NUMBER
MOVE TA,[POINT 7,TBLOCK+1]
SETZM TBLOCK+1
HRRZI TC,^D1000
P218.A: IDIVI TE,(TC)
ADDI TE,"0"
IDPB TE,TA
IDIVI TC,^D10
HRRZI TE,(TD)
JUMPG TC,P218.A
MOVE TB,[ASCII /LINE /]
MOVEM TB,TBLOCK
MOVE TA,[XWD CD.VAL,3]
PUSHJ PP,GETENT
HRRZI TD,^D9
DPB TD,[POINT 14,(TA),13]
MOVE TC,[POINT 7,TBLOCK]
MOVSI TB,(POINT 7,(TA),13)
ILDB TD,TC
IDPB TD,TB
JUMPN TD,.-2
HLRZ W1,TA
HRLI W1,^D9
TLO W1,GWLIT
DMOVEM W1,ARG1
JRST PA21.
INTER. PA219.
PA219.: MOVE TA,[XWD NAMWRD,NAMWRD+1]
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TA,[XWD [SIXBIT /:GENERATED:SECTION:NAME:/],NAMWRD]
BLT TA,NAMWRD+3
SETZM PRIOR
MOVSI W1,GWNOT
PUSHJ PP,PA2.
PUSHJ PP,PCA3A ; [271] SET UP SECTION NAME
MOVE TA,CURPRO ;GET PTR TO PROTAB ENTRY
SETZ TB, ;CLEAR DEFINED FLAG SO THIS WONT BE
DPB TB,PR.DEF ; ON LISTING
PA219X: MOVE TA,[XWD NAMWRD,NAMWRD+1] ; [271] NEW LABEL
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TA,[XWD [SIXBIT /:GENERATED:PARAGRAPH:NAME:/],NAMWRD]
BLT TA,NAMWRD+4
MOVSI W1,GWNOT
PUSHJ PP,PA2.
PUSHJ PP,PCA2.
MOVE TA,CURPRO ;GET PTR TO PROTAB ENTRY
SETZB TB,PROGST ;CLEAR DEFINED FLAG AND DON'T COUNT AS REAL PRO NAMES
DPB TB,PR.DEF
POPJ PP,
;THIS ACTION IS SO THAT THE STARTING ADDRESS "PROGST" DOESN'T GET
;RESET IN A DBMS PROGRAM, AFTER THE DECLARATIVES.
INTER. PA219A
PA219A: MOVE TA,PROGST ;SAVE STARTING ADDRESS
PUSH PP,TA ;SAVE ON STACK
PUSHJ PP,PA219. ;DO THE NORMAL STUFF
POP PP,TA
MOVEM TA,PROGST ;RESET IT (MAY BE ZERO)
HRRZ TA,CURPRO ; [327] GET GENERATED PARA PROTAB POINER
SETO TB, ; [327] TURN ON THE
DPB TB,PR.MDF ; [327] MULTI-DEFINED BIT- NOTE DEFINED BIT OFF
; [327] THIS TELLS PARGEN IN XFRGEN IN PHASE E THIS IS A GENERATED PARA
POPJ PP,
INTER. PA220.
PA220.: MOVS TA,[XWD ARG1,ARG3]
BLT TA,ARG1+1
SKIPN RMFLG ;if here with rmflag on,
POPJ PP, ;
SETZM RMFLG ; then never found colon for ref. mod.
TSWT FNOSUB ;
POPJ PP, ;(phase E flags some)
LDB LN,[POINT 13,ARG1+1,28] ; so reset flag
LDB CP,[POINT 7,ARG1,35] ; and give error
HRRZI DW,E.275 ;
JRST WARN ;
INTER. PA222.
PA222.: FLAGAT HI
MOVEI TA,120 ;'RELEASE' OP CODE
JRST SETOP1
INTER. PA223.
PA223.: FLAGAT HI
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
MOVEI TA,121 ;'RETURN' OP CODE
JRST SETOP1
INTER. PA224.
PA224.: MOVE TA,FL.OEN## ;'OBJECT OF ENTER'
JRST FLENT.
SUBTTL REPORT WRITER SYNTAX
;"GENERATE"
INTER. PA225.
PA225.: FLAGAT RP
HRRZI TA,124 ;GENERATE OP CODE
JRST SETOP1
;"GENERATE <REPORT-ITEM-NAME>"
INTER. PA226.
PA226.: DMOVEM W1,ARG1 ;GET READY TO PUTGEN THIS ITEM
PUSHJ PP,DA96.D ;CONVERT QUALIFIERS TO A DATAB LINK
HRRZI TA,(TE) ;CONVERT DATAB LINK TO RPWTAB LINK
HRRZI TB,(TE)
TRZ TB,077777
CAIE TB,100000
JRST PA226E
PUSHJ PP,LNKSET
LDB TB,DA.RPW##
HRRZ TA,RPWLOC##
ADDI TA,(TB)
LDB TC,RW.TYP##
CAIE TC,%RG.DE
JRST PA226E
HRRM TB,ARG1 ;OK, STORE REAL DATAB LINK
DMOVE W1,ARG1 ;READY TO CALL PA2.
SKPNAM
;"GENERATE <REPORT-NAME>"
INTER. PA227.
PA227.: PUSHJ PP,PA2. ;GET ITEM IN ARG1, ARG1+1
PUSHJ PP,CHKUFL ;MAKE SURE NOT IN USE PROCEDURE AND
; REFERENCING A REPORT IN THE SAME FILE
PUSHJ PP,PA21. ;WRITE OUT THE ARGUMENT
PUSHJ PP,PA22. ;WRITE OUT OPERATOR
MOVE TA,W1 ;[1527] GET RPWTAB LINK TO RD ENTRY
ADD TA,RPWLOC ;[1527] MAKE ABSOLUTE ADDRESS
LDB TC,RW.TYP## ;[1527] DID WE PROCESS A <REPORT-ITEM-NAME>?
CAIN TC,%RG.DE ;[1527]
JRST PA0. ;[1527] YES, THEN EXIT NOW
SETOM TD ;[1527] SET NUMBER OF DETAIL GROUPS TO -1
LDB TA,RW.FGP## ;GET ADDRESS OF LAST GROUP IN RD ENTRY
PA227A: CAIE TA,1 ;[1527] POINTING TO DUMMY DATAB ENTRY
SKIPN TA ;OR NO GROUPS ?
JRST PA0. ;YES, POP UP NODE STACK AND RETURN
PUSHJ PP,LNKSET ;GET ABSOLUTE ADDRESS
LDB TA,DA.RPW ;GET RPWTAB LINK
ADD TA,RPWLOC ;MAKE IT ABSOLUTE
LDB TB,RW.TYP ;GET TYPE OF THIS GROUP
CAIN TB,%RG.DE ;TYPE DETAIL ?
AOJ TD, ;YES, ADD ONE TO COUNTER
SKIPLE TD ;SEEN MORE THAN ONE DETAIL GROUP ?
JRST PA227E ;YES, GENERATE WARNING
LDB TB,RW.DAT## ;REGET DATAB LINK
LDB TC,RW.DAT ;FNDBRO IS DIFFERENT IN THIS MODULE
PUSHJ PP,FNDBRO ;GET BROTHER
JRST PA0.
MOVE TA,TB
JRST PA227A ;REPEAT FOR NEXT GROUP
PA226E: EWARNW E.361 ;NOT A TYPE DETAIL ITEM
JRST PA0. ;POP UP TO HIGHER NODE
PA227E: EWARNW E.786 ;CAN ONLY HAVE ONE DETAIL GROUP WHEN SUMMARY
JRST PA0. ;POP UP TO HIGHER NODE
;"INITIATE"
INTER. PA228.
PA228.: FLAGAT RP
HRRZI TA,123 ;INITIATE OP CODE
JRST SETOP1
;"INITIATE/TERMINATE <REPORT-NAME>"
INTER. PA229.
PA229.: PUSHJ PP,PA2. ;GET ITEM IN ARG1, ARG1+1
PUSHJ PP,CHKUFL ;MAKE SURE WE ARE NOT IN A USE PROCEDURE AND
; REFERENCING A REPORT IN THE SAME FILE
PUSHJ PP,PA21. ;WRITE OUT ARGUMENT
JRST PA160. ;WRITE OPERATOR AND SAVE INCASE THERE IS A LIST
;SORT/MERGE COLLATING SEQUENCE
INTER. PA229A
PA229A: PUSHJ PP,PA2.
PUSHJ PP,PA21.
JRST PA160.
;"TERMINATE"
INTER. PA230.
PA230.: FLAGAT RP
HRRZI TA,125 ;TERMINATE OP CODE
JRST SETOP1
;ROUTINE TO CHECK FOR BEING IN A "USE BEFORE REPORTING" PROCEDURE
; WHEN A REPORT IS REFERENCED. THIS IS NOT ALLOWED BY THE ANSI
; COBOL-74 STANDARD, BUT DEC ALLOWS IT IF THE REPORT REFERENCED
; IS NOT IN THE SAME FILE.
; THIS ROUTINE WILL GENERATE A WARNING AND SET THE OPERATOR TO "YECCH"
;IF THE USER HAS ILLEGALLY REFERENCED A REPORT.
;
;CALL: PUSHJ PP,CHKUFL
; <RETURN HERE ALWAYS>
CHKUFL: SKIPN TA,INUPRG ;SKIP IF IN A "USE BEFORE REPORTING"
; DECLARATIVES PROCEDURE
POPJ PP, ;NOT, OK THEN
ADD TA,RPWLOC ;COULD BE TROUBLE--POINT TO GROUP ITEM
LDB TA,RW.RDL## ;GET LINK TO RD
ADD TA,RPWLOC ;POINT TO RD
LDB TE,RW.FIL## ;TE:= LINK TO FILTAB OF "USE" REPORT
;FIND FILTAB OFFSET OF THE NAMED REPORT OR REPORT GROUP,
; GIVE WARNING IF THEY ARE THE SAME.
MOVE TA,ARG1 ;OFFSET IN RPWTAB OF GROUP OR RD
ADD TA,RPWLOC
SKIPL (TA) ;SKIP IF GROUP
JRST CHKUF1 ;BIT 0 = 0, MEANS RD
LDB TA,RW.RDL ;GET LINK TO RD
ADD TA,RPWLOC
CHKUF1: LDB TA,RW.FIL ;TA:= LINK TO FILTAB OF NAMED REPORT
CAMN TA,TE ;SAME FILE REFERENCED?
POPJ PP, ;NO, LET HIM GET AWAY WITH IT
; NO HARM DONE EXCEPT VIOLATE THE "STANDARD"
;SAME FILENAME - COULD BE TROUBLE - INFINITE LOOP AT RUNTIME WOULD
;BE POSSIBLE
;"FMay not reference a report in a USE BEFORE REPORTING procedure
;which uses the same file as the USE report group"
EWARNW E.644 ;GENERATE THE ABOVE ERROR
MOVEI TA,105 ;SET OPERATOR TO "YECCH"
PJRST SETOP3 ; THEN RETURN
;"WITH NO ADVANCING" CLAUSE FOR "DISPLAY" VERB
INTER. PA231.
PA231.: SETO TA,
DPB TA,OP.DNA## ;SET NO ADVANCING BIT
POPJ PP,
;"WITH DELETE" CLAUSE FOR CLOSE
INTER. PA232.
PA232.: FLAGAT NS
SETO TA,
DPB TA,OP.WDL## ;SET "DELETE" BIT
POPJ PP,
;"USE BEFORE REPORTING" STATEMENT
INTER. PA233.
PA233.: PUSHJ PP,DA96.D ;GET REPORT GROUP NAME WITH QUALIFIER
HRRZ TA,DATLOC## ;MAKE PTR TO ITEM
ADDI TA,(TE)
SUBI TA,<CD.DAT>B20
LDB TB,DA.RPW ;GET CORRESP. RPWTAB LINK
JUMPE TB,JCE267 ;?MUST BE A REPORT GROUP
MOVEM TB,INUPRG ;REMEMBER WE ARE IN A USE PROCEDURE
LDB TC,DA.LVL ;MAKE SURE IT IS A GROUP-LEVEL ITEM
SOJN TC,JCE267 ; (ERROR IF NOT LEVEL 01)
HRRZ TA,RPWLOC ;MAKE PTR TO RPWTAB ENTRY
ADDI TA,(TB)
MOVEM TA,CURRPW## ;SAVE IT
PUSHJ PP,GETTAG ;GET TAG FOR USE PROCEDURE
HRRZ TA,CURRPW ;STORE TAG IN RPWTAB
DPB CH,RW.USE##
JRST PRFSUB## ;OUTPUT PRF. UUO TO AS2FILE
JCE267: EWARNJ E.267
;PLUS SIGN FOLLOWS SUBSCRIPT IDENTIFIER
INTER. PA234.
PA234.: MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVSI TB,400000 ;CLR BIT 0 OF 1ST WORD OF ENTRY
ANDCAM TB,SBSCR1-4(TA) ; TO INDICATE PLUS
POPJ PP,
;MINUS SIGN FOLLOWS SUBSCRIPT IDENTIFIER
INTER. PA235.
PA235.: MOVE TA,NSBSC1
ASH TA,2
MOVSI TB,400000 ;SET BIT 0 OF 1ST WORD OF ENTRY
IORM TB,SBSCR1-4(TA) ; TO INDICATE MINUS
POPJ PP,
;INTEGER TO BE ADDED TO SUBSCRIPT
INTER. PA236.
PA236.: PUSHJ PP,PA2. ;PROCESS LITERAL
MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVE TB,ARG1 ;STORE WORDS FOR ADDITIVE
MOVEM TB,SBSCR1-2(TA)
MOVE TB,ARG1+1
MOVEM TB,SBSCR1-1(TA)
POPJ PP,
INTER. PA236A
PA236A: ; did the index end the last expected
MOVE TB,NBRSUB ; subscript?
CAMLE TB,NSBSC1 ;
POPJ PP, ; No, keep looking
PUSHJ PP,PA220. ; Yes, all found
SETOM RMFLG## ; turn on Ref Mod flag
JRST PA0. ; pop up one level
;SET UP TRACE OPERATOR
INTER. PA237.
PA237.: FLAGAT NS
HRRZI TA,126 ;"TRACE" OP CODE
SKIPE PRODSW## ;/P ON?
HRRZI TA,105 ;YES, GENERATE A YECCH INSTEAD
JRST SETOP1
INTER. PA238.
PA238.:
IFN DEBUG,<SETOM TRACFL##> ;TURN ON SYNTAX SCAN TRACE (PROVIDED /TP ON)
SKIPE PRODSW ;/P ON?
POPJ PP, ;YES
SETO TA, ;'ON' FLAG
PA238A: DPB TA,OP.TRC##
POPJ PP,
INTER. PA239.
PA239.:
IFN DEBUG,<SETZM TRACFL> ;TURN OFF SYNTAX SCAN TRACE
SKIPE PRODSW ;/P ON?
POPJ PP, ;YES
SETZ TA, ;'OFF' FLAG
JRST PA238A
SUBTTL TABLE HANDLING SYNTAX
;SET UP SEARCH OPERATOR
INTER. PA240.
PA240.: FLAGAT HI
PUSHJ PP,GETTAG ;GET TAG FOR END OF WHENS
ANDI CH,077777
JUMPE CH,PA240. ;[511] %0 NOT ALLOWED
HRRZM TYPE,CURVRB ;SAVE VERB FOR END-SEARCH
AOS TA,SPFLVL ;[511] GET NESTED LEVEL
ADD TA,IFLVL ;[511] ADD IF NESTED LEVEL
CAILE TA,IF.DEP ;[511] MORE THAN LIMIT?
JRST PA240A ;[511] YES OVERFLOW
HRLZM CH,ARGL2-1(TA) ;[511] SAVE THE TAG FOR LATER
HRLZM CH,CURTAG## ; & SAVE IT (USING CURTAG(LH) FOR SCRATCH)
SKIPE SWHEN## ;[1005] 'WHEN' ALREADY ACTIVE?
EWARNW E.632 ;[1005] GIVE ERROR MSG.
SETOM SWHEN## ;DIDN'T SEE "." BEFORE "WHEN"
HRRZI TA,OPSEAR ;SEARCH OP CODE
JRST SETOP
PA240A: EWARNW E.323 ;[511] MORE THAN 12 NESTED IF/SEARCH
JRST PA133. ;[511] GET OUT
;DATA NAME FOR SEARCH & INDEX FOR SEARCH
INTER. PA241.
PA241.: DMOVEM W1,ARG1 ;STORE ITEM WORDS
PUSHJ PP,PA820. ;[1553]SAVE CURRENT RESERVED WORD.
PUSHJ PP,DA96.D ;GET ALL QUALIFIERS
HRRM TE,ARG1
JRST PA21.
;SET SEARCH 'ALL' FLAG
INTER. PA242.
PA242.: SETO TB,
DPB TB,OP.ALL##
POPJ PP,
;SINCR OPERATOR AFTER ALL WHENS DONE
INTER. PA244.
PA244.: HRRZI TA,(TYPE)
ANDI TA,777 ;TYPE LESS A-MARGIN BIT
CAIE TA,PRIOD. ;IF NOT A PERIOD, TURN OFF FLAG THAT PA245.
SWOFF FPERWD ; [413] TURNED ON, BECAUSE WE ARE COMING UP FROM
;AN 'ELSE'
PUSHJ PP,PA37.
PUSHJ PP,PA246. ;OUTPUT SINCR
JRST PA247. ;OUTPUT %ENDWHN TAG
;OUTPUT JUMPTO TAG-FOLLOWING-ALL-WHENS
INTER. PA245.
PA245.: HRRZI TA,(TYPE)
ANDI TA,777 ;TYPE LESS A-MARGIN BIT
SETZM EWFLG## ;[1553] RESET WHEN SEEN FLAG
CAIN TA,PRIOD. ;IF AT END OF SEARCH STATEMENT
SWON FPERWD ; [413] REGET THE PERIOD
PA245B: HRRZI TA,OPJUMP ;[1556] REMOVE EXTRANEOUS PERIOD CODE
PUSHJ PP,SETOP
HLLZ TB,CURTAG
HLLM TB,OPRTR+1
SWOFF UNCONT; ;INCASE "GOTO" OR "STOP RUN" IN SEARCH
MOVEI TC,SEARC. ;[1553] TERMINATOR TO LOOK FOR
PUSHJ PP,PA824. ;[1553] CLEAN UP TERMINATOR STACK
JRST PA22. ;GO OUTPUT JUMP OPERATOR
;OUTPUT SINCR
INTER. PA246.
PA246.: HRRZI TA,OPSINC
PUSHJ PP,SETOP
JRST PA22.
;OUTPUT %ENDWHN TAG
INTER. PA247.
PA247.: MOVE TA,SPFLVL ;[511] GET SEARCH LEVEL
ADD TA,IFLVL ;[511] ADD IF LEVEL FOR INDEX
HLRZ CH,ARGL2-1(TA) ;[511] RETRIEVE TAG
HLLM CH,ARGL2-1(TA) ;[511] REMOVE ENTRY
SOS SPFLVL ;[511] SUBTRACT 1 LEVEL
SWOFF UNCONT ;[460] SEARCH IS NOT UNCOND. GO TO
JRST PA139X
;CALL
INTER. PA248.
PA248.: FLAGAT LI
PUSHJ PP,PA169. ;SET 'ENTER' OP CODE
PA248A: SETO TA, ;[171] NEW LABEL FOR ENTRY FROM PA143A FOR ENTER COBOL
DPB TA,OP.CAL## ;SET 'CALL' BIT
POPJ PP,
;ENTER FORTRAN
INTER. PA249.
PA249.: SETO TA, ;SET 'FORTRAN' BIT
DPB TA,OP.F10##
POPJ PP,
;CANCEL
INTER. PA250.
PA250.: FLAGAT HI
HRRZI TA,130 ;'CANCEL' OP CODE
JRST SETOP1
;OPERANDS FOR CANCEL
INTER. PA251.
PA251.: PUSHJ PP,PA2. ;SET UP OPERAND
PUSHJ PP,PA172. ;PUT IN EXTAB
HRRZ TA,W1 ;GET EXTAB LINK
PUSHJ PP,LNKSET
PUSHJ PP,PA251S ;PUT OPERAND NAME IN HLDTAB
JRST PA21.
;PUT A NAME IN HLDTAB FOR USE BY PHASE E
PA251S: HRRZM TA,CUREXT## ;SAVE ABS PTR
LDB TB,EX.NAM ;MAKE PTR TO NAME
HRRZ TA,NAMLOC
ADDI TB,1(TA)
HLRZ TD,NAMLOC ;[261] GET SIZE OF NAMTAB TABLE
TRC TD,-1 ;[261] MAKE IT POSITIVE
ADDI TA,(TD) ;[261] GET LAST NAMTAB TABLE ADDRESS
PA251A: CAIGE TA,(TB) ;[261] ARE WE STILL IN NAMTAB
JRST PA251T ;[261] NO- DONE
MOVE TC,(TB) ;[261]GET NAMTAB WORD
TLNE TC,600000 ;BEGINNING OF NEXT ENTRY?
AOBJP TB,PA251A ;NO, COUNT IT
PA251T: HLRZ TB,TB ;[261] GET NAMWRD COUNT
PUSH PP,TB ;SAVE COUNT
ADDI TB,2 ;SIZE OF HLDTAB ENTRY WANTED
MOVSI TA,CD.HLD ;GET SPACE FOR ENTRY
HRRI TA,(TB)
PUSHJ PP,GETENT
MOVEI TB,100 ;ENTRY TYPE CODE
DPB TB,HL.COD##
POP PP,TB ;COUNT OF EXTRA WORDS
DPB TB,HL.QAL##
PUSH PP,TA ;SAVE HLDTAB LINK
HRRZ TA,CUREXT ;SET UP 'FROM' PTR
LDB TB,EX.NAM##
HRRZ TA,NAMLOC
ADDI TB,(TA)
HRLI TB,(POINT 6,0,35)
HRRZ TA,(PP) ;SET UP 'TO' PTR
ADDI TA,2
HRLI TA,(POINT 6,)
PA251B: ILDB TD,TB
TRNN TD,60 ;2 HI ORDER BITS ZERO?
JRST PA251C ;YES, END OF NAME
CAIN TD,':' ;CONVERT : TO -
MOVEI TD,'-'
IDPB TD,TA
JRST PA251B
PA251C: POP PP,TA ;PUT HLDTAB LINK IN EXTAB
HLRZ TB,TA
HRRZ TA,CUREXT ;GET BACK EXTAB PTR
DPB TB,EX.HLD##
POPJ PP,
;EXIT PROGRAM
INTER. PA253.
PA253.: FLAGAT LI
SETOM SUBPRG## ;INDICATE THIS IS A SUBPROGRAM
HRRZI TA,37 ;'GOBACK' OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.PGM## ;'EXIT PROGRAM' BIT
JRST PA22. ;OUTPUT OPERATOR
INTER. PA253A
PA253A: ;Wanted 'PROGRAM', found period
EWARNW E.18 ;Improper clause
SWON FREGWD ;
JRST PA253. ;Fall into 'EXIT PROGRAM' code
;LITERAL FOR SUBPROGRAM NAME - CONVERT TO NORMAL NAME
INTER. PA254.
PA254.: LDB TB,GWVAL ;GET CHAR COUNT
CAILE TB,^D30 ;RESTRICT TO 30 CHARS
MOVEI TB,^D30
MOVE TC,[POINT 7,LITVAL]
MOVE TD,[POINT 6,NAMWRD]
PA254A: SOJL TB,PA254B ;LOOP TO MOVE CHARS
ILDB TE,TC
CAIL TE,141 ;CONVERT LC TO UC
TRZ TE,40
CAIG TE,"Z" ;CK FOR ILLEGAL CHARS
CAIGE TE,"A"
CAIG TE,"9"
CAIGE TE,"0"
CAIN TE,"-"
CAIA
EWARNJ E.57 ;?ILLEGAL CHAR
SUBI TE,40 ;CONVERT TO SIXBIT
IDPB TE,TD
JRST PA254A
PA254B: HRLZI W1,GWNOT
PUSHJ PP,TRYNAM
POPJ PP, ;NOT FOUND
HLRZ TB,(TA) ;WAS IT A RESERVED WORD?
TRNE TB,GWRESV
EWARNJ E.315 ;YES
SETZ W1,
HLRS TA ;[246] GET NAMTAB RELATIVE LOCATION
DPB TA,[POINT 15,W2,15] ;[246] STORE FOR LATER CHECK AT PA260.
POPJ PP, ;RESUME NORMAL PROCESSING
;OVERFLOW OPTION FOR CALL/ENTER
INTER. PA255.
PA255.: FLAGAT HI
PUSHJ PP,PA820. ;PUT RESERVED WORD ON TEMTAB STACK
LDB TA,OP.OPC ;USING OPERATOR WAITING?
CAIN TA,46
PUSHJ PP,PA22. ;YES, PUT IT OUT
HRRZI TA,23 ;'SPECIAL IF'
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.OVR## ;'ON OVERFLOW'
PA255A: PUSHJ PP,GETTAG##
ANDI CH,077777
JUMPE CH,PA255A ;%0 NOT ALLOWED
DPB CH,OP.TRG##
AOS TA,SPFLVL
ADD TA,IFLVL
CAILE TA,^D12 ;ARGL2 OVERFLOW?
JRST PA255B ;YES
HRLZM CH,ARGL2-1(TA)
JRST PA22.
PA255B: EWARNW E.323
JRST PA133. ;GIVE UP
;ENTRY
INTER. PA256.
PA256.: FLAGAT NS
SETOM SUBPRG ;INDICATE THIS IS A SUBPROGRAM
PA256A: SWOFF UNCONT ;MAY FOLLOW UNCONDIT GOTO
HRRZI TA,77 ;'ENTRY' OP CODE
JRST SETOP1
;ENTRY-NAME
INTER. PA257.
PA257.: PUSHJ PP,PA2. ;PUT SYMBOL IN NAMTAB
PUSHJ PP,CHKEXT ;CHECK LENGTH
PUSHJ PP,PA172. ;PUT IN EXTAB
HRRZ TA,W1 ;GET LINK TO EXTAB ENTRY
PUSHJ PP,LNKSET
PA257A: SETO TB, ;SET ENTRY BIT
DPB TB,EX.ENT##
PJRST PA251S ;PUT ENTRY NAME IN HLDTAB
;CHECK LENGTH OF EXTERNAL NAME
CHKEXT: SKIPN NAMWRD+1 ;MORE THAN 6 CHARS?
POPJ PP, ;NO
HRRZI DW,E.410 ;[214]
JRST WARN ;YES, ERROR
;SET UP PROCEDURE DIVISION ENTRY
INTER. PA258.
PA258.: PUSHJ PP,PA256A ;'ENTRY' OP CODE
SETO TB, ;SET PROC DIV ENTRY FLAG
DPB TB,OP.PD##
HRR W1,PIDLNK## ;GET LINK TO PROGRAM-ID
DMOVEM W1,ARG1 ;[631] SET UP ARGS
HRRZI TA,(W1) ;PUT PROGRAM-NAME IN HLDTAB
PUSHJ PP,LNKSET
PJRST PA251S
;USING CLAUSE FOR PROCEDURE DIVISION HEADER
INTER. PA259.
PA259.: FLAGAT LI
SETOM SUBPRG ;SET SUBPROGRAM FLAG
POPJ PP,
;PROGRAM-NAME FOR CALL & ENTER
INTER. PA260.
PA260.: PUSHJ PP,CHKEXT ;CHECK SIZE OF NAME
PUSHJ PP,PA172. ;SET UP EXTAB ENTRY
LDB TE,OP.CAL ;IS THIS A CALL?
JUMPE TE,CPOPJ ;NO
HRRZ TA,W1 ;YES, GET EXTAB LINK
PUSHJ PP,LNKSET
SETO TE, ;SET "REFERENCED-BY-CALL" BIT
DPB TE,EX.CAL##
POPJ PP,
;OUTPUT TAG IF NO INITIAL SECTION OR PARA NAME
INTER. PA261.
PA261.: SKIPE PROGST## ;STORED ALREADY?
JRST PA24. ;YES
PUSHJ PP,GETTAG ;NO, GET A TAG FOR IT
HRRM CH,PROGST ;REMEMBER FOR START CODE IN COBOLG
HRRZ TA,CH
PUSHJ PP,REFTAG## ;IT WILL BE REFERENCED IN PHASE G
ANDI CH,077777 ;OUTPUT TAG
HRLI TB,(CH)
HRRI TB,102 ;TAG OP CODE
HRLZI TA,102000
PUSHJ PP,PUTGEN
JRST PA24.
;ENTRY IS ALREADY IN EXTAB
INTER. PA262.
PA262.: PUSHJ PP,PA2.
HRRZ TA,W1 ;GET LINK TO EXTAB ENTRY
PUSHJ PP,LNKSET
LDB TB,EX.ENT ;GET ENTRY DEFN BITS
JUMPE TB,PA257A ;REF'D BY A CALL -- LET PHASE E FLAG IT
EWARNW E.397 ;?DUPLICATE ENTRY DEFN
HRRZI TA,105 ;"YECCH" OP CODE
JRST SETOP1
;IMPROPER SUBSCRIPT ERROR
INTER. PA263.
PA263.: MOVEI W1,<CD.DAT>B20+1 ;USE DUMMY DATA ITEM FOR SUBSCRIPT
TLZ W2,777770
DMOVEM W1,ARG1 ;NO NEED TO GIVE DIAGNOSTIC BECAUSE
; PHASE E DOES IT ALREADY
SWOFF FREGWD ;GO ON TO NEXT SOURCE ITEM
HRRZI TA,(W1) ;[262] SET UP DUMMY RELATIVE ADDRESS
PUSHJ PP,LNKSET ;[262] GET DATAB ADR FOR DUMMY
HRRM TA,CURDAT ;[262] STORE IT
HRLM W1,CURDAT ;[262] PUT BACK DATAB RELATIVE ADR
POPJ PP,
;SET DECLARED BY ENTRY OR PD USING CLAUSE BIT IN DATAB
INTER. PA264.
PA264.: HRRZI TA,(W1) ;GET DATAB LINK
PUSHJ PP,LNKSET
PA264A: SETO TB, ;[***]
DPB TB,DA.RBE##
LDB TB,DA.LVL ;[***] GET LEVEL
SOJN TB,CPOPJ ;[***] GIVE UP UNLESS LEVEL 1
LDB TA,DA.BRO## ;[***] DOES IT HAVE A BROTHER
JUMPE TA,CPOPJ ;[***] NO, GIVE UP
PUSHJ PP,LNKSET ;[***] YES, POINT TO IT
LDB TB,DA.RDF ;[***] IS IT A REDEFINES
JUMPN TB,PA264A ;[***] YES, SET BIT IN HERE ALSO
POPJ PP, ;[***]
SUBTTL DBMS SYNTAX
IFN DBMS,<
;SAVE SET-NAME AS A LITERAL FOR 'IF SET-NAME SET [NOT] EMPTY' CONDITION
; OR 'IF RECORD [NOT] [MEMBER/OWNER] OF SET-NAME/ANY SET' CONDITION
INTER. PA265.
PA265.: MOVEI TC,^D30 ;CHAR CTR
MOVE TB,[POINT 6,NAMWRD]
PA265A: ILDB TD,TB
SKIPE TD ;END OF WORD?
SOJG TC,PA265A ;LOOKED AT ALL 30 CHARS?
MOVEI TB,^D30 ;GET POS CHAR COUNT
SUBI TB,(TC)
PUSH PP,TB ;SAVE CHAR COUNT
ADDI TB,2+4 ;ALLOW FOR COUNT AND ROUNDING
IDIVI TB,5 ;CONVERT TO WORDS
HRRZI TA,(TB) ;GET VALTAB ENTRY OF THAT SIZE
HRLI TA,CD.VAL
PUSHJ PP,GETENT
HLR W1,TA ;SAVE OPERAND
TLO W1,GWLIT ;SET LITERAL FLAG
TLZ W2,777774 ;[353] CLEAR ALL BUT LINE AND CHAR POSITION.
DMOVEM W1,ARG1
POP PP,TB ;PUT BYTE COUNT IN ENTRY
DPB TB,[POINT 14,(TA),13]
MOVE TC,[POINT 6,NAMWRD] ;FROM PTR
MOVSI TD,(POINT 7,(TA),13) ;TO PTR
MOVE W1,[POINT 7,LITVAL] ;[1035] MAKE BYTE POINTER
PA265B: ILDB TE,TC
ADDI TE,40 ;MAKE ASCII
CAIN TE,":" ;CONVERT GETITM'S COLON TO DASH
MOVEI TE,"-"
IDPB TE,TD
IDPB TE,W1 ;[1035] SAVE IN LITVAL, TOO
SOJG TB,PA265B ;DONE ALL YET?
IDPB TB,W1 ;[1035] STORE A NULL AT THE END FOR FNDSYM
MOVE W1,ARG1 ;RESTORE W1 AGAIN
SKIPN SYMTAB ;[1035] CHECK FOR INVOKE DONE
JRST PA265D ;[1035] NO, MESSED UP
MOVS TA,NAMWRD ;GET SET NAME
CAIN TA,'ANY' ;BUT DON'T CHECK FOR ANY
POPJ PP, ;AS ITS ALWAYS VALID
MOVEI TA,[-2,,0 ;[1035] GET ARGUMENTS
SYMTAB## ;[1035] TABLE
17B12+LITVAL]+1 ;[1305] SYMBOL
PUSH PP,0 ;[1035] PRESERVE ACS OVER CALL
PUSH PP,1 ;[1035] ...
PUSHJ PP,FNDSYM## ;[1035] LOOK FOR SYMBOL IN SUBSCHEMA
MOVE TA,0 ;[1035] COPY NAME
POP PP,1 ;[1035] RESTORE ACS
POP PP,0 ;[1035] ...
JUMPN TA,CPOPJ ;[1035] OK IF FOUND
SKIPE SYMTAB ;[1114] [1035] SKIP SUB-SCHEMA MSG IF NO INVOKE
EWARNJ E.588 ;[1035] MUST BE DEFINED IN SUBSCHEMA
;IF "<undefined name>" and no INVOKE done. Probably not DBMS.
PA265D: SWON FREGWD; ;Set so we reget word
POPJ PP, ;Let compiler give "undefined" error
;STILL IN IFN DBMS
;SET UP IFDB OPERATOR FOR 'IF SET-NAME SET [NOT] EMPTY'
INTER. PA266.
PA266.: PUSHJ PP,PA21. ;SET UP OPERAND
MOVE TE,OP.EMP## ;GET SET EMPTY CONDITION FLAG
PA266A: SETZM OPRTR+1
HRRZI TA,131 ;IFDB OPERATOR
PUSHJ PP,SETOP1
JRST P195.B
;ERROR: 'IF <USER-NAME>' NOT FOLLOWED BY 'SET'
INTER. PA267.
PA267.: LDB LN,[POINT 13,ARG1+1,28]
LDB CP,[POINT 7,ARG1+1,35]
HRRZI DW,E.104 ; [314] UNDEFINED
JRST FATAL
;STILL IN IFN DBMS
;SAVE OPRTR FLAG FOR 'IF RECORD *MEMBER* OF SET-NAME SET'
INTER. PA268.
PA268.: MOVE TE,OP.MEM##
PA268A: MOVEM TE,TBLOCK
POPJ PP,
;SAVE OPRTR FLAG FOR 'IF RECORD *OWNER* OF SET-NAME/ANY SET'
INTER. PA269.
PA269.: MOVE TE,OP.OWN##
JRST PA268A
;SAVE OPRTR FLAG FOR 'IF RECORD <<OWNER OR MEMBER>> OF SET-NAME/ANY SET'
INTER. PA270.
PA270.: MOVE TE,OP.MOO##
JRST PA268A
;SET UP OPERATOR FOR 'IF RECORD [MEMBER/OWNER] OF SET-NAME/ANY SET'
INTER. PA271.
PA271.: PUSHJ PP,PA21. ;SET UP OPERAND
MOVE TE,TBLOCK ;GET PTR TO FLAG BIT
JRST PA266A
;STILL IN IFN DBMS
;SET UP USETAB ENTRY FOR 'USE IF ERROR-STATUS'
INTER. PA272.
PA272.: MOVE TB,['ERROR:'] ;CK FOR ERROR-STATUS DATA-NAME
CAME TB,NAMWRD
JRST PA272E ;NO
MOVE TB,['STATUS']
CAME TB,NAMWRD+1
JRST PA272E ;NO
SKIPE NAMWRD+2
JRST PA272E ;NO
MOVE TA,[CD.USE,,SZ.USE] ;GET ROOM FOR NEW ENTRY
PUSHJ PP,GETENT
MOVEI TB,%UT.ES ;SET ERROR-STATUS FLAG
DPB TB,US.TYP##
HLRZ TB,CURPRO ;LINK USE TO CURRENT SECTION
DPB TB,US.PRO##
HLRZM TA,CURUSE## ;REMEMBER REL ADDR OF USETAB ENTRY
POPJ PP,
INTER. PA272E
PA272E: EWARNW E.405 ;?ERROR-STATUS EXPECTED
SWOFF FREGWD ;SKIP TO NEXT SOURCE ITEM
HRRZI NODE,PD1127## ;RETURN TO ERROR NODE IN TREE
HRRZM NODE,(NODPTR)
POPJ PP,
;STILL IN IFN DBMS
;SCAN USETAB FOR ERROR-STATUS ENTRIES WITH SELECTED CODES
; WHICH WOULD MEAN AN ILLEGAL COMBINATION OR ERROR-STATUS USE-PROCS
;
;CTR=0 IMPLIES ANY OTHER ERROR-STATUS ENTRY IS AN ERROR
;CTR NOT = 0 IMPLIES ANY ENTRY WITH CODE=CTR IS AN ERROR
; AND ANY ENTRY WITH CODE -1 (GENERAL PURPOSE ENTRY) IS AN ERROR
;SKIP RETURN IF NO ERROR
PA272S: HRRZ TA,USELOC## ;INIT SCAN OF USETAB ERROR-STATUS ENTRIES
ADDI TA,1
HRRZ TB,USELOC ;STOP WHEN ENTRY BEFORE CURRENT HAS BEEN CHECKED
ADD TB,CURUSE
PA272A: CAIL TA,(TB) ;CHECKED ALL?
JRST CPOPJ1 ;YES, NO ERRORS
LDB TC,US.TYP## ;THIS AN ERROR-STATUS ENTRY?
CAIE TC,%UT.ES
JRST PA272B ;NO
LDB TC,US.XTR## ;EXTRA WORDS ALLOCATED FOR THIS ENTRY?
JUMPE TC,PA272B ;NO (MUST HAVE BEEN LEFT BY AN ERROR)
SKIPN CTR ;WHICH TYPE OF CHECK ARE WE DOING?
EWARNJ E.406 ;ANY OTHER ENTRY IS AN ERROR
LDB TC,US.CNT ;GET EXTRA WORDS COUNT
MOVE TD,[POINT 18,1(TA),17] ;SET PTR TO GET ERROR CODES
PA272D: ILDB TE,TD ;GET NEXT ERROR CODE FROM ENTRY
JUMPE TE,PA272B ;NO MORE
CAIE TE,-1 ;-1 OR CTR IS AN ERROR
CAMN TE,CTR
EWARNJ E.406
SOJG TC,PA272D ;CK WORD COUNT
PA272B: LDB TC,US.XTR ;ADVANCE TO NEXT ENTRY
JUMPE TC,PA272C ;NO EXTRA WORDS IN THIS ENTRY
LDB TC,US.CNT## ;GET # OF EXTRA WORDS
ADDI TA,(TC)
PA272C: AOJA TA,PA272A ;TRY NEXT ENTRY
;STILL IN IFN DBMS
;STORE GIVEN ERROR-STATUS CODE IN USETAB ENTRY
INTER. PA273.
PA273.: LDB TB,GWVAL ;GET THE VALUE OF THE INTEGER
MOVEM TB,CTR
HRRZI TA,LITVAL
PUSHJ PP,GETVAL
MOVEM TC,CTR ;SAVE VALUE FOR LATER STORAGE
PUSHJ PP,PA272S ;SCAN USETAB FOR SAME CODE OR GEN-PURP CODE
POPJ PP, ;ERROR RETURN
PA273A: HRRZ TA,USELOC ;GET PTR TO CURRENT USETAB ENTRY
ADD TA,CURUSE
LDB TB,US.XTR ;ANY EXTRA WORDS ALREADY ALLOCATED?
JUMPN TB,PA273F ;YES
MOVE TA,[CD.USE,,SZ.USE] ;GET ROOM FOR 1ST EXTRA WORD
PUSHJ PP,GETENT
HRRZ TA,USELOC ;GET BACK PTR TO CURRENT USETAB ENTRY
ADD TA,CURUSE
SETO TB, ;SET EXTRA WORD FLAG
DPB TB,US.XTR
MOVEI TB,1 ;SET EXTRA WORD COUNT IN ENTRY
DPB TB,US.CNT
AOJA TA,PA273H ;BUMP PTR UP TO EXTRA WORD
PA273F: LDB TC,US.CNT ;GET # OF EXTRA WORDS
MOVEI TC,1(TC) ;BUMP WORD COUNT IN ENTRY
DPB TC,US.CNT
TRNE TC,1 ;HOW MANY CODES STORED ALREADY?
JRST PA273G ;ODD #
MOVE TA,[CD.USE,,SZ.USE] ;GET ANOTHER WORD
PUSHJ PP,GETENT
MOVE TC,CTR ;STORE NEW CODE IN LEFT HALF OF NEW WORD
HRLZM TC,(TA)
POPJ PP,
PA273G: LSH TC,-1 ;MAKE PTR TO LAST EXTRA WORD
ADDI TA,1(TC)
PA273H: MOVE TC,CTR ;STORE NEW WORD IN RIGHT HF OF WORD
HRRM TC,(TA)
POPJ PP,
;STILL IN IFN DBMS
;STORE CODE FOR GENERAL PURPOSE 'USE IF ERROR-STATUS' ENTRY
INTER. PA274.
PA274.:
;;; JUST FORBID A PRIOR "USE" OF SAME FORM
MOVEI TC,-1 ;STORE GENERAL PURPOSE CODE IN ENTRY
MOVEM TC,CTR
PUSHJ PP,PA272S ;SCAN USETAB FOR OTHER E-S ENTRIES
POPJ PP, ;ERROR RETURN
JRST PA273A
INTER. PA277R ;[1026] HANDLE MOVE CURRENCY STATUS FOR <REC> RECORD
PA277R: MOVE TA,W1 ;[1026] GET "RECORD NAME" TABLE LINK
PUSHJ PP,LNKSET ;[1026] GET DATA TABLE
LDB TB,DA.LVL ;[1026] GET LEVEL NUMBER
CAIN TB,LVL.01 ;[1026] CHECK FOR LEVEL 1 (A RECORD)
JRST PA277. ;[1026] YES, GO ON
EWARNJ E.422 ;[1026] COMPLAIN THAT IT MUST BE A RECORD
;PROCESS "CLOSE ALL" DBMS COMMAND
INTER. PA275.
PA275.: FLAGAT DB
PUSHJ PP,PA276.
SKPNAM
INTER. PA277.
PA277.: MOVSI W1,5!GWLIT!GWNLIT
PA277A: MOVE TA,[POINT 6,NAMWRD] ;GET PTR TO USER-NAME
PUSHJ PP,FIXLIT ;FIX IT LIKE A LITERAL
PUSHJ PP,PA2. ;SET UP OPERAND
JRST PA21. ;OUTPUT OPERAND
FIXLIT: MOVE TB,[POINT 7,LITVAL]
SETZ TD, ;CLEAR CHAR COUNT
FIX2: ILDB TC,TA ;GET CHAR
CAIL TD,^D30 ;WOULD THIS CHAR BE OUT-OF-BOUNDS?
SETZM TC ;YES, SO FAKE TERM-CHAR
CAIN TC,':' ;CONVERT ALL ":" BACK TO "-"
MOVEI TC,'-'
SKIPE TC ;DON'T CONVERT IF ZERO
ADDI TC,40 ;CONVERT TO ASCII
IDPB TC,TB ;DEPOSIT IT IN LITVAL
JUMPE TC,FIX3
AOJA TD,FIX2 ;BUMP COUNTER
FIX3: JUMPN W1,FIXNMID
HRLZ W1,TD ;MOVE COUNT IN W1
TLO W1,1B19 ;SET BIT 1
POPJ PP,
FIXNMID:
SM.NMID==SM.USR##+1
MOVEI TA,[-2,,0
SYMTAB##
17B12+LITVAL]+1
;;; 0/1 USED BY SUBROUT
SKIPN SYMTAB ;INVOKE STAT MESSED UP?
JRST FIXNM1 ;YES
PUSH PP,0
PUSH PP,1
PUSHJ PP,FNDSYM##
MOVE TA,0 ;FIND A SYMBOL
POP PP,1
POP PP,0
JUMPN TA,FIXNM2
FIXNM1: EWARNW E.588 ;NO BAD
SKIPA TB,[ASCII/00000/] ;FUDGE IT
FIXNM2: MOVE TB,SM.NMID(TA)
MOVEM TB,LITVAL
POPJ PP,
INTER. PA276.
PA276.: MOVEI W1,%CLOSE## ;SET UP "CLOSD" ADDRESS
SKPNAM
INTER. PA278.
PA278.: FLAGAT DB
PUSHJ PP,PA169. ;SET UP ENTER OPRTR
PUSHJ PP,PA141. ;...AND MACRO BIT
PUSHJ PP,PA2. ;CONSTRUCT ARG1,ARG1+1
JRST PA217. ;OUTPUT THEM
INTER. PA279.
PA279.: MOVEI W1,%STORE## ;GET STORE EXTAB OFFSET
PUSHJ PP,PA278.
JRST PA277.
;SET UP "INSERT" REFERENCE.
INTER. PA280.
PA280.: MOVEI W1,%INSRT##
JRST PA278.
;MODIFY <REC-NAME>.
INTER. PA281.
PA281.: MOVEI W1,%MODIF##
JRST PA278.
;SET UP REFERENCE TO "GETS"
INTER. PA282.
PA282.: MOVEI W1,%GETS##
JRST PA278.
;OUTPUT OPERAND REFERENCE TO DBMS-NULL.
INTER. PA283.
PA283.: MOVE TB,[ASCII/00000/] ;PASS 0 CAUSE SIMPLER & NO ARG PASSING PROB
MOVEM TB,LITVAL
MOVSI W1,5!GWLIT!GWNLIT
PUSHJ PP,PA2. ;SET UP ARG1
JRST PA21. ;OUTPUT OPERAND
;REMOVE VERB
INTER. PA284.
PA284.: MOVEI W1,%REMOV##
JRST PA278.
;STILL IN IFN DBMS
;ACTIONS FOR "DELETE" VERB.
SAVEPP: POP PP,TE ;GET RETURN ADDRESS
PUSH PP,W1
PUSH PP,W2
PUSH PP,CT
PUSH PP,NAMWRD
PUSH PP,NAMWRD+1
PUSH PP,NAMWRD+2
PUSH PP,NAMWRD+3
PUSH PP,NAMWRD+4
JRST (TE)
GETPP: POP PP,TE
POP PP,NAMWRD+4
POP PP,NAMWRD+3
POP PP,NAMWRD+2
POP PP,NAMWRD+1
POP PP,NAMWRD
POP PP,CT
POP PP,W2
POP PP,W1
JRST (TE)
INTER. PA285.
PA285.: PUSHJ PP,SAVEPP
MOVEI W1,%DELET##
PUSHJ PP,PA278.
PUSHJ PP,PA283. ;OUTPUT DBMS-NULL
PUSHJ PP,GETPP
JRST PA277.
;PROCESS THE STATEMENT: DELETE.
INTER. PA285A
PA285A: MOVEI W1,%DELET
PUSHJ PP,PA278.
PUSHJ PP,PA283.
JRST PA283.
INTER. PA286.
PA286.: PUSHJ PP,SAVEPP
PUSHJ PP,GETEM. ;GET <REC-NAME> BACK AGAIN
PUSHJ PP,PA2. ;OUTPUT IT
PUSHJ PP,PA171.
PUSHJ PP,GETPP
PUSHJ PP,PA170. ;NOW, WE ARE LOOKING AT "INVALID"
PUSHJ PP,PA216.
PUSHJ PP,PA22.
JRST PA90.
INTER. PA287.
PA287.: MOVEI W1,%DELET
PUSHJ PP,PA278.
PUSHJ PP,GETEM. ;GET <REC-NAME> BACK
PUSHJ PP,PA277. ;OUTPUT AS LITERAL
JRST PA283. ;OUTPUT DBMS-NULL.
INTER. PA288.
PA288.: PUSHJ PP,SAVEPP
MOVEI W1,%DELET
PUSHJ PP,PA278.
PUSHJ PP,GETEM. ;GET <REC-NAME>
PUSHJ PP,PA277.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA288A; ;'DELETE <REC-NAME> OF ...'
PA288A: PUSHJ PP, SAVEPP
PUSHJ PP, GETEM.
PUSHJ PP, PA2.
PUSHJ PP, PA171.
PUSHJ PP, GETPP
POPJ PP,
;STILL IN IFN DBMS
;THESE SUBROUTINES ARE DESIGNED TO PRESERVE THE VITAL
;INFORMATION ABOUT THE CURRENT ITEM BEING SCANNED. THIS INFO CAN
;THEN BE RESTORED LATER AS IF THE SCANNER WAS RETURNING TO THE
;PREVIOUS WORD.
INTER. SAVEM.
SAVEM.: PUSH SAVPTR,W1
PUSH SAVPTR,W2
PUSH SAVPTR,CT
PUSH SAVPTR,NAMWRD
PUSH SAVPTR,NAMWRD+1
PUSH SAVPTR,NAMWRD+2
PUSH SAVPTR,NAMWRD+3
PUSH SAVPTR,NAMWRD+4
POPJ PP,
INTER. GETEM.
GETEM.: POP SAVPTR,NAMWRD+4
POP SAVPTR,NAMWRD+3
POP SAVPTR,NAMWRD+2
POP SAVPTR,NAMWRD+1
POP SAVPTR,NAMWRD
POP SAVPTR,CT
POP SAVPTR,W2
POP SAVPTR,W1
POPJ PP,
;STILL IN IFN DBMS
;SET UP "MOVE" EXTERNAL REFERENCE.
INTER. PA289.
PA289.: MOVEI W1,%MOVEC##
JRST PA278.
;OUTPUT DBMS-NULL, AND "RUN-UNIT".
INTER. PA290.
PA290.: PUSHJ PP,SAVEM. ;SAVE "RUN-UNIT"
PUSHJ PP,PA283. ;OUTPUT DBMS-NULL
PUSHJ PP,GETEM.
MOVEI TA,15 ;15=SIXBIT /-/
DPB TA,[POINT 6,NAMWRD,23]
JRST PA277. ;NOW, PUT OUT "RUN-UNIT".
;STILL IN IFN DBMS
;ACTIONS FOR "FIND" VERB AND RSE.
INTER. PA291.
PA291.: PUSHJ PP,PA292.
JRST PA283.
INTER. PA292.
PA292.: MOVEI W1,%FIND2##
JRST PA278.
INTER. PA293.
PA293.: MOVEI W1,%FIND4##
JRST PA278.
INTER. PA294.
PA294.: PUSHJ PP,PA292.
PUSHJ PP,GETEM. ;GET <REC-NAME> BACK AGAIN
JRST PA277. ;PUT IT OUT.
;FIND OWNER <SET-NAME>.
INTER. PA295.
PA295.: PUSHJ PP,PA293.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA296.
PA296.: PUSHJ PP,SAVEM.
PUSHJ PP,PA297.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA297.
PA297.: MOVEI W1,%FIND3##
JRST PA278.
INTER. PA297A
PA297A: MOVEI W1,%FINDO## ;FIND OFFSET GETS SPECIAL PATH FOR V4
JRST PA278.
INTER. PA298.
PA298.: PUSHJ PP,SAVEM.
PUSHJ PP,PA297A
PUSHJ PP,GETEM.
JRST PCA5. ;OUTPUT INTEGER
INTER. PA299.
PA299.: PUSHJ PP,SAVEM. ;COME HERE ON "DUPLICATE"
PUSHJ PP,PA300.
PUSHJ PP,GETEM.
SETZ TA,
DPB TA,[POINT 6,NAMWRD,23] ;TRUNCATE TO "DUP"
JRST PA277.
INTER. PA300.
PA300.: MOVEI W1,%FIND5##
JRST PA278.
INTER. PA301.
PA301.: MOVEI W1,%FIND1##
JRST PA278.
INTER. PA302.
PA302.: PUSHJ PP,PA301.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA303.
PA303.: PUSHJ PP,PA300.
PUSHJ PP,PA283.
PUSHJ PP,GETEM.
JRST PA277.
INTER. PA304.
PA304.: PUSHJ PP,PA297A
PUSHJ PP,GETEM.
PUSHJ PP,PA2. ;[675] MAKE SURE ITS IN NAMTAB
HRRZ TA,ARG1 ;[675] GET TABLE ENTRY
JUMPE TA,PA304A ;[675] INCASE OF ERROR
PUSHJ PP,LNKSET ;[675] SET UP POINTER TO DATAB
LDB TD,DA.CLA## ;[675] GET CLASS OF DATAB
LDB TE,DA.NDP## ;[675] GET NUMBER OF DECIMAL PLACES
CAIN TD,%CL.NU ;[675] MUST BE NUMERIC
JUMPE TE,PA304B ;[1104] [675] AND HAVE NO DECIMAL PLACES
HRRZI DW,E.264 ;[675] NO, ERROR
PA304C: LDB CP,[POINT 7,ARG1+1,35] ;[1104] [675]
LDB LN,[POINT 13,ARG1+1,28] ;[675]
PUSHJ PP,FATAL ;[675]
PA304A: PUSHJ PP,PA21. ;[675]
JRST PA283.
PA304B: LDB TD,DA.USG ;[1104] GET USAGE
CAIE TD,%US.1C ;[1431] [1104] MUST BE ONE-WORD COMPUTATIONAL
CAIN TD,%US.IN ;[1431] OR INDEX
JRST PA304A ;[1104] OK
HRRZI DW,E.639 ;[1431] [1104] GET ERROR
JRST PA304C ;[1104] AND PROCESS
INTER. PA305.
PA305.: PUSHJ PP,SAVEPP
PUSHJ PP,PA304. ;OUTPUT <REC>, NULL.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA306.
PA306.: PUSHJ PP,SAVEPP
PUSHJ PP,PA297A
PUSHJ PP,GETEM.
PUSHJ PP,PA2. ;[1046] BREAK UP PCA5. CALL INTO TWO PIECES
HRRZ TA,ARG1 ;[1046] GET THE ENTRY
JUMPE TA,PA306A ;[1046] ...
PUSHJ PP,LNKSET ;[1046] GET DATAB ENTRY
LDB TD,DA.USG ;[1046] GET USAGE
LDB TE,DA.NDP ;[1443] GET NO. DECIMAL PLACES
CAIE TD,%US.1C ;[1431] [1046] MUST BE ONE-WORD COMP
CAIN TD,%US.IN ;[1431] OR INDEX
JUMPE TE,PA306A ;[1443] [1046] AND NO DECIMAL PLACES
HRRZI DW,E.639 ;[1046] NO GOOD, GIVE ERROR
LDB CP,[POINT 7,ARG1+1,35] ;[1046] GET CHARACTER POSITION
LDB LN,[POINT 13,ARG1+1,28] ;[1046] AND LINE NUMBER
PUSHJ PP,FATAL ;[1046] GIVE FATAL ERROR
PA306A: PUSHJ PP,PA21. ;[1046]
PUSHJ PP,GETPP
JRST PA277.
INTER. PA307.
PA307.: PUSHJ PP,SAVEPP
PUSHJ PP,PA297.
PUSHJ PP,GETEM.
PUSHJ PP,PA277.
PUSHJ PP,GETPP
JRST PA277.
INTER. PA308.
PA308.: PUSHJ PP,PA297.
PUSHJ PP,GETEM.
PUSHJ PP,PA277.
JRST PA283.
INTER. PA309.
PA309.: PUSHJ PP,PA299. ;OUTPUT "DUP"
JRST GETEM. ;POP GARBAGE OFF STACK
INTER. PA310.
PA310.: PUSHJ PP,PA301.
JRST PA283.
;STILL IN IFN DBMS
;ACTIONS FOR "OPEN" VERB.
INTER. PA311.
PA311.: FLAGAT DB
SETZM BUFCTR##
MOVEI W1,%OPEND##
JRST PA278.
INTER. PA312.
PA312.: MOVE TA,BUFCTR ;GFET # OF ENTRIES
CAIL TA,^D10 ;IS TABLE FULL?
EWARNJ E.428 ;YES, GIVE ERROR AND IGNORE NEW ENTRY.
LSH TA,3 ;MULTIPLY BY 8
ADDI TA,BUFFER##-1 ;GET ADDRESS OF NEW ENTRY
PUSH TA,W1
PUSH TA,W2 ;PUSH ALL GOOD STUFF INTO TABLE
PUSH TA,CT
PUSH TA,NAMWRD
PUSH TA,NAMWRD+1
PUSH TA,NAMWRD+2
PUSH TA,NAMWRD+3
PUSH TA,NAMWRD+4
AOS BUFCTR ;BUMP COUNT
POPJ PP,
INTER. PA313.
PA313.: SETZ TA,
DPB TA,[POINT 6,NAMWRD,29]
JRST SAVEM. ;SAVE "EXCLUSIVE"
; *** OPEN VERB NOW COMES HERE IF BOTH ACCESS &SHARE-LEVEL SPEC
INTER. PA314.
PA314.: PUSHJ PP,PA277.
PUSHJ PP,GETEM. ;GET TYPE OF UPDATE
JRST PA277. ;OUTPUT IT
INTER. PA315.
PA315.: SETZ W1, ;SO FIXLIT WILL KNOW TRUE LIT...I.E. NOT PRESENT
PUSHJ PP,PA277A ;SKIP THE PRESET
SKPNAM
INTER. PA316.
PA316.: SETZ TB, ;OUTPUT ALL OPERANDS STORED IN BUFFER
P3161.: MOVE TA,TB ;GET TEMP COUNTER
LSH TA,3 ;MULTIPLY BY 8
ADDI TA,BUFFER-1+^D8 ;POINT TO END OF NEXT ENTRY
HRLI TA,^D10 ;SET UP FAKE PUSH-DOWN COUNT
POP TA,NAMWRD+4
POP TA,NAMWRD+3 ;GET GOOD STUFF
POP TA,NAMWRD+2
POP TA,NAMWRD+1
POP TA,NAMWRD
POP TA,CT
POP TA,W2
POP TA,W1
PUSH PP,TB ;SAVE COUNTER FOR NOW
PUSHJ PP,PA277. ;OUTPUT OPERAND
POP PP,TB
AOS TB ;BUMP COUNTER
CAME TB,BUFCTR ;HAVE WE GOTTEN ALL ENTRIES?
JRST P3161. ;NO
POPJ PP,
; *** OPEN VERB COMES HERE IF JUST ACCESS SPEC
INTER. PA317.
PA317.: PUSHJ PP,PA277.
JRST PA283.
INTER. PA318.
PA318.: MOVE TA,[SIXBIT /RETR/] ;OUTPUT "RETR"
MOVEM TA,NAMWRD
JRST PA277.
INTER. PA319.
PA319.: FLAGAT DB
PUSHJ PP,SAVEM. ;SAVE "ALL"
PUSHJ PP,PA311. ;OUTPUT EXTERNAL REFERENCE
PUSHJ PP,GETEM.
JRST PA312.
INTER. PA320.
PA320.: PUSHJ PP,PA318.
PUSHJ PP,PA283.
PUSHJ PP,PA283.
JRST PA316.
INTER. PA321.
PA321.: PUSHJ PP,PA283. ;OUTPUT NULL
JRST PA22. ;OUTPUT BAD OPERAND
IFN DBMS6,<
INTER. PAOT01
PAOT01: MOVEI W1,%OPENT## ;OPEN A TRANSACTION
JRST PA278.
INTER. PACT01
PACT01: MOVEI W1,%CLOTR## ;CLOSE A TRANSACTION
JRST PA278.
INTER. PADT01
PADT01: MOVEI W1,%DELTR## ;DELETE A TRANSACTION
JRST PA278.
INTER. PAFIN6
PAFIN6: MOVEI W1,%FIND6## ;FIND RSE6
PUSHJ PP,PA278.
PUSHJ PP,GETEM. ;GET BACK THE RECNAME THAT HAS ALREADY BEEN EATEN
JRST PA277. ;PUT IT OUT IN ADDITION TO THE CALL & GO BACK TO PARSE
> ;END IFN DBMS6
>;END IFN DBMS
;COME HERE BEFORE DECLARATIVES TO SEE IF THERE IS
;A DBMS FILE TO BE PROCESSED.
INTER. PA322.
PA322.: SKIPN FINVD## ;IS OUR FLAG SET?
POPJ PP, ;NO, EXIT
IFE DBMS,<
OUTSTR [ASCIZ /?PA322.: FINVD flag is set
/]
JRST KILL##
>
IFN DBMS,<
SETZM FINVD ;THIS TELLS GETITM TO DELETE FILES
;[%316] DELETE BUMP OF DBCNTC SINCE RCLAIM NO MORE
AOS DBCNTD## ;Bump count of INVOKES
PUSHJ PP,DBGTF.## ;GO PROCESS 1ST FILE (###DB1.TMP)
SETOM FINVOK## ;SET INVOKE FLAG
SETZM SRCCOL##
TSWFZ FSEQ ;[453] IS /S SWITCH ON--IF YES TURN IT OFF
SETOM DBONLY## ;[453] IT WAS ON, REMEMBER IT
POPJ PP,
>
SUBTTL MCS SYNTAX
;DISABLE/ENABLE ACTIONS
IFN MCS,<
INTER. PA323.
PA323.: FLAGAT HI
HRRZI TA,132 ;DISABLE OPERATOR
JRST SETOP
INTER. PA324.
PA324.: PUSHJ PP,PA323. ;SET UP OP CODE
SETO TA,
DPB TA,OP.ENA## ;SET ENABLE BIT
POPJ PP,
INTER. PA325.
PA325.: HRRZ TA,W1 ;CHECK TO MAKE SURE IT'S AN...
ADD TA,CDLOC## ;...INPUT CD!
SKIPGE 1(TA) ;INPUT CD?
EWARNW E.458 ;NO
JRST PA328. ;GO ON
INTER. PA326.
PA326.: SETO TA,
DPB TA,OP.TRM## ;SET TERMINAL BIT
POPJ PP,
INTER. PA327.
PA327.: SETO TA,
DPB TA,OP.OT2## ;SET OUTPUT
POPJ PP,
INTER. PA328A
PA328A: LDB TE,GWVAL ;TEST FOR ZERO ONLY
CAIN TE,ZERO.
JRST PA328. ;OK
EWARNW E.638 ;TELL USER
MOVEI TE,ZERO. ;TURN IT INTO ZERO
DPB TE,GWVAL ;TO AVOID ERROR IN COBOLE
SKPNAM
INTER. PA328.
PA328.: PUSHJ PP,PA2. ;OUTPUT OPERAND
JRST PA21.
INTER. PA329.
PA329.: FLAGAT HI
HRRZI TA,133
PUSHJ PP,SETOP ;SET OP CODE
JRST PA328.
INTER. PA330.
PA330.: FLAGAT HI
HRRZI TA,134 ;SEND OP CODE
JRST SETOP
INTER. PA330A
PA330A: HRRZ TA,W1 ;CHECK FOR OUTPUT CD
ADD TA,CDLOC##
SKIPL 1(TA)
EWARNW E.453 ;ERROR IF INPUT CD
JRST PA328. ;NO, OUTPUT OPERAND
INTER. PA331.
PA331.: MOVSI TA,(ASCIZ /0/) ;OUTPUT "0"
;SUBROUTINE TO OUTPUT A LITERAL NUMERIC
OUTLIT: MOVEM TA,LITVAL
MOVSI W1,1B19+1B23+1 ;SET "LITERAL","NUMERIC LITERAL",LENGTH (ALWAYS 1)
JRST PA328. ;OUTPUT IT
INTER. PA332.
PA332.: HRRZ TA,W1 ;CHECK FOR ALPHANUMERIC
PUSHJ PP,LNKSET ;FIND DATAB ENTRY
LDB TB,DA.CLA## ;[772] GET DATA TYPE
IFN TOPS20,<
CAIE TB,%CL.NU ;TCS WANTS TO ALLOW INTEGERS HERE
JRST PA332A ;NOT NUMERIC, CONTINUE TESTING
LDB TB,DA.USG ;GET USAGE
CAIE TB,%US.1C ;1-WORD COMP?
CAIN TB,%US.IN ;OR INDEX?
JRST PA2. ;YES
TRNA ;NO, GIVE ERROR
PA332A:>
CAIE TB,%CL.AN
EWARNW E.454 ;NOT ALPHANUMERIC
JRST PA2.
INTER. PA333.
PA333.: MOVSI TA,(ASCIZ /1/) ;ESI
JRST OUTLIT
INTER. PA334.
PA334.: MOVSI TA,(ASCIZ /2/) ;EMI
JRST OUTLIT
INTER. PA335.
PA335.: MOVSI TA,(ASCIZ /3/) ;EGI
JRST OUTLIT
IFE TOPS20,<
INTER. PA336.
PA336.: MOVSI TA,(ASCIZ /4/) ;EPI
JRST OUTLIT
>
INTER. PA337.
PA337.: SETO TA,
DPB TA,OP.AF2## ;SET "AFTER" BIT
POPJ PP,
INTER. PA338.
PA338.: SETO TA,
DPB TA,OP.PAG## ;SET PAGE BIT
JRST PA331.
INTER. PA339.
PA339.: FLAGAT HI
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
HRRZI TA,135 ;'RECEIV' OP CODE
JRST SETOP
INTER. PA340.
PA340.: SETO TA,
DPB TA,OP.SEG## ;SET SEGMENT BIT
POPJ PP,
INTER. PA341.
PA341.: SETO TA,
DPB TA,OP.NDP## ;SET 'NO DATA PHRASE' BIT
PUSHJ PP,PA22. ;OUTPUT RECEIV OPERATOR
P341A: HRRZI TA,23 ;SPIF OP CODE
PUSHJ PP,SETOP1
SETO TA,
DPB TA,OP.ATE## ;SET 'AT END' BIT
DPB TA,OP.SPN## ;SPECIAL IF, NO I-O
JRST PA90.A ;OUTPUT SPIF
>;END OF MCS ACTIONS
;STRING ACTIONS
;OUTPUT DUMMY DATAB ENTRY FOR MISSING DATA ITEM
INTER. PA360.
PA360.: PUSHJ PP,DE111. ;?IDENTIFIER EXPECTED
PUSHJ PP,PA263. ;SUBSTITUTE DUMMY DATAB ENTRY
JRST PA21.
;SET UP SDELIM OPERATOR
INTER. PA361.
PA361.: HRRZI TA,SDELIM
JRST SETOP
;MISSING DELIMITED BY CLAUSE
INTER. PA363.
PA363.: EWARNW E.462 ;?'DELIMITED BY' CLAUSE REQUIRED
PUSHJ PP,PA361. ;SET UP SDELIM OPERATOR WITH SIZE FLAG
SKPNAM
;SET 'DELIMITED BY SIZE' FLAG
INTER. PA362.
PA362.: SETO TA,
DPB TA,OP.DSZ##
POPJ PP,
;SET UP STRING OPERATOR
INTER. PA364.
PA364.: HRRZI TA,STRNG
JRST SETOP
;SET 'WITH POINTER' FLAG
INTER. PA365.
PA365.: SETO TA,
DPB TA,OP.PTR##
POPJ PP,
;SET 'ON OVERFLOW' FLAG
INTER. PA366.
PA366.: SETO TA,
DPB TA,OP.OVF##
PUSHJ PP,PA820. ;PUT RESERVED WORD ON TEMTAB STACK
POPJ PP,
;UNSTRING ACTIONS
INTER. PA370.
PA370.: HRLZI TA,ARG1 ;SAVE SOME THINGS ABOUT SOURCE-ITEM
HRRI TA,STRSAV## ;ADDR OF SAVE AREA
BLT TA,STRSAV+1 ;[765] SAVE OPERAND (TWO WORDS)
MOVE TB,NSBSC1
MOVEM TB,STRSAV+2 ;SAVE # OF SUBSCRIPTS
HRLI TA,SBSCR1
HRRI TA,STRSAV+3
BLT TA,STRSAV+3+<MAXSUB*4>-1 ;[765] SAVE SUBSCRIPT INFO
SETZM NSBSC1## ;RESET SUBSCRIPT COUNT FOR NEXT ITEM.
POPJ PP,
INTER. PA372.
PA372.: HRRZI TA,UDELIM ;SET UP UDELIM OPERATOR
JRST SETOP
INTER. PA373.
PA373.: SETO TA, ;SET THE 'ALL' FLAG
DPB TA,OP.ALL##
POPJ PP,
INTER. PA374.
PA374.: PUSHJ PP,PA22. ;OUTPUT PREVIOUS UDELIM
JRST PA372. ;SET UP NEW UDELIM OP
INTER. PA375.
PA375.: HRRZI TA,UNSDES ;SET UP UNSDES OPERATOR
JRST SETOP
INTER. PA376.
PA376.: SETO TA, ;SET 'DELIMITER IN' FLAG
DPB TA,OP.DEL##
POPJ PP,
INTER. PA377.
PA377.: SETO TA, ;SET 'COUNT IN' FLAG
DPB TA,OP.COU##
POPJ PP,
INTER. PA378.
PA378.: PUSHJ PP,PA22. ;OUTPUT LAST UNSDES OP
HRLZI TA,STRSAV ;SET UP TO RESTORE SOURCE-ITEM
HRRI TA,ARG1
BLT TA,ARG1+1
MOVE TB,STRSAV+2
MOVEM TB,NSBSC1 ;GET # OF SUBSCRIPTS
HRLI TA,STRSAV+3
HRRI TA,SBSCR1 ;RESTORE SUBSCRIPT INFO
BLT TA,SBSCR1+<MAXSUB*4>-1 ;[765] FOUR WORDS FOR EACH SUBSCRIPT
PUSHJ PP,PA21. ;OUTPUT IT
HRRZI TA,UNSTR ;SET UP UNSTR OPERATOR
JRST SETOP
INTER. PA379.
PA379.: SETO TA, ;SET 'TALLYING IN' FLAG
DPB TA,OP.TLG##
POPJ PP,
INTER. PA380.
PA380.: PUSHJ PP,PA22. ;OUTPUT PREVIOUS UNSDES OPERATOR
JRST PA375. ;SET UP NEW UNSDES OP
; CHECK FIG CONSTANT- ONLY ZERO IS LEGAL.
INTER. PA400.
PA400.: LDB TA,[POINT 9,W1,17] ;[265] GET WHICH FIG CONSTANT
CAIN TA,ZERO. ;[265] IS IT ZERO?
JRST PA2. ;[265] YES-OK
EWARNW E.131 ;[265] NO- ILLEGAL
MOVEI TA,ZERO. ;[265] MAKE ZERO
DPB TA,[POINT 9,W1,17] ;[265] TO PREVENT MORE ERRORS
JRST PA2. ; [265]
;SET WITH SEQUENCE CHECK FOR MERGE VERB
INTER. PA401.
PA401.: FLAGAT NS
SETO TA,
DPB TA,OP.WSC##
POPJ PP,
;Error recovery nodes
INTER. PA450.
PA450.: PUSHJ PP,PAYECC ;SET OPERATOR TO "YECCH"
EWARNJ E.104 ;DATA-NAME NOT DEFINED
INTER. PA451.
PA451.: PUSHJ PP,PAYECC ;SET OPERATOR TO "YECCH"
EWARNJ E.101 ;IDENTIFIER EXPECTED
SUBTTL COBOL-74 SYNTAX
;START FILE-NAME KEY ARITHMETIC-CONDITION
INTER. PA500.
PA500.: SETO TA,
DPB TA,OP.EQU
POPJ PP,
INTER. PA501.
PA501.: SETO TA,
DPB TA,OP.GRT
POPJ PP,
INTER. PA502.
PA502.: SETO TA,
DPB TA,OP.LES
POPJ PP,
INTER. PA503.
PA503.: PUSHJ PP,PA2. ;GET FILTAB
MOVE TA,ARG1
HRLZM TA,CURFIL ;SAVE FOR LATTER CHECKING
SKIPN FLGSW ;WANT FIPS FLAGGER?
JRST PA21. ;NO, WRITE OPERAND
ADD TA,FILLOC ;ADD IN BASE
LDB TB,FI.ORG ;GET FILE ORGANIZATION
MOVE TA,[0 ;SEQUENTIAL - NOT POSSIBLE
%LV.HI ;RELATIVE
%LV.H ;INDEXED
0](TB)
PUSHJ PP,FLG.ES## ;FLAG IF ILLEGAL
JRST PA21. ;OUTPUT OPERATOR
;START.. KEY IS DATANAME
; DATANAME MUST BE EITHER
;1) A KEY OF THAT FILE
;2) AN ITEM SUBORDINATE TO THAT KEY WITH THE SAME STARTING POSITION
; IF 2),
; AND DATANAME SIZE IS LESS THAN KEY SIZE, THE SIZE IS PASSED TO PHASE E
INTER. PA504.
PA504.: HLRZ TA,CURFIL
PUSHJ PP,LNKSET ;CONVERT TO ADDRESS
HRRM TA,CURFIL
HRRZ TB,ARG1 ;GET ITEM
LDB TC,FI.ORG##
JRST @[EXP PA504E,PA504R,PA504I,PA504E](TC)
;RELATIVE FILE
PA504R: LDB TC,FI.ACK## ;GET ACTUAL KEY
CAMN TC,TB ;IS IT THE SAME AS USER SPECIFIED?
POPJ PP, ;YES, ALL IS WELL
CAIE TC,AS.MSC## ;NO, COULD IT BE A CONVERTED KEY?
JRST PCASER ;NO
LDB TC,FI.CKA## ;YES, GET REAL KEY
CAME TC,TB ;CHECK AGAIN
JRST PCASER ;STILL WRONG
POPJ PP,
;INDEXED FILES
PA504I:
;CHECK THE PRIMARY RECORD KEY
PCASK0: MOVE TA,TB ;PTR TO ITEM
PUSHJ PP,LNKSET ;GET ITEM PTR
LDB TD,DA.DFS## ;Better be defined in the file section..
JUMPE TD,PCASKE ; No, can't be a key then.
;This data item is defined in the file section. Now we can check
; LOC and RES to see if it starts in the same place as a key.
; [1354] Also store size in case multiple keys with the same offsets.
LDB TD,DA.INS## ;[1354] Get size of user's item
MOVEM TD,DKEYSZ## ;[1465] [1354] save for later test
LDB TD,DA.LOC ;GET LOC
LDB TE,DA.RES ;AND RESIDUE
MOVE TA,CURFIL
LDB TA,FI.RKY ;GET PTR TO RECKEY
JUMPE TA,PAYECC ;(If no record key defined, then this
; program has errors. Forget about trying
; to generate code for this START statement).
PUSH PP,TD ;SAVE LOC
PUSH PP,TE ; and RES of the user's item
PUSHJ PP,LNKSET ;Point to DATAB entry of RECORD KEY.
LDB TD,DA.LOC
LDB TE,DA.RES
CAMN TD,-1(PP) ;DOES ITEM START SAME PLACE AS KEY?
CAME TE,0(PP)
JRST PCASAK ;NO, TRY ALTERNATE KEYS
LDB TD,DA.INS ;[1354] Get size of key field
CAMGE TD,DKEYSZ ;[1465] [1354] If key greater or equal, match
JRST PCASAK ;[1354] else search alternatives
POP PP,(PP)
POP PP,(PP) ;FIX STACK
JRST PCASK1 ;GO USE RECORD KEY
;NOT THE PRIMARY RECORD KEY.. TRY ALTERNATE KEYS
;TOP OF STACK HAS RESIDUE & LOC OF THE ITEM
PCASAK: MOVE TA,CURFIL
LDB TA,FI.ALK ;SEE IF ANY ALTERNATE KEYS EXIST
JUMPE TA,PCASKP ;NO, ERROR, CLEAN UP STACK
PUSH PP,TA ;SAVE # OF ENTRY (1 INITIALLY)
PUSH PP,[2] ;WE'RE AT KEY #2 NOW
PCASK2: ADD TA,AKTLOC ;POINT TO ALTERNATE KEY TABLE
PCAS2A: LDB TA,AK.DLK ;DATAB LINK IN TA
PUSHJ PP,LNKSET
LDB TD,DA.LOC
LDB TE,DA.RES
CAMN TD,-3(PP)
CAME TE,-2(PP) ;MATCH?
JRST PCASK3 ;NO, TRY NEXT ALT KEY
LDB TD,DA.INS ;[1354] Get size of key field
CAMGE TD,DKEYSZ ;[1465] [1354] If key greater or equal, match
JRST PCASK3 ;[1354] else search alternatives
POP PP,TD ;FIX STACK
POP PP,(PP)
POP PP,(PP)
POP PP,(PP)
JRST PCASKG ;GO WRITE KEY VALUE
;THIS KEY ISN'T THE ONE. TRY THE NEXT ONE, IF ANY.
PCASK3: MOVEI TA,SZ.AKT ;BUMP UP TO NEXT ENTRY
ADDB TA,-1(PP) ;TA= ENTRY NUMBER
ADD TA,AKTLOC ;POINT TO ENTRY
HRRZ TA,TA ;JUST RH
HRRZ TB,AKTNXT ;CHECK PAST END OF TABLE
CAML TA,TB ;ARE WE PAST IT?
JRST PCASK6 ;YES, GIVE ERROR
AOS (PP) ;ASSUME OK, BUMP KEY NUMBER
LDB TC,AK.FLK ;CHECK FILTAB LINK
HLRZ TB,CURFIL
CAMN TB,TC ;STILL SAME FILE?
JRST PCAS2A ;YES, GO TRY THIS KEY
;NO KEY MATCHED.. ADJUST STACK AND GIVE ERROR
PCASK6: POP PP,(PP)
POP PP,(PP)
PCASKP: POP PP,(PP)
POP PP,(PP)
JRST PCASKE
;HERE IF PRIMARY KEY IS THE ONE
;TA POINTS TO RECKEY, ARG1 IS LINK TO ITEM
PCASK1: MOVEI TD,1 ;SET TD TO 1
;KEY# IS IN "TD"
;TA POINTS TO ALTKEY OR RECKEY, ARG1 IS LINK TO ITEM
PCASKG: PUSH PP,TD ;SAVE KEY NUMBER
;ITEM IS THE KEY OR ITEM SUBORDINATE TO IT.
LDB TC,DA.INS ;IS SIZE THE SAME?
PUSH PP,TC
HRRZ TA,ARG1
PUSHJ PP,LNKSET
LDB TD,DA.INS
POP PP,TC
CAME TC,TD ;SKIP IF SAME SIZE
JRST PCASG0 ;NO, "APPROXIMATE KEY"
POP PP,TB ;KEY # IN RH
SETO TA, ;-1 + 0,,KEY#
PJRST PUTGEN ;WRITE IT OUT AND RETURN
;APPROXIMATE KEY
PCASG0: HRRZ TE,TD ;INTERNAL SIZE
POP PP,TD ;KEY #
;
;WRITE OUT ARG AS -1 + SIZE,,KEY#
SETO TA, ;-1
HRLZ TB,TE ;SIZE IN LH
HRR TB,TD ;KEY # IN RH
DPB TA,OP.APK## ;SET APPROX. KEY BIT
PJRST PUTGEN ;WRITE TO GENFIL AND RETURN
;CONT'D ON NEXT PAGE..
;PCASKI ROUTINE (CONT'D) ** ERRORS **
;Organization not relative or indexed.
PA504E: MOVEI DW,E.205 ;ORGANIZATION MUST BE RELATIVE OR INDEXED
JRST PCASEX
PCASER: SKIPA DW,[E.739] ;THIS ITEM MUST BE THE RELATIVE KEY
PCASKE: MOVEI DW,E.619 ;MUST BE A KEY OR ITEM SUBORDINATE TO IT
PCASEX: LDB CP,[POINT 7,ARG1+1,35] ;POINT AT DATANAME
LDB LN,[POINT 13,ARG1+1,28]
PUSHJ PP,FATAL ;GIVE ERROR
JRST PAYECC ;SET OPERAND TO "YECCH"
;USE FOR DEBUGGING ...
INTER. PA510.
PA510.: FLAGAT LI
SKIPN DEBSW## ;DEBUG STUFF REQUIRED?
JRST SKPSEC ;NO, SKIP REST OF SECTION
MOVEI TA,17 ;[*DMN*] CHANGE OPERATOR TO "USE FOR DEBUGGING"
PUSHJ PP,SETOP3 ;[*DMN*] SO ALL IS HANDLED CORRECTLY
MOVE TA,[CD.USE,,SZ.USE] ;GET ROOM FOR NEW ENTRY
PUSHJ PP,GETENT
MOVEI TB,%UT.DB ;SET USE FOR DEBUGGING CODE
DPB TB,US.TYP##
HLRZ TB,CURPRO ;LINK USE TO CURRENT SECTION
DPB TB,US.PRO##
HLRZM TA,CURUSE## ;REMEMBER REL ADDR OF USETAB ENTRY
POPJ PP,
INTER. PA511.
PA511.: HRRZ TE,CURUSE ;GET CURRENT USETAB ENTRY
JUMPE TE,CPOPJ ;GIVE UP
MOVEM TE,DEBALP## ;TURN ON ALL PROCEDURES FLAG FOR PHASE E
POPJ PP,
IFN MCS,<
INTER. PA512.
PA512.: PUSHJ PP,PA2.HI ;CD-NAME
HRRZ TA,ARG1 ;GET LINK POINTER
JUMPE TA,CPOPJ ;GIVE UP
ADD TA,CDLOC
LDB TB,CD.DUP## ;SEE IF ALREADY DEFINED
JUMPN TB,JDE517 ;YES, ERROR
HRRZ TB,CURUSE ;LINK TO CURRENT USE SECTION
DPB TB,CD.DUP
LDB TB,CD.RDL## ;GET 01 RECORD ASSOCIATED WITH CD-NAME
MOVEM TB,CURDAT ;IT MIGHT MOVE SO SAVE TABLE LINK
MOVE TA,[CD.DAT,,SZ.DAT] ;GET A BASIC DATAB ENTRY
PUSHJ PP,GETENT
EXCH TA,CURDAT ;SAFE PLACE
PUSHJ PP,LNKSET ;GET CD RECORD DATAB ADDRESS
HRLZ TA,TA ;FROM
HRR TA,CURDAT ;TO
MOVEI TB,SZ.DAT-1(TA) ;END
BLT TA,(TB) ;COPY DATA
MOVE TA,ARG1 ;GET CDTAB LINK
ADD TA,CDLOC
HLRZ TB,CURDAT ;LINK TO DATAB
DPB TB,CD.FDL## ;SO DEBUG USE CAN FIND IT
MOVE TB,0(TA) ;GET CD.NAM,,CD.SNL
MOVE TA,CURDAT ;POINT TO NEW DATAB
MOVEM TB,0(TA) ;AND POINT NEW DATAB AT NAMTAB
POPJ PP,
>;END IFN MCS
INTER. PA513.
PA513.: PUSHJ PP,PA2.HI ;FILE-NAME
HRRZ TA,ARG1 ;GET LINK POINTER
JUMPE TA,CPOPJ ;GIVE UP
PUSHJ PP,LNKSET
LDB TB,FI.DEB## ;SEE IF ALREADY DEFINED
JUMPN TB,JDE517 ;YES, ERROR
LDB TB,FI.IRM## ;GET RECORD USAGE
LDB TC,FI.MRS## ;GET SIZE
IDIV TC,[EXP 6,1,5,4,5](TB) ;GET SIZE IN WORDS
SKIPE TB
ADDI TC,1 ;COUNT REMAINDER
CAMLE TC,MAXDBC## ;BIGGEST YET?
MOVEM TC,MAXDBC ;YES
HLRZ TA,CURPRO ;SEE IF WE ALREADY HAVE A TAG FOR THIS USE PROCDURE
ANDI TA,077777
ADD TA,PROLOC##
LDB CH,PR.SFI## ;GET IT
SKIPN CH ;SKIP IF DEFINED
PUSHJ PP,GETTAG ;ELSE, GET NEXT TAG
HRRZ TA,ARG1
ADD TA,FILLOC ;POINT TO FILTAB
DPB CH,FI.DEB## ;SAVE TAG IN FILE TABLE
HLRZ TA,CURPRO
ANDI TA,077777
ADD TA,PROLOC##
DPB CH,PR.SFI## ;SIGNAL CLEAND TO USE THIS TAG
POPJ PP,
INTER. PA514.
PA514.: TLNN W1,GWNOT ;IS ITEM ALREADY IN NATAB?
JRST [HALT] ;YES, THEN ITS NOT A PROCEDURE REQUEST
PUSHJ PP,PA2.
PUSHJ PP,PA158. ;PUT USE PROCEDURE IN FLOTAB
HRRZ TA,CURUSE ;POINT BACK TO START OF USETAB ENTRY
ADD TA,USELOC
LDB TB,US.XTR## ;HAVE WE BEEN HERE BEFORE
JUMPN TB,PA514A ;YES
MOVE TA,[CD.USE,,1] ;NO
PUSHJ PP,GETENT ;EXPAND ENTRY
HRRZ TA,CURUSE
ADD TA,USELOC ;GET ADDRESS BACK
MOVEI TB,1
DPB TB,US.XTR ;SET EXTRA WORD FLAG
DPB TB,US.CNT## ;AND NEW COUNT
JRST PA514B ;THE FIRST TIME IS SPECIAL
PA514A: LDB TB,US.CNT## ;GET CURRENT COUNT
ADD TB,TA ;ADVANCE POINTER
HRRZ TC,(TB) ;DO WE ALREADY HAVE VALUE STORED?
JUMPN TC,PA514B ;YES, NEED EXTRA WORD
HLRZ TC,CURFLO
HRRM TC,(TB) ;STORE FLOTAB LINK
POPJ PP,
PA514B: LDB TB,US.CNT
ADDI TB,1
DPB TB,US.CNT ;MAKE ONE BIGGER
MOVE TA,[CD.USE,,1] ;EXPAND CURRENT USETAB ENTRY
PUSHJ PP,GETENT
HLRZ TB,CURFLO ;GET FLOTAB
HRLZM TB,(TA) ;SAVE IT IN EXTRA USETAB WORD
POPJ PP,
INTER. PA515.
PA515.: PUSHJ PP,PA516. ;ALL REFERENCES OF IDENTIFIER-1
SETO TB,
DPB TB,DB.ARO## ;SET ALL REF. FLAG
POPJ PP,
INTER. PA516.
PA516.: HRRZ TA,ARG1 ;GET LINK POINTER
JUMPE TA,CPOPJ ;GIVE UP
PUSHJ PP,LNKSET
LDB TB,DA.DEB## ;SEE IF ALREADY DEFINED
JUMPN TB,JDE517 ;YES, ERROR
SETO TB,
DPB TB,DA.DEB ;SET IT NOW
MOVE TA,[CD.DEB,,SZ.DEB]
PUSHJ PP,GETENT ;GET SPACE IN DEBTAB
HRRZ TB,ARG1 ;GET DATAB
DPB TB,DB.DAT## ;SAVE POINTER
HRRZ TB,CURUSE ;LINK TO CURRENT USE SECTION
DPB TB,DB.DUP##
POPJ PP,
JDE517: EWARNJ E.517
;FOR DEBUGGING..
INTER. PA520.
PA520.:
IFN DEBUG,<
PUSHJ PP,PA2. ;READ LITERAL, CHECK FOR ERRORS
HLRZ TA,ARG1 ;LOOK AT LITERAL
ANDI TA,777 ;GET LENGTH
CAIE TA,1 ;MUST BE ONE CHAR LONG.
JRST P520E1 ;NO, GIVE ERROR
HRRZ TA,ARG1 ;LOOK IN VALTAB
TRZ TA,700000
ADD TA,VALLOC## ;GET ADDRESS OF IT
HRLI TA,(POINT 7,)
IBP TA ;SKIP OVER LENGTH
ILDB TB,TA ;GET THE LETTER
CAIN TB,"D"
JRST P520DD ;COMPILER BREAK IN PHASE D
CAIN TB,"E"
JRST P520.E ;PASS INFO TO PHASE E
CAIE TB,"O"
CAIN TB,"G"
JRST P520.E ;PASS INFO TO PHASE E
OUTSTR [ASCIZ/?PA520: bad value for literal
/]
JRST P520.X ;SET OPR TO "YECCH"
;COMPILER-BREAK-IN-PHASE "E"
P520.E: PUSHJ PP,PA21. ;WRITE OPERAND = LITERAL
HRRZI TA,OPCBPH ;"COMPILER BREAK IN PHASE"
JRST SETOP1 ;SET OPERATOR
P520E1: OUTSTR [ASCIZ/?PA520: one-character literal expected after/]
JRST P520EE
;HERE TO SET BREAKPOINT FOR PHASE D
P520DD: OUTSTR [ASCIZ/[$CBD]
/]
$CBD:: JFCL ;FALL INTO P520.X
>;END IFN DEBUG
;COMPILER-BREAK-IN-PHASE "<BAD LETTER>"
P520.X: HRRZI TA,105 ;"YECCH"
JRST SETOP1 ;SET OPERAND AND RETURN
INTER. PA521.
PA521.:
IFN DEBUG,<
OUTSTR [ASCIZ/?PA521.: non-numeric literal expected after/]
P520EE: OUTSTR [ASCIZ/
"COMPILER-BREAK-IN-PHASE"
/]
>;END IFN DEBUG
JRST P520.X ;SET OPERATOR TO "YECCH" AND RETURN
;RPW: SUPPRESS [PRINTING].
INTER. PA523.
PA523.: HRRZI TA,161 ;"SUPPRESS" OP CODE
PUSHJ PP,SETOP ;SET IT UP
SKIPN INUPRG ;SKIP IF WE ARE IN GOOD USE PROCEDURE..
JRST P523.E ;NO, COMPLAIN
;DON'T ALLOW SUPPRESSION OF A TYPE DETAIL GROUP
HRRZ TA,INUPRG ;POINT TO RPWTAB ENTRY
ADD TA,RPWLOC ; ABS. ADDR
LDB TB,RW.TYP## ;MAKE SURE NOT TYPE DE
CAIN TB,%RG.DE
JRST P523.F ;COMPLAIN
;GET A %PARAM WORD UNLESS WE GOT ONE ALREADY.
HRRZ TA,INUPRG ;POINT TO RPWTAB ENTRY
ADD TA,RPWLOC ; ABS ADDR
LDB TB,RW.SUP## ;GET RUNTIME LOCATION
JUMPN TB,P523A ;ALREADY GOT IT
AOS TB,RPWPRS## ;GET ONE AND INCREMENT COUNTER
DPB TB,RW.SUP## ; REMEMBER A 'SUPPRESS' IS DONE FOR
; THIS REPORT GROUP
;ROUTINE "SETRPW" CALLED AT BEGINNING
; OF PHASE E ALLOCATES THE %PARAM WORD
P523A: MOVSI TA,(1B0) ;SET OPERAND BIT
PJRST PUTGEN ;WRITE IT OUT
;ERROR: "May only appear in a USE BEFORE REPORTING procedure"
P523.E: EWARNW E.636
JRST P523.X ;SET "YECCH" OPERATOR
;ERROR: "SUPPRESS not allowed for DETAIL lines - use GENERATE RD-name"
P523.F: EWARNW E.637
; JRST P523.X ;SET "YECCH" OPERATOR
P523.X: HRRZI TA,105 ;"YECCH"
JRST SETOP3 ;SET OPERAND AND RETURN
INTER. PA524.
;Here after parsing "IF <condition>..." or "WHEN <condition>.." expecting
; a statement. This routine checks to see if there was an error parsing
;<condition> and if so, POP's up a node in the syntax tree since we
;have eaten to the next period.
PA524.: CAIN TYPE,PRIOD. ;Are we at "." now?
SKIPN ERSKIP## ;Yes, error in condition parsing?
POPJ PP, ;No, let parser give error for random "."
SETZM ERSKIP## ;Yes, clear flag
JRST PA0. ;Pop up node in tree
;SKIP THE ENTIRE SECTION
;REQUIRED FOR DEBUG MODULE WHEN "FOR DEBUGGING" IS NOT SPECIFIED.
;WE HAVE TO SKIP THE CURRENT PARAGRAPH AND ALL SUBSEQUENT ONES
;UNTIL ANOTHER SECTION IS FOUND
SKPSEC: PUSHJ PP,SKPPGF## ;SKIP REST OF THIS PARAGRAPH
PUSHJ PP,GETITM ;GET FIRST WORD OF NEXT PARAGRAPH
CAIE TYPE,END.+AMRGN. ;IS IT RESERVED WORD END DECLARATIVES
CAIN TYPE,ENDIT. ;OR END-OF-FILE?
JRST SKPSC1 ;YES
CAIE TYPE,USERN.+AMRGN. ;POSSIBLE PARAGRAPH NAME?
JRST SKPSEC ;NO
PUSHJ PP,PA2. ;DO ACTION OF PD14.
PUSHJ PP,GETITM ;GET NEXT WORD
CAIE TYPE,SECT. ;SECTION?
JRST SKPSEC ;NO
MOVEI NODE,PD20.##
MOVEM NODE,(NODPTR) ;RESET THE CURRENT NODE TO PD20.
JRST PCA1. ;AND PERFORM THE ACTION OF NODE PD20.
SKPSC1: MOVEI NODE,PD36.##
MOVEM NODE,(NODPTR) ;RESET THE CURRENT NODE TO PD36.
JRST PA147. ;AND PERFORM THE ACTION OF NODE PD36.
;READ & FIND A DEFINED DATA-NAME WITH ALL QUALIFIERS
;RETURNS TE=DATAB LINK
INTER. DA96.D
DA96.D: SETZM TBLOCK ;CLR TBLOCK
MOVE TA,[TBLOCK,,TBLOCK+1]
BLT TA,TBLOCK+24
MOVEM W2,TBLOCK+4 ;FACTS ABOUT DATA-NAME TO TBLOCK SETUP
DA96.1: PUSHJ PP,GETITM ;READ NEXT SOURCE WORD
CAIE TYPE,OF. ;IS IT "OF" OR "IN"?
JRST DA96.2 ;NO, TIME TO EXIT
PUSHJ PP,GETITM ;YES, QUALIFIER SHOULD FOLLOW
CAILE TYPE,ENDIT. ;IS IT A RESERVED WORD?
JRST DA96.0 ;NO, IT'S OK
SWON FREGWD ;YES, PREPARE TO REGET THAT ITEM
EWARNJ E.101 ;& FLAG THIS AS ILLEGAL QUALIFIER
DA96.0: AOS TA,TBLOCK+1 ;COUNT THE QUALIFIER
LDB TB,[POINT 15,W2,15] ;GET NAMTAB LINK
JUMPL W1,JDE104 ;[240] QUALIFIER MUST BE DEFINED
MOVEM TB,TBLOCK+4(TA) ;STORE NAMTAB LINK OF QUAL IN TBLOCK
JRST DA96.1 ;ANY MORE QUALS?
DA96.2: SWON FREGWD ;REGET THIS LAST WORD THAT WASN'T "OF"
PUSHJ PP,FINDAT## ;FIND A DATAB MATCH FOR THE ITEM
JUMPN DW,DA96.3 ;SKIP IF ERROR
POPJ PP, ;RETURN WITH DATAB LINK IN TE
JDE104: MOVEI DW,E.104 ;[240] NAME IS UNDEFINED
DA96.3: PUSHJ PP,FATAL## ;GIVE MESSAGE
MOVEI TE,<CD.DAT>B20+1 ;AIM AT DUMMY ENTRY
POPJ PP,
SUBTTL SIMULTANEOUS UPDATE SYNTAX
; ACTIONS PASU1 THROUGH PASU21 ARE USED TO SCAN THE OPEN STATEMENT,
; AS MODIFIED TO SUPPORT SIMULTANEOUS UPDATE. NO GEN FILE OUTPUT IS
; PRODUCED UNTIL THE OPEN STATEMENT IS COMPLETELY SCANNED.
;
;
; EACH FILENAME SCANNED DURING THE SCANNNING OF AN OPEN STATEMENT
; RESULTS IN THE CREATION OF A TABLE ENTRY IN THE TABLE CALLED BUFFER.
; THERE MAY BE UP TO EIGHT SUCH TABLE ENTRIES.
; EACH TABLE ENTRY HAS THE FOLLOWING FORMAT:
;
; WORD 0:
;
OPN%I==400000 ;BIT 0: INPUT
OPN%O==200000 ;BIT 1: OUTPUT
OPN%IO==100000 ;BIT 2: INPUT-OUTPUT
OPN%NR==040000 ;BIT 3: NO REWIND
OPN%FR==020000 ;BIT 4: FOR READ
OPN%FC==010000 ;BIT 5: FOR REWRITE (CHANGE)
OPN%FW==004000 ;BIT 6: FOR WRITE
OPN%FD==002000 ;BIT 7: FOR DELETE
OPN%FA==001000 ;BIT 8: FOR ALL
OPN%ON==000400 ;BIT 9: OTHERS NONE
OPN%OR==000200 ;BIT 10: OTHERS READ
OPN%OC==000100 ;BIT 11: OTHERS REWRITE (CHANGE)
OPN%OW==000040 ;BIT 12: OTHERS WRITE
OPN%OD==000020 ;BIT 13: OTHERS DELETE
OPN%OA==000010 ;BIT 14: OTHERS ALL
OPN%UN==000004 ;BIT 15: USER SUPPLIED UNAVAILABLE STATEMENT (1ST FILENAME ONLY)
OPN%EX==000002 ;BIT 16: [74] EXTENDED
OPN%RV==000001 ;BIT 17: [74] REVERSED
;
; WORD 1: SAVE W1
;
; WORD 2: SAVE W2
;
; WORD 3: SAVE CT
;
; WORD 4: SAVE NAMWRD
;
; WORD 5: SAVE NAMWRD + 1
;
; WORD 6: SAVE NAMWRD + 2
;
; WORD 7: SAVE NAMWRD + 3
;
; WORD 8: SAVE NAMWRD + 4
; THE GENFIL GENERATED FOR AN OPEN STATEMENT INCLUDING SIMULTANEOUS
; UPDATE LOOKS LIKE THIS:
;
; FILE-NAME-1
; FENQ (OP CODE 143) WITH FLAGS INDICATING USAGE
; .
; .
; .
; FILE-NAME-N
; FENQ, AS ABOVE
; EFENQ (OP CODE 146) WITH FLAG INDICATING IF USER SUPPLIED
; AN UNAVAILABLE STATEMENT
; FILE-NAME-1
; OPEN
; .
; .
; .
; FILE-NAME-M M>=N
; OPEN
; FUNAV (OP CODE 144) IF USER SUPPLIED UNAVAILABLE STATEMENT
; [GENFIL FOR UNAVAILABLE STATEMENT]
; EFUNAV (OP CODE 145) IF USER SUPPLIED UNAVAILABLE STATEMENT
INTER. PASU1.
PASU1.: SETZM BUFCTR; INITIALIZE BUFFER TABLE
SETZM BUFFER; INITIALIZE WORD 0 OF THE 1ST ENTRY
JRST PA49.; EXECUTE PA49 IN CASE THIS IS A DBMS OPEN
INTER. PASU2.
PASU2.: MOVEI TD,OPN%I; SET INPUT BIT
MOVEI TC,OPN%O!OPN%IO!OPN%EX; CLEAR OUTPUT AND INPUT-OUTPUT BITS
PASU2A: PUSHJ PP,PASU2B; SET UP TA
MOVE TB,BUFFER(TA)
TLZ TB,0(TC); ZERO BITS INDICATED BY TC
TLO TB,0(TD); SET BITS INDICATED BY TD
MOVEM TB,BUFFER(TA)
POPJ PP,
PASU2B: MOVE TA,BUFCTR; THIS SUBROUTINE PREPARES IN TA A
CAIGE TA,^D16; RELATIVE POINTER TO THE CURRENT ENTRY
JRST PASUYY
EWARNW E.573; IN THE BUFFER TABLE, AFTER CHECKING
SETZB TA,BUFCTR
PASUYY: LSH TA,3; THAT THE NUMBER OF FILE NAMES HAS NOT
ADD TA,BUFCTR; EXCEEDED 16.
POPJ PP,
INTER. PASU3.
PASU3.: MOVEI TD,OPN%O; SET OUTPUT BIT
MOVEI TC,OPN%I!OPN%IO!OPN%EX; CLEAR INPUT AND INPUT-OUTPUT BITS
JRST PASU2A
INTER. PASUE.
PASUE.: FLAGAT HI
MOVEI TD,OPN%O!OPN%NR!OPN%EX; SET OUTPUT, NO REWIND & EXTEND BITS
MOVEI TC,OPN%I!OPN%IO; CLEAR INPUT AND INPUT-OUTPUT BITS
JRST PASU2A
INTER. PASUR.
PASUR.: FLAGAT HI
PUSHJ PP,PASU6B ;CHECK FOR NOT SUPPORTED WITH RMS FILES
MOVEI TD,OPN%RV ;SET REVERSED BIT
JRST PASU6A
INTER. PASU4.
PASU4.: MOVEI TD,OPN%IO; SET INPUT-OUTPUT BIT
MOVEI TC,OPN%I!OPN%O!OPN%NR!OPN%EX; CLEAR INPUT AND OUTPUT BITS
JRST PASU2A
INTER. PASU5.
PASU5.: PUSHJ PP,PASU2B; SET UP TA
ADDI TA,BUFFER
MOVE TB,TA ;MAKE A COPY FOR LATER TEST
PUSH TA,W1; SAVE EVERYTHING NECESSARY TO
PUSH TA,W2; LATER PRETEND WE HAVE JUST
PUSH TA,CT; SEEN THE FILENAME
PUSH TA,NAMWRD
PUSH TA,NAMWRD+1
PUSH TA,NAMWRD+2
PUSH TA,NAMWRD+3
PUSH TA,NAMWRD+4
HRRZ TA,W1 ;[757] GET FILE
ADD TA,FILLOC ;[757] IN FILE TABLE
LDB TE,FI.DSD ;[757] GET SD BIT
SKIPE TE ;[757] OK IF NOT AN SD
EWARNJ E.291 ;[757] IN AN SD, SO GIVE ERROR
LDB TE,FI.LCP## ;DOES FILE HAVE LINAGE CLAUSE
SKIPL AS7482## ;OK IN COBOL-74
SKIPN TE ;BUT NOT IN COBOL-8x
JRST PASU5A
HLRZ TE,(TB) ;GET OPEN MODE
TRNE TE,OPN%EX ;OPEN EXTEND IS ILLEGAL
EWARNJ E.825 ;TELL USER
PASU5A: LDB TE,FI.RPG##
JUMPE TE,CPOPJ ;OK IF NOT A REPORT WRITER FILE
HLRZ TE,(TB) ;GET FLAGS
TRZ TE,OPN%O!OPN%EX!OPN%NR ;[1563] ONLY ALLOW OUTPUT, EXTEND, OR
;[1563] NO REWIND
JUMPE TE,CPOPJ ;OK
EWARNJ E.748 ;NO, WARN USER
INTER. PASU6.
PASU6.: FLAGAT HI
PUSHJ PP,PASU6B ;TEST FOR UNSUPPORTED CLASUE WITH RMS FILE
MOVEI TD,OPN%NR; SET NO REWIND BIT
PASU6A: SETZ TC,; CLEAR NO BITS
JRST PASU2A
PASU6B: ;
HRRZ TA,CURFIL ;
LDB TE,FI.RMS ;CHECK FOR RMS FILE AND WARN IF SO
CAIN TE,0 ;
POPJ PP, ; IS NOT
HRRZI DW,E.853 ;IT IS, SO WARN
PUSHJ PP,WARN## ;
POPJ PP, ;
INTER. PASU7.
PASU7.: PUSHJ PP,PASU2B; SET UP TA
MOVE TB,BUFFER(TA)
TLZ TB,037774; INITIALIZE 1ST WORD OF NEXT ENTRY
MOVEM TB,BUFFER+^D9(TA)
AOS BUFCTR; PUSH BUFFER TABLE
POPJ PP, ;RETURN
INTER. PASU9.
PASU9.: MOVEI TD,OPN%FR; SET FOR READ BIT
JRST PASU6A
INTER. PASU10
PASU10: MOVEI TD,OPN%FC; SET FOR REWRITE BIT
JRST PASU6A
INTER. PASU11
PASU11: MOVEI TD,OPN%FW; SET FOR WRITE BIT
JRST PASU6A
INTER. PASU12
PASU12: MOVEI TD,OPN%FD; SET FOR DELETE BIT
JRST PASU6A
INTER. PASU13
PASU13: MOVEI TD,OPN%FR!OPN%FC!OPN%FW!OPN%FD; SET FOR ALL BITS
JRST PASU6A
INTER. PASU14
PASU14: MOVEI TD,OPN%ON; SET OTHERS NONE BIT
JRST PASU6A
INTER. PASU15
PASU15: MOVEI TD,OPN%OR; SET OTHERS READ BIT
JRST PASU6A
INTER. PASU16
PASU16: MOVEI TD,OPN%OC; SET OTHERS REWRITE BI
JRST PASU6A
INTER. PASU17
PASU17: MOVEI TD,OPN%OW; SET OTHERS WRITE BIT
JRST PASU6A
INTER. PASU18
PASU18: MOVEI TD,OPN%OD; SET OTHERS DELETE BIT
JRST PASU6A
INTER. PASU19
PASU19: MOVEI TD,OPN%OR!OPN%OC!OPN%OW!OPN%OD; SET OTHERS ALL BITS
JRST PASU6A
INTER. PASU8.
PASU8.: SKIPN BUFCTR
POPJ PP,
MOVE TA,[XWD NAMWRD,HLDNAM##] ; [420] SAVE CURRENT
BLT TA,HLDNAM+4 ; [420] SOURCE ITEM
DMOVEM W1,HLDSRC## ; [420] STORE FIRST WORD OF SOURCE PARAMS
; [420] 2ND SOURCE WORD PARAMS
MOVEM CT,HLDSRC+2 ; [420] 3RD SOURCE PARAMS
;;;;;
;
; THE FOLLOWING 6 LINES OF CODE COMPUTE AND STORE THE SIZE OF THE ENQ
; BLOCK WHICH IS BEING CREATED FOR A SMU OPEN VERB. HOWEVER, THEY DO IT
; OBSCURELY. THEY START OFF WITH THE BUFCTR VALUE AS THE COUNT OF FILES
; IN THE OPEN, THEN THEY MULTIPLY THIS BY THREE WITH THE LSH AND ADD.
; THEY ORIGINALLY ADDED 2 TO INCLUDE THE ENQ BLOCK HEADER. I REALIZED
; THAT IT BUFCTR WAS ONE COUNT SHORT (OFF-BY-ONE BUG) FOR THE PURPOSES
; OF ARITHMETIC, SO I COMPOUNDED THE OBSCURITY BY SIMPLY ADDING 3 TO THE
; 2 MAKING 5. THIS PROCEDURE IDENTIFIES ONLY THE BUFFER SIZE FOR THE
; CURRENT OPEN, SO IT HAS TO BE COMPARED AGAINST THAT FOR THE BIGGEST
; SIZE SO FAR AND SAVED IN SUEQT., IF IT IS NOW THE BIGGEST. THIS ENQ
; BUFFER IS KNOWN AS THE SU.EQT TABLE, AND IT ALSO IS USED BY THE RETAIN
; VERB. SO A SIMILAR CALCULATION IS DONE AT SUCS1: UNDER PASU44:.
;
;;;;;
SETZM SU8FLG
MOVE TA,BUFCTR ;ADJUST SPACE REQUIRED FOR ENQ/DEQ BUFFERING
LSH TA,1
ADD TA,BUFCTR
ADDI TA,5 ;MAKE IT LONG ENOUGH TO COVER HDR + 1 REQ
CAMLE TA,SUEQT.
MOVEM TA,SUEQT.
SETZB TC,SU8CNT; GET READY FOR FIRST PASS OF BUFFER TABLE
;DURING THE 1ST PASS, DETERMINE
PASU8A: CAML TC,BUFCTR; WHICH FILES, IF ANY, ARE TO BE OPENED
JRST PASU8B; WITH SIMULTANEOUS UPDATE, AND FOR THOSE
LSH TC,3; FILES WHICH ARE, GENERATE APPROPRIATE
ADD TC,SU8CNT; CODE.
MOVE TD,BUFFER(TC)
TLNN TD,OPN%ON!OPN%OR!OPN%OC!OPN%OW!OPN%OD!OPN%OA
JRST PASU8R; JUMP IF NO SIMULTANEOUS UPDATE
TLNN TD,OPN%IO
PUSHJ PP,ERRNIO ;GIVE ERROR ABOUT NOT I-O MODE
HRRZ TA,BUFFER+1(TC) ;GET FILE-TABLE ADDRESS
ANDI TA,77777 ;JUST GET TABLE OFFSET
ADD TA,FILLOC ;LOOK AT THE FILTAB ENTRY
LDB TB,FI.RMS## ;IS THIS AN RMS FILE?
CAIN TB,0 ;IS BIT ON?
JRST PAS8A0 ; NO, FILE IS NOT RMS. GO CHECK FOR SEQUENTIAL
LDB TB,FI.ABL## ;FILE IS RMS, ARE WE DOING BASIC-LOCKING?
JUMPN TB,PAS8A1 ; JUMP IF WE ARE. LET BASIC-LOCKING DO
; ITS OWN THING IN RMS
PAS8A0: ;DON'T ALLOW SMU OPTION 1 ON SEQUENTIAL FILES
LDB TB,FI.ORG## ;GET FILE'S ORGANIZATION, AT THIS POINT
; IT IS NOT UNDETERMINED ANY MORE
SKIPN TB, ; SKIP IF NOT SEQUENTIAL
PUSHJ PP,ERRNSQ ;GIVE ERROR ABOUT NO OPTION 1 SIMULTANEOUS
; UPDATE FOR SEQUENTIAL FILES
PAS8A1:
MOVE TA,BUFFER+2(TC); SET UP LINE NUMBER AND CHARACTER POSITION
TLZ TA,777774; ZERO IRRELEVANT FIELDS
TLO TA,400000; SET OPERAND BIT
HRRZ TB,BUFFER+1(TC); SET UP FILE NAME TABLE ADDRESS
TRZ TB,700000; ZERO IRRELEVANT BITS
MOVEM TC,SU8SVC
PUSHJ PP,PUTGEN; GENERATE FILE NAME OPERAND
MOVE TC,SU8SVC
MOVE TD,BUFFER(TC)
LSH TD,-4; GET R, W, D BITS IN POSITION
TLZ TD,777077; ZERO EVERYTHING ELSE
MOVE TA,BUFFER(TC)
LSH TA,-2; GET OR, OR, OW, OD BITS IN POSITION
TLZ TA,777703; ZERO EVERYTHING ELSE
OR TA,TD
TLO TA,143000; COMBINE AND ADD OP CODE
HRRI TA,0
TLZ W2,777774
OR TA,W2; ADD LINE AND CHARACTER POSITION
HRRZI TB,000143; SET UP WORD 2
MOVE TE,BUFFER(TC) ;CHECK TO SEE IF WE HAVE UNAVAILABLE CLAUSE
TLNE TE,OPN%UN ; SPECIFIED FOR THIS FILE
HRLI TB,1 ;YES, STICK FLAG INTO LH OF WORD 2, WHICH
; IS CURRENTLY UNUSED.
PUSHJ PP,PUTGEN; GENERATE OPERATOR
SETOM SU8FLG
JRST PASU8C
PASU8R: TLNE TD,037000
EWARNW E.575 ;WARN IF FOR BUT NO OTHERS
PASU8C: AOS TC,SU8CNT
JRST PASU8A
PASU8B:
SKIPN ABSEEN## ;SKIP IF APPLY BASIC-LOCKING SEEN
SKIPN SU8FLG
JRST PASU8F; JUMP IF NO FILES OPENED FOR SIMULTANEOUS UPDATE
MOVE TA,BUFFER
LSH TA,6; GET FLAG INDICATING IF USER SUPPLIED
TLZ TA,777377; AN UNAVAILABLE STATEMENT AND MOVE
TLO TA,146000; TO BIT 9 OF OPERATOR FLAG FIELD
TRZ TA,777777
TLZ W2,777774
OR TA,W2
HRRZI TB,000146
PUSHJ PP,PUTGEN; GENERATE EFENQ OPERATOR
PASU8F: SETZB TA,SU8CNT; PREPARE TO MAKE SECOND PASS OF BUFFER TABLE
PASU8D: ;THIS TIME, GENERATE REGULAR OPEN CODE
;FOR FILES NOT OPEN FOR SIMULTANEOUS UPDATE
CAML TA,BUFCTR
JRST PASU8E
LSH TA,3
ADD TA,SU8CNT
MOVE TB,BUFFER(TA)
TLNE TB,000770
JRST PASU8Z ;JUMP IF OPEN FOR SIMULTANEOUS UPDATE
MOVEM TA,SU8SVA
PUSHJ PP,PA49.; EXECUTE OLD ACTION PA49 OF NODE PD491A
MOVE TA,SU8SVA
MOVE TB,BUFFER(TA)
MOVEM TB,SU8SVB
TLNE TB,OPN%I
PUSHJ PP,PA74.; EXECUTE OLD ACTION PA74 OF NODE PD491
MOVE TB,SU8SVB
TLNE TB,OPN%O
PUSHJ PP,PA75.; EXECUTE OLD ACTION OF NODE PD492
MOVE TB,SU8SVB
TLNE TB,OPN%IO
PUSHJ PP,PA76.; EXECUTE OLD ACTION PA76 OF NODE PD493
MOVE TA,SU8SVA
ADDI TA,BUFFER+^D8
HRLI TA,20
POP TA,NAMWRD+4
POP TA,NAMWRD+3
POP TA,NAMWRD+2
POP TA,NAMWRD+1
POP TA,NAMWRD
POP TA,CT
POP TA,W2
POP TA,W1
PUSHJ PP,PA2.; EXECUTE OLD ACTION PCA48 OF NODE PD496
PUSHJ PP,PA77.
SKIPN FLGSW## ;FIPS FLAGGER WANTED?
JRST PASU8J ;NO
LDB TB,FI.ORG ;GET FILE ORGANIZATION
SKIPE SU8CNT ;IF NOT FIRST FILE
ADDI TB,4 ;PUT IN SECOND SET
LDB LN,[POINT 13,W2,28] ;LOAD LN &
LDB CP,[POINT 7,W2,35] ;CP JUST IN CASE
MOVE TA,[%LV.L ;SEQUENTIAL FIRST FILE
%LV.LI ;RELATIVE FIRST FILE
%LV.H ;INDEXED FIRST FILE
0
%LV.HI ;SEQUENTIAL NOT FIRST FILE
%LV.LI ;RELATIVE, NOT FIRST FILE
%LV.H ;INDEXED, NOT FIRST FILE
0](TB)
PUSHJ PP,FLG.ES## ;FLAG IF ILLEGAL
PASU8J: PUSHJ PP,PA78.
MOVE TB,SU8SVB
TLNE TB,OPN%NR ;NO REWIND?
PUSHJ PP,PA79.; EXECUTE OLD ACTION PA79 OF NODE PD504
TLNE TB,OPN%EX ;EXTENDED?
PUSHJ PP,PA79E. ;YES
TLNE TB,OPN%RV ;REVERSED?
PUSHJ PP,PA79R. ;YES
PUSHJ PP,PA21. ;EXECUTE OLD ACTION PCA49 OF NODE PD507
PUSHJ PP,PA160.
AOS TA,SU8CNT
JRST PASU8D
PASU8E: MOVE TB,BUFFER
TLNN TB,OPN%UN; TEST IF USER SUPPLIED UNAVAILABLE STATEMENT
JRST PASU8M ;[420] DO OLD ACTION
MOVE TA,W2
TLZ TA,777774
TLO TA,144000; GENERATE FUNAV OPERATOR
HRRZI TB,000144
PUSHJ PP,PUTGEN
MOVE TA,[XWD HLDNAM,NAMWRD] ; [420] RESTORE CURRENT
BLT TA,NAMWRD+4 ; [420] SOURCE ITEM
DMOVE W1,HLDSRC## ; [420] RESTORE FIRST WORD OF SOURCE PARAMS
; [420] 2ND SOURCE WORD PARAMS
MOVE CT,HLDSRC+2 ; [420] 3RD SOURCE PARAMS
POPJ PP,
PASU8M: MOVE TA,[XWD HLDNAM,NAMWRD] ; [420] RESTORE CURRENT
BLT TA,NAMWRD+4 ; [420] SOURCE ITEM
DMOVE W1,HLDSRC## ; [420] RESTORE FIRST WORD OF SOURCE PARAMS
; [420] 2ND SOURCE WORD PARAMS
MOVE CT,HLDSRC+2 ; [420] 3RD SOURCE PARAMS
JRST PA0. ;EXECUTE OLD ACTION PA0. OF NODE PD508
;ERRORS THAT POINT TO THE FILENAME
; THESE ARE ROUTINES THAT RETURN AFTER CALLING "FATAL"
;WHEN CALLED, THEY ASSUME BUFFER+1(TC) HAS THE LN&CP INFO.
ERRNSQ: MOVEI DW,E.659 ;SMU OPTION 1 NOT ALLOWED FOR SEQENTIAL FILES
JRST ERRFXX ;FILE ERROR
ERRNIO: MOVEI DW,E.574 ;FILE MUST BE OPENED FOR I-O
ERRFXX: MOVE TA,BUFFER+2(TC) ;GET LN & CP INFO
LDB LN,[POINT 13,TA,28]
LDB CP,[POINT 7,TA,35] ;SAME BITS AS OPRTR FIELDS
PJRST FATAL ;GO GIVE FATAL ERROR AND RETURN
INTER. PASU20
PASU20: FLAGAT NS
PUSHJ PP,PA820. ;STORE IN TEMTAB IN CASE END-OPEN
MOVSI TA,OPN%UN; SET BIT INDICATING USER SUPPLIED UNAVAILABLE STATEMENT
IORB TA,BUFFER
JRST PASU8.
INTER. PASU21
PASU21: HRLZI TA,145000
TLZ W2,777774
OR TA,W2
HRRZI TB,000145
PUSHJ PP,PUTGEN; GENERATE EFUNAV OPERATOR
PUSHJ PP,PA24.
SWOFF UNCONT; SET SWITCH TO INDICATE IT'S OK FOR AN UNLABELED STATEMENT TO FOLLOW
;
;THE PURPOSE OF THE FOLLOWING CHANGE IS TO LET THE UNAVAILABLE CLAUSE
;BE FOLLOWED BY THE OPEN-MODE CLAUSE (I.E. INPUT, OUTPUT, I-O, EXTEND)
;SO THAT EACH FILE NAME MAY HAVE AN UNAVAILABLE CLAUSE. THIS WILL BE
;USED FOR SMU OPTION 5 WHERE THE LOCKING AT OPEN TIME WILL BE DONE ON
;A PER-FILE BASIS.
;
;;;;; JRST PA0.
POPJ PP,
PASU8Z: HRRZ TA,BUFFER+1(TA)
HRLZM TA,CURFIL
PUSHJ PP,LNKSET ;GET ADDRESS OF FILE TABLE
HRRM TA,CURFIL
SETO TB,
DPB TB,FI.IOO ;SET BIT INDICATING I-0 OPEN SEEN
AOS TA,SU8CNT
JRST PASU8D
;ACTIONS PASU30 THROUGH PASU45 GENERATE GENFIL FOR THE RETAIN
;STATEMENT. THE GENFIL FOR A RETAIN STATEMENT LOOKS LIKE THIS:
;
; FILE-NAME-1
; [DATA-NAME-1 OR LITERAL-1]
; RENQ (OP CODE 147) WITH FLAGS INDICATING USAGE
; .
; .
; .
; FILE-NAME-N
; [DATA-NAME-N OR LITERAL-N]
; RENQ, AS ABOVE
; ERENQ (OP CODE 150) WITH FLAG INDICATING IF USER SUPPLIED
; AN UNAVAILABLE STATEMENT
; [CODE FOR THE UNAVAILABLE STATEMENT]
; ERUNAV (OP CODE 151) IF USER SUPPLIED UNAVAILABLE STATEMENT
INTER. PASU30
PASU30: MOVE TA,W2; CREATE FILENAME OPERAND
TLZ TA,777774; AND SAVE IN SU30F1, SU30F2
TLO TA,400000
HRRZ TB,W1
TRZ TB,700000
MOVEM TA,SU30F1
MOVEM TB,SU30F2
SETZM SU30FG; ZERO FLAGS
POPJ PP,
INTER. PASU31
PASU31:
SKIPE SU30FG ;FOR FIRST KEY NAME THIS FLAG WORD CONTAINS 0
JRST PASU3A ; FOR SURROGATES IT IS NON-ZERO
;IF RMS INDEXED FILE, TEST FOR A VALID KEY FIELD FROM RECORD FORMAT
; NAMED IN KEY CLAUSE OF RETAIN VERB
SETZM CURMKY## ;INIT CURRENT RMS RETAIN KEY
MOVE TA,SU30F2## ;GET FILE'S REFERENCE NUMBER
PUSHJ PP,LNKSET## ;GET ITS FILE TABLE ADDRESS
LDB TB,FI.RMS## ;GET ITS RMS BIT
CAIE TB,1 ; AND SEE IF IT IS ON
JRST PAS31C ; IS NOT
LDB TB,FI.ORG ;GET ITS ORG BITS
CAIE TB,%ACC.I ; IS IT INDEXED?
JRST PAS31C ; NO
HRRZ TE,W1 ;GET KEY'S DATA REFERENCE LINK
LSH TE,-17 ;SLIDE IT OVER TO GET 3-BIT TYPE CODE
CAIN TE,1 ;SEE IF IT IS A DATA REF LINK CODE
JRST PAS31D ; IT IS
EWARNJ E.662 ;IF NOT, GIVE FATAL DIAG
JRST PAS31X ;
PAS31D: ;
HRRZ TE,W1 ;GET KEY'S DATA REFERENCE LINK AGAIN
MOVEM TE,CURMKY## ; AND SAVE IT ASIDE
LDB TB,FI.RKY## ;GET DATA REF LINK FOR FILE'S PRIMARY KEY
CAMN TE,TB ; ARE THEY THE SAME?
JRST PAS31C ; YES
MOVE TC,TA ;SAVE FILTAB LINK
PAS31E: MOVE TA,TE ;FIND DATAB ENTRY
PUSHJ PP,LNKSET ;
LDB TE,DA.SNL## ;IS THERE ANOTHER FIELD W/ SAME NAME?
JUMPE TE,PAS31F ; NO
CAME TE,TB ;YES, IS IF FILE'S PRIMARY KEY?
JRST PAS31E ; NO, SEE IF ANOTHER
MOVEM TE,CURMKY ; YES, CLEAN UP DATAB REFERENCES
HRR W1,TE ;
JRST PAS31C ;
PAS31F: HRRZ TE,W1 ;RESTORE KEY'S DATA REFERENCE LINK
MOVE TA,TC ;GET FILTAB OFFSET
LDB TA,FI.ALK## ;GET FILE'S FIRST ALTERNATE KEY REF
CAIN TA,0 ; ARE THERE NONE?
JRST PAS31B ; YUP - UNFORTUNATELY
ADD TA,AKTLOC## ;GET ABSOLUTE ADDRESS OF AKT ENTRY
PAS31A: ;
LDB TB,AK.FLK## ;GET ALT KEY'S FILE REFERENCE LINK
CAME TB,SU30F2## ; SAME FILE?
JRST PAS31B ; NO, WE ARE THROUGH THE ALT KEYS
LDB TB,AK.DLK## ;GET THE KEY'S DATA LINK
CAMN TE,TB ;SAME AS OUR DATA LINK FOR RETAIN KEY?
JRST PAS31C ; YES
MOVE TC,TA ;SAVE FILTAB OFFSET
MOVE TA,TE ;
PUSHJ PP,LNKSET ;
PAS31G: LDB TE,DA.SNL ;ANOTHER WITH SAME NAME?
JUMPE TE,PAS31I ; NO
CAMN TE,TB ;DOES IT MATCH KEY FIELD?
JRST PAS31H ; YES
MOVE TA,TE ;NO, WELL LOOK FOR ANOTHER
PUSHJ PP,LNKSET ;
JRST PAS31G ;
PAS31H: MOVEM TE,CURMKY ;CLEAN UP DATAB REFERENCES
HRR W1,TE ;
JRST PAS31C ; AND SAY MATCH FOUND
PAS31I: EXCH TA,TC ;LOOK AT AKTTAB ENTRY AGAIN
HRRZ TE,W1 ;RESTORE ORIGINAL DATAB FIELD
ADDI TA,SZ.AKT ;BUMP UP TO NEXT ENTRY AND GO TRY AGAIN
JRST PAS31A ;
;
PAS31B: ;REPORT SYNTAX ERROR - BAD RMS RETAIN KEY
EWARNJ E.665 ;
JRST PAS31X ;
PAS31C: ;GO ON TO SET UP RETAIN KEY
HRLZI TA,000010 ;SET FLAG INDICATING DATA NAME OR
ORM TA,SU30FG ;LITERAL SUPPLIED
PAS31X: ;
JRST PA2. ;
PASU3A:
;COMPARE SURROGATE RMS RETAIN KEYS WITH THE SPECIFIED KEY WHICH
;HAS ALREADY BEEN PROCESSED IN PASU31. THEY MUST BE COMPATIBLE
;WITH THE SPECIFIED KEY ACCORDING TO DATA USAGE MODE AND SIZE OF
;PIC CLAUSE.
MOVE TA,SU30F2 ;GET FILE'S FILE TABLE NUMBER
PUSHJ PP,LNKSET## ;FIND ITS FILE TABLE ADDRESS
LDB TB,FI.RMS## ;IS IT RMS FILE?
CAIE TB,1 ;
JRST [EWARNJ E.664 ;NO, FATAL ERROR, SURROGATE NOT ALLOWED
JRST PAS3AC] ;
LDB TB,FI.ORG ;LOOK AT FILE'S ORGANIZATION
CAIE TB,%ACC.I ;IF INDEXED IS OK
JRST [EWARNJ E.664 ; OTHERWISE, IS FATAL ERROR
JRST PAS3AC] ; AND BYPASS THE REST
HRRZ TE,W1 ;GET KEY'S DATA REFERENCE LINK
LSH TE,-17 ;SLIDE IT OVER TO GET 3-BIT TYPE CODE
CAIE TE,1 ;SEE IF IT IS A DATA REF LINK CODE
JRST [EWARNJ E.662 ; IS NOT, FATAL ERROR
JRST PAS3AC] ;
MOVE TA,CURMKY## ;GET CURRENT RMS RETAIN KEY DATA LINK
PUSHJ PP,LNKSET## ;GET ITS ABSOLUTE TABLE ADDRESS
LDB TC,DA.USG## ;GET ITS DATA USAGE MODE
LDB TD,DA.INS## ; AND ITS SIZE
LDB TE,DA.CLA## ; AND ITS CLASS
; FOR COMPARISIONS BELOW
MOVE TA,W1 ;GET CURRENT SURROGATE'S DATA REF LINK AGAIN
PUSH PP,TC ;PRESERVE TC, TD AND TE ACROSS CALL TO LNKSET
PUSH PP,TD ;
PUSH PP,TE ;
PUSHJ PP,LNKSET## ;GET SURROGATE'S DATA REF LINK
POP PP,TE ;RESTORE AC'S FOR COMPARISONS BELOW
POP PP,TD ;
POP PP,TC ;
LDB TB,DA.USG## ;GET SURROGATE'S DATA USAGE MODE
CAME TB,TC ; SAME AS CURRENT RMS KEY?
JRST PAS3AA ; NO, FATAL ERROR
LDB TB,DA.CLA## ;GET SURROGATE'S CLASS
CAME TB,TE ; SAME AS CURRENT RMS KEY?
JRST PAS3AA ; NO, FATAL EROR
LDB TB,DA.INS## ;GET SURROGATE'S PIC SIZE
CAMN TB,TD ; SAME AS CURRENT RMS KEY?
JRST PAS3AB ; YES, SUCCESS. THIS SURROGATE IS OK
LDB TB,DA.CLA## ;GET SURROGATE'S CLASS AGAIN
CAIN TB,2 ;IS SURROGATE NUMERIC
CAIE TE,2 ; AND SPECIFIED KEY NUMERIC TOO?
JRST PAS3AA ;AT LEAST ONE IS NOT, FATAL ERROR
LDB TB,DA.INS## ;GET SURROGATE'S PIC SIZE AGAIN
CAMG TB,TD ;LENGTH OF SURROGATE CAN BE LESS
JRST PAS3AB ; LENGTH OK
; JRST PAS3AA ; FATAL ERROR IF SURROGATE LONGER
PAS3AA: ;
EWARNJ E.666 ;GIVE FATAL ERROR MESSAGE
JRST PAS3AC ;
PAS3AB: ;EXIT FROM THIS ROUTINE
HRLZI TA,000010 ;SET FLAG INDICATING DATA NAME OR
ORM TA,SU30FG ;LITERAL SUPPLIED
PAS3AC: ;
JRST PA2. ;
INTER. PASU33
PASU33: HRLZI TA,000400; SET READ FLAG
PASU3X: ORM TA,SU30FG
MOVE TC,TA ;[1412] SAVE IT, NEED TO
;;;;;[R-JSM-2/20/84] MOVE TA,CURFIL ;[1412] GET CURRENT FILE
MOVE TA,SU30F2 ;[A-JSM-2/20/84]THIS IS WHERE CURRENT FILE'S
;[A-JSM-2/20/84]DISPLACEMENT IN FILE TABLE IS
PUSHJ PP,LNKSET## ;[A-JSM-2/20/84] GET IT'S ADDRESS INTO TA.
LDB TB,FI.ORG ;[1412] TO CHECK ON ORGANIZATION.
CAIE TB,%ACC.I ;[1412] IS IT INDEXED?
JRST PASU3Y ;[1412] YES, DON'T NEED TO GO FURTHER.
LDB TB,FI.FAM ;[1412] OTHERWISE, CHECK ACCESS MODE.
CAIE TB,%FAM.S ;[1412] IF NOT SEQUENTIAL,
JRST PASU3Y ;[1412] DO NOTHING,
MOVE TA,TC ;[1412] OTHERWISE,
HRLZI TA,(1B15) ;[1412] SET BIT FOR RETAIN NEXT,
ORM TA,SU30FG ;[1412] SO ISAM SEQUENTIAL WORKS.
PASU3Y: ;[1412]
POPJ PP,
INTER. PASU34
PASU34: HRLZI TA,000600; SET READ, REWRITE FLAGS
JRST PASU3X
INTER. PASU35
PASU35: HRLZI TA,000500; SET READ, WRITE FLAGS
JRST PASU3X
INTER. PASU36
PASU36: HRLZI TA,000040; SET DELETE FLAG
JRST PASU3X
INTER. PASU37
PASU37: HRLZI TA,000100; SET WRITE FLAG
JRST PASU3X
INTER. PASU38
PASU38: HRLZI TA,000200; SET REWRITE FLAG
JRST PASU3X
INTER. PASU39
PASU39: HRLZI TA,000740; SET ALL FLAGS
JRST PASU3X
INTER. PASU40
PASU40: HRLZI TA,000020; SET UNTIL FREED FLAG
JRST PASU3X
INTER. PASU90
PASU90: HRLZI TA,(1B15) ;SET "NEXT RECORD" FLAG
JRST PASU3X
;;;;;
;
; PASU44 HAS THE TASK OF SETTING UP THE RETAIN STATEMENT, AND THIS INCLUDES
; SETTING UP THREE TABLES WHICH ARE GOING TO BE USED AT RUN-TIME. THE
; FIRST IS THE FILL-FLUSH BUFFER TABLE (SU.FBT), WHICH CONSISTS OF A
; LIST OF LOCAL BUFFER ADDRESSES IN ONE-WORD TABLE ENTRIES. THE NEXT IS
; THE ENQ/DEQ TABLE (SU.EQT) WHICH IS THE ENQ BLOCK FOR THE MONITOR
; CALLS, AND THE ENQ MODIFY TABLE (SU.MQT) AND THE DEQ TABLE (SU.DQT)
; ARE OVERLAPPED INTO THIS AREA. UNFORTUNATELY ALL OF THESE TABLES CAN
; OVERLAP AND THE WHOLE AREA IS A WORK AREA, SO IT IS A MESS TO DETERMINE
; WHAT IS IN THIS AREA ON A LONG-TERM BASIS. THERE IS A FOURTH AREA, THE
; RETAINED-RECORDS TABLE (SU.RRT), WHICH IS MORE PERMANENT. THIS AREA
; PRECEDES THE AREA OF THE PREVIOUS THREE AT RUN-TIME, AND THE TWO ARE
; CONTIGUOUS AND ALLOCATED CONTIGUOUSLY AT RESET TIME IN CBLIO.
; PASU41 MASSAGES THESE INDIVIDUAL VALUES TO FIND THE LARGEST ONE OF
; EACH OF THE FOUR IN ORDER TO SET UP AND ACQUIRE THE CORE SPACE AT RESET
; TIME.
;
;;;;;
INTER. PASU44
PASU44: AOS SUFBTM ;INCREMENT SPACE REQUIRED IN THE
;FILL FLUSH BUFFER TABLE
MOVEI TA,3
ADDM TA,SUEQTM ;INCREMENT SPACE REQUIRED IN EACH
;OF THE ENQ/DEQ TABLES.
HRRZ TA,SU30F2 ;MOVE ADDRESS OF FILE TABLE TO TA
HRLZM TA,CURFIL
PUSHJ PP,LNKSET
HRRM TA,CURFIL
MOVEI TC,1
LDB TB,FI.ORG
CAIE TB,%ACC.I
JRST SUCS1 ;SIZE OF SPACE REQUIRED TO SAVE KEY
;IS ONE WORD IF FILE IS NOT INDEXED
LDB TA,FI.RKY ;Get record key
JUMPE TA,SUCS1 ;RECORD KEY NOT DEFINED
HRLZM TA,CURDAT
PUSHJ PP,LNKSET
HRRM TA,CURDAT
LDB TB,DA.USG
CAIE TB,%US.1C
CAIN TB,%US.C1
JRST SUCS1 ;JUMP IF KEY 1 WORD COMP OR COMP-1
CAIN TB,%US.IN
JRST SUCS1 ;JUMP IF KEY INDEX
MOVEI TC,2
CAIE TB,%US.2C
CAIN TB,%US.C2
JRST SUCS1 ;JUMP IF KEY 2 WORD COMP OR COMP-2
CAIN TB,%US.D6
MOVEI TC,6 ;SET DIVISOR TO 6 IF KEY DISPLAY-6
CAIN TB,%US.D7
MOVEI TC,5 ;SET DIVISOR TO 5 IF KEY DISPLAY-7
CAIE TB,%US.EB
CAIN TB,%US.C3
MOVEI TC,4 ;SET DIVISOR TO 4 IF KEY DISPLAY-9 OR COMP-3
LDB TD,DA.INS ;GET INTERNAL SIZE FROM DATAB ENTRY
SETZ TE,
DIV TE,TC
MOVE TC,TE
SKIPE TD
ADDI TC,1
; AT THIS POINT TC CONTAINS THE NUMBER OF WORDS REQUIRED TO
; STORE A KEY OF THE FILE
SUCS1: ADDI TC,3 ;ADD 1 WORD FOR THE MISCELLANEOUS
;WORD, 1 WORD FOR THE BLOCK NUMBER,
;AND 1 WORD FOR THE RMS KEY-OF-REF WORD.
;TC NOW CONTAINS THE LENGTH OF A
;RETAINED RECORDS TABLE ENTRY AT RUN TIME.
ADDM TC,SURRTM
MOVE TA,CURFIL
LDB TB,FI.ORG ;GET ACCESS MODE FROM FILE TABLE
CAIE TB,%ACC.I
JRST PASUAA ;JUMP IF FILE NOT INDEXED
LDB TB,FI.RTC
JUMPN TB,PASUAA ;JUMP IF A PRIOR ELEMENT IN THIS
;RETAIN STATEMENT REFERENCES THE SAME FILE
SUBI TC,1 ;OTHERWISE, ADD TO THE SPACE REQUIRED
;IN THE RETAINED RECORDS TABLE, ROOM
;TO TEMPORARILY SAVE THE KEY OF THE FILE
;WHEN DOING FAKE LOW-VALUES READS AT RUN TIME.
ADDM TC,SURRTM
DPB TC,FI.RTC ;SET FI.RTC TO NON-ZERO TO INDICATE WE
;PROCESSED AN ELEMENT OF THIS RETAIN
;STATEMENT NAMING THIS FILE.
MOVEI TC,3
ADDM TC,SUEQTM ;INCREMENT THE SPACE REQUIRED IN EACH
;OF THE ENQ/DEQ TABLE BY 3 (FOR THE FILE INDEX)
PASUAA: HRLZI TA,147000
PASU4Z: MOVEM TA,PASU4T
MOVE TA,SU30F1
MOVE TB,SU30F2
PUSHJ PP,PUTGEN; GENERATE FILE NAME
MOVE TA,SU30FG
TLNE TA,000010
PUSHJ PP,PA21.; GENERATE DATA NAME OR LITERAL, IF ANY
MOVE TA,SU30F1
TLZ TA,777774
OR TA,SU30FG
OR TA,PASU4T
HLRZ TB,PASU4T
LSH TB,-9
JRST PUTGEN; GENERATE RENQ OPERATOR AND RETURN
INTER. PASU41
PASU41: PUSHJ PP,PA820. ;PUT RESERVED WORD ON TEMTAB STACK
HRLZI TC,150400
PASU4Y: MOVEM TC,SU41TP##
MOVE TC,SURRTM ;SET SURRT., SUEQT., SUFBT. TO THE
;LARGEST REQUIREMENT OF ANY RETAIN
;STATEMENT PROCESSED SO FAR.
CAMLE TC,SURRT.
MOVEM TC,SURRT.
MOVE TC,SUEQTM
ADDI TC,5 ;MAKE IT LONG ENOUGH TO COVER HDR + 1 REQ
; THIS IS THE SAME MAGIC 5 AS IN PASU8.
CAMLE TC,SUEQT.
MOVEM TC,SUEQT.
MOVE TC,SUFBTM
CAMLE TC,SUFBT.
MOVEM TC,SUFBT.
PUSHJ PP,SUZRTC ;ZERO FI.RTC IN ALL FILE TABLES
MOVE TA,SU30F1
TLZ TA,777774
OR TA,SU41TP##
HRRZI TB,000150
PJRST PUTGEN; GENERATE ERENQ OPERATOR AND RETURN
SUZRTC: MOVE TA,FILLOC ;ZERO FI.RTC IN ALL FILE TABLES AND RETURN
CAMN TA,FILNXT
POPJ PP,
HRRZI TA,CD.FIL*1B20+1
SUZRT1: HRLZM TA,CURFIL
PUSHJ PP,LNKSET
HRRM TA,CURFIL
SETZ TB,
DPB TB,FI.RTC
SUZRT2: HRRZ TA,CURFIL
LDB TA,FI.NXT
JUMPN TA,SUZRT1
POPJ PP,
INTER. PASU42
PASU42: HRLZI TC,150000
PUSHJ PP,PASU4Y
JRST PA0.; POP UP
INTER. PASU45
PASU45: MOVE TA,SU30F1; GENERATE ERUNAV OPERATOR
TLZ TA,777774; AND POP UP
TLO TA,151000
HRRZI TB,000151
PUSHJ PP,PUTGEN
PUSHJ PP,PA24.
SWOFF UNCONT; 0K FOR GO TO OR STOP TO PRECEDE NEXT STATEMENT
JRST PA0.
INTER. PASU64
PASU64: HRLZI TA,000200; SET FILENAME EVERY FLAG
JRST PASU3X
INTER. PASU92
PASU92: HRLZI TA,(1B15) ;SET "FILENAME NEXT" FLAG
JRST PASU3X
;ACTIONS PASU60 THROUGH PASU81 GENERATE GENFIL FOR THE FREE STATEMENT.
;THE GENFIL FOR THE FREE STATEMENT LOOKS LIKE THIS:
;
; FILE-NAME-1
; [DATA-NAME-1 OR LITERAL-1]
; RDEQ (OP CODE 152)
; .
; .
; .
; FILE-NAME-N
; [DATA-NAME-N OR LITERAL-N]
; RDEQ, AS ABOVE
; ERDEQ (OP CODE 153) WITH FLAG INDICATING IF USER SUPPLIED
; A NOT RETAINED STATEMENT
; [CODE FOR THE NOT RETAINED STATEMENT]
; ENR (OP CODE 154) IF USER SUPPLIED NOT RETAINED STATEMENT
;
INTER. PASU60
PASU60: MOVE TA,W2; GET LINE NUMBER AND CHARACTER POSITION
TLZ TA,777774
TLO TA,152400; SET RDEQ AND EVERY FLAG
HRRZI TB,000152
JRST PUTGEN
INTER. PASU61
PASU61: HRLZI TC,153400; SET NOT RETAINED FLAG
PASU6Y: MOVE TA,W2
TLZ TA,777774
OR TA,TC
HRRZI TB,000153; GENERATE ERDEQ
PJRST PUTGEN
INTER. PASU63
PASU63: HRLZI TC,153000
PUSHJ PP,PASU6Y; GENERATE ERDEQ
JRST PA0.; POP UP
INTER. PASU62
PASU62: MOVE TA,W2; GENERATE ENR AND POP UP
TLZ TA,777774
TLO TA,154000
HRRZI TB,000154
PUSHJ PP,PUTGEN
PUSHJ PP,PA24.
SWOFF UNCONT; OK FOR GO OR STOP TO PRECEDE NEXT STATEMENT
JRST PA0.
INTER. PASU66
PASU66: HRLZI TA,152000; GENERATE RDEQ
JRST PASU4Z
;STUB FOR UNLOCK VERB.
;WHEN VAX VMS COBOL V2-STYLE SMU IS IMPLEMENTED IN THIS COBOL, THE UNLOCK
; VERB PROCESSING WILL BEGIN HERE. BUT, FOR NOW IT IS JUST A STUB.
; IF IT IS USED WITH APPLY BASIC-LOCKING IN THE SAME PROGRAM, THE USER
; WILL GET A DIAGNOSTIC TO SAY THAT IT IS ILLEGAL TO USE BASIC-LOCKING
; WITH UNLOCK. IF HE JUST TRIES TO USE UNLOCK HE WILL GET THE STANDARD
; NOT IMPLEMENTED MESSAGE.
INTER. PASU70
PASU70: SKIPE ABSEEN## ;SEEN APPLY BASIC-LOCKING?
JRST PASU7E ; YES
EWARNJ E.91 ; NO - NOT IMPLEMENTED
PASU7E: EWARNJ E.831 ; YES - NOT LEGAL
SUBTTL ANS-82 SYNTAX
INTER. PA800.
PA800.: MOVEI TA,OPSETC ;Change to SET condition-name
PA800A: PUSHJ PP,SETOP3
SKIPN FLGSW ;WANT FIPS FLAGGER?
POPJ PP, ;NO
LDB LN,OP.LN
LDB CP,OP.CP
MOVEI TA,%LV.8
JRST FLG.ES ;FLAG AT -82 LEVEL
INTER. PA801.
PA801.: MOVEI TA,OPSWON ;Change to SET mnemonic-name ON
JRST PA800A
INTER. PA802.
PA802.: MOVEI TA,OPSWOF ;Change to SET mnemonic-name OFF
JRST PA800A
INTER. PA803.
PA803.: MOVEI TE,OP%LCA## ;IF ... ALPHABETIC-LOWER
JRST P183.A
INTER. PA804.
PA804.: MOVEI TE,OP%UCA## ;IF ... ALPHABETIC-UPPER
JRST P183.A
INTER. PA805.
PA805.: FLAGAT 8 ;ANSI-8x STANDARD
SETZM REFCON## ;BY REFERENCE
POPJ PP,
INTER. PA806.
PA806.: FLAGAT 8 ;ANSI-8x STANDARD
SETOM REFCON## ;BY CONTENT
POPJ PP,
INTER. PA807.
PA807.: FLAGAT 8 ;ANSI-8x STANDARD
SETZM PERFAB ;PERFORM BEFORE TEST
POPJ PP,
INTER. PA808.
PA808.: FLAGAT 8 ;ANSI-8x STANDARD
SETOM PERFAB ;PERFORM AFTER TEST
POPJ PP,
INTER. PA809.
PA809.: FLAGAT 8 ;ANSI-8x STANDARD
MOVEI TA,106 ;NOOP OP CODE FOR CONTINUE
JRST SETOP ;SET IT UP
INTER. PA810.
PA810.: FLAGAT 8 ;ANSI-8x STANDARD
SOS PRGLVL## ;COUNT DOWN CONTAINED PROGRAM LEVEL
MOVE TA,PROGID## ;NAME OF CURRENT PROGRAM
CAMN TA,NAMWRD ;SAME AS THIS?
SKIPE NAMWRD+1 ;AND ONLY 6 CHARACTERS?
EWARNJ E.4 ;NO, WARN USER
POPJ PP,
;INITIALIZE identifier REPLACING class-type DATA BY {identifier|literal}
INTER. PA811.
PA811.: FLAGAT 8
;[1600]inidat defined?
SKIPE INIDAT ;[1600]Counter defined?
JRST PA811A ;[1600]Yes use old one
;[1600]no make a -generated-initialize-counter- DATAB entry
MOVE TA,[XWD NAMWRD,NAMWRD+1] ; [1600]
SETZM NAMWRD ;[1600]
BLT TA,NAMWRD+4 ;[1600]
MOVE TA,[XWD [SIXBIT /:GENERATED:INITIALIZE:COUNTER:/],NAMWRD];[1600]
BLT TA,NAMWRD+4 ;[1600]
PUSHJ PP,BLDNAM ;[1600]Get a NAMTAB entry
HLRZ W1,TA ;[1600]Save for now
MOVE TA,[CD.DAT,,SZ.DAT] ;[1600]Get a basic datab entry
PUSHJ PP,GETENT ;[1600]
MOVEM TA,INIDAT ;[1600]Save the address
DPB W1,DA.NAM## ;[1600]Save the NAMTAB pointer
MOVE TB,EAS1PC## ;[1600]Get a core location
DPB TB,DA.LOC## ;[1600]
AOS EAS1PC ;[1600]Bump the PC
HRRZI TB,LVL.01 ;[1600]Set the level
DPB TB,DA.LVL## ;[1600]
HRRZI TB,%US.1C ;[1600]1-WORD COMP
DPB TB,DA.USG## ;[1600]Set usage
HRRZI TB,%CL.NUM ;[1600]Numeric
DPB TB,DA.CLA## ;[1600]Set the class
SETOM TB ;[1600]This is a fake entry
DPB TB,DA.FAK## ;[1600]
DPB TB,DA.DEF## ;[1600]Item is defined
HRRZI TB,6 ;[1600]1 word = 6 characters
DPB TB,DA.EXS## ;[1600]External size is 1 word
DPB TB,DA.INS## ;[1600] so is internal size
DPB LN,DA.LN## ;[1600]Point errors at INITIALIZE
DPB CP,DA.CP## ;[1600]Line number and character position
MOVE CH,[XWD AS.XWD##,1] ;[1600]Put an xwd
PUSHJ PP,PUTAS1## ;[1600] into AS1FIL
; MOVE CH,[XWD AS.CNS##,0] ;[1600]Value of zero
HRRZI CH,AS.CNB## ;[1600]
PUSHJ PP,PUTAS1 ;[1600]Put it into AS1FIL
HRRZI CH,AS.CNB## ;[1600]
PUSHJ PP,PUTAS1 ;[1600]Put it into AS1FIL
MOVE TA,[CD.VAL,,1] ;[1600]Get a valtab entry 1 word long
PUSHJ PP,GETENT ;[1600]
MOVEM TA,INIVAL ;[1600]Save VALTAB pointer
HRRZI TB,1 ;[1600]Size is 1
DPB TB,VA.SIZ## ;[1600]
HRRZI TB,"1" ;[1600]ASCII '1'
DPB TB,VA.LFC## ;[1600]Store the character value
PA811A: ;[1600]yes use old one
HLRZ TB,INIDAT ;[1600] DATAB for counter
HRLZI TA,400000 ;[1600] Set operand bit
HRRZI TD,%US.1C ;[1600]One word comp
DPB TD,[POINT 4,TA,13] ;[1600]PUT USAGE IN FIRST GENFIL WORD.
DPB LN,[POINT 13,TA,28] ;[1600]Line number
DPB CP,[POINT 7,TA,35] ;[1600]Character position
PUSHJ PP,PUTGEN ;[1600] put it in the genfil
HRLZI TA,400000 ;[1600] Set operand bit
TLO TA,GNLIT ;[1600] SET LITERAL BIT
TLO TA,GNNUM ;[1600] SET NUMERIC LITERAL BIT
DPB LN,[POINT 13,TA,28] ;[1600]Line number
DPB CP,[POINT 7,TA,35] ;[1600]Character position
HLRZ TB,INIVAL ;[1600] valtab + 1 offset
PUSHJ PP,PUTGEN ;[1600] Put the VALTAB entry into GENFIL
MOVEI TA,OPITLZ ;INITIALIZE
JRST SETOP
INTER. PA812.
PA812.: MOVEI TA,OP%ALF## ;ALPHABETIC
JRST PA816A
INTER. PA813.
PA813.: MOVEI TA,OP%ANM## ;ALPHANUMERIC
JRST PA816A
INTER. PA814.
PA814.: MOVEI TA,OP%NUM## ;NUMERIC
JRST PA816A
INTER. PA815.
PA815.: MOVEI TA,OP%AED## ;ALPHANUMERIC-EDITED
JRST PA816A
INTER. PA816.
PA816.: MOVEI TA,OP%NED## ;NUMERIC-EDITED
PA816A: DPB TA,OP.ILZ##
SETZM REPSUB ;[1600]Start counting subscripts from here
POPJ PP,
INTER. PA817. ;[1600]
PA817.: HRRZ TB,REPSUB## ;[1600]The number of subs on replace item
HRLZI TA,400000 ;[1600] Set operand bit
TLO TA,GNLIT ;[1600] SET LITERAL BIT
TLO TA,GNNUM ;[1600] SET NUMERIC LITERAL BIT
DPB LN,[POINT 13,TA,28] ;[1600]Line number
DPB CP,[POINT 7,TA,35] ;[1600]Character position
PUSHJ PP,PUTGEN ;[1600]Put it in genfil
POPJ PP, ;[1600]Done
;GLOBAL attribute for USE ...
INTER. PA819.
PA819.: FLAGAT 8
EWARNJ E.899 ;NOT SUPPORTED YET
;Explicit scope termination routines
INTER. PA820.
PA820.: SKIPN CURVRB## ;Anything to store?
POPJ PP, ;No
MOVE TA,[CD.TEM,,SZ.TEM]
PUSHJ PP,GETENT
MOVE TB,CURVRB ;Get verb we really want
TRZ TB,AMRGN. ;Shut off any margin flag
MOVEM TB,(TA) ;Store verb any any info in LHS.
SETZM CURVRB
POPJ PP,
INTER. PA821.
PA821.: MOVE TA,[CD.TEM,,SZ.TEM]
PUSHJ PP,GETENT
TRZ TYPE,AMRGN. ;[1541]SHUT OFF ANY MARGIN FLAG
HRRZM TYPE,(TA) ;Store current verb
POPJ PP,
INTER. PA822.
PA822.: FLAGAT HI
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
POPJ PP,
INTER. PA822N
PA822N: FLAGAT NS
SKIPE ABSEEN## ;APPLY BASIC-LOCKING SEEN?
JRST PA822X ; YES - FATAL ERROR - NOT ALLOWED WITH BASIC-LOCKING
HRRZM TYPE,CURVRB ;SAVE CURRENT RESERVED WORD.
POPJ PP,
PA822X: EWARNJ E.832 ;GIVE FATAL DIAGNOSTIC MESSAGE
INTER. PA823.
PA823.: SKIPE SCPTRM## ;[1553] Did we get here from a popped node?
JRST PA823E ;[1553] Yes - Check next token
DMOVE TB,NAMWRD ;remove END- from current token
LSHC TB,4*6
DMOVEM TB,NAMWRD
SKIPN TA,NAMWRD+2 ;Should not happen
JRST PA823A ; Since longest is 12 characters
MOVE TB,NAMWRD+1
LSH TB,-4*6
LSHC TB,4*6
DMOVEM TB,NAMWRD+1
PA823A: PUSHJ PP,TRYNAM ;Get reserved word type
JRST KILL ;[1553] Cannot happen
HLRZ TYPE,(TA) ;Get first word of NAMTAB
TRZN TYPE,GWRESV ;Should be a reserved word
JRST KILL ;[1553] Should not happen
MOVEM TYPE,ENDTOK## ;[1553] Save the token that we found
SETOM SCPTRM## ;[1553] Flag to Pop nodes for one level
MOVE TA,TEMNXT## ;[1553] Start at bottom of stack
JRST PA823D ;[1553]
PA823B: MOVE TA,TEMNXT## ;[1553] Restore last location
SUB TA,[SZ.TEM,,SZ.TEM] ;Back up 1 item
MOVEM TA,TEMNXT## ;[1553] Save new pointer
PA823D: CAMN TA,TEMLOC## ;[1553] Back up to top yet ?
JRST PA823C ;Yes, we did not find a match
HRRZ TB,(TA) ;Get token
SETZM PEREPR## ;[1553]
TRNE TB,400000 ;Is this an inline PERFORM xxx END-PERFORM ?
SETOM PEREPR## ;[1553] Yes
ANDI TB,177777 ;[1553] Clear per-endper and if-else flags
MOVE TYPE,ENDTOK## ;[1553] Get the token back
CAMN TYPE,TB ;Is this the matching pair?
JRST PA823F ;[1553] Yes - end the loop
SWON FREGWD ;[1553] Turn on REGET word
CAIN TB,PERFO. ;[1553] Is it END-PERFORM ?
JRST PA823P ;[1553] Yes
JRST PA0. ;[1553] No, Pop node and try next
PA823F: MOVM TA,SCPTRM## ;[1553] Change flag
MOVEM TA,SCPTRM## ;[1553] to match found
CAIN TYPE,PERFO. ;[1553] Is it END-PERFORM ?
JRST PA823P ;[1553] Yes
SWOFF UNCONT ;Switch off unconditional GOTO flag
SWON FREGWD ;[1553] Turn on REGET word
JRST PA0. ;
PA823E: SKIPG SCPTRM## ;[1553] Found the match yet?
JRST PA823B ;[1553] No - check next token
SWOFF FREGWD ;[1553] Clear reget word
SETZM SCPTRM## ;[1553] Reset flag
MOVE TA,TEMNXT## ;[1553] Get current stack
SUB TA,[SZ.TEM,,SZ.TEM] ;[1553] Back up 1 item
MOVEM TA,TEMNXT ;[1553] Reset bottom of stack
POPJ PP, ;[1553]
PA823P: SKIPE PEREPR## ;[1553]Is it inline PERFORM xxx END-PERFORM ?
JRST PA823E ;[1553]Yes, don't put out opcode
SOS ILPERF ;[1553] Count down active in-line PERFORMs
JRST PA0. ;[1553]No pop its node
INTER. PA823C
PA823C: SETZM SCPTRM## ;[1553]Incorrect scope terminator
SWOFF FREGWD ;[1553]Reset flags, Get next word
SETZM EWFLG## ;[1553]Don't give E.855 error
EWARNJ E.820
;[1553] PA824. removes the tokens from the terminator stack whose scope
;[1553] is terminated by an ELSE or a WHEN. It is called from the ELSE
;[1553] and WHEN action routines with the token (IF, EVLAUATE or SEARCH)
;[1553] in TC.
INTER. PA824.
PA824.: CAIN TYPE,PRIOD. ;[1553] Did we scan a period?
POPJ PP, ;[1553] No more terminator stack
SKIPA TA,TEMNXT## ;[1553] Start at bottom of stack
PA824A: SUB TA,[SZ.TEM,,SZ.TEM] ;[1553] Back up 1 item
CAMN TA,TEMLOC## ;[1553] Back up to top yet ?
EWARNJ E.855 ;[1553] Yes, we did not find the matching one
HRRZ TB,(TA) ;[1553] Get token
CAME TB,TC ;[1553] Is this the matching token ?
JRST PA824A ;[1553] No keep looking
MOVEM TA,TEMNXT ;[1553] Reset bottom of stack
CAIE TC,IF. ;[1553] IF-ELSE ?
POPJ PP, ;[1553] No - return
TRO TB,200000 ;[1553] Flag this IF as having an ELSE
HRRZM TB,(TA) ;[1553] Up date the terminator stack
POPJ PP, ;[1553] Done
;In-line PERFORM routines
;Save current literal until we know what to do with it
INTER. PA830.
PA830.: DMOVEM W1,ARG1
MOVE TA,[LITVAL,,SAVLIT##]
BLT TA,SAVLIT+MAXWLT-1
POPJ PP,
;It a numeric paragraph name - do action as for PA163.
INTER. PA831.
PA831.: EXCH W1,ARG1 ;Get previous values
EXCH W2,ARG1+1 ;...
TLNE W1,40000 ;SIGNED?
EWARNW E.25 ;[467] YES
LDB TE,GWVAL ;SIZE
MOVE TA,[XWD NAMWRD,NAMWRD+1]
SETZM NAMWRD
BLT TA,NAMWRD+4
MOVE TB,[POINT 6,NAMWRD]
MOVE TA,[POINT 7,SAVLIT]
PA831A: ILDB TC,TA
SUBI TC,40 ;CONVERT TO SIXBIT
IDPB TC,TB
SOJG TE,PA831A
TLZ W2,GWDEF ;ENTER REF. TO NUMERIC PARA. NAME
PUSHJ PP,PUTCRF ; IN CREF TABLE
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM ;NOT FOUND
HRRZ W1,(TA)
HLRZS TA
DPB TA,[POINT 15,W2,15]
EXCH W1,ARG1
EXCH W2,ARG1+1
POPJ PP,
;It an in-line PERFORM n times
INTER. PA832.
PA832.: AOS ILPERF## ;Increment nesting level
DMOVE W1,ARG1
MOVS TA,[LITVAL,,SAVLIT##]
BLT TA,LITVAL+MAXWLT-1
PUSHJ PP,PA2. ;Action of PD518.
MOVEI TA,OPIPRF ;In-line PERFORM
PUSHJ PP,SETOP3
PA832A: PUSHJ PP,GETTAG ;Get next tag
ANDI CH,077777
JUMPE CH,PA832A ;%0 is not allowed
HRLM CH,CURVRB ;Store in terminator stack for END-PERFORM
DPB CH,OP.TRG ;And in operator word
PUSHJ PP,GETTAG ;Get %tag+1 also
PUSHJ PP,PA820. ;Store PERFORM verb on terminator stack
JRST PA21. ;Action of PD530.
;It's an in-line PERFORM VARYING or PERFORM UNTIL
INTER. PA833.
PA833.: AOS ILPERF ;Increment nesting level
PUSHJ PP,PA156.
SETO TB,
DPB TB,FL.TAG ;Set bit for link is a TAGTAB entry
PA833A: PUSHJ PP,GETTAG ;Get a tag
TRNN CH,077777 ;Is the tag %0 ?
JRST PA833A ; Yes, %0 is not allowed
MOVEM CH,INPTAG## ;Save tag for later use
DPB CH,FL.PRO ;Set paragraph name link to TAGTAB
SOS CH
HRLM CH,CURVRB ;Also save for exit
AOS CH
PUSHJ PP,PA820. ;Store PERFORM verb on terminator stack
PUSHJ PP,GETTAG ;Get tag+1 for next statement after perform
DPB CH,OP.TRG
POPJ PP,
;In-line PERFORM xxx END-PERFORM
INTER. PA834.
PA834.: MOVE TA,[CD.TEM,,SZ.TEM]
PUSHJ PP,GETENT
MOVE TB,CURVRB ;Set verb to be perform in temtab
IORI TB,400000 ;Set first bit in temtab entry
TRZ TB,AMRGN. ;[1541]RESET A MARGIN FLAG
MOVEM TB,(TA)
SETZM CURVRB
POPJ PP,
;[1553] In-line perform wrap up actions
INTER. PA835.
PA835.: MOVEI TC,PERFO. ;[1553] Find the last perform
PUSHJ PP,PA824. ;[1553] in the terminator stack
MOVEI TA,OPEPRF ;[1553] End in-line PERFORM opcode
PUSHJ PP,SETOP ;[1553]
HRRZ TA,TEMNXT ;[1553]
HLRZ TB,(TA) ;[1553] It hasn't moved yet
DPB TB,OP.TRG ;[1553] Store tag number
PUSHJ PP,PA22. ;[1553]
SWON FREGWD ;[1553] Reget the word
JRST PA0. ;[1553] Pop the node
;EVALUATE ACTIONS ...
INTER. PA840.
PA840.: ;Initialize Evaluate Verb
FLAGAT 8 ;
SKIPN TB,EV.LVL## ;Are we in EVALUATE already?
JRST P840.1 ;No
SKIPE ERSKIP ;Error during last pass?
SOS TB,EV.LVL ;Yes, back up one level
SETZM ERSKIP ;
JUMPE TB,P840.1 ;Nothing to save, at outermost level
CAIL TB,EV.DEP ;Already 3 deep?
JRST P840.E ;That's the limit
SOS TB ;
IMULI TB,EV.SIZ ;Get next available 5 word block
MOVE TA,EVALFL ;Save flag word
MOVEM TA,EV.TAB##(TB) ;
HRRZ TA,EVSSCT ;Save SS count,
HRL TA,EVSOCT ; SO count
AOS TB ;Bump counter
MOVEM TA,EV.TAB(TB) ;
HRRZ TA,EVNXTS ;Save next selection set tag,
HRL TA,EVDONE ; save done tag
AOS TB ;Bump counter
MOVEM TA,EV.TAB(TB) ;
HRRZ TA,EVCOND ;Save false tag of condition test,
HRL TA,EVNOT ; save false tag of NOT test
AOS TB ;Bump counter
MOVEM TA,EV.TAB(TB) ;
MOVE TA,EVLNCP ;Save LN, CP of beginning of conditional exp
AOS TB ;Bump counter
MOVEM TA,EV.TAB(TB) ;
P840.1: AOS EV.LVL ;Add one to nest level
SETZ TA, ;Zero flag word
TXO TA,EVALF ;Set in EVALUATE flag
MOVEM TA,EVALFL ;Store in flag word
SETZM EVSSCT## ;Init Selection Subject Counter
HRRZI TA,OPEVAL ;"EVALUATE" op code
PUSHJ PP,SETOP1 ;Set up the operator
PUSHJ PP,PA22. ;Put it in GENFIL
HRRZM TYPE,CURVRB ;Set up scope terminator
PUSHJ PP,PA820. ;Put it in TEMTAB
POPJ PP, ;Return
P840.E: EWARNW E.824 ;Nested too deep error
JRST P840.1 ;Try to keep checking syntax
INTER. PA841F
PA841F: ;Set up TRUE operator for "False"
SETZ TC, ;Clear a work AC
TXO TC,EVFABT ;Set "Not" flag for FALSE (bit 15)
JRST P841.1 ; and go produce TRUE operator
INTER. PA841.
PA841.: ;Set up TRUE operator
SETZ TC, ;"Not" flag is null for "True"
P841.1:
MOVE TA,EVALFL ;
TXO TA,EVALTF ;Set TRUE/FALSE flag
MOVEM TA,EVALFL ;
HRRZI TA,OPTRUE ;Op code for TRUE/FALSE
PUSHJ PP,SETOP1 ;Set up opcode in OPRTR+0,+1
MOVE TA,OPRTR ;
MOVE TB,OPRTR+1 ;
MOVE TD,EVALFL ;
TXNE TD,EVWHEN ;
HRL TB,EVNXTS ;store false tag
IOR TA,TC ; Do "Not" flag
TXNN TD,EVWHEN ;Seen "When" in Evaluate yet?
TXO TA,EVSSBT ;No, turn on bit 9 to tell Phase E
; to save result in Selection Subject table
JRST PUTGEN ;Put operator in Genfil
INTER. PA841E
PA841E: SKIPG EVALFL ;If not EVALUATE, or in EVAL, but want imp stmt
JRST P841.E ; give syntax error
JRST PA0. ;no error if EVALUATE selection subj/obj
P841.E: EWARNW E.86 ;found error while scanning
JRST PCA12. ; expression for IF
INTER. PA842.
PA842.: ;Finish up a selection subject
AOS EVSSCT ;increment selection subj counter
MOVE TA,EVALFL ;
TXNN TA,EVALTF ;Has TRUE/FALSE been scanned?
JRST P842.1 ; no
TXZ TA,EVALTF ; yes, zero flag
MOVEM TA,EVALFL ;
POPJ PP, ; and leave
P842.1: HRRZI TA,OPEVGN ;Op code for processing selection subj/obj
PUSHJ PP,SETOP1 ;set up operator
MOVE TA,OPRTR ;
TXO TA,EVSSBT ;distinguish selection subject from object
MOVEM TA,OPRTR ;
HRRZ TA,ARGLST+IF.DEP-1 ;IF's tag table, relationals expression will
SKIPN TA ; leave a false tag, if zero, no expression,
JRST P842.2 ;so skip ahead
DPB TA,OP.TRG ; else store it to declare later
HLRM TA,ARGLST+IF.DEP-1 ;
P842.2: PUSHJ PP,PA22. ;put operator in GENFIL
POPJ PP, ;
INTER. PA843I
PA843I: ;Put out "End SS for Evaluate" Operator
HRRZI TA,OPEVSS ; "END SS" op code
PUSHJ PP,SETOP1 ;
PUSHJ PP,PA22. ;
P843I: PUSHJ PP,GETTAG ;get tag for JRST %NNN,
ANDI CH,077777 ; done after each imperative
JUMPE CH,P843I ; statement, all can use same tag
MOVEM CH,EVDONE## ;
SKPNAM ; and on to handle "When"
INTER. PA843.
PA843.: ;When clause of Evaluate
PUSHJ PP,GETTAG ;Get a tag
ANDI CH,077777 ; to mark start of next selection set
JUMPE CH,PA843. ; (preferably non-zero)
MOVEM CH,EVNXTS## ;so can jump ahead if fail to match SS/SO's
SETZM EVSOCT## ;Init Selection Object Counter
SETZM EWFLG## ;[1553] Turn off when seen for E.855
MOVE TA,EVALFL ;
TXO TA,EVWHEN ;Set flag for "Wehn" clause
MOVEM TA,EVALFL ;
MOVEI TC,EVAL. ;[1553] The token to look for
JRST PA824. ;[1553] Clean up terminator stack
INTER. PA844.
PA844.: ;"Any" Operator of Evaluate
MOVE TA,EVALFL ;
TXO TA,EVNYSN ;Set 'ANY' seen bit
MOVEM TA,EVALFL ;
HRRZI TA,OPANY ; "ANY" op code
PUSHJ PP,SETOP1 ;
PUSHJ PP,PA22. ;
POPJ PP, ;
INTER. PA845.
PA845.: ;completed scan of selection object
AOS EVSOCT ;increment so counter
MOVE TA,EVALFL ;
TXNE TA,EVNYSN!EVALTF ;If scanned 'ANY or 'TRUE/FALSE'
JRST P845.4 ; don't need this
HRRZI TA,OPEVGN ;setup op code to process selection subj/obj
SKIPE EVLNCP ;(If SS/SO is expression
EXCH W2,EVLNCP ; use LN, CP of start of expression)
PUSHJ PP,SETOP1 ;to trigger phase E set up of ss operand
SKIPE EVLNCP ;
EXCH W2,EVLNCP ;must restore w2, it's the next scanned token
MOVE TA,EVALFL ;
TXNN TA,EVCND ;
JRST P845.0 ;
MOVE TA,OPRTR ;
TXO TA,EVCDBT ;
MOVEM TA,OPRTR ;
HRRZ TB,EVCOND ;
JRST P845.2 ;
P845.0: MOVE TA,IFLVL ;
SOS TA ;
HRRZ TB,ARGL2(TA) ;Was an expression scanned?
JUMPE TB,P845.1 ;No
HLRM TB,ARGL2(TA) ;Yes, zero tag table entry
P845.2: DPB TB,OP.TRG ; and store tag
PUSHJ PP,PA22. ;
HRLZ TB,EVNXTS ;Set up failure jrst
HRRI TB,OPJUMP ;
PUSHJ PP,P198.E ;
JRST P845.4 ;
P845.1: PUSHJ PP,PA22. ;put it in GENFIL
HRRZI TA,OPIF ;set up IF op code
PUSHJ PP,SETOP1 ;
MOVE CH,EVNXTS## ;tag for failure to match,
DPB CH,OP.TRG ; will mark start of next selection set
SETO TA, ;
DPB TA,OP.FLS ;mark tag as false tag
DPB TA,OP.EQU ;test on equality
MOVE TB,EVALFL ;
TXNE TB,EVTHRU ;Is this the end of a 'THRU' clause?
DPB TA,OP.GRT ;Yes, need test on LESS or EQUAL
TXNE TB,EVNOTF ;'NOT' scanned?
DPB TA,OP.NOT ;Yes, set bit in op code
PUSHJ PP,PA22. ;
HRRZI TB,OPCLRE ;end-condition op code (GOBACK)
PUSHJ PP,P198.E ;needed to clear EOPTAB
MOVE TB,EVALFL ;
TXNE TB,EVNOTF ;If 'NOT'
TXNN TB,EVTHRU ; 'THRU' scanned
JRST P845.4 ;
HRLZ TB,EVNOT ; put out tag for TRUE case
PUSHJ PP,P198.D ;
;Ascertain Action and Return Point
P845.4: MOVE TA,EVALFL ;
TXZ TA,EVNYSN!EVALTF!EVCND!EVNOTF!EVTHRU ;Zero some flags
TSWFZ FNOTF ;Did we see 'NOT' in scan ahead?
TXO TA,EVNOTF ;Yes
MOVEM TA,EVALFL ;
SETZM EVCOND## ;Zero
SETZM EVNOT## ; out
SETZM EVLNCP## ; tag holders
SKIPLE IFLVL ;
SOS IFLVL ;Decrement IF level
MOVE TA,EVSOCT## ;Current count of Selection Objects
CAMGE TA,EVSSCT## ; up to count of Selection Subjects?
JRST PA0. ; and return to superior node
P845.5:
MOVE TA,EVALFL ;
TXO TA,EVIMPS ;Set imperative stmt flag
MOVEM TA,EVALFL ;
MOVE TE,[XWD 0,PD2094##] ;Node to fake to for SOIS
HRRZM TE,(NODPTR) ;Diddle the node list
POPJ PP, ; and return to SQURL.
INTER. PA846.
PA846.: ;Wrap up Set of Imperative Stmts for "When" clause
HRRZI TA,(TYPE) ;Did we munch up to a period (.)?
ANDI TA,777 ;Get TYPE less A-Margin
CAIN TA,PRIOD. ;Is it a period?
SWON FPERWD ;Set flag to re-get period.
SKIPE SCPTRM## ;[1553] or a scope terminator?
SWON FREGWD ;[1553] Set flag to re-get the terminator.
MOVE TB,EVALFL ;
TXNE TB,EVOTHR ;is this the imperative of WHEN OTHER?
JRST P846.1 ;yes, don't need tag or JRST
HRLZ TB,EVDONE## ;else we have completed imperative statement,
HRRI TB,OPJUMP ; now need JUMPTO to end of EVALUATE
PUSHJ PP,P198.E ;
HRLZ TB,EVNXTS## ;generate TAGNAM for next selection set
PUSHJ PP,P198.D ;put in GENFIL
P846.1: SETZM EVSOCT ;reset selection object counter
MOVE TA,EVALFL ;
TXZ TA,EVIMPS ;
MOVEM TA,EVALFL ;
SETZM SWHEN ;GETITM turned on SEARCH's 'WHEN SEEN' flag
JRST PA0. ;Go to PA0. to pop up a node
INTER. PA847.
PA847.: ;Wrap-up actions for Evaluate Verb
P847.1: HRLZ TB,EVDONE## ;put out tag for JRST's after
PUSHJ PP,P198.D ; imperative statements
HRRZI TA,OPEVND ; "END-EVALUATE" op code
PUSHJ PP,SETOP1 ;
PUSHJ PP,PA22. ;
SETZM EVALFL## ;Reset Evaluate counters and pointers
SETZM EVSOCT## ;
SETZM EVSSCT## ;
SOSG TB,EV.LVL ;Decrement EVALUATE nest count
POPJ PP, ;If zero, no other levels
CAIL TB,EV.DEP ;Error should have been caught elsewhere
POPJ PP, ;
SOS TB ;Backup one
IMULI TB,EV.SIZ ;Multiply by entry size
MOVE TA,EV.TAB(TB) ;Get flag word
MOVEM TA,EVALFL ; restore
AOS TB ;
MOVE TA,EV.TAB(TB) ;Get SS and SO counts
HRRM TA,EVSSCT ; restore
HLRM TA,EVSOCT ;
AOS TB ;
MOVE TA,EV.TAB(TB) ;Get tags
HRRM TA,EVNXTS ; restore
HLRM TA,EVDONE ;
AOS TB ;
MOVE TA,EV.TAB(TB) ;Get more tags
HRRM TA,EVCOND ; restore
HLRM TA,EVNOT ;
AOS TB ;
MOVE TA,EV.TAB(TB) ;Get expression LN, CP
MOVEM TA,EVLNCP ; restore
POPJ PP, ;
INTER. PA848.
PA848.: ;Evaluate "OTHER"
MOVE TA,EVALFL ;
TXO TA,EVOTHR ;Set "Other" flag
MOVEM TA,EVALFL ;
POPJ PP, ;
INTER. PA849.
PA849.: ;Fatal error in selection subject/object?
SKIPN ERSKIP ;Trapped during expression scan,
POPJ PP, ; so any error messages were
SETZM EVALFL ; generated there
SETZM EWFLG ;[1553] This is not a scope term error
SETZM EVSOCT ;Have scanned to period, so will
PUSHJ PP,PA165. ; put out a yecch and
JRST PA0. ; fall into evaluate wrap up stuff
INTER. PA850.
PA850.: ;Scanned an 88 level
MOVE TA,EVALFL ;
TXO TA,EVCND ;turn on CONDITION-NAME flag
MOVEM TA,EVALFL ;
PUSHJ PP,PA2.HI ;set up operand
PUSHJ PP,PA21. ;put it in GENFIL
HRRZI TA,OPIFC ;op code for conditional IF
PUSHJ PP,SETOP1 ;
P850.0: PUSHJ PP,GETTAG ;get tag for false jrst
ANDI CH,077777 ;
JUMPE CH,P850.0 ;
HRRM CH,EVCOND ;save it in RH of evcond
DPB CH,OP.TRG ;
SETO TA, ;
DPB TA,OP.FLS ;
DPB TA,OP.EQU ;
MOVE TB,EVALFL ;
TXNE TB,EVNOTF ;
DPB TA,OP.NOT ;
PUSHJ PP,PA22. ;put operator in GENFIL
POPJ PP, ;exit
INTER. PA851.
PA851.: ;Scanned 'THRU' in selection object
MOVE TA,EVALFL ;
TXOE TA,EVTHRU ;
JRST P851.E ;Can't have 2 'THRU's
MOVEM TA,EVALFL ;
HRRZI TA,OPEVGN ;op code for processing selection subj/obj
PUSHJ PP,SETOP1 ;
MOVE TA,OPRTR ;Get first word of op code
TXO TA,EVTHRB ;Set 'THRU' bit
MOVEM TA,OPRTR ;
PUSHJ PP,PA22. ;Put op code in GENFIL
HRRZI TA,OPIF ;Set up IFGEN op code
PUSHJ PP,SETOP1 ; in OPRTR+0,+1
SETO TA, ;
DPB TA,OP.EQU ;Set EQUAL bit
DPB TA,OP.LES ; and GREATER bit
DPB TA,OP.FLS ;Set jump if false
MOVE TA,EVALFL ;
TXNN TA,EVNOTF ;If 'NOT ... THRU',
JRST P851.1 ;
PUSHJ PP,GETTAG ; need tag for TRUE case
ANDI CH,077777 ;
HRRM CH,EVNOT ;Store in flag word
SKIPA ;
P851.1: MOVE CH,EVNXTS ;Get target
DPB CH,OP.TRG ; for false jump
PUSHJ PP,PA22. ;Put it in GENFIL
HRRZI TA,OPCLRE ;Put out GOBACK op code
PUSHJ PP,SETOP1 ; to clear EOPTAB after
PUSHJ PP,PA22. ; leaving IFGEN
JRST PA0. ;
P851.E: EWARNW E.258 ;Give error if another 'THRU'
JRST PA0. ;
INTER. PA852.
PA852.: ;'NOT' seen at beginning of expression
MOVE TA,EVALFL ;
TXO TA,EVNOTF ;turn on 'NOT' flag
MOVEM TA,EVALFL ;
POPJ PP, ;Exit
INTER. PA853.
PA853.: ;'PERIOD' scanned
SKIPN ERSKIP ;
SWON FGTPER ;
POPJ PP, ;
INTER. PA854.
PA854.: ;About to scan selection object
MOVE TA,EVALFL ;
TXNE TA,EVTHRU ;If not handling a 'THRU' clause
POPJ PP, ;
AOS TA,IFLVL ; add 1 to IF depth
ADD TA,SPFLVL ;
CAIG TA,IF.DEP ;exceeded maximum?
POPJ PP, ;no
JRST PA90.B ;yes, error
INTER. PA860.
PA860.: ;No length given with reference modification
SETZ TA, ;
HRLM TA,RMFLG ;
HRRZI TA,OPREFM ;
PUSHJ PP,SETOP1 ;
MOVE TA,OPRTR ;[1535] Get op code
SKIPN ERSKIP ;[1535] Was there an error with modifier?
TXO TA,RFMERR ;[1535] Yes, set bit in op code
MOVEM TA,OPRTR ;[1535] Restore it
MOVE TB,RMOPPAR## ;[1561] Get stored open paren count
MOVEM TB,ELEVEL ;[1561] Restore for IF expression
PUSHJ PP,PA22. ;
POPJ PP, ;
INTER. PA861.
PA861.: ;Reference modification w/ length modifier
HRRZI TA,OPREFM ;
PUSHJ PP,SETOP1 ;
MOVE TA,OPRTR ;
TXO TA,RFMBTH ;set bit marking both offset and length
MOVEM TA,OPRTR ; as being modified
PUSHJ PP,PA22. ;put out op code
POPJ PP, ;
INTER. PA862.
PA862.: ;Reference modifier for length
CAIN TYPE,COLON. ;
EWARNW E.845 ;Expression scan found a second COLON
CAIE TYPE,RPREN. ;If scan didn't end on a RPREN.,
PUSHJ PP,PA132. ; something wrong in modifier expression
HRRZI TA,OPREFM ;
PUSHJ PP,SETOP1 ;
MOVE TA,OPRTR ;
TXO TA,RFMLEN ;
MOVEM TA,OPRTR ;
SWOFF FREGWD ;
MOVE TB,RMOPPAR## ;[1561] Get stored open paren count
MOVEM TB,ELEVEL ;[1561] Restore for IF expression
JRST PA22. ;
INTER. PA863.
PA863.: ;Subscripts only in ( )'s
SETZM RMFLG ;
POPJ PP, ;
INTER. PA864.
PA864.: ;Error while scanning subs or ref modders
SKIPN ERSKIP ;If on, error msg already given
EWARNW E.849 ;Incorrect sub or ref modder
PUSHJ PP,PA860. ;[1522] Expression scanner handled error,
DMOVE TB,RMOPR ;[1522] put out op code and continue
DMOVEM TB,OPRTR ;
JRST PA0. ;
INTER. PA865.
PA865.: ;Error in expression within ( ), give yecch
EWARNW E.849 ;
PUSHJ PP,PA860. ;[1535] Put out op code
JRST PA0. ;[1535] Pop up one node
SUBTTL COMPOUND ACTIONS
INTER. PCA1.
PCA1.: PUSHJ PP,PA3.
PUSHJ PP,PA21.
JRST PA22.
INTER. PCA2.
PCA2.: PUSHJ PP,PA137. ;SET PARA OPERATOR
PUSHJ PP,PA4. ;CHECK TO SEE NOT DUPLICATED
JRST PCA25.
INTER. PCA3.
PCA3.: PUSHJ PP,PCA3A ; [271] SET UP SECTION
MOVE TB,PROGST ; [271] SAVE START OF PROG
PUSH PP,TB ; [271]
PUSHJ PP,PA219X ; [271] MAKE GENERATED PARA NAME FOR NEW SECTION
POP PP,TB ; [271] RESTORE
MOVEM TB,PROGST ; [271] START OF PROG
SETO TB, ; [271] SET MULTI-DEFINED BIT ON
DPB TB,PR.MDF ; [271] DEFINED BIT OFF-MEANS GENERATED PARA IN XFRGEN
POPJ PP, ; [271]
PCA3A: PUSHJ PP,PA3. ; [271] ADD LABEL
PUSHJ PP,PA7.
JRST PCA25.
INTER. PCA5A.
PCA5A.: TLNE W1,GWSIGN!GWDP
EWARNW E.702
JRST PCA5.
INTER. PCA5.8
PCA5.8: FLAGAT 8 ;ANS-8x code
JRST PCA5.
INTER. PCA5.M
PCA5.M: HRRZ TA,CURFIL
LDB TA,FI.LCP## ;SEE IF LINAGE CLAUSE SPECIFIED
SKIPE TA ;NO, OK
EWARNW E.754 ;YES, GIVE ERROR
SKPNAM
INTER. PCA5.F
PCA5.F: FLAGAT HI
JRST PCA5.
INTER. PCA5.N
PCA5.N: FLAGAT NS
SKPNAM
INTER. PCA5.
PCA5.: PUSHJ PP,PA2.
JRST PA21.
;PCA5F. IS A VERSION OF PCA5. THAT IS CALLED WHEN A FILE NAME
; IS READ, TO SET UP "CURFIL".
INTER. PCA5F.
PCA5F.: PUSHJ PP,PA2.
MOVE TA,ARG1
HRLM TA,CURFIL ;SET UP CURFIL
ADD TA,FILLOC
HRRM TA,CURFIL
PCA5G.: SKIPN FLGSW ;WANT FIPS FLAGGER?
JRST PA21. ;NO, WRITE OPERAND
LDB TB,FI.ORG ;GET FILE ORGANIZATION
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H ;INDEXED
0](TB)
PUSHJ PP,FLG.ES## ;FLAG IF ILLEGAL, NOTE LN & CP ARE SET UP
JRST PA21. ;WRITE OPERAND
INTER. PCA5Z.
PCA5Z.: LDB TE,GWVAL ;TEST FOR ZERO ONLY
CAIN TE,ZERO.
JRST PCA5. ;OK
EWARNW E.638 ;TELL USER
MOVEI TE,ZERO. ;TURN IT INTO ZERO
DPB TE,GWVAL ;TO AVOID ERROR IN COBOLE
JRST PCA5.
INTER. PCA6A.
PCA6A.: PUSHJ PP,PA22.
PUSHJ PP,PA59.
SKPNAM
INTER. PCA6.
PCA6.: PUSHJ PP,PA22.
JRST PA0.
INTER. PCA7C. ;[1334]
PCA7C.: PUSHJ PP,PA4.Z ;[1322] SAME AS PCA7., BUT CHECK LAST PARA
JRST PCA7. ;[1322] FOR ENDING IN UNCONDITIONAL GOTO
;IN A SEARCH STATEMENT.. SET FLAG THAT SAYS "WHEN" SEEN TO DELIMIT
; STATEMENT, NOT "."
INTER. PCA7A.
PCA7A.: SETOM SWHEN##
SKPNAM ;REGET THE "WHEN" AND POP UP A NODE
INTER. PCA7.
PCA7.: PUSHJ PP,PA24.
JRST PA0.
;[1556] REMOVE CODE TO IGNORE A EXTRA PERIOD IN A SEARCH ... WHEN
INTER. PCA7B.
PCA7B.: SWON FPERWD ;[1573] REGET THE PERIOD
SKPNAM ;[1573] ON TO PCA7BA
INTER. PCA7BA ;[1573]
PCA7BA: SETZM SWHEN## ;[1573] CLEAR FLAG
SETZM SCPTRM## ;[1553] CLEAR END-XXX
MOVE TA,TEMLOC ;Reset scope terminator stack
MOVEM TA,TEMNXT
SKIPLE ILPERF ;[1553] Do the in-line PERFORMs balance?
EWARNW E.821 ;No
SETZM ILPERF
JRST PA0. ;POP UP A NODE
;[1553] The next four entries make sure an ELSE or a WHEN after an Incorrect
;[1553] Scope terminator gets a good error message
INTER. PCA7G.
PCA7G.: SKIPN ERSKIP ;[1553] Skip if doing error recovery
SETOM EWFLG## ;[1553] Set flag that ELSE was seen
JRST PCA7. ;[1553] Pop the node
INTER. PCA7D.
PCA7D.: SKIPN ERSKIP ;[1553] Skip if doing error recovery
SETOM EWFLG## ;[1553] Set flag that WHEN was seen
JRST PCA7A. ;[1553] Set flag and pop a node
INTER. PCA7E.
PCA7E.: SETZM EWFLG## ;[1553] Reset the flag
POPJ PP, ;[1553]
INTER. PCA7F.
PCA7F.: SKIPE EWFLG## ;[1553] Flag still set?
JRST PCA7FX ;[1553] Yes - Must have had a bad END-XXX
EWARNJ E.148 ;[1553] No - Use the old error
PCA7FX: EWARNJ E.855 ;[1553] Scope already terminated
;Test for incomplete IF statement
INTER. PCA7X.
PCA7X.: PUSH PP,TE ;[1313] GET AN AC TO WORK WITH
MOVE TE,IFLVL## ;[1313] GET THE CURRENT IF LEVEL
ADD TE,SPFLVL ;[1313] PLUS THAT OF SPECIAL IF
JUMPE TE,PCA7X1 ;[1313] OK IF ZERO
CAIN TYPE,USERN.+AMRGN. ;[1313] USER NAME IN A-MARGIN?
EWARNW E.148 ;[1313] YES, GIVE DIAGNOSTIC MESSAGE
PCA7X1: POP PP,TE ;[1313] RESTORE AC
JRST PCA7. ;[1313] AND CONTINUE
INTER. PCA11.
PCA11.: PUSHJ PP,PCA10.
JRST PA24.
INTER. PCA12.
PCA12.: SWOFF FNOSUB; ;[645] CLEAR "SUBSCRIPTING NOT ALLOWED" FLAG
PUSHJ PP,PA165. ;OUTPUT "YECCH"
PUSHJ PP,PA133. ;SKIP TO NEXT PERIOD
SETZM RMFLG ;CLEAR UP REF MOD FLAG
JRST PA0. ;GO POP UP A LEVEL
INTER. PCA13.
PCA13.: PUSHJ PP,PA148.
JRST PA0.
INTER. PCA14.
PCA14.: PUSHJ PP,PA135.
JRST PA22.
INTER. PCA15.
PCA15.: PUSHJ PP,PCA5.
HRRZ TA,W1 ;GET FILTAB LINK
PUSHJ PP,LNKSET
LDB TB,FI.DSD ;LOOK FOR SORT FLAG
JUMPN TB,PA22. ;OK
EWARNW E.44 ;NOT A SORT FILE
JRST PA22.
INTER. PCA16.
PCA16.: PUSHJ PP,PA148.
JRST PA0.
INTER. PCA17.
PCA17.: PUSHJ PP,PA2.
JRST PA150.
INTER. PCA18.
PCA18.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA150.
JRST PA152.
INTER. PCA19S
PCA19S: FLAGAT 8
SKPNAM
INTER. PCA19.
PCA19.: PUSHJ PP,PA2.
SKPNAM
INTER. PCA10.
PCA10.: PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST PA0.
INTER. PCA19A
PCA19A: PUSHJ PP,PA2.
MOVE TA,ARG1 ;GETSRC W1
TLNE TA,GWSIGN!GWDP ;TEST FOR SIGN AND POINT
EWARNW E.702 ;TOO BAD
JRST PCA10.
INTER. PCA21.
PCA21.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA154.
JRST PA152.
INTER. PCA22.
PCA22.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA155.
JRST PA152.
INTER. PCA23.
PCA23.: PUSHJ PP,PA47.
PUSHJ PP,PA2.
JRST PA155.
INTER. PCA25C ;CLOSE VERB
PCA25C: SKIPN FLGSW## ;FIPS FLAGGER WANTED?
JRST PCA25. ;NO
MOVE TA,ARG1 ;GET FILE TABLE
ADD TA,FILLOC
LDB TB,FI.ORG ;GET FILE ORGANIZATION
SKIPE SU8CNT ;IF NOT FIRST FILE
ADDI TB,4 ;PUT IN SECOND SET
LDB LN,[POINT 13,ARG1+1,28] ;LOAD LN &
LDB CP,[POINT 7,ARG1+1,35] ;CP JUST IN CASE
MOVE TA,[%LV.L ;SEQUENTIAL FIRST FILE
%LV.LI ;RELATIVE FIRST FILE
%LV.H ;INDEXED FIRST FILE
0
%LV.HI ;SEQUENTIAL NOT FIRST FILE
%LV.LI ;RELATIVE, NOT FIRST FILE
%LV.H ;INDEXED, NOT FIRST FILE
0](TB)
PUSHJ PP,FLG.ES## ;FLAG IF ILLEGAL
SKPNAM
INTER. PCA25.
PCA25.: PUSHJ PP,PA21.
JRST PA22.
INTER. PCA26.
PCA26.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA156.
JRST PA152.
INTER. PCA27.
PCA27.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA157.
JRST PA152.
INTER. PCA28.
PCA28.: PUSHJ PP,PA47.
PUSHJ PP,PA2.
JRST PA157.
INTER. PCA29.
PCA29.: PUSHJ PP,PA159.
JRST PA21.
INTER. PCA30.
PCA30.: PUSHJ PP,PA163.
JRST PA150.
INTER. PCA31.
PCA31.: PUSHJ PP,PA47.
PUSHJ PP,PA163.
JRST PA155.
INTER. PCA32.
PCA32.: PUSHJ PP,PA47.
PUSHJ PP,PA163.
JRST PA157.
INTER. PCA34.
PCA34.: PUSHJ PP,PA2.
PUSHJ PP,PA21.
JRST PA38.
INTER. PCA36.
PCA36.: PUSHJ PP,PA24.
PUSHJ PP,PA139.
JRST PA0.
INTER. PCA36A
PCA36A: PUSHJ PP,PA24.
PUSHJ PP,PA140. ;SPIF, NOT FOR I-O
JRST PA0.
INTER. PCA37.
PCA37.: PUSHJ PP,PA22.
JRST PA34.
INTER. PCA38.
PCA38.: PUSHJ PP,PA21.
JRST PA166.
INTER. PCA39.
PCA39.: PUSHJ PP,PA73.
JRST PA22.
INTER. PCA40.
PCA40.: PUSHJ PP,PA34.
JRST PA36.
INTER. PCA41.
PCA41.: PUSHJ PP,PA34.
PUSHJ PP,PA22.
JRST PA0.
INTER. PCA42.
PCA42.: PUSHJ PP,PA2.
JRST PA171.
INTER. PCA44.
PCA44.: PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
JRST PA21.
INTER. PCA45.
PCA45.: PUSHJ PP,PA95.
JRST PA21.
INTER. PCA46.
PCA46.: PUSHJ PP,PA24.
PUSHJ PP,PA26.
PUSHJ PP,DE125.
JRST PA0.
INTER. PCA47.
PCA47.: PUSHJ PP,PA50A.
AOS SU8CNT ;COUNT ONE MORE FOR FIPS FLAGGER
JRST PA2.
INTER. PCA51.
PCA51.: PUSHJ PP,PA173.
JRST PA0.
INTER. PCA54.
PCA54.: PUSHJ PP,PA22.
JRST PA81.
INTER. PCA55.
PCA55.: PUSHJ PP,PA175.
JRST PA22.
INTER. PCA56.
PCA56.: PUSHJ PP,PA22.
PUSHJ PP,PA820. ;PUT RESERVED WORD ON TEMTAB STACK
JRST PA90.
INTER. PCA59.
PCA59.: PUSHJ PP,PA132.
JRST PA0.
INTER. PCA60.
PCA60.: PUSHJ PP,PA37.
SKIPN SCPTRM## ;[1553] Scope Terminator?
PUSHJ PP,PA148.
JRST PA0.
INTER. PCA61.
PCA61.: PUSHJ PP,PA37.
PUSHJ PP,PA24.
SWON FREGWD ;[1553] Reget the period
JRST PA0.
INTER. PCA62.
PCA62.: PUSHJ PP,PA47.
PUSHJ PP,PA21.
PUSHJ PP,PA47.
PUSHJ PP,PA21.
JRST PA160.
INTER. PCA63.
PCA63.: PUSHJ PP,PA73.
PUSHJ PP,PA21.
JRST PA22.
INTER. PCA64.
PCA64.: PUSHJ PP,PA22.
SKPNAM
INTER. PCA64A
PCA64A: PUSHJ PP,PA21.
JRST PA34.
INTER. PCA65.
PCA65.: PUSHJ PP,PA21.
PUSHJ PP,PA22.
JRST PA34.
INTER. PCA66.
PCA66.: FLAGAT HI
PUSHJ PP,PA22.
JRST PA168.
INTER. PCA67.
PCA67.: PUSHJ PP,PA47.
JRST PA202.
INTER. PCA68.
PCA68.: PUSHJ PP,PA2.
PUSHJ PP,PA215.
PUSHJ PP,PA21.
JRST PA22.
INTER. PCA69.
PCA69.: SWOFF FGTPER!FREGWD ;
PUSHJ PP,PA1. ;[665] INITIALIZE
PUSHJ PP,PA258. ;[665] SET UP PROCEDURE DIVISION ENTRY
JRST PCA25. ;[665] OUTPUT THE OPERATOR
INTER. PCA70.
PCA70.: PUSHJ PP,PA151.
PUSHJ PP,PA153.
PUSHJ PP,PA2.
PUSHJ PP,PA224.
JRST PA152.
INTER. PCA71.
PCA71.: PUSHJ PP,PA2.
JRST PA224.
INTER. PCA72.
PCA72.: HRRZI TA,72 ;EXPR OP CODE
PUSHJ PP,SETOP
PUSHJ PP,PA22.
JRST PA2.
INTER. PCA73.
PCA73.: PUSHJ PP,PA21.
HRRZI TA,73 ;ENDEXP OP CODE
PUSHJ PP,SETOP
JRST PA22.
;ITEM DECLARED IN ENTRY OR PD USING CLAUSE
INTER. PCA74.
PCA74.: PUSHJ PP,PA2.
JRST PA264.
INTER. PCA75.
PCA75.: PUSHJ PP,PA21. ;OUTPUT OPERAND
JRST PA0. ;POP TO PREVIOUS NODE
; CHECK TO SEE IF RECORD IS IN A SORT FILE [257]
; AND INSERT RECORD OPERANDS INTO GENFIL , EVEN IF ERROR
INTERN. PCA80.
PCA80.: PUSHJ PP,PCA83. ; [276] SEE IF RECORD LEVEL
MOVEI DW,E.206 ; [257] SET UP NOT RECORD ERROR CODE
PUSHJ PP,FNDFIL ; [257] GET CORR FILE FOR THIS RECORD
JRST PCA80B ; [257] NOT A RECORD ERROR
LDB TB,FI.DSD ; [257] IS RECORD IN SORT FILE
PCA80A: MOVEI DW,E.488 ; [257] NOT IN SORT FILE ERROR CODE
SKIPN TB ; [257]
PUSHJ PP,FATAL ; [257] GIVE ERROR
JRST PA21. ; [257] PUT OUT OPERANDS-EVEN IF ERROR ONES
PCA80B: PUSHJ PP,FATAL ; [257] GIVE ERROR
SETZ TB, ; [257] WILL FORCE NOT IN SORT FILE ERROR
JRST PCA80A ; [257] CONTINUE
; [257] SEE IF FILE IS SORT FILE
INTER. PCA81.
PCA81.: PUSHJ PP,PCA5. ; [257] SET UP ARG1 AND OPERAND
HRRZ TA,W1 ; [257] GET FILTAB LINK
PUSHJ PP,LNKSET ; [257]
LDB TB,FI.DSD ; [257] IS IT A SORT FILE
JUMPN TB,CPOPJ ; [257] YES OKAY
EWARNJ E.44 ; [257] NO ILLEGAL
INTER. PCA82.
PCA82.: SETZM CLEVEL ; [313] CLEAR THE PAREN
SETZM ELEVEL ; [313] COUNTS- BECAUSE WE LOSE COUNT
JRST DE111. ; [313] GIVE ERROR MESSAGE AND RETURN
; CHECK THAT DATA NAME IS RECORD ( 01 OR 77 LEVEL).
INTER. PCA83.
PCA83.: HRRZ TA,ARG1 ; [276] GET DATAB REL LOCACTION
JUMPE TA,PCA83A ;[461] IF ARG IS ZERO TROUBLE
PUSHJ PP,LNKSET ; [276] GET REAL ADDRESS
MOVE TC,ARG1+1 ; [276] GET LINE AND CHAR POSITION
LDB LN,[POINT 13,TC,28] ; [276] EXTRACT OUT LINE
LDB CP,[POINT 7,TC,35] ; [276] EXTRACT OUT CHAR POS.
LDB TB,DA.LVL ; [276] GET LEVEL OF DATA ITEM
CAIE TB,1 ; [276] RECORD NAME IF 01
CAIN TB,^D77 ; [276] 0R 77 LEVEL
POPJ PP, ; [276] OK
MOVEI DW,E.159 ; [276] NOT AT RECORD LEVEL
JRST FATAL ; [276] FLAG ERROR AND RETURN
PCA83A: MOVEI TA,<CD.DAT>B20+1 ;[461] USE DUMMY DATA ITEM
MOVEM TA,ARG1 ;[461] SO PHASE E DOESN'T CRASH
JRST FATAL ;[461] AND GET OUT
INTER. PCA84.; ; [362]
PCA84.: SOS SPFLVL ;[532] [511] COUNT DOWN ONE MORE ADDED BY
SOSGE SPFLVL ; [362] COUNT DOWN "IF" LEVEL IN
; [362]"SEARCH" STATEMENTS
SETZM SPFLVL ; [362] ZERO MINIMUM
EWARNJ E.390 ; [362] "WHEN" EXPECTED ERROR MSG
INTER. PCA88.
PCA88.: SKIPN RMFLG ;IF REF. MOD.
JRST PCA88A ;
DMOVE TB,RMOPND## ; NEED TO RESTORE ORIGINAL OPERAND
DMOVEM TB,ARG1 ;
PCA88A: PUSHJ PP,FNDFIL ; [455] GET FILE FOR THIS RECORD
JRST [SETZ TB, ; [455] FORCE NOT IN SORT FILE ERROR
JRST PCA88B] ; [455] CONTINUE
MOVE TC,ARG1+1 ; [455] GET LINE AND CHAR POSITION
LDB LN,[POINT 13,TC,28] ; [455] EXTRACT LINE
LDB CP,[POINT 7,TC,35] ; [455] EXTRACT CHAR POS
LDB TB,FI.DSD ; [455] IS RECORD IN SORT FILE
PCA88B: MOVEI DW,E.488 ; [455] NOT IN SORT FILE ERROR CODE
SKIPN TB ; [455]
PUSHJ PP,FATAL ; [455] GIVE ERROR
SKIPE RMFLG ;IF REF. MOD., OPERAND IS ALREADY OUT,
SETZM ARG1 ; BUT PERFROM ANYWAY FOR OTHER CLEANUP
PUSHJ PP,PA21. ; [455] PUT OUT OPERANDS
JRST PA160. ; [455] CONTINUE
SUBTTL ANS-74 PROCEDURE DIVISION ACTIONS
;ACCEPT XXX FROM DAY, DATE, TIME, DAY-OF-WEEK.
INTER. PCA90X
PCA90X: FLAGAT 8
SKPNAM
INTER. PCA90.
PCA90.: PUSHJ PP,PA2.
HRRZ TB,ARG1 ;R. H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
TLZ TA,777774 ;LN, CP
SETZM NSBSC1
TLO TA,400000!GNLIT!GNFIGC ;SET OPERAND AND FIGURATIVE CONSTANT BITS
HLRZ TC,TD
ANDI TC,777 ;YES--GET VALUE
SETZ TE,
CAIN TC,DATE..
HRLZI TE,GNTODY!GNDATE
CAIN TC,DAY..
HRLZI TE,GNTODY!GNDAY
CAIN TC,TIME..
HRLZI TE,GNTODY!GNTIME
CAIN TC,DOW.
HRLZI TE,GNTODY!GNDOW
IOR TA,TE ;SET APPROPRIATE BITS
SETZM ARG1
SETZM ARG1+1
JRST PUTGEN ;OUTPUT ARG1
;COMPUTE SERIES
INTER. PCA93.
PCA93.: PUSHJ PP,PA191. ;COMPUTE OP-CODE
JRST PA2. ;DATAN.
;DIVIDE INTO SERIES
INTER. PCA95.
PCA95.: PUSHJ PP,PA22. ;DUMP DIV OPERATOR
SKPNAM
INTER. PCA96.
PCA96.: PUSHJ PP,PA21. ; AND LAST OPERAND
jrst pa2.
;SAVE DATA ITEM IN CASE TYPE 3 INSPECT
INTER. PCA91.
PCA91.: PUSHJ PP,PA2.
DMOVEM W1,SVINSP##
POPJ PP,
;RESTORE DATA ITEM AND OP-CODE FOR INSPECT
INTER. PCA92.
PCA92.: PUSHJ PP,PA22. ;OUTPUT LAST OPERATOR
MOVE TA,SVINSO## ;EITHER "TALLYING" OR "REPLACING" ARG
PJRST SETOP ; SETUP FRESH OPERATOR
INTER. PCA92T
PCA92T: PUSHJ PP,PA22. ;OUTPUT PREVIOUS "TALLYING" OPERAND
MOVE TA,SVINSO ; GET "TALLYING" AGAIN
PUSHJ PP,SETOP ;SETUP FRESH OPERATOR
JRST PA2. ;READ DATAN
INTER. PCA92L
PCA92L: PUSHJ PP,PCA92.
JRST PA64. ;LEADING
INTER. PCA92F
PCA92F: PUSHJ PP,PCA92.
JRST PA67. ;FIRST
INTER. PCA92C
PCA92C: PUSHJ PP,PCA92.
JRST PA65. ;CHARACTER
INTER. PCA92Y
PCA92Y: FLAGAT 8
SKPNAM
INTER. PCA92R
PCA92R: PUSHJ PP,PCA92.
JRST PCA5. ;READ DATAN
INTER. PCA92S
PCA92S: PUSHJ PP,PCA92.
JRST PA2. ;READ DATAN
INTER. PCA92E
PCA92E: SETO TA,
DPB TA,OP.EIN## ;"LAST ARGUMENT" FOR INSPECT
JRST PCA6.
INTER. PCA94.
PCA94.: SKIPE TA,RMFLG## ;RM - may be set in PA205 or here
TRZE TA,200000 ;RM - have we seen a COLON already?
JRST PCA94A ;RM - no
MOVEM TA,RMFLG ;RM -
EWARNW E.845 ;RM - found two colons
PUSHJ PP,PA132. ;RM - put out OPENDX (073)
HRRZI TA,OPREFM ;RM -
PUSHJ PP,SETOP ;RM -
JRST PA22. ;RM -
PCA94A: SKIPN RMFLG ;RM - don't want to overwrite flag settings
SETO TA, ;turn on flag
MOVEM TA,RMFLG ;RM
DMOVE TB,ARG1 ;save current operand
DMOVEM TB,RMOPND ; in case needed for later syntax error
DMOVE TC,OPRTR ;save current verb's op code
;[1562] If oprtr is zero, the operator and its operands have already been
;[1562] written to genfil; have now scanned another operand without
;[1562] a new operator => have found an expression continued by an 'AND'
;[1562] or an 'OR'. A prior routine will have put the current op code in
;[1562] implop.
;[1635] If we have IF FOO(1:2) EQUALS BAR(1:2)
;[1635] AND FOO(3:4) EQUALS BAR(3:4)
;[1635] then we come here four times for each of the RM. The first time
;[1635] OPRTR will be non-zero but the other three times it will be zero.
;[1635] We want to put out a '072' for the first RM after a IF, AND or OR.
;[1635] If we had an AND or OR then OPRTR+1, and therefore, TB was set to
;[1635] OPIF.
SKIPN TC ;[1562] If no current verb
MOVE TC,IMPLOP ;[1635] get it from implop
DMOVEM TC,RMOPR ;
CAIE TB,OPIF ;[1561] Is this an 'IF' clause
JRST PA21. ;[1561] No, go put out data field
PUSHJ PP,PA111. ; Then put '072' in genfil first
MOVE TA,ELEVEL ;[1561] Elevel has open paren count
MOVEM TA,RMOPPAR## ;[1561] Save until ref. modifiers are processed
JRST PA21. ;put out data field
INTER. PCA97.
PCA97.: SWON FREGWD ;[1553] Clean up for END-EVALUATE
PUSHJ PP,PA847. ;[1553] Wrap-up actions
JRST PA0. ;[1553] Pop a node
INTER. PCA98.
PCA98.: PUSHJ PP,PA800. ;[1564] BUILD OP CODE FOR SET CONDITION-NAME
JRST PA22. ;[1564] PUT IT IN GENFIL
SUBTTL ERRORS USED BY PD SYNTAX SCAN
INTER. DE111.
DE111.: TLNE W1,GWLIT!GWFIGC ;LITERAL OR FIG. CONST?
EWARNJ E.101 ;? IDENTIFIER EXPECTED
TLNN W1,GWRESV ;SKIP IF RESERVED WORD
EWARNJ E.104 ;NO, SAY "?NOT DEFINED"
SKPNAM ;ELSE "CAN NOT BE A DATA-NAME"
INTER. DE103.
DE103.: HRRZI DW,E.103 ;DIAGNOSTIC 103
LDB TA,[POINT 9,W1,17]
TLNE W1,GWRESV
CAIE TA,FILLE.
JRST WARNW##
EWARNJ E.289
INTER. DE125.
DE125.: DMOVE LN,BLNKLN ;GET LN & CP
HRRZI DW,E.125 ;DIAGNOSTIC 125
JRST WARN ;WARNING ONLY
IFE ONESEG,< END COBOLD>
IFN ONESEG,< END >