Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/cobolc.mac
There are 20 other files named cobolc.mac in the archive. Click here to see a list.
; UPD ID= 1533 on 2/22/84 at 9:32 AM by HOFFMAN
TITLE COBOLC V13
SUBTTL DATA DIV. SYNTAX SCAN W.NEELY/CAM/SEB
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
DBMS==:DBMS
DEBUG==:DEBUG
MCS==:MCS
IFN TOPS20,<SEARCH MONSYM,MACSYM>
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
SALL
RELOC 400000
;EDITS
;NAME DATE COMMENTS
;JEH 14-FEB-84 [1515] If defining implied indexes for REPORT SECTION,
; check PCHOLD for correct core assignment
;SMI 23-Feb-83 [1452] Error 370 when RPWTAB get expanded.
;JEH 18-Nov-82 [1424] Fatal error on COMP, COMP-1, and INDEX fields in ASCII file.
;RLF 2-Aug-82 [1376] Corrects diagnostic when line before FD is too long.
;RJD 15-Jul-82 [1373] Corrects page advancing when more than 2 report header lines.
;JEH 14-Jun-82 [1366] Correct 1335, set up CURHLD properly.
;JEH 7-Jun-82 [1362] Make HLDSAV external.
;RJD 24-May-82 [1356] Allow qualification in DATA RECORDS ARE clause.
;JEH 30-Mar-82 [1346] Fatal error if too many ascending/descending keys.
;JEH 2-Feb-82 [1335] Declare DATAB entries for all indices if REPORT SECTION
; is scanned for their use by REPORT WRITER statements.
;DAW 31-DEC-80 [1106] Don't give wrong error message when 88 level
; item has value clause and item is subordinate to an item
; whose usage is INDEX.
;DMN 14-NOV-80 [1071] GIVE ERROR MESSAGE WHEN VARIABLE PART IS NOT THE LAST THING IN RECORD.
;CLRH 9-APR-80 [1011] FIX EDIT 733 TO NOT REQUIRE DATA RECORD IF FD HAS
; A REPORT CLAUSE.
;DMN 28-MAR-80 [1003] FIX DUPLICATE CREF DEFINITION WHEN LEVEL # DECREASES.
;DMN 30-JAN-80 [763] CHECK FOR DUPLICATE LINKAGE AND REPORT SECTIONS.
;DMN 29-JAN-80 [760] MAKE "BLANK WHEN ZERO" WORK AGAIN FOR NUMERIC SENDING ITEM.
;DMN 24-OCT-79 [751] BAD DATAB DEFINITION IF FD NAME MATCHES PROGRAM ID.
;DMN 13-SEP-79 [733] GIVE ERROR IF NO DATA RECORD IN FD.
;V12A SHIPPED
;DMN 8-AUG-79 [723] FIX EDIT 706 TO POINT TO CORRECT RECORD
;DAW 22-MAY-79 [711] FIX ANOTHER ERROR IN 674 (INDEX ITEMS)
;DMN 16-MAY-79 [710] SET FLAG SHOWING WORKING-STORAGE SEEN
;CLRH 3-MAY-79 [706] CHECK RECORD CONTAINS CLAUSE AGAINST MAX. RECORD SIZE.
;DAW 27-APR-79 [700] FIX UNDESERVED ERROR FOR COMP-1 ITEMS WHEN
; EDIT 674 IS INSTALLED
;CLRH 3-APR-79 [674] GENERATE ERROR FOR BAD VALUE CLAUSE OF 88 LEVEL ITEM
;DAW 29-MAR-79 [672] FIX ILL MEM REF WHEN SOMEONE DEFINES A DATANAME "TALLY".
;DMN 6-MAR-79 [651] USE CORRECT BYTE POINTER TO TEST RPW CONTROL FLAGS
;DAW 21-FEB-79 [635] FIX WRONG SIZE COMPUTATION FOR ITEMS RENAMING ITEM-1 THRU ITEM-2
;V12******************
;DMN 5-JAN-79 [624] RECORD SIZE MUST MATCH RECORD CONTAINS IN F MODE FILE
;DMN 28-NOV-78 [603] FIX ILL UUO WHEN "CONTROL" IN "RD" REFERS TO EDITED ITEM.
;V11******************
;NAME DATE COMMENTS
;EHM 16-DEC-78 [527] FIX CATASTROPHE WHEN REPORT WRITER VALUE IS MESSED UP
;MDL 22-SEP-77 [513] IF INVALID DBMS PRIVACY KEY, GIVE FATAL
; AND BEGIN PROCESSING AFTER SCHEMA SECTION.
;V10*****************
;NAME DATE COMMENTS
;VR 13-SEP-77 [507] TO BUILD COBOL WITH DBMS==0, DBMS4==0
; WHEN EDIT [476] IS INSTALLED
;VR 13-SEP-77 [503] TO BUILD COBOL WITH DBMS==0, DBMS4==0
;DPL 24-MAY-77 [476] CHECK FOR PROPER SEQUENCE OF SECTION
; NAMES AND PROPER ALLOCATION OF DATA STORAGE
;MDL 26-APR-77 [471] GIVE APPROPRIATE ERROR MESSAGE WHEN OCCURS
; MAXIMUM EXCEEDED.
;VR 15-FEB-77 [465] LOCATE TOO LARGE DATA ITEM DEFINED BY
; OCCURS FOLLOWED BY OCCURS. GIVE FATAL ERROR.
;DPL 09-DEC-76 [453] MAKE /S WORK FOR DBMS PROGRAMS
;EHM 23-NOV-76 [451] LINKAGE SECTION MUST COME AFTER W-S IF
; THERE IS A SCHEMA SECTION OR A COMM SECTION
;SER 5-NOV-76 [450] FIX RENAMES THRU FOR DATA-NAME USED IN LINKAGE SECTION.
;EHM 14-SEP-76 [442] GIVE ERROR MESSAGES FOR COMMUNICATION SECTION
; OUT OF ORDER AND RESET THE LEVEL 77 FLAG
; 6-APR-76 [423] DON'T ATTEMPT TO MAKE CONTROL ID PREVIOUS IF ID IS ERROR
;DPL 23-MAR-76 [412] FIX COMM SECTION AND SCHEMA SECTION SHARING
; SAME DATA AREA. DA119A AND DA120.
; 29-JAN-76 FIX BLANK WHEN ZERO
;ACK 9-FEB-75 ADD COMP-3/EBCDIC CODE.
;SSC MAR-5-75 PLACED 6A EDIT %316 DIRECTLY INTO V10
;ACK 5-MAR-75 REWRITE OF DA54.
;ACK 10-MAR-75 VALUE CLAUSE CODE FOR COMP-3/EBCDIC
;********************
;DPL 24-MAY-77 [476] CHECK FOR PROPER SEQUENCE OF SECTION
; NAMES AND PROPER ALLOCATION OF DATA STORAGE
; EDIT 356 ALLOW LOWER CASE LETTERS FOR VALUE OF ID.
; EDIT 335 REPORT WRITER FATAL ERROR CONDITION.
; EDIT 331 CHECK FOR SCHEMA BEFORE FILE SECTION OR AFTER ANY OTHER SECTION
; EDIT 315 VARIOUS REPORT WRITER FIXES - SEE P.MAC
; EDIT 270 REMOVE EXTRA ERROR MSG WHEN VALUE OF ID UNDEFINED
; EDIT 264 FIXES ILL MEM REF WHEN ACTUAL KEY MISSING
; EDIT 260 FIX 01 DATAN ..
; EDIT 253 FIXES A RENAMES B.
; EDIT 247 FLAGS ERROR FOR ITEMS IN REPORT SECTION THAT ARE SUBCRIPTED.
; EDIT 243 FIXES PHASE E CRASHES BECAUSE OF ERROR IN OCCURS N
; TO P CLAUSE - ALSO ALLOWS N TO BE 0.
;[237] /JEF COBOLC.MAC, DIAGS.MAC QAR-2918
; IDENTIFIERS GIVEN IN THE CONTROL CLAUSE MUST BE DEFINED
; ONLY IN THE FILE OR WORKING SECTIONS.
;[236] /ACK COBOLC.MAC, CLEAND.MAC
; RESERVE SPACE FOR LABEL RECORD IF LARGER THAN FD
; BUT DONT CHANGE FILE TABLE MAX-REC-SIZE
;[220] /ACK GENERATE AN ERROR IF A MINOR KEY IS THE SUBJECT OF AN OCCURS.
; EDIT 215 REPORT-WRITER CHECK THAT HEADER .LE. FIRST-DETAIL .LE. LAST-DETAIL .LE. FOOTING
; EDIT 175 PREVENT ASSEMBLY IF A RECORD ASSOCIATED WITH AN FD HAS NO FILE NAME
; EDIT 174 FIXES RD FILNAME COPY .
; EDIT 164A FIX TO 164
; EDIT 164 FLAG AS FATAL ANY DEPENDING ITEM NOT 1-WORD COMP OR
; SUBSCRIPTED OR IN LINK SECTION.
; EDIT 162 GIVE WARNING THE FOLLOWING MAY NOT BE IN LINKAGE SECTION
; VALUE OF ID, DATE-WRITTEN, OR USER-NAME
; FILE-LIMITS, ACTUAL-KEY OR SYMBOLIC-KEY
; EDIT 152 FIXES ILLEGAL MEM REF FOR UNDEFINED VALUES OF ID
; DATE-WRITTEN, AND PPN.
; EDIT 110 NO MULTIPLE WORKING STORAGE
; RESERVE ALTERNATE AREAS GIVES TOO MANY BUFFERS
; ALTER STATEMENT GETS ERROR IF PRG COMPILED WITH /A.
; LAST STATEMENT IN PARA IS AN OPEN NOT TERMINATED BY A PERIOD GETS NO WARNING.
ENTRY COBOLC
EXTERN CTREE,CPOPJ,CPOPJ1
EXTERN DA.DEF,DA.INS,DA.EXS,DA.OCC,DA.FAL,DA.RDS,DA.LN,DA.CP
EXTERN DA.BWZ,DA.DPR,DA.EDT,DA.ERR,DA.JST,DA.NAM,DA.NDP,DA.NOC,DA.PIC
EXTERN DA.PWA,DA.SGN,DA.SUB,DA.USG,DA.VAL
EXTERN HL.COD,HL.LNK,HL.LNC,HL.NAM,HL.QAL
EXTERN CFLM,CURCON,DATLVL,EAS2PC,FATALW,LEVEL
EXTERN PUTCRF,PUTLNK
EXTERN RDFLVL,RPWRDL,RUSAGE,THSCTL
EXTERN CURRPW
EXTERN LNKSET
EXTERN RENLOC,RENNXT,RN.01,RN.66,XPNREN
INTERN D54.NJ ; [315]
COBOLC: SETFAZ C;
SETZM FILSEC ;CLR FILE-SECTION-SEEN FLAG
SETZM WRKSEC## ;CLR WORKING-STORAGE-SECTION-SEEN FLAG
SETZM RPWERR## ; [335] CLEAR REPORT WRITER ERROR FLAG
SETZM CURRPW ;CLR RPWTAB PTR
SETZM LASTYP## ;CLR LAST RPW TYPE SEEN STORAGE
SETZM LASCOL## ; [315] CLEAR LAST COLUMN
MOVE TA,['000000'] ;INIT 6-DIGIT SIXBIT #
MOVEM TA,SIXHLD
MOVE SAVPTR,ISVPTR##
MOVE NODPTR,INDPTR##
IFN DEBUG,<
SWOFF FNDTRC;
MOVE TE,CORESW##
TRNE TE,TRACED
SWON FNDTRC; ;TRACE DD NODES
>
HRRZI TA,DD1.##
PUSH NODPTR,TA
PUSHJ PP,SQURL.##
OUTSTR [ASCIZ /COBOLC--lost; too many POPJ's
/]
JRST KILL##
SUBTTL ACTIONS FOR DD SYNTAX PROCESSING
;COME HERE TO POP UP ONE LEVEL IN THE SYNTAX TREE.
INTER. DA0.
DA0.: POP NODPTR,NODE ;POP UP CURRENT NODE
IFN DEBUG,<PUSHJ PP,PTPOP.##> ;IF TRACING, PRINT NODE POPING UP TO
POPJ PP,
;COME HERE AFTER WE SEE "DATA DIVISION" TO INITIALIZE.
INTER. DA1.
DA1.: SWOFF FFILSC; ;'FILE SECTION' FLAG
MOVE SAVPTR,ISVPTR ;SAVE LIST POINTER
HRRZI TA,1
PUSH SAVPTR,TA
SETZM RDFLVL ;CLR REDEFINES NESTING LEVEL
SETZM CURFIL
SETZM CURDAT
SETZM CURCON
SETZM CURVAL##
SETZM CURNAM##
SETZM BLDIX## ;[1335]
SETOM PCHOLD##
SETZM SVDADR
SETZM WSAS1P
SETZM IDXLST##
SETOM LSTW77## ;LAST LEVEL NUMBER WAS NOT 77.
SETZM LASTRD## ;INIT LAST RD PTR
DA1.X: SETZM EAS1PC##
DA1.Y: SETZM EAS2PC##
SETZM CFLM
POPJ PP,
INTER. DA2.
DA2.: SWON FFILSC;
SETOM FILSEC## ;SET FILE-SECTION-SEEN FLAG
SETZM REPSEC ;CLR REPORT SECTION FLAG
SETZM LNKSEC ;CLR LINKAGE SECTION FLAG
IFN DBMS,<
SETZM INVSEE## ;[%331] CLEAR THIS NOW SO ERROR HERE
;[%331] WONT CAUSE MANY LATER
SKIPE SCHSEC## ;[%331] SEEN SCHEMA SECTION YET
EWARNJ E.470 ;[%331] YES, OUT OF ORDER
> ;[%331] END OF DBMS SPECIAL CHECK
SKIPL TA,PCHOLD ;RESET EAS1PC TO PREVIOUS
MOVEM TA,EAS1PC ; IF CHANGED BY LINKAGE SECTION
SETOM PCHOLD
MOVE TA,EAS1PC
MOVEM TA,WSAS1P##
JRST DA1.X
INTER. DA3.
DA3.: SETZM LNKSEC ;CLR LINKAGE SECTION FLAG
SKIPL TA,PCHOLD ;RESET EAS1PC TO PREVIOUS
MOVEM TA,EAS1PC ; IF CHANGED BY LINKAGE SECTION
SETOM PCHOLD
DA3.0: SWOFF FFILSC;
SETZM REPSEC ;CLR REPORT SECTION FLAG
MOVE TA,WSAS1P
MOVEM TA,EAS1PC
SETZM LAST01##
JRST DA1.Y
;WE COME HERE WHEN WE ARE FINISHED PROCESSING THE DATA DIVISION TO
; CLEAN THINGS UP.
INTER. DA4.
DA4.: PUSHJ PP,DA10.
SKIPN SVDADR
JRST D4.1
MOVE CH,SVDWRD##
PUSHJ PP,PUTAS1
SETZM SVDADR
D4.1: SETZM EAS2PC
TSWT FFILSC;
JRST D4.11
MOVE TA,WSAS1P
MOVEM TA,EAS1PC
D4.11: SKIPL TA,PCHOLD ;NEED TO RESTORE DATA DIV PC?
MOVEM TA,EAS1PC ;YES
SETOM PCHOLD ;PC HAS BEEN RESTORED
SKIPN EAS1PC
JRST DA4.A2
HLRZ TA,EAS1PC
JUMPE TA,DA4.A2
AOS TA,EAS1PC
HRRZM TA,EAS1PC
DA4.A2: SKIPN DEBSW## ;NEED DEBUG CODE?
JRST DA4.A3 ;NO
MOVE TB,[NAMWRD,,TBLOCK] ;NEED TO SAVE CURRENT NAME
BLT TB,TBLOCK+4 ;SINCE TRACE CODE WILL PRINT IT AGAIN
PUSH PP,FLGSW ;SAVE CURRENT STATE
SETZM FLGSW ;ZERO SO WE DON'T FLAG DEBUG-ITEM
PUSH PP,W1 ;SO TRACING IS CORRECT
PUSH PP,W2 ;...
PUSHJ PP,DA210. ;ALLOCATE DEBUG-ITEM
POP PP,W2
POP PP,W1
POP PP,FLGSW
MOVS TB,[NAMWRD,,TBLOCK]
BLT TB,NAMWRD+4 ;RESTORE PREVIOUS NAME
DA4.A3: PUSHJ PP,CLEANC## ;DO CLEANC HERE SO SUM-CTRS GET ALLOCATED
SKIPN SVDADR ; [315] SEE IF ANY "VALUE" ITEM LEFT
JRST D4.12 ; [315] NONE LEFT
MOVE CH,SVDWRD## ; [315] GET THE LAST "VALUE" DATA
PUSHJ PP,PUTAS1 ; [315] PUT INTO AS1 FILE
SETZM SVDADR ; [315] CLEAR IT
D4.12: HRLZI CH,AS.REL##
HRRI CH,1+AS.DAT##
PUSHJ PP,PUTAS1
HRRZ CH,EAS1PC
DA4.A: HRRZM CH,TBLOCK
MOVE CH,[XWD AS.REL+1,AS.MSC##]
PUSHJ PP,PUTAS1
HRRZ CH,TBLOCK
CAILE CH,077777
HRRZI CH,077777
IORI CH,AS.DOT##
PUSHJ PP,PUTAS1
HRRZ CH,TBLOCK
SUBI CH,077777
JUMPG CH,DA4.A
PUSHJ PP,CLRNAM## ;DELETE UNNECESSARY RESERVED WORDS
ENDFAZ C;
INTER. DA5.
DA5.: MOVEM LN,TBLOCK
DA5.0: MOVEM TYPE,TBLOCK+1
PUSHJ PP,GETITM##
CAIE TYPE,AMRGN.+ENDIT.
CAIN TYPE,ENDIT. ;EOF?
POPJ PP, ;YES
CAMN LN,TBLOCK
JRST DA5.B
MOVEM LN,TBLOCK
CAIE TYPE,AMRGN.+LINKG.
CAIN TYPE,AMRGN.+FILE.
JRST DA5.X
CAIE TYPE,AMRGN.+WORKI.
CAIN TYPE,AMRGN.+PROC.
JRST DA5.X
CAIN TYPE,AMRGN.+RD.
JRST DA5.X
IFN DBMS,<
CAIE TYPE,AMRGN.+SCHEM.
>
CAIN TYPE,AMRGN.+FD.
JRST DA5.X
IFN MCS,<
CAIE TYPE,AMRGN.+COMM. ;COMMUNICATION?
CAIN TYPE,AMRGN.+CD.
JRST DA5.X ;YES
>
CAIN TYPE,PRIOD.
JRST DA5.0
CAIE TYPE,INTGR.
CAIN TYPE,AMRGN.+INTGR.
JRST DA5.X
DA5.B: CAIN TYPE,PIC.
PUSHJ PP,PSCAN##
JRST DA5.0
DA5.X: MOVE TA,TBLOCK+1
CAIE TA,PRIOD.
PUSHJ PP,CE125.
SKPNAM
INTER. DA7.
DA7.: SWON FREGWD;
POPJ PP,
INTER. DA6.
DA6.: SWOFF FREGWD;
POPJ PP,
INTER. DA8.
DA8.: HLRZ TB,CURDAT
JUMPE TB,DA8.X
PUSHJ PP,DA54.
SETZM LASTYP ;CLR LAST RPW TYPE SEEN STORAGE
SETZM LASCOL ; [315] CLR LAST COLUMN SEEN IN GROUP
HLRZ TB,CURDAT
PUSHJ PP,FNDPOP##
JRST DA8.X
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST DA8.X ;FATHER NOT DATTAB
HRRZ TA,TB
HRLZM TB,CURDAT
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,CURDAT
JRST DA8.
DA8.X: SETZM CURDAT
POPJ PP,
INTER. DA9.
DA9.: PUSHJ PP,TRYNAM##
PUSHJ PP,BLDNAM##
HLRZS TA
DPB TA,[POINT 15,W2,15]
TLZ W1,GWNOT
LDB TA,[POINT 15,W2,15]
HRRZI TB,CD.FIL
PUSHJ PP,FNDLNK## ;FIND A FILTAB ENTRY
JRST DA9.E ;NONE FOUND
MOVEM TB,CURFIL ;SAVE POINTER
MOVE TA,TB
LDB TB,FI.FDD## ;FD ALREADY SEEN?
JUMPN TB,DA9.E2 ;YES
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST DA9.1 ;NO
LDB LN,GWLN ;GET LN
LDB CP,GWCP ; & CP
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
PUSHJ PP,@[TST.L## ;SEQUENTIAL
TST.LI## ;RELATIVE
TST.H## ;INDEXED
CPOPJ](TB)
MOVE TA,CURFIL ;TA WAS DESTROYED BY TEST
DA9.1: SETO TB,
DPB TB,FI.FDD
DPB W2,FI.FLC##
JRST DA1.X
DA9.E: EWARNW E.20
DA9.E1: MOVE TA,[XWD CD.FIL,SZ.FIL]
PUSHJ PP,GETENT
MOVEM TA,CURFIL
HRRZI TB,CD.FIL
DPB TB,[POINT 3,0(TA),2]
LDB TB,[POINT 15,W2,15]
DPB TB,FI.NAM##
DPB W2,FI.FLC
HRRZI TC,%%RM
LDB TE,FI.RM2## ;RECORDING MODE CLAUSE SEEN?
SKIPN TE ;YES, DON'T CHANGE
DPB TC,FI.ERM##
DPB TC,FI.IRM##
HRRZI TC,%%LBL
DPB TC,FI.LBL##
HRRZI TC,%%ACC
DPB TC,FI.ORG##
HRRZI TC,1
DPB TC,FI.NDV##
AOS TC,NFILES## ;GET # OF FILES; BUMP COUNTER
DPB TC,FI.NUM## ;STORE # IN FILE TABLE
MOVE TA,[XWD CD.VAL,1]
PUSHJ PP,GETENT
MOVE TB,[ASCII /*****/]
HRRZI TC,03
DPB TC,[POINT 14,TB,13]
MOVEM TB,(TA)
HLRZ TB,TA
MOVE TA,CURFIL
DPB TB,FI.VAL##
LDB TB,[POINT 15,W2,15]
HRRI TA,(TB)
PUSHJ PP,PUTLNK
MOVE TA,CURFIL
JRST DA9.1
DA9.E2: EWARNW E.34
JRST DA9.E1
INTER. DA10R.
DA10R.: FLAGAT RP
JRST DA10.
INTER. DA10S.
DA10S.: FLAGAT HI
SKPNAM
INTER. DA10.
DA10.: PUSHJ PP,DA8.
D10A.0: MOVE TA,CURFIL
JUMPE TA,DA10.X
HRRZ TB,CFLM
HRRZI TD,(TB)
HRRZ TC,EAS2PC
SUBI TD,(TC)
CAIGE TD,5
HRRZI TB,5(TC)
MOVE TE,EAS1PC
TLNE TE,777777
HRRZI TE,1(TE)
CAIGE TB,(TE)
HRRZI TB,(TE)
HRRZM TB,EAS1PC
SETZM EAS2PC
SETZM CFLM
HRRZ TA,CURFIL
SETZM TBLOCK
LDB TB,FI.MRS ;GET MAXIMUM SIZE WE NEED
MOVEM TB,TBLOCK+1 ;USE SIZE AS NON-ZERO FLAG ALSO
LDB TA,FI.DRL##
JUMPE TA,DA10.B ;NO DATA RECORDS
D10A.1: HRLZM TA,CURDAT
PUSHJ PP,LNKSET
HRRM TA,CURDAT
LDB TB,DA.DEF
JUMPN TB,.+3 ;THIS RECORD IS DEFINED
PUSHJ PP,D10E.1
JRST D10A.2
LDB TB,DA.EXS
SKIPE TC,TBLOCK+1 ;VARIABLE LENGTH SYNTAX
CAMG TB,TC ;MUST BE AT LEAST BIG ENOUGH
JRST D10A.4 ;ITS OK
LDB LN,DA.LN
LDB CP,DA.CP
MOVEI DW,E.758 ;RECORD IS NOT BIG ENOUGH
PUSHJ PP,FATAL
D10A.4: SKIPN TC,TBLOCK
HRRZM TB,TBLOCK
CAMN TB,TBLOCK ;SAME SIZE RECORDS?
JRST D10A.3 ;YES
CAMLE TB,TBLOCK
HRRZM TB,TBLOCK
HRRZ TA,CURFIL## ;POINT AT THE FILE.
LDB TB,FI.ERM## ;GET ITS RECORDING MODE.
SETO TC, ;GET SOME ONES.
CAIE TB,%RM.EB ;IF THE RECORDING MODE IS NOT
DPB TC,FI.VLR## ; EBCDIC, SET THE VARIABLE LENGTH
LDB TC,FI.VLR## ; FLAG. IF IT IS EBCDIC AND
JUMPN TC,D10A.2 ; THE VARIABLE LENGTH FLAG IS
HRRZ TA,CURDAT## ; NOT ON, COMPLAIN.
LDB LN,DA.LN
LDB CP,DA.CP
MOVEI DW,E.584 ;ALL RECORDS IN A FILE WHOSE
PUSHJ PP,FATAL## ; RECORDING MODE IS F OR EBCDIC
; MUST BE OF THE SAME LENGTH.
D10A.2: HRRZ TA,CURDAT
D10A.3: LDB TB,DA.FAL
JUMPN TB,DA10.B ;NO MORE DATA RECORDS
LDB TA,DA.BRO##
JUMPN TA,D10A.1 ;CHECK THIS RECORD
DA10.B: HRRZ TA,CURFIL
LDB TB,FI.MRS ;[624] WAS THERE A RECORD CONTAINS CLAUSE?
JUMPE TB,DA10.F ;[624] NO, SO NOTHING TO WORRY ABOUT
HRRZ TC,TBLOCK ;[624] YES, IS IT THE SAME SIZE AS MAX. RECORD?
JUMPE TC,DA10.F ;LAST RECORD WAS A RENAMES SO IGNORE IT
CAIN TB,(TC) ;[624]
JRST DA10.F ;[624] YES, SO NO PROBLEM
LDB TB,FI.ERM ;[624] GET ITS RECORDING MODE.
CAIN TB,%RM.EB ;[706] IF THE RECORDING MODE IS EBCDIC,
JRST DA10.G ;[706] GO CHECK FOR VARIABLE LENGTH
HRRZ TA,CURFIL ;[723] [706] OTHERWISE, IT IS NOT EBCDIC,
LDB TB,FI.DRL ;[723] SO FIND MAX. RECORD
JUMPE TB,[LDB TB,FI.RPG ;[1011] IF ITS A REPORT FILE
JUMPN TB,DA10.X ;[1011] THEN ITS OK NOT TO HAVE A DATA-RECORD
MOVEI DW,E.201 ;[733] NO DATA RECORD
LDB LN,FI.FLN## ;[733]
LDB CP,FI.FCP## ;[733]
JRST DA10.J] ;[733] GIVE ERROR MESSAGE
LDB TA,FI.DRL ;POINT TO FIRST DATA RECORD
DA10.E: PUSHJ PP,LNKSET ;[723]
LDB TB,DA.EXS ;[723] GET SIZE
CAMN TB,TBLOCK ;[723] IS THIS IT?
JRST DA10.H ;[723] YES
LDB TB,DA.FAL ;[723]
JUMPN TB,DA10.I ;[723] GIVE UP, NO MORE RECORDS
LDB TA,DA.BRO ;[723]
JRST DA10.E ;[723] TRY THIS ONE
DA10.H: LDB LN,DA.LN ;[723] [706] SO GET LINE
LDB CP,DA.CP ;[706] AND CHARACTER POSITION
MOVEI DW,E.622 ;[706] FOR WARNING
PUSHJ PP,WARN ;[706] AND TELL THE USER SOMETHING MAY BE WRONG
JRST DA10.I ;[706] AND CONTINUE
DA10.G: LDB TC,FI.VLR## ;[706] [624] IT'S EBCDIC, IS IT VARIABLE LENGTH (V)
JUMPN TC,DA10.F ;[624] YES, IT'S OK
HRRZ TA,CURDAT ;[624] IT'S F MODE, WARN THE USER
LDB LN,DA.LN ;[624]
LDB CP,DA.CP ;[624]
MOVEI DW,E.614 ;[624] MAX. RECORD SIZE MUST MATCH
DA10.J: PUSHJ PP,FATAL ;[733] [624] RECORD CONTAINS CLAUSE IN FD
DA10.I: HRRZ TA,CURFIL ;[624]
DA10.F: HRRZ TB,TBLOCK ;[624]
DPB TB,FI.MRS
DA10.X: SETZM CURFIL
SETZM CURDAT
SETZM DATLVL ;INIT LAST DATA LEVEL HOLD
SETZM LSTDAT## ;& CLR LAST DATA-ITEM-NOT-A-REDEF TABLE
MOVE TA,[LSTDAT,,LSTDAT+1]
BLT TA,LSTDAT+^D49
POPJ PP,
D10E.1: HRRZ TA,CURDAT
LDB LN,DA.LN##
LDB CP,DA.CP
HRRZI DW,E.104 ;'NOT DEFINED'
JRST FATAL
INTER. DA11.
DA11.: TLNE W1,GWNLIT ;IS ITEM NUMERIC LITERAL?
TLNE W1,GWDP ;YES, IS IT INTEGER?
JRST DA11.E ;NO
LDB TB,GWVAL ;NO. OF CHARACTERS
MOVEM TB,CTR##
HRRZI TA,LITVAL##
PUSHJ PP,GETVAL
MOVEM TC,0(SAVPTR)
POPJ PP,
DA11.E: SETZB TC,0(SAVPTR)
EWARNJ E.25
INTER. DA12.
DA12.: SETZ TC,
PUSH SAVPTR,TC
PUSHJ PP,DA11.
POP SAVPTR,TC
CAML TC,0(SAVPTR)
MOVEM TC,0(SAVPTR)
POPJ PP,
INTER. DA13.
DA13.: HRLZM LN,RCLNCP## ;SAVE LN AND CP
HRRM CP,RCLNCP ;SO WE CAN FLAG IT RIGHT
SETZ TB,
EXCH TB,0(SAVPTR)
CAIL TB,^D4096 ;REQUIRE BLK FACTOR .LE. 4095
EWARNJ E.2 ;IT ISN'T
SKIPE TA,CURFIL
DPB TB,FI.BLF##
POPJ PP,
INTER. DA13A.
DA13A.: SKIPN TA,CURFIL
POPJ PP,
LDB TB,FI.BLF
LDB TC,FI.FBS
JUMPE TB,DA7. ;SHOULD HAVE SEEN RECORD
JUMPN TC,DA7. ;BUT NOT CHARACTERS
DPB TC,FI.BLF ;YES, SO SWAP EFFECT
DPB TB,FI.FBS ;OF SEEING RECORD TOO SOON
POPJ PP,
INTER. DA14.
DA14.: SETZ TB,
EXCH TB,(SAVPTR)
SKIPE TA,CURFIL
DPB TB,FI.FBS## ;BUFFER SIZE
POPJ PP,
INTER. DA15.
DA15.: SETZ TB,
EXCH TB,0(SAVPTR)
SKIPN TA,CURFIL
POPJ PP,
LDB TC,FI.MRS## ;MAX. DATA RECORD SIZE
CAIGE TC,(TB)
DPB TB,FI.MRS
LDB TC,FI.LRS
CAIG TC,(TB) ;MIN. GREATER THAN MAX.?
POPJ PP,
EWARNJ E.847 ;YES
INTER. DA15T.
DA15T.: SETZ TB,
EXCH TB,0(SAVPTR)
SKIPN TA,CURFIL
POPJ PP,
LDB TC,FI.LRS## ;MIN. DATA RECORD SIZE
SKIPE TC ;BUT NOT ZERO
CAILE TC,(TB)
DPB TB,FI.LRS
POPJ PP,
INTER. DA16.
DA16.: MOVE TA,FI.DRL ;DATA RECORD LINK
MOVEM TA,PNTS##
MOVE TA,DA.DRC##
MOVEM TA,PNTS2##
SETO TB,
SKIPE TA,CURFIL
DPB TB,FI.DRC##
JUMPE TA,DA25F. ;TEST FOR FIPS FLAGGER
LDB TB,FI.RPG## ;HAVE WE ALREADY SEEN A REPORT CLAUSE?
JUMPE TB,DA25F. ;NO
EWARNW E.749 ;YES, WARN USER
JRST DA25F. ;TEST FOR FIPS FLAGGER
INTER. DA17.
DA17.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TB,TA ;GET NAMTAB LINK (ITS ALL WE HAVE)
SKIPE TA,CURFIL ;GET CURRENT FILE
DPB TB,FI.DEP## ;STORE DEPENDING VARIABLE
POPJ PP,
INTER. DA18.
DA18.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
MOVEM TA,CURNAM
TLZ W1,GWNOT
HLRS TA
DPB TA,[POINT 15,W2,15]
DA18.P: MOVE TA,[XWD CD.DAT,SZ.DAT+SZ.DOC+SZ.MSK]
PUSHJ PP,GETENT##
MOVEM TA,CURDAT
LDB TB,[POINT 15,W2,15]
IORI TB,CD.DAT*1B20
MOVSM TB,0(TA)
DPB W2,DA.LNC##
SETZ TB, ;LEVEL 0 IS USED FOR 'PRE-NAMED' DATA ITEMS
DPB TB,DA.LVL
SETO TB,
DPB TB,DA.CLA## ;CLASS
DPB TB,DA.PWA
TSWF FFILSC;
DPB TB,DA.DFS##
SKIPN TA,CURFIL
JRST DA18.X
MOVE TA,CURDAT
DPB TB,PNTS2 ;SET 'LABEL RECORD' OR 'DATA RECORD' BIT
MOVE TA,CURFIL
LDB TB,PNTS ;GET 'DATA RECORD' OR 'LABEL RECORD' PTR
JUMPE TB,DA18.V ;THIS IS FIRST SUCH RECORD
HLRZ TC,CURDAT
DPB TC,PNTS
MOVE TA,CURDAT
DA18.Q: DPB TB,DA.BRO ;BROTHER LINK
DA18.W: LDB TB,[POINT 15,W2,15]
HRRI TA,(TB)
JRST PUTLNK
DA18.T: PUSHJ PP,FNDNXT##
JRST DA18.P
LDB TC,DA.LVL## ;LEVEL OF ITEM
CAIE TC,1 ;RECORD
JRST DA18.T ;NO
MOVEM TA,TBLOCK
MOVEM TB,TBLOCK+1
HLRS TB ;GET RELATIVE ADDRESS IN R. H.
PUSHJ PP,FNDPOP ;FIND FATHER LINK
HLRZ TC,CURFIL
CAMN TB,TC ;CURRENT FILE?
EWARNJ E.35 ;YES
MOVE TA,TBLOCK
MOVE TB,TBLOCK+1
JRST DA18.T
DA18.V: HLRZ TB,CURDAT
DPB TB,PNTS
SETO TB,
MOVE TA,CURDAT
DPB TB,DA.FAL ;'FATHER LINK' FLAG
HLRZ TB,CURFIL
JRST DA18.Q
DA18.X: MOVE TA,CURDAT
JRST DA18.W
INTER. DA18A. ;[1356]
DA18A.: PUSHJ PP,TRYNAM ;[1356] IS NAME IN TABLE?
JRST DA18B. ;[1356] NO
HLRZS TA ;[1356] SET UP REL ADDR AND
HRRZI TB,CD.FIL ;[1356] TYPE CODE FOR TABLE SEARCH
PUSHJ PP,FNDLNK ;[1356] SEARCH FILTAB
JRST DA18B. ;[1356] ENTRY NOT FOUND
MOVE TA,CURFIL ;[1356] GET CURRENT FILE ADDR
CAMN TA,TB ;[1356] SAME FILE USED TO QUALIFY?
POPJ PP, ;[1356] YES
DA18B.: EWARNJ E.190 ;[1356] GIVE IMPROPER QUALIFICATION MSG.
INTER. DA19.
DA19.: HRRZI TC,%LBL.S ;'STANDARD LABELS' CODE
CHKLBL: MOVE TA,CURFIL
JUMPE TA,CPOPJ
LDB TB,FI.LBL
CAIE TB,%%LBL ;INITIAL STATE?
EWARNJ E.16 ;NO--ERROR
DPB TC,FI.LBL
POPJ PP,
INTER. DA20.
DA20.: HRRZI TC,%LBL.O ;'OMITTED LABELS' CODE
JRST CHKLBL
INTER. DA21.
DA21.: FLAGAT NS
MOVEI TA,%HL.PR ;'VALUE OF PROTECTION CODE' FLAG
MOVEM TA,PNTS
POPJ PP,
INTER. DA22.
DA22.: MOVEI TA,%HL.VI ;'VALUE OF IDENTIFICATION' FLAG
MOVEM TA,PNTS
POPJ PP,
INTER. DA23.
DA23.: FLAGAT NS
MOVEI TA,%HL.VD ;'VALUE OF DATE-WRITTEN' FLAG
MOVEM TA,PNTS
POPJ PP,
;GET LITERAL VALUE OF IDENTIFICATION
INTER. DA24I.
DA24I.: HLRZ TB,W1 ;GET LENGTH OF LITERAL
ANDI TB,777
IFE TOPS20,<
CAIG TB,^D17 ;17 CHARS OR LESS?
>
IFN TOPS20,<
CAIG TB,377 ;255 CHARS OR LESS?
>
JRST DA24I1 ;YES
IFE TOPS20,<
MOVEI TB,^D17 ;NO, TRUNCATE
>
IFN TOPS20,<
MOVEI TB,377 ;NO, TRUNCATE
>
HRRZI DW,E.238 ;& WARN
PUSHJ PP,DA24X.
DA24I1: MOVEM TB,TBLOCK+2 ;SAVE TRUE SIZE
PUSHJ PP,DA24S. ;SET PTRS & CTR
IFE TOPS20,<
SETZM TBLOCK+1 ;CLR NON-STANDARD CHAR FLAG
>
DA24I3:
DA24I4: ILDB TE,TB ;GET LITERAL CHAR
IFE TOPS20,< ;ALLOW ALL CHARACTERS IN TOPS-20
CAIN TE,40 ;MAKE SURE CHAR IS A-Z OR 0-9 OR SPACE
JRST DA24I6 ;IT'S SPACE
CAIL TE,"a" ; [356] IF LOWER CASE
CAILE TE,"z" ; [356]
TRNA ; [356] IT IS NOT.
TRZ TE,40 ; [356] CONVERT TO UPPER CASE
CAIL TE,"0"
CAILE TE,"Z"
JRST DA24I5 ;NON-STANDARD CHAR
CAILE TE,"9"
CAIL TE,"A"
JRST DA24I6 ;CHAR IS OK
DA24I5: CAIN TE,"." ;ALLOW "." ALSO
JRST DA24I6
AOS TBLOCK+1 ;REQUEST NON-STD CHAR WARNING
>
DA24I6: IDPB TE,TC ;STORE LITERAL CHAR
SOSLE TBLOCK ;COUNT CHARS INCLUDING PADDING
JRST DA24I3 ;DO NEXT CHAR
IFE TOPS20,<
SKIPE TBLOCK+1 ;NEED A NON-STD CHAR WARNING?
PUSHJ PP,DA24W. ;YES
>
HRRZ TA,CURFIL
MOVE TB,TBLOCK+2 ;GET SIZE OF LITERAL
DPB TB,FI.SID## ;SAVE FOR RUN TIME
SKIPA TD,FI.VID## ;GET PTR TO VAL-OF-ID
DA24I8: HRRZ TA,CURFIL ;FILTAB ADDR
HLRZ TB,CURVAL ;VALTAB REL ADDR
LDB TC,TD ;VALUE SEEN BEFORE?
JUMPN TC,JCE16. ;YES, DUPLICATE CLAUSE
DPB TB,TD ;NO, STORE VALTAB LINK
POPJ PP,
;GET LITERAL VALUE OF PROTECTION CODE
INTER. DA24C.
DA24C.: HLRZ TB,W1 ;GET LENGTH OF LITERAL
ANDI TB,777
CAILE TB,6 ;MORE THAN 6 CHARS?
EWARNJ E.336 ;YES, THAT'S ILLEGAL
PUSHJ PP,DA24S. ;SET PTRS & CTR
DA24C1: SOJL TD,DA24C2 ;SKIP IF FINISHED
ILDB TE,TB ;GET LITERAL CHAR
CAIL TE,"0" ;IS IT AN OCTAL DIGIT?
CAILE TE,"7"
EWARNJ E.336 ;ILLEGAL CHARACTER
IDPB TE,TC ;STORE LITERAL CHAR
JRST DA24C1 ;DO NEXT CHAR
DA24C2: HRRZ TA,CURFIL ;FILTAB ADDR
HLRZ TB,CURVAL ;VALTAB REL ADDR
LDB TC,FI.PRT## ;SEEN PROTECTION BEFORE?
JUMPN TC,JCE16. ;YES, DUPLICATE CLAUSE
DPB TB,FI.PRT ;NO, STORE IT
POPJ PP,
;GET LITERAL VALUE OF DATE-WRITTEN
INTER. DA24D.
DA24D.: HLRZ TB,W1 ;GET LENGTH OF LITERAL
ANDI TB,777
CAIGE TB,6 ;FEWER THAN 6 CHARS?
EWARNJ E.333 ;YES, THAT'S ILLEGAL
CAIG TB,6 ;MORE THAN 6?
JRST DA24D1 ;NO, OK
MOVEI TB,6 ;YES, TRUNCATE
HRRZI DW,E.238 ;& WARN
PUSHJ PP,DA24X.
DA24D1: PUSHJ PP,DA24S. ;SET PTRS & CTR
SETZM TBLOCK ;CLR NON-STANDARD CHAR FLAG
DA24D2: SOJL TD,DA24D3 ;SKIP IF FINISHED
ILDB TE,TB ;GET LITERAL CHAR
CAIL TE,"0" ;IS IT A DIGIT?
CAILE TE,"9"
AOS TBLOCK ;NO, REQUEST FLAG
IDPB TE,TC ;STORE LITERAL CHAR
JRST DA24D2 ;DO NEXT CHAR
DA24D3: SKIPE TBLOCK ;NEED A NON-STD CHAR WARNING?
PUSHJ PP,DA24W. ;YES
MOVE TD,FI.VDW## ;GET PTR TO VAL-OF-DATE-WRITTEN
JRST DA24I8
;GET LITERAL VALUE OF PROJECT-PROGRAMMER
INTER. DA24P.
DA24P.: HLRZ TB,W1 ;GET LENGTH OF LITERAL
ANDI TB,777
TLNE W1,GWNLIT ;IS IT A NUMERIC LITERAL?
TLNE W1,GWDP ;DOES IT HAVE A DECIMAL POINT
EWARNJ E.336 ;NOT AN INTEGER
CAILE TB,6 ;MORE THAN 6 CHARS?
EWARNJ E.336 ;YES
PUSHJ PP,DA24S. ;SET PTRS & CTR
DA24P2: SOJL TD,DA24P3 ;SKIP IF FINISHED
ILDB TE,TB ;GET LITERAL CHAR
CAIL TE,"0" ;IS IT AN OCTAL DIGIT?
CAILE TE,"7"
EWARNJ E.336 ;ILLEGAL CHARACTER
IDPB TE,TC ;STORE LITERAL CHAR
JRST DA24P2 ;DO NEXT CHAR
DA24P3: HRRZ TA,CURFIL ;FILTAB ADDR
HLRZ TB,CURVAL ;VALTAB REL ADDR
LDB TC,FI.VPP## ;1ST HALF OF PPN ALREADY IN?
SKIPN TC ;IF SO, 2ND HALF ASSUMED IN NEXT VALTAB ENTRY
DPB TB,FI.VPP ;NO, STORE 1ST HALF VALTAB LINK
POPJ PP,
;SUBROUTINE TO SET UP PTRS AND CTR FOR TRANSFERRING LITERAL TO VALTAB
DA24S.: MOVEM TB,TBLOCK ;SAVE LENGTH OF LITERAL
ADDI TB,2+4 ;ALLOW FOR COUNT AND REMAINDER
IDIVI TB,5 ;NUMBER OF WORDS
HRRZ TA,TB
HRLI TA,CD.VAL
PUSHJ PP,GETENT
MOVEM TA,CURVAL ;SAVE VALTAB ADDR
HLR W1,TA ;PUT POINTER IN W1
MOVE TB,[POINT 7,LITVAL] ;'GET' POINTER
MOVE TC,[POINT 14,(TA),13] ;COUNT POINTER
MOVE TD,TBLOCK ;SIZE
DPB TD,TC
MOVE TC,[POINT 7,(TA),13] ;'PUT' POINTER
POPJ PP,
;ISSUE A WARNING FOR NON-STD CHAR IN VALUE ITEM
DA24W.: HRRZI DW,E.242 ;NON-STD CHAR
DA24X.: LDB LN,GWLN## ;GET LINE POSITION
LDB CP,GWCP##
JRST WARN
;2ND HALF OF PROJ-PROGRAMMER NUMBER MISSING
INTER. DA24PE
DA24PE: MOVE TA,[XWD CD.VAL,1] ;GET 1-WORD VALTAB ENTRY
PUSHJ PP,GETENT
MOVSI TB,26 ;PUT <null>,1,"0" IN VALTAB
MOVEM TB,(TA)
EWARNJ E.335 ;FATAL ERROR
INTER. DA25.
DA25.: PUSHJ PP,DA25G. ;SEE IF FIPS FLAGGER WANTED
PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZ TB,PNTS ;STORE 'VALUE OF XXX' FLAG
DPB TB,HL.COD
HLRZ TB,CURFIL ;STORE FILTAB LINK IN HLDTAB
DPB TB,HL.LNK
POPJ PP,
;TEST FOR LEVEL 1 SYNTAX (I.E. SEQ 1, REL 1, IDX 1)
INTER. DA25F.
DA25F.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[TST.L ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;TEST FOR LEVEL 2 SYNTAX (I.E. SEQ 2, REL 2, IDX 2)
INTER. DA25G.
DA25G.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[TST.HI ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;SAVE LN & CP SINCE WE DON'T KNOW WHAT CLAUSE WE HAVE JUST YET
INTER. DA25R.
DA25R.: HRLZM LN,RCLNCP## ;SAVE LN
HRRM CP,RCLNCP ; AND CP
POPJ PP, ;SO WE CAN FLAG IT RIGHT
;SET UP HLDTAB ENTRY
DA25S.: MOVE TA,[XWD CD.HLD,SZ.HLD] ;GET A HLDTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURHLD## ;SAVE ADDR
HLRZ TB,CURNAM ;PUT LINK TO NAMTAB IN HLDTAB
DPB TB,HL.NAM##
DPB W2,HL.LNC## ;ALSO POSITION OF ITEM IN SOURCE
SETZ TB, ;CLR # OF QUALIFIERS
DPB TB,HL.QAL##
POPJ PP,
;CHECK LEVEL NUMBER FOR 01 LEVEL ITEMS
INTER. DA26.
DA26.: PUSHJ PP,DA11. ;GET VALUE OF INTEGER
DA26N.: SKIPG TC,0(SAVPTR)
JRST DA26.E
SETZM LSTW77## ;ASSUME THIS IS LEVEL 77.
CAIE TC,^D77 ;IS IT?
SETOM LSTW77## ;NO, REMEMBER THAT.
SKIPN REPSEC ;IN REPORT SECTION?
JRST DA26.1 ;NO
CAILE TC,LVL.49 ;YES, ONLY 1-49 ARE LEGAL.
JRST DA26.E ;COMPLAIN.
CAIE TC,LVL.01 ;IF IT'S 01, NOTE THAT WE
JRST DA26.A ; HAVEN'T SEEN A LINE OR
SETZM RWLCS.## ; COLUMN CLAUSE YET.
SETZM RWCCS.##
JRST DA26.A
DA26.1: CAIN TC,^D66
JRST DA26.R ;LEVEL 66
CAILE TC,LVL.49 ;49. IS MAX. LEVEL NUMBER
CAIN TC,^D77 ;EXCEPT FOR 77
JRST DA26.A
DA26.E: EWARNW E.64
HRRZ TC,LEVEL
CAILE TC,0
CAILE TC,LVL.49
HRRZI TC,LVL.01
MOVEM TC,0(SAVPTR)
DA26.X: PUSHJ PP,SAVLVL ;LEAVE TRACKS FOR REDEFINES
SETZM RUSAGE## ;INIT GROUP ITEM USAGE CHECK
SKIPN FLGSW## ;FIPS FLAGGER REQUESTED?
POPJ PP, ;NO
LDB TB,GWVAL## ;GET SIZE OF LITERAL
CAIE TB,2 ;MUST BE TWO CHARACTERS
PUSHJ PP,FLG.HI## ;NO, FLAG AT HIGH-INTERMEDIATE LEVEL
POPJ PP,
DA26.A: CAIN TC,^D77 ;77.
HRRZI TC,LVL.77
MOVEM TC,LEVEL
CAIE TC,LVL.01
CAIN TC,LVL.77 ;77-LEVEL ITEM
JRST DA26.X
HRRZI TC,LVL.01
MOVEM TC,LEVEL
EWARNJ E.48
DA26.R: SKIPE FLGSW## ;FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
HRRZI TC,LVL.66
HRRZM TC,LEVEL
HRRZI NODE,DD165.##
HRRZM NODE,0(NODPTR)
POPJ PP,
;REMEMBER THIS DATA LEVEL FOR REDEFINES
;ALSO IF LEVEL INCREASING, CLEAN UP PART OF TABLE BELOW THIS
SAVLVL: SKIPE REPSEC ;NOT NEEDED BY REPORT SECTION
POPJ PP,
MOVE TA,(SAVPTR) ;NEW LEVEL
CAIN TA,^D77 ;CONVERT 77 TO 1
MOVEI TA,1
CAML TA,DATLVL## ;ARE WE GOING UP A LEVEL?
JRST SAVLV1 ;NO
HRLZI TB,LSTDAT+1(TA) ;YES, CLEAR BELOW THIS LEVEL
HRRI TB,LSTDAT+2(TA)
SETZM LSTDAT+1(TA)
BLT TB,LSTDAT+^D49
SAVLV1: MOVEM TA,DATLVL ;REMEMBER THIS LEVEL
POPJ PP,
;SET UP DATAB ENTRY FOR 01 LEVEL ITEMS
INTER. DA27.
DA27.: SKIPL REPSEC ;IN REPORT SECTION AND NOT PAGE- OR LINE-CTR?
JRST .+4 ;NO
SKIPN NAMWRD ;YES, DOES ITEM HAVE A NAME?
JRST DA27.S ;NO
SETZM RPWPFL## ;SET PAGE FOOTING LINE CLAUSE TO ZERO
TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
HRRZI TB,(TYPE) ;(EXCEPT FILLERS)
ANDI TB,1777
CAIE TB,FILLE.
PUSHJ PP,PUTCRF##
DA27A: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
MOVEM TA,CURNAM
HLRZS TA ;NAMTAB POINTER
DPB TA,[POINT 15,W2,15]
TLZ W1,GWNOT;
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK ;FIND DATTAB LINK
JRST DA27.N ;NONE
DA27.0: MOVE TA,TB ;GET LEVEL
LDB TC,DA.LVL
CAIE TC,LVL.01
CAIN TC,LVL.77
JRST .+2
JUMPN TC,DA27.B ;NOT AN INDEPENDENT ITEM
HRRZI TB,(TYPE)
ANDI TB,1777
CAIN TB,FILLE.
JRST DA27.B ;FILLER
MOVEM TA,TBLOCK+15
MOVEM TB,TBLOCK+16
HLRZ TB,TA ;REL. ADDR. OF ITEM
PUSHJ PP,FNDPOP
SETZ TB,
SKIPLE TD,REPSEC ;DOING REPORT SECTION PAGE- OR LINE-CTR?
JUMPE TB,D27.E3 ;YES, IF OTHER ITEM HAS NO FATHER, ERROR
JUMPN TD,D27.B0 ;ALL REPORT ITEMS NOW SKIP AHEAD
HLRZ TD,CURFIL
CAIE TB,(TD)
JRST D27.B0
TSWT FFILSC;
JRST D27.E1 ;IN W-S==ERROR
MOVE TA,TBLOCK+15
HLRZM TA,TBLOCK ;REL. ADDR. OF RECORD
HRRZ TA,CURFIL
LDB TB,FI.DRL ;DATA RECORDS CHAIN
DA27.A: JUMPE TB,D27.E2 ;NO
CAMN TB,TBLOCK
JRST DA27.F ;IT IS A DATA RECORD
PUSHJ PP,FNDBRO## ;FIND BROTHER LINK
JRST D27.E2 ;NONE
JRST DA27.A
D27.B0: MOVE TA,TBLOCK+15
MOVE TB,TBLOCK+16
DA27.B: PUSHJ PP,FNDNXT
JRST DA27.N
JRST DA27.0
DA27.N: TSWF FFILSC;
JRST D27.E2 ;IN FILE SECTION---ERROR
DA27.S: MOVE TA,[XWD CD.DAT,SZ.DAT]
D27N.1: PUSHJ PP,GETENT
MOVEM TA,CURDAT
IFN MCS,<
SKIPN COMSEC## ;IN COMM SECTION?
JRST D27MCX ;NO, NORMAL PROCESSING
PUSH PP,TA
PUSH PP,W1
PUSH PP,W2
MOVE TA,LAST01
PUSHJ PP,LNKSET ;GET ADDRESS OF LAST DATAB ENTRY
HLRZ TC,(TA) ;GET NAMTAB LINK
DPB TC,[POINT 15,W2,15]
HRRZ W1,LAST01
PUSHJ PP,DA30.
POP PP,W2
POP PP,W1
POP PP,TA
D27MCX:>
LDB TB,[POINT 15,W2,15]
DPB TB,DA.NAM##
HRRZI TB,CD.DAT
DPB TB,[POINT 3,(TA),2]
HRRZ TB,LEVEL##
DPB TB,DA.LVL
SETO TB,
DPB TB,DA.CLA
DPB TB,DA.DEF
SKIPN LNKSEC ;LINKAGE SECTION?
JRST D27MCY ;[***] NO
MOVE TB,EAS1PC ;[***] YES, GET CURRENT VALUE OF EAS1PC
MOVEM TB,LNK1PC## ;[***] AND SAVE FOR LATER
SETO TB, ;[***]
SETZM EAS1PC ;YES, RESET DATA PC
DPB TB,DA.LKS## ; SET LINKAGE FLAG IN ENTRY
D27MCY: TSWF FFILSC ;[***]
DPB TB,DA.DFS
DPB W2,DA.LNC
LDB TB,DA.NAM
SKIPL REPSEC ;RPW SECTION AND NOT PAGE- OR LINE-CTR?
JRST D29XIT ;NO
SETZM THSCTL ;CLR STORE FOR CURRENT CF CONTROL
HRRZ TB,RPWRDL## ;LINK ITEM TO FATHER REPORT
HRRZ TA,CURDAT
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
PUSHJ PP,GETRDL ;MAKE PTR TO RD ENTRY
LDB TB,RW.FGP## ;GET LINK TO LAST GROUP ITEM SEEN
HLRZ TC,CURDAT ;GET LINK TO NEW GROUP
DPB TC,RW.FGP ;STORE LINK TO NEW GROUP IN RD ENTRY
JUMPE TB,D27XIT ;EXIT IF THIS WAS THE 1ST GROUP ITEM
HRRZ TA,CURDAT ;LINK NEW GROUP BACK TO LAST AS A BROTHER
DPB TB,DA.BRO
SETZ TB,
DPB TB,DA.FAL
D27XIT: MOVE TA,CURDAT ;SET UP FOR PUTLNK
LDB TB,DA.NAM
JRST D29XIT
D27.E1: MOVE TA,CURDAT
SETO TB,
DPB TB,DA.ERR
EWARNJ E.60
D27.E2: HLRZ TB,CURFIL ;[751] GET FILE TABLE POINTER
JUMPE TB,D27.E5 ;[751] ERROR IF NOT DEFINED
MOVE TA,[XWD CD.DAT,SZ.DAT+SZ.DOC+SZ.MSK]
PUSHJ PP,D27N.1
HLRZ TB,CURFIL
HRRZ TA,CURDAT
DPB TB,DA.POP##
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.DRC
DPB TB,DA.PWA
HRRZ TA,CURFIL
LDB TB,FI.DRL
HLRZ TC,CURDAT
DPB TC,FI.DRL
JUMPE TB,D27E22
HRRZ TA,CURDAT
DPB TB,DA.BRO
SETZ TB,
DPB TB,DA.FAL
HRRZ TA,CURFIL
D27E22: LDB TB,FI.DRC
JUMPE TB,D27F.1
EWARNW E.228
JRST D27F.1
DA27.F: HRLZM TB,CURDAT
HRRZI TA,(TB)
PUSHJ PP,LNKSET##
HRRM TA,CURDAT
LDB TC,DA.DEF
SETO TB,
DPB TB,DA.DEF
HRRZ TB,LEVEL
DPB TB,DA.LVL
DPB W2,DA.LNC
JUMPN TC,JCE16.
D27F.1: HRRZ TB,EAS2PC##
EXCH TB,EAS1PC
TLZE TB,777777
HRRZI TB,1(TB)
CAMLE TB,CFLM
HRRZM TB,CFLM
POPJ PP,
D27.E5: PUSHJ PP,DA27.S ;[751] BUILD SMALL DATAB ENTRY
MOVEI DW,E.13 ;[175] NO FILE NAME FOR THIS RECORD
JRST FATALW ;[175] FATAL ERROR AND FFATAL SW ON
JCE25.: EWARNJ E.25 ;?POSITIVE INTEGER REQUIRED
JCE183: EWARNJ E.183
JCE268: EWARNJ E.268
JCE269: EWARNJ E.269
;PAGE-COUNTER OR LINE-COUNTER INDEPENDENTLY DEFINED IN WORKING-STORAGE
D27.E3: LDB LN,DA.LN ;GET POSITION OF W-S ITEM
LDB CP,DA.CP
HRRZI DW,E.399
JRST FATAL
;CHECK LEVEL NUMBER FOR ALL ITEMS BELOW 01 LEVEL
INTER. DA28.
DA28.: SKIPG TA,0(SAVPTR)
JRST DA28.E ;ERROR IF .LE. 0
CAIN TA,LVL.01
JRST DA28.A
CAIG TA,LVL.49 ;IF THE LEVEL INDICATES A SPECIAL
SKIPGE LSTW77## ; ITEM, OR THE LAST ITEM WAS NOT
JRST DA28.5 ; A LEVEL 77 ITEM, GO ON.
EWARNW E.567 ;COMPLAIN. A LEVEL 77 ITEM WAS
; FOLLOWED BY AN ITEM WITH A LEVEL
; BETWEEN 02 AND 49.
HRLZI TA,(<SIXBIT '01'>) ;FAKE AN 01 LEVEL.
MOVEM TA,NAMWRD##
HRLZI TA,(<ASCII "01">)
MOVEM TA,LITVAL
JRST DA28.F ;GO PRETEND IT'S AN 01.
DA28.5: SKIPN REPSEC ;IN REPORT SECTION?
JRST DA28.0 ;NO
CAIG TA,LVL.49 ;YES, ONLY 01-49 ALLOWED
POPJ PP, ;OK
JRST DA28.E ;TOO BIG
DA28.0: PUSHJ PP,SAVLVL ;LEAVE TRACKS FOR REDEFINES
MOVE TA,(SAVPTR) ;RESTORE TRUE LEVEL #
CAIE TA,^D77 ;LEVEL 77
JRST DA28.B
TSWF FFILSC;
EWARNW E.46
DA28.A: PUSHJ PP,DA7.
JRST DA0.
DA28.B: CAIE TA,^D88 ;88-LEVEL?
JRST DA28.R
HRRZI NODE,DD93A.## ;YES
HRRZM NODE,(NODPTR)
SKIPE FLGSW## ;FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
POPJ PP,
DA28.R: CAIN TA,^D66
JRST DA28.S ;LEVEL 66
SKIPN FLGSW## ;FIPS FLAGGER REQUESTED?
JRST DA28.D ;NO
LDB TB,GWVAL## ;GET SIZE OF LITERAL
CAIG TA,LVL.10 ;YES, SEE IF IN NUCLEUS 2 (GT 10)
CAIE TB,2 ;OR NOT TWO CHARACTERS
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
DA28.D: CAIG TA,LVL.49
POPJ PP,
DA28.E: EWARNW E.64 ;LEVEL NUMBER NOT LEGAL
HRRZ TA,LEVEL
CAILE TA,0
CAILE TA,LVL.49
DA28.F: HRRZI TA,LVL.01
MOVEM TA,0(SAVPTR)
JRST DA28.A
DA28.S: HRRZI NODE,DD86A.##
HRRZM NODE,0(NODPTR)
SKIPE FLGSW## ;FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
JRST DA7.
;SET UP DATAB ENTRY FOR ALL ITEMS BELOW 01 LEVEL
INTER. DA29.
DA29.: SKIPN REPSEC ;IN REPORT SECTION?
JRST .+3 ;NO
SKIPN NAMWRD ;YES, DOES ITEM HAVE A NAME?
JRST DA29.0 ;NO
TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
HRRZI TB,(TYPE) ;IF ITEM IS FILLER, SKIP PUTCRF
ANDI TB,1777
CAIE TB,FILLE.
PUSHJ PP,PUTCRF
TLZN W1,GWNOT ;[373] IF DEFINED ALREADY
JRST DA29.0 ;[373] THEN DON'T ENTER AGAIN
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TB,TA
DPB TB,[POINT 15,W2,15]
;NOTE: COMMENTS ADDED 9-FEB-75 /ACK
; ACTUALLY THE WHOLE THING SHOULD BE REWRITTEN, BUT THERE IS NO TIME.
DA29.0: HRRZ TC,0(SAVPTR) ;GET THE LEVEL NUMBER.
CAIN TC,^D66 ;LEVEL 66?
JRST DA29.R ;YES, GO WORRY OVER RENAME STUFF.
CAIN TC,^D77 ;LEVEL 77?
HRRZI TC,LVL.01 ;YES, PRETEND IT'S LEVEL 01 FOR A WHILE.
HRRZ TA,CURDAT ;GET THE CURRENT ITEM'S DATAB ADR.
JUMPE TA,DA29.A ;NO CURRENT ITEM.
LDB TB,DA.LVL ;PICK UP THE CURRENT ITEM'S LEVEL NUMBER.
CAIL TB,(TC) ;IS THE CURRENT ITEM'S LEVEL NUMBER
; LESS THAN THE NEW ITEM'S?
JRST DA29.B ;NO, NEW ITEM SAME OR LOWER LEVEL NUMBER
;WE GET HERE IF THE LEVEL NUMBER OF THE NEW ITEM IS GREATER THAN THE
; LEVEL NUMBER OF THE CURRENT ITEM.
DA29.A: SETZM LASCOL ;[315] CLEAR THE LAST COL NO.
;WE GET HERE IF THERE IS NO CURRENT ITEM OR THE LEVEL NUMBER OF THE
; NEW ITEM IS GREATER THAN THE CURRENT ITEM'S.
; SET UP AND INITIALIZE A DATAB ENTRY.
MOVE TA,[XWD CD.DAT,SZ.DAT] ;GET A DATAB ENTRY.
PUSHJ PP,GETENT
LDB TB,[POINT 15,W2,15] ;GET THE NAMTAB LINK.
DPB TB,DA.NAM ;PUT IT IN THE DATAB ENTRY.
HRRZI TB,CD.DAT ;I AM A DATAB ENTRY.
DPB TB,[POINT 3,(TA),2]
HRRZ TB,0(SAVPTR) ;GET THE LEVEL NUMBER BACK.
CAIN TB,^D77 ;LEVEL 77?
HRRZI TB,LVL.77 ;YES USE ^O77 SINCE WE ONLY HAVE 6 BITS.
HRRZM TB,LEVEL ;REMEMBER WHAT LEVEL WE'RE AT.
DPB TB,DA.LVL ;PUT THE LEVEL NUMBER IN DATAB.
SETO TB, ;GET SOME ONES.
DPB TB,DA.CLA ;CLASS NOT YET KNOWN.
DPB W2,DA.LNC ;SET LN/CP.
DPB TB,DA.DEF ;SET WE ARE DEFINED.
SKIPN LNKSEC ;LINKAGE SECTION?
JRST D29.A2 ;NO
DPB TB,DA.LKS ;YES, SET LINKAGE FLAG IN ENTRY
LDB TC,DA.LVL ;LEVEL 01 OR 77?
CAIE TC,LVL.77
CAIN TC,LVL.01
SETZM EAS1PC ;YES, RESET DATA PC
D29.A2: TSWF FFILSC; ;ARE WE IN THE FILE SECTION?
DPB TB,DA.DFS ;YES, SET DEFINED IN FILE SECTION.
SKIPN CURDAT ;DO WE HAVE A CURRENT ITEM?
JRST D29.A1 ;NO, THEN WE DON'T HAVE A FATHER.
DPB TB,DA.FAL ;FATHER/BROTHER BIT
HLRZ TB,CURDAT ;SET TO INDICATE
DPB TB,DA.POP ;FATHER
D29.A1: EXCH TA,CURDAT ;TA==FATHER-TO-BE
MOVS TB,CURDAT ;TB==SON-TO-BE
PUSHJ PP,PUTSON ;SET UP SON CHAIN
PUSHJ PP,DA29.D ;CHECK TO SEE WHAT LEVEL WE ARE AT
MOVE TA,CURDAT ;GET NEW ITEM'S DATAB ADDRESS.
JRST D29.B1 ;PUT IN SAME NAME CHAIN AND SET UP SUBSCRIPTS
;WE GET HERE IF THE LEVEL NUMBER OF THE NEW ITEM IS GREATER THAN OR
; EQUAL TO THE LEVEL NUMBER OF THE CURRENT ITEM.
; IF THE LEVEL NUMBER OF THE NEW ITEM IS GREATER THAN THE LEVEL
; NUMBER OF THE CURRENT ITEM, WE FINISH OFF THE CURRENT ITEM,
; MAKE HIS FATHER THE CURRENT ITEM AND REENTER DA29. EVENTUALLY
; THE LEVEL NUMBER OF THE NEW ITEM WILL BE LESS THAN OR EQUAL TO
; THE LEVEL NUMBER OF THE CURRENT ITEM.
; IF THE LEVEL NUMBER OF THE NEW ITEM IS EQUAL TO THE LEVEL NUMBER
; OF THE CURRENT ITEM, WE FINISH OFF THE CURRENT ITEM AND THEN
; SET UP AND INITIALIZE A DATAB ENTRY.
DA29.B: CAIE TB,(TC) ;ARE WE AT THE SAVE LEVEL AS THE LAST ITEM?
JRST DA29.C ;NO, NEW ITEM IS LOWER LEVEL NUMBER -
; GO FINISH OFF THE CURRENT ITEM AND
; ITS ANCESTORS.
PUSHJ PP,DA54. ;FINISH OFF THE LAST ITEM.
MOVE TA,[XWD CD.DAT,SZ.DAT] ;GET A DATAB ENTRY.
PUSHJ PP,GETENT
LDB TB,[POINT 15,W2,15] ;SET THE NAMTAB LINK.
DPB TB,DA.NAM
HRRZI TB,CD.DAT ;I AM A DATAB ENTRY.
DPB TB,[POINT 3,(TA),2]
HRRZ TB,0(SAVPTR) ;GET THE LEVEL NUMBER.
CAIN TB,^D77 ;LEVEL 77?
HRRZI TB,LVL.77 ;YES, USE ^O77 SINCE WE ONLY HAVE 6 BITS.
HRRZM TB,LEVEL ;REMEMBER WHAT LEVEL WE'RE AT.
DPB TB,DA.LVL ;PUT IT IN THE DATAB ENTRY.
SETO TB, ;GET SOME ONES.
DPB TB,DA.CLA ;CLASS IS NOT KNOWN YET.
DPB TB,DA.DEF ;WE ARE DEFINED.
SKIPN LNKSEC ;LINKAGE SECTION?
JRST D29.B0 ;NO
DPB TB,DA.LKS ;YES, SET LINKAGE FLAG IN ENTRY
LDB TC,DA.LVL ;01 OR 77 LEVEL?
CAIE TC,LVL.77
CAIN TC,LVL.01
SETZM EAS1PC ;YES, RESET DATA PC
D29.B0: TSWF FFILSC; ;ARE WE IN THE FILE SECTION?
DPB TB,DA.DFS ;YES, SET THE DEFINED IN FILE SECTION FLAG.
DPB TB,DA.FAL ;TURN ON FATHER LINK FLAG.
DPB W2,DA.LNC ;SET LN/CP.
EXCH TA,CURDAT ;POINT AT BROTHER'S DATAB ENTRY.
PUSH PP,TA
PUSHJ PP,DA29.D ;CHECK TO SEE WHAT LEVEL WE ARE AT
POP PP,TA
HLRZ TB,CURDAT ;GET LINK TO CURRENT ENTRY.
LDB TC,DA.POP ;GET POINTER TO FATHER.
DPB TB,DA.BRO ;MAKE BROTHER POINT AT THIS ENTRY.
SETZ TB, ;OLD ENTRY BECOMES BROTHER OF
DPB TB,DA.FAL ;NEW AND FATHER OF OLD IS FATHER
MOVE TA,CURDAT ;OF NEW
DPB TC,DA.POP
;WE COME HERE TO FINISH UP THE DATAB ENTRY'S INITIALIZATION.
D29.B1: LDB TB,DA.NAM ;GET NAMTAB LINK.
HRR TA,TB ;SET UP FOR PUTLNK CALL.
PUSHJ PP,PUTLNK ;GO LINK THIS ITEM INTO THE SAME NAME CHAIN.
SKIPN FLGSW## ;FIPS FLAGGER REQUESTED?
JRST D29.B2 ;NO
MOVE TA,CURDAT ;YES, RESET TO DATA-ITEM
LDB TB,DA.SNL ;IS THIS A DUPLICATE NAME?
JUMPE TB,D29.B2 ;NO
HRRZI TB,(TYPE) ;(EXCEPT FILLERS)
ANDI TB,1777
CAIN TB,FILLE.
JRST D29.B2 ;NOT FILLER
DMOVE LN,WORDLN## ;SET UP LN & CP
PUSHJ PP,FLG.HI## ;FLAG AT HIGH-INTERMEDIATE LEVEL
D29.B2: HLRZ TB,CURDAT ;GET THE ITEM'S DATAB LINK.
PUSHJ PP,FNDPOP ;FIND ITS FATHER.
JRST RPWPOP ;NO FATHER, LEAVE.
LDB TC,[POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TC,CD.DAT ;IS HE IN DATAB?
JRST RPWPOP ;NO, LEAVE.
HRLZM TB,TBLOCK+13 ;SAVE FATHER LINK.
HRRZI TA,(TB) ;SET UP FOR LNKSET CALL.
PUSHJ PP,LNKSET ;GO CONVERT LINK TO AN ADDRESS.
HRRM TA,TBLOCK+13 ;RESTORE FATHER'S LINK.
LDB TD,DA.RDF## ;GET FATHER'S REDEFINITION FLAG.
CAIN TD,0 ;DID FATHER HAVE A REDEFINITION CLAUSE?
LDB TD,DA.RDH## ;NO, GET FATHER'S REDEFINES AT A
; HIGHER LEVEL FLAG.
LDB TB,DA.VAL ;GET FATHER'S VALUE FLAG.
LDB TC,DA.VHL ;AND HIS VALUE AT A HIGHER LEVEL FLAG.
CAIE TB,0 ;DID FATHER HAVE A VALUE CLAUSE?
SETO TC, ;YES, REMEMBER THAT.
HRRZ TA,CURDAT ;GET ITEM'S DATAB ADDRESS.
DPB TC,DA.VHL ;SET VALUE AT A HIGHER LEVEL FLAG APPROPRIATELY.
DPB TD,DA.RDH ;SET REDEFINES AT HIGHER LEVEL FLAG APPROPRIATELY.
MOVE TA,TBLOCK+13 ;GET FATHER'S DATAB ADDRESS.
LDB TB,DA.SUB ;GET FATHER'S "I MUST BE SUBSCRIPTED" FLAG.
JUMPE TB,RPWPOP ;NOT, SO LEAVE.
LDB TD,DA.OCH## ;GET FATHER'S LINK TO HIGHER LEVEL OCCURS.
LDB TE,DA.OCC ;GET FATHER'S "I HAVE OCCURS" FLAG.
CAIE TE,0 ;DID HE HAVE AN OCCURS CLAUSE?
HLRZ TD,TBLOCK+13 ;YES, GET FATHER'S DATAB LINK.
PUSH PP,TD ;SAVE LINK TO WHOEVER HAD THE OCCURS CLAUSE.
MOVE TA,[CD.DAT,,SZ.DOC] ;MAKE DATAB WORDS 8,9.
PUSHJ PP,GETENT
POP PP,TD ;GET LINK TO WHOEVER HAD THE OCCURS CLAUSE.
HRRZ TA,CURDAT ;GET ITEM'S DATAB ADR.
DPB TD,DA.OCH ;SET THE LINK TO HIGHER LEVEL OCCURS.
SETO TE, ;GET SOME ONES.
DPB TE,DA.SUB ;TURN ON "I MUST BE SUBSCRIPTED" FLAG.
JRST RPWPOP ;EXIT
;WE COME HERE TO FINISH OFF AN ITEM AND ITS ANCESTORS.
DA29.C: PUSHJ PP,DA54. ;GO FINISH OFF THE CURRENT ITEM.
HLRZ TB,CURDAT ;GET THE CURRENT ITEM'S LINK.
SETZM CURDAT ;NO CURRENT ITEM FOR A WHILE.
PUSHJ PP,FNDPOP ;FIND EX-CURRENT ITEM'S FATHER.
JRST DA29.0 ;[1003] NO FATHER, REENTER.
LDB TA,[POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TA,CD.DAT ;IS HE DATAB?
JRST DA29.0 ;[1003] NO, REENTER.
HRLZM TB,CURDAT ;FATHER BECOMES CURRENT ITEM.
HRRZ TA,TB ;SET UP TO CONVERT A LINK TO AN ADR.
PUSHJ PP,LNKSET ;GO DO IT TO IT.
HRRM TA,CURDAT ;SET FATHER'S ADDRESS.
JRST DA29.0 ;[1003] REENTER.
; DA29.D IS USED TO TEST THE LEVEL OF THE HEIRARCHY FOR A DATA ENTRY
; IF THE DATA ITEM IS DEFINED IN THE REPORT SECTION, THAN A MAXIMUM OF
; THREE HEIRARCHICAL LEVELS ARE PERMITTED.
DA29.D: SKIPN REPSEC ;IN REPORT SECTION ?
POPJ PP, ;NO
HLRZ TB,CURDAT ;GET CURRENT DATAB ENTRY
MOVEI TD,RW.MX ;MAX NUMBER OF LEVELS IN REPORT SECTION
DA29.1: PUSHJ PP,FNDPOP ;GET FATHER
POPJ PP, ;NO FATHER, EXIT
CAIG TB,1 ;POINTING TO DATAB DUMMY ENTRY ?
POPJ PP, ;YES, EXIT
SOJG TD,DA29.1 ;JUMP IF NOT PAST MAX LEVEL
EWARNJ E.779 ;GENERATE ERROR AND EXIT
COMMENT \
WE COME TO DA29.R TO PROCESS LEVEL 66 ITEMS. WE GET HERE WHEN WE
HAVE SEEN THE FOLLOWING:
66 DATA-NAME
WHAT WE DO IS:
FINISH PROCESSING THE LAST ITEM VIA DA54., MAKE THE LAST ITEM'S
FATHER THE CURRENT ITEM, IF HE IS A DATAB ITEM, AND REENTER DA29.
EVENTUALLY CURDAT WILL BE ZERO INDICATING THAT THERE ARE NO MORE ITEMS
TO BE FINISHED UP AND WE WILL COME BACK HERE WHERE WE WILL SET UP THE
DATAB ENTRY FOR THE LEVEL 66 ITEM WE SAW.
\
DA29.R: SKIPE CURDAT ;DO WE HAVE A CURRENT ITEM?
JRST DA29.C ;YES GO FINISH IT UP.
MOVE TA,[XWD CD.DAT,SZ.DAT] ;GET A DATAB ENTRY.
PUSHJ PP,GETENT
MOVEM TA,CURDAT ;MAKE THIS THE CURRENT ITEM.
DPB W2,DA.LNC ;SET LN/CP.
LDB TB,[POINT 15,W2,15] ;GET OUR NAMTAB LINK.
DPB TB,DA.NAM ;PUT IT IN OUR DATAB ENTRY.
HRRZI TC,CD.DAT ;I AM A DATAB ENTRY.
DPB TC,[POINT 3,(TA),2]
HRRZI TC,LVL.66 ;SET OUR LEVEL NUMBER TO 76. (SHOULD BE
; 102 BUT THE FIELD IS ONLY 6 BITS.)
DPB TC,DA.LVL
D29XIT: HRRI TA,(TB) ;SET UP OUR NAMTAB LINK.
PUSHJ PP,PUTLNK ;GO LINK THIS DATAB ENTRY INTO THE SAME
; NAME CHAIN.
RPWPOP: SKIPL REPSEC ;RPW SECTION?
POPJ PP, ;NO
MOVE TA,[CD.RPW,,SZ.RPG] ;GET A REPORT GROUP ENTRY IN RPWTAB
PUSHJ PP,GETENT
MOVE TB,RPWRDL ;STORE LINK TO RD ENTRY
DPB TB,RW.RDL
MOVEM TA,CURRPW ;SAVE PTR
MOVEI TB,4 ;SET RPG BIT
DPB TB,[POINT 3,(TA),2]
HLRZ TB,CURDAT ;STORE DATAB LINK IN RPWTAB
DPB TB,RW.DAT
MOVE TB,LASTYP ;COPY LAST TYPE SEEN INTO THIS ENTRY
DPB TB,RW.TYP
HRRZ TA,CURDAT ;STORE RPWTAB LINK IN DATAB
HLRZ TB,CURRPW
DPB TB,DA.RPW
POPJ PP,
COMMENT \
ROUTINE TO SET UP A SON LINK.
ENTRY CONDITIONS:
(TA) LH: FATHER'S TABLE LINK.
RH: FATHER'S ADDRESS.
(TB) LH: SON'S ADDRESS.
RH: SON'S TABLE LINK.
NOTE: USE IS MADE OF THE FACT THAT TA=TB+1.
THERE ARE NO OUTPUT PARAMETERS.
RETURN IS ALWAYS TO CALL+1.
\
PUTSON: JUMPE TA, CPOPJ ;LEAVE IF NO FATHER.
JUMPE TB, CPOPJ ;LEAVE IF NO SON.
LDB TC, DA.SON## ;IF THERE ALREADY IS A SON
JUMPN TC, PS.2 ; GO LINK NEW ONE TO THE
; YOUNGEST SON.
DPB TB, DA.SON## ;OTHERWISE MAKE THIS THE SON.
ROTC TB, ^D18 ;POINT AT SON'S DATAB ENTRY AND
; GET FATHER'S LINK IN RH OF TB.
PS.1: DPB TB, DA.POP## ;PUT FATHER'S LINK IN SON.
SETO TC, ;GET SOME ONES.
DPB TC, DA.FAL## ;SET THE FATHER LINK FLAG.
POPJ PP, ;RETURN.
;COME HERE IF WE ARE NOT THE ONLY SON.
PS.2: MOVEM TA, TBLOCK+1 ;SAVE FATHER'S DATA.
MOVEM TB, TBLOCK+2 ;SAVE NEW SON'S DATA.
HRRZM TC, TBLOCK+3 ;SAVE OLDEST SON'S LINK.
HRRZI TB, (TC) ;SET UP FOR FNDBRO CALL.
PS.3: PUSHJ PP, FNDBRO## ;GO FIND A BROTHER.
JRST PS.4 ;NO MORE BROTHERS.
HRRZM TB, TBLOCK+3 ;SAVE THIS SON'S LINK.
JRST PS.3 ;GO LOOK FOR ANOTHER BROTHER.
;COME HERE WHEN WE HAVE FOUND THE YOUNGEST SON.
PS.4: HRRZ TA, TBLOCK+3 ;GET HIS LINK BACK.
PUSHJ PP, LNKSET## ;MAKE IT AN ADDRESS.
SETZ TB, ;GET SOME ZEROES.
DPB TB, DA.FAL## ;CLEAR THE FATHER LINK FLAG.
MOVE TB, TBLOCK+2 ;GET NEW SON'S DATA BACK.
DPB TB, DA.BRO## ;MAKE HIM THE YOUNGEST SON.
HLRZ TA, TB ;POINT AT NEW SON'S DATAB ENTRY.
HLRZ TB, TBLOCK+1 ;GET FATHER'S LINK.
JRST PS.1 ;GO PUT THE FATHER'S LINK IN THE SON.
;SET UP "REDEFINES"
INTER. DA30.
DA30.: JUMPL W1,JCE104 ;EXIT IF NOT DEFINED
MOVE TC,DATLVL ;CURRENT LEVEL
CAIE TC,1 ;DISALLOW REDEF AT 01 LEVEL IN FILE SECT.
JRST DA30.0
TSWF FFILSC;
EWARNJ E.66
IFN MCS,<
SKIPN COMSEC; ;IN COMMUNICATIONS SECTION?
JRST DA30X1 ;NO
HRRZ TA,LAST01 ;YES, WE MAY HAVE ALREADY FAKED A REDEFINE
HLRZ TB,CURDAT ; OF THE 01 AT D27N.1 - MAKE SURE WE'RE NOT
CAMN TA,TB ; HERE A SECOND TIME BECAUSE OF "REDEFINES"!
EWARNJ E.640 ; CLAUSE SPECIFIED.
DA30X1:
>;END IFN MCS
HRRZ TA,LAST01 ;GET LINK TO LAST 01 ITEM
JUMPE TA,CPOPJ ;IF ITEM REDEFINES DUPLICATE,
; TREAT THIS AS AN ORDINARY DEFN
PUSHJ PP,LNKSET
HLRZ TB,CURDAT ;MAKE CURRENT ITEM LAST 01'S BROTHER
DPB TB,DA.BRO
SETZ TB,
DPB TB,DA.FAL
DA30.0: LDB TB,[POINT 15,W2,15] ;GET NAMTAB LINK
HRRZ TA,LSTDAT(TC) ;LAST ITEM AT THIS LEVEL NOT A REDEF
DA30.1: CAIN TA,0 ;GOOD LINK?
HRRI TA,<CD.DAT>B20+1 ;NO, AIM AT DUMMY ENTRY
PUSHJ PP,LNKSET ;MAKE PTR
LDB TD,DA.NAM ;GET NAMTAB LINK
CAIN TB,(TD) ;THIS THE ONE WE ARE REDEFINING?
JRST DA30.2 ;YES
LDB TD,DA.FAL ;FATHER BIT ON?
JUMPN TD,JCE266 ;YES, NO MORE BROTHERS
LDB TD,DA.BRO ;TRY BROTHER
HRRZI TA,(TD)
JUMPN TD,DA30.1
JCE266: EWARNJ E.266 ;ILLEGAL REDEFINITION
DA30.2: HRRZ TA,CURDAT ;GET PTR TO CURRENT ITEM
MOVE TC,DATLVL
HRRZ TA,LSTDAT(TC)
PUSHJ PP,LNKSET
HRRZI TB,44
LDB TC,DA.RES
SUBI TB,(TC)
LDB TC,DA.LOC##
HRLI TC,(TB)
MOVEM TC,EAS1PC
MOVE TA,CURDAT
SETO TB,
DPB TB,DA.RDF
LDB TD,DA.RDH ;IS THERE A REDEFINITION AT A HIGHER LEVEL?
JUMPE TD,DA30.3 ;NO
SKIPE FLGSW## ;YES, FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
DA30.3: MOVE TB,DATLVL ;IF 01 LEVEL
CAIN TB,LVL.01 ;SAVE LINK
HLRZM TA,LAST01
POPJ PP,
;ITEM IS NOT A REDEFINITION -- REMEMBER THIS
INTER. DA30N.
DA30N.: SKIPE REPSEC ;NOT NEEDED IN REPORT SECTION
JRST DA7.
IFN MCS,<
SKIPN COMSEC ;COMMUNICATION SECTION ACTIVE?
JRST DA30NN ;NO
MOVE TA,LEVEL
CAIE TA,LVL.01 ;01 LEVEL?
JRST DA30NN ;NO
MOVE TA,CURDAT
HLRZ TD,CURCD
DPB TD,DA.POP## ;SET FATHER LINK
SETO TD,
DPB TD,DA.FAL ;SET FATHER BIT
MOVEI TD,%CL.AN
DPB TD,DA.CLA## ;CLASS
MOVEI TD,%US.D7
DPB TD,DA.USG ;USAGE
DA30NN:>
MOVE TC,DATLVL
HLRZ TB,CURDAT
MOVEM TB,LSTDAT(TC)
MOVE TA,CURDAT ;PTR & LINK TO ITEM
CAIN TC,LVL.01 ;01 LEVEL?
HLRZM TA,LAST01 ;YES, STORE LINK
JRST DA7. ;WANT TO REGET THIS WORD
;BLANK WHEN ZERO
INTER. DA31.
DA31.: LDB TB,[POINT 9,W1,17]
CAIE TB,ZERO.
JCE18.: EWARNJ E.18
SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.CLA ;CLASS
CAIE TB,%%CL ;UNKNOWN
CAIN TB,%CL.NU ;NUMERIC
JRST DA31.A
LDB LN,DA.LN
LDB CP,DA.CP
HRRZI DW,E.223
JRST FATAL
DA31.A: LDB TB,DA.BWZ##
AOSE FLOTBZ ; [403] PICTURE WITH NO 9'S, THEN OK
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.BWZ ;SET FLAG
LDB TB,DA.PWA## ;SEE IF PICTURE ALLOCATED
JUMPE TB,CPOPJ ;NOT YET
LDB TB,DA.FSC## ;GET SUPPRESSION CHAR
CAIN TB,'*' ;IS IT *
EWARNJ E.701 ;YES, GIVE ERROR
POPJ PP,
;JUSTIFIED RIGHT
INTER. DA32.
DA32.: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.JST##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.JST
POPJ PP,
;SIGN CLAUSE
INTER. DA32.C
DA32.C: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.USG## ;SIGN ONLY APPLIES TO DISPLAY MODE
CAILE TB,%US.DS
EWARNJ E.554 ;NO, GIVE ERROR
LDB TB,DA.PIC##
JUMPE TB,CPOPJ ;NOT YET SEEN PICTURE
LDB TB,DA.SGN## ;SIGNED
JUMPN TB,CPOPJ ;YES
DA32.E: EWARNJ E.710
;LEADING SIGN
INTER. DA32.L
DA32.L: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.LSC##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.LSC
POPJ PP,
;SEPARATE SIGN
INTER. DA32.S
DA32.S: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.SSC##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.SSC
DA32.T: LDB TB,DA.PIC ;PICTURE SEEN?
JUMPE TB,CPOPJ ;NOT YET
HRLI TB,1 ;YES, GET [1,,1]
ADDM TB,@DA.EXS## ;YES, SIZE IS BIGGER BY 1 CHAR
POPJ PP,
INTER. DA33.
DA33.: PUSHJ PP,DA11. ;GET NUMBER OF OCCURRENCES
D33MCS: PUSHJ PP,DANXT. ;[243] SEE IF NEXT ITEM IS A 'TO'
MOVEI TB,1 ;[243] IF NO MINIMUM IS 1
CAIN TYPE,TO. ;[243] IS NEXT SOURCE ITEM 'TO'
SETZ TB, ;[243] YES, ALLOW 0
MOVE TC,0(SAVPTR) ;[243] GET USERS NO. OF OCCURS
CAIGE TC,(TB) ;[243] SEE IF NO. OF OCCURS LEGAL
JRST JCE25 ;[243] ILLEGAL
CAIG TC,77777
JRST DA33.A
MOVEI DW,E.593 ;[471] TO MANY FOR "OCCURS"
PUSHJ PP,DA24X. ;[243] GIVE ERROR AND COME BACK
HRRZI TC,77777 ;ONLY 32K OCCURRENCES ALLOWED
HRRZM TC,0(SAVPTR)
DA33.A: HRRZ TA,CURDAT
LDB TB,DA.OCC
JUMPN TB,JCE16.
HRRZ TC,0(SAVPTR)
DPB TC,DA.NOC
LDB TB,DA.PWA ;DATAB WORDS 8,9 CREATED YET?
LDB TC,DA.SUB
IORI TB,(TC)
JUMPN TB,.+4 ;YES
MOVE TA,[CD.DAT,,SZ.DOC] ;NO, DO IT
PUSHJ PP,GETENT
HRRZ TA,CURDAT ;RESTORE TA
SETO TB,
DPB TB,DA.OCC
DPB TB,DA.SUB
POPJ PP,
JCE25: HRRZ TA,CURDAT ;[243] GET POINTER TO DATA ITEM
SETO TB, ;[243] THEN SET
DPB TB,DA.ERR ;[243] ERROR BIT
MOVEI DW,E.25 ;[243] GIVE ERROR MESSAGE AND RETURN
JRST DA24X. ;[243]
;[243] THIS ROUTINES LOOKS AHEAD AT NEXT SOURCE ITEM
DANXT.: MOVEM W2,1(SAVPTR) ;[243] SAVE CURRENT SOURCE ITEM
PUSHJ PP,GETITM ;[243] GET NEXT SOURCE ITEM
MOVE W2,1(SAVPTR) ;[243] RESTORE CURRENT SOURCE
JRST DA7. ;[243] SET SW TO REGET SAME ITEM FOR SYNTAX SCAN
;SET UP INDEX FOR "INDEXED BY" CLAUSE
INTER. DA34.
DA34.: PUSHJ PP,DA60S. ;SAVE NAMTAB LINK IN CURNAM
HRRZI TB,CD.DAT ;(USING TA LEFT BY DA60S.)
PUSHJ PP,FNDLNK
JRST DA34.B ;NO LINK
EWARNJ E.297 ;BAD NAME
DA34.B: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.IX ; BECAUSE PUTTING INDEX IN DATAB NOW
DPB TB,HL.COD ; MIGHT PUT IT BETWEEN THE ITEM INDEXED
IFN MCS,<
SKIPE COMSEC## ;ARE WE IN COMM SECTION?
POPJ PP, ;YES, DON'T LINK DATAB TO HLDTAB
>
HLRZ TB,CURDAT ; AND ITS SEARCH KEYS
DPB TB,HL.LNK
HRRZ TA,CURDAT ;PUT HLDTAB LINK IN DATAB ENTRY
HLRZ TB,CURHLD ; "INDEXED BY" FIELD
LDB TC,DA.XBY## ; UNLESS ONE HAS BEEN STORED ALREADY
JUMPN TC,.+2
DPB TB,DA.XBY
POPJ PP,
INTER. DA35.
DA35.: SKIPN TA,CURDAT
JRST DA35.1
LDB TB,DA.PIC
JUMPN TB,JCE16. ;CLAUSE DUPLICATED
DA35.1: PUSHJ PP,PSCAN
HRRZ TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,DA.PIC
JUMPN TB,CPOPJ ;PICTURE SEEN BEFORE
SETO TB,
DPB TB,DA.PIC
LDB TB,DA.USG
CAIN TB,%US.IN ;USAGE INDEX?
JRST DA35.E ;YES
CAIE TB,%US.C1 ;COMP-1?
CAIN TB,%US.C2 ; OR COMP-2?
JRST DA35.E ;YES
DPB SW,DA.CLA ;BITS 34-35 OF SW ARE CLASS
SETZ TB,
TSWF FSIGN; ;SIGNED?
SETO TB, ;YES
DPB TB,DA.SGN##
;STORE THE SIZE
;IF NOT SIGNED, GIVE ERROR IF "SIGN" CLAUSE WAS GIVEN.
; IF SIGNED AND "SIGN IS SEPARATE", ADD 1 TO SIZE
JUMPN TB,[LDB TE,DA.SSC## ;GET "SEP SIGN FLAG" IN TE
JRST DA35.S] ;AND GO
;NOT SIGNED.
LDB TE,DA.SSC## ;SEP SIGN
LDB TD,DA.LSC## ;LEADING SIGN
IOR TD,TE
JUMPE TD,DA35.S ;NO SIGN FLAGS GIVEN, OK
EWARNW E.710 ;"ITEM MUST BE SIGNED NUMERIC"
MOVEI TE,0 ;GET A 0
HRRZ TA,CURDAT ;RELOAD TA INCASE IT WAS SMASHED
;HERE WITH TE= 1 IF SEP. SIGN, ELSE 0
DA35.S: HRRZ TB,INSIZE##
ADD TB,TE ;ADD 0 OR 1
DPB TB,DA.INS## ;INTERNAL SIZE
HRRZ TB,EXSIZE##
ADD TB,TE ;ADD 0 OR 1
DPB TB,DA.EXS ;EXTERNAL SIZE
SKIPL TB,DPSIZE##
JRST DA35.A
SETO TB,
DPB TB,DA.DPR## ;DECIMAL POINT TO RIGHT OF ITEM
MOVN TB,DPSIZE
DA35.A: DPB TB,DA.NDP## ;NUMBER OF DECIMAL PLACES
TSWF FEDIT;
JRST DA35.C ;YES
LDB TB,DA.BWZ## ;SEE IF "BLANK WHEN ZERO"
JUMPE TB,CPOPJ ;NEITHER EDITED NOR BWZ
JRST DA35.D ;SAVE EDIT MASK PER NAVY TESTS
DA35.C: SETO TB,
DPB TB,DA.EDT##
SKIPN FLOTBZ## ;PICTURE ALL FLOAT CHARS & NO 9'S?
TSWF FBWZ;
DPB TB,DA.BWZ
DA35.D: SKIPG MSKSIZ##
POPJ PP, ;NO MASK
DA35.B: HRRZ TB,MSKSIZ
CAILE TB,SZ.MSK
HRRZI TB,SZ.MSK
HRRZM TB,MSKSIZ
LDB TB,DA.PWA
JUMPE TB,D35B.1
ADDI TA,SZ.DAT+SZ.DOC
JRST D35B.0
D35B.1: LDB TB,DA.SUB ;WORDS 8&9 ALLOCATED YET?
JUMPN TB,.+4 ;YES
MOVE TA,[CD.DAT,,SZ.DOC] ;NO, DO IT
PUSHJ PP,GETENT
HRRZ TA,CURDAT
SETO TB,
DPB TB,DA.PWA
MOVE TA,[CD.DAT,,SZ.MSK]
PUSHJ PP,GETENT ;GET ENTRY FOR MASK
D35B.0: HRRZ TC,MSKSIZ
ADDI TC,-1(TA) ;LAST WORD FOR STORING MASK
HRLI TA,MSKWRD##
BLT TA,(TC) ;MOVE MASK
POPJ PP,
DA35.E: HRRZI DW,E.221
LDB LN,DA.LN
LDB CP,DA.CP##
JRST WARN
INTER. DA36.
DA36.: SKIPN TA,CURDAT
POPJ PP, ;NO DATTAB LINK
LDB TB,DA.SYL## ;SYNC LEFT?
JUMPN TB,JCE18. ;YES--ERROR
LDB TB,DA.SYR## ;ALREADY SYNC RIGHT?
JUMPN TB,JCE16. ;YES
SETO TB,
DPB TB,DA.SYR
POPJ PP,
INTER. DA37.
DA37.: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,DA.SYR
JUMPN TB,JCE18.
LDB TB,DA.SYL
JUMPN TB,JCE16.
SETO TB,
DPB TB,DA.SYL
POPJ PP,
INTER. DA38.
DA38.: HRRZI TC,%US.D7 ;USAGE CODE 'DISPLAY-7'
;FALL INTO SET USAGE ROUTINE.
;SET THE USAGE OF A DATAB ITEM AND DETERMINE IF IT IS CONSISTANT WITH
; ITS ANCESTOR'S USAGES.
SETUSF: FLAGAT NS
SETUSG: HRRZ TA, CURDAT ;GET THE ADDRESS OF THE CURRENT ITEM.
JUMPE TA, CPOPJ ;IF THERE IS NO CURRENT ITEM LEAVE.
LDB TB, DA.USG## ;GET THE USAGE FIELD.
IFN MCS,<
;24-SEP-80 /DAW THERE MAY HAVE ALREADY BEEN A DEFAULT USAGE (DISPLAY-7)
; ASSIGNED FOR THE 01 LEVEL. IF HE ALSO SPECIFIES A USAGE, A WARNING
; WILL BE GIVEN AND THE USAGE CLAUSE WILL BE IGNORED.
CAIN TB,%%US ;USAGE ALREADY DEFINED?
JRST SETSG0 ;NO, OK
CAMN TB,TC ;SAME USAGE?
JRST SETSG0 ;YES, DON'T COMPLAIN
EWARNW E.641 ;GIVE WARNING
MOVE TC,TB ;ASSUME THE DEFAULT
SETSG0:
>;END IFN MCS
IFE MCS,<
CAIE TB, %%US ;DO WE ALREADY HAVE A USAGE?
EWARNJ E.16 ;YES, COMPLAIN.
>
HRRZM TC, TBLOCK ;SAVE THE SON'S USAGE.
;IF WE DON'T HAVE A USAGE FOR THE RECORD YET, SEE IF WE CAN USE THIS ONE.
SKIPE TB, RUSAGE## ;DO WE HAVE A USAGE FOR THE REC?
JRST DA38.5 ;YES, GO ON.
;SEE IF WE CAN USE THIS USAGE.
CAIE TC, %US.D6 ;IF THE USAGE IS DISPLAY-6
CAIN TC, %US.D7 ; OR DISPLAY-7, THE RECORD
MOVEI TB, (TC) ; IS ALSO.
CAIE TC, %US.EB ;IF THE USAGE IS DISPLAY-9 OR
CAIN TC, %US.C3 ; COMP-3, THE RECORD IS
MOVEI TB, %US.EB ; DISPLAY-9.
MOVEM TB, RUSAGE## ;SET THE RECORD'S USAGE.
;HERE WE ARE GOING TO TRY TO FIND AN ANCESTOR FOR WHICH A USAGE
; CLAUSE WAS GIVEN.
DA38.5: HLRZ TB, CURDAT ;GET LINK TO CURRENT ITEM.
HRRZM TB, TBLOCK+1 ;[1424] SAVE LINK
DA38.A: PUSHJ PP, FNDPOP## ;FIND THE FATHER.
JRST DA38.L ;NO FATHER.
LDB TC, [POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TC, CD.DAT ;IS HE IN DATAB?
JRST DA38.L ;NO.
HRRZM TB, TBLOCK+1 ;SAVE FATHER'S LINK.
HRRZI TA, (TB) ;SET UP FOR LNKSET.
PUSHJ PP, LNKSET## ;GET FATHER'S ADDRESS.
LDB TC, DA.USG## ;GET HIS USAGE.
HRRZ TB, TBLOCK+1 ;RESTORE FATHER'S LINK.
CAIN TC, %%US ;DOES HE HAVE A USAGE?
JRST DA38.A ;NO, GO LOOK AT HIS FATHER.
;FOUND A FATHER FOR WHICH A USAGE CLAUSE WAS GIVEN.
HRRZ TB, TBLOCK ;RESTORE SON'S USAGE.
COMMENT \
NOW WE HAVE TO MAKE SURE THAT THE USAGES ARE VALID.
THE FOLLOWING ARE OK:
USAGE OF FATHER USAGE OF SON
DISPLAY-6 DISPLAY-6
COMP
COMP-1
INDEX
DISPLAY-7 DISPLAY-7
COMP
COMP-1
INDEX
DISPLAY-9(EBCDIC) DISPLAY-9
COMP
COMP-1
COMP-3
INDEX
COMP COMP
COMP-1 COMP-1
COMP-3 COMP-3
INDEX INDEX
\
CAIN TB, (TC) ;FATHER AND SON HAVE SAME USAGES?
JRST DA38.L ;YES, ALL IS WELL.
;SON'S USAGE IS NOT THE SAME AS FATHER'S USAGE.
CAIE TC, %US.D6 ;IS THE FATHER DISPLAY-6
CAIN TC, %US.D7 ; OR DSIPLAY-7?
JRST DA38.F ;YES.
CAIE TC, %US.EB ;HOW ABOUT EBCDIC?
JRST DA38.E ;NO, COMPLAIN SINCE ONLY ITEMS
; WITH SOME FORM OF DISPLAY USAGE
; MAY HAVE SUBORDINATE ITEMS WITH
; DIFFERENT USAGES.
;FATHER IS EBCDIC - DO THE COMP-3 SPECIAL CASE.
CAIN TB, %US.C3 ;IS THE SON COMP-3?
JRST DA38.L ;YES, ALL IS WELL.
;FATHER IS SOME FORM OF DISPLAY AND THE SON'S USAGE IS DIFFERENT.
; MAKE SURE THE SON IS NOT DISPLAY OR COMP-3 SINCE IF IT IS
; DISPLAY IT ISN'T THE SAME FLAVOR AS THE FATHER'S AND IF IT
; IS COMP-3 THE FATHER ISN'T EBCDIC.
DA38.F: CAIE TB, %US.D6 ;IS THE SON DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7?
JRST DA38.E ;YES, COMPLAIN.
CAIE TB, %US.EB ;IS THE SON EBCDIC
CAIN TB, %US.C3 ; OR COMP-3?
JRST DA38.E ;YES, COMPLAIN.
;THE SON'S USAGE IS ACCEPTABLE.
DA38.L: HRRZ TA, CURDAT ;RESTORE SON'S DATAB ADDRESS
HRRZ TB, TBLOCK ; AND HIS USAGE CODE.
DPB TB, DA.USG## ;PUT THE CODE IN THE DATAB ENTRY.
CAIG TB,%US.DS ;[1424] IF IT'S A DISPLAY MODE,
POPJ PP, ;[1424] EXIT
LDB TB,DA.DFS ;[1424] IF DATA ITEM IS NOT
JUMPE TB,CPOPJ ;[1424] IN FILE SECTION, EXIT
HRRZ TB,TBLOCK+1 ;[1424] GET LAST LINK IN TB FOR FNDFIL
PUSHJ PP,FNDFIL## ;[1424] FIND THE FILE TABLE
POPJ PP, ;[1424] NO FILTAB LINK
LDB TC,FI.ERM ;[1424] GET FILE'S MODE
CAIE TC,%RM.7B ;[1424] IS IT ASCII?
POPJ PP, ;[1424] NO, EXIT
HRRZI DW,E.661 ;[1424] GIVE ERROR
HRRZ TA,CURDAT ;[1424] AT DATA FIELD DECLARATION
LDB LN,DA.LN ;[1424]
LDB CP,DA.CP ;[1424]
PJRST FATAL## ;[1424] RETURN
;USAGE ERRORS COME HERE.
DA38.E: HRRZI DW, E.41 ;CONFLICT WITH HIGHER LEVEL USAGE.
HRRZ TA, CURDAT ;RESTORE ITEM'S ADDRESS.
LDB LN, DA.LN## ;SET UP THE LINE NUMBER
LDB CP, DA.CP## ; AND THE CHARACTER POSITION.
PJRST FATAL## ;GO PUT THE ERROR MESSAGE OUT
; AND DON'T COME BACK.
INTER. DA39.
DA39.: HRRZI TC,%US.D6 ;USAGE 'DISPLAY-6'
JRST SETUSF
INTER. DA39A.
DA39A.: HRRZ TC,DEFDSP## ;USAGE 'DISPLAY', GET DEFAULT
JRST SETUSG ;GO SET IT.
INTER. DA40.
DA40.: HRRZI TC,%US.1C ;USAGE 'COMP'
JRST SETUSC
INTER. DA41A.
DA41A.: HRRZI TC,%US.C2 ;USAGE 'COMP-2'
JRST SETUSN
INTER. DA41.
DA41.: HRRZI TC,%US.C1 ;USAGE 'COMP-1'
SETUSN: FLAGAT NS
SETUSC: SKIPN REPSEC ;IN REPORT SECTION?
JRST SETUSG ;NO
EWARNW E.349 ;?ILLEGAL USAGE IN REPORT GROUP
JRST DA73.X ;NEXT NODE IS DD144.
INTER. DA42.
DA42.: HRRZI TC,%US.C3 ;USAGE 'COMP-3'.
JRST SETUSF
INTER. DA43.
DA43.: HRRZI TC,%US.IN ;USAGE 'INDEX'
JRST SETUSC
;THIS ACTION IS USED FOR DATABASE-KEY PROCESSING. THE
;DATAB ENTRY IS SET UP WITH A SIZE OF 10 AND LATER, (AT DA54.Y)
;THE ENTRY IS CHECKED FOR THIS.
INTER. DA43A.
DA43A.: FLAGAT DB
PUSHJ PP,DA43. ;PERFORM NORMAL INDEX STUFF
HRRZ TA,CURDAT ;GET CURRENT DATAB ENTRY
MOVEI TB,^D10
DPB TB,DA.EXS## ;CHANGE EXTERNAL SIZE
DPB TB,DA.INS## ;AND INTERNAL SIZE
POPJ PP,
INTER. DA43B.
DA43B.: HRRZI TC,%US.EB ;USAGE 'DISPLAY-9'.
JRST SETUSF
INTER. DA46.
DA46.: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
MOVEM TA,CURNAM
HLRZS TA
DPB TA,[POINT 15,W2,15]
TLZ W1,GWNOT
HRRZI TB,CD.CON
PUSHJ PP,FNDLNK
JRST DA46.B ;NO CONDITION OF THIS NAME
DA46.A: MOVE TA,TB
LDB TC,CO.DAT##
HLRZ TD,CURDAT
CAIN TC,(TD)
EWARNJ E.230 ;DUPLICATE CONDITION FOR THIS DATTAB ITEM
PUSHJ PP,FNDNXT
JRST DA46.B ;NO MORE
JRST DA46.A
DA46.B: MOVE TA,[XWD CD.CON,SZ.CON]
PUSHJ PP,GETENT
MOVEM TA,CURCON##
HLRZ TB,CURNAM
ANDI TB,77777
IORI TB,CD.CON*1B20
MOVSM TB,(TA)
HLRZ TA,CURDAT##
JUMPE TA,DA46.J ;IF THERE ISN'T A DATAB ITEM
; THERE, GO USE THE DUMMY.
DA46.F: ANDI TA,77777 ;GET THE ITEM'S ADDRESS.
ADD TA,DATLOC##
LDB TB,DA.LVL## ;PICK UP IT'S LEVEL NUMBER.
CAIE TB,LVL.01 ;IF WE ARE AT THE TOP OF
CAIN TB,LVL.77 ; THE TREE, ALL IS WELL,
JRST DA46.N ; GO ON.
LDB TA,DA.POP## ;PICK UP THE FATHER/BROTHER LINK.
JUMPN TA,DA46.F ;IF IT EXISTS, GO SEE IF WE ARE
; AT THE TOP OF THE TREE.
DA46.J: SKIPA TB,[EXP CD.DAT*1B20+1] ;OTHERWISE USE THE DUMMY.
DA46.N: HLRZ TB,CURDAT## ;PICK UP THE DATAB ITEM'S LINK AGAIN.
MOVE TA,CURCON## ;POINT AT THE CONTAB ENTRY.
DPB TB,CO.DAT
LDB TB,CO.NAM##
HRRI TA,(TB)
SKIPN FLGSW ;DO WE NEED THE FIPS FLAGGER?
JRST PUTLNK##
PUSHJ PP,PUTLNK ;YES
HLRZ TA,CURDAT ;NOW SEE IF DATAB IS FILLER
JUMPE TA,CPOPJ ;JUST A DUMMY
PUSHJ PP,LNKSET ;GET DATAB ENTRY
LDB TB,DA.NAM ;GET NAMTAB LINK
ADD TB,NAMLOC ;PLUS BASE
HLRZ TB,(TB) ;LOOK FOR "FILLER"
CAIE TB,1B20+FILLE.
POPJ PP,
LDB LN,DA.LN
LDB CP,DA.CP
JRST FLG.HI
;STORE VALUE ON CONTAB ENTRY FOR 88 ITEM
INTER. DA47.
DA47.: SETOM FLG88## ;[674] SET 88 LEVEL LITERAL FLAG
CAIA ;[674] AND SKIP
DA47.A: SETZM FLG88## ;[674] CLEAR 88 LEVEL LITERAL FLAG
TLNE W1,GWFIGC ;[674] FIGURATIVE CONSTANT?
JRST DA47.C ;YES
TLNN W1,GWLIT
EWARNJ E.45 ;LITERAL EXPECTED
LDB TC,GWVAL ;SIZE
HRLM TC,TBLOCK+13 ;SAVE NO. OF CHARACTERS
ADDI TC,4 ;TAKE CARE OF REMAINDER
IDIVI TC,5
HRRM TC,TBLOCK+13 ;SAVE NO. OF WORDS
HRRZI TA,SZ.LIT(TC)
HRLI TA,CD.LIT
PUSHJ PP,GETENT
HLR W1,TA
MOVEM TA,CURLIT##
HLRZ TC,TBLOCK+13
DPB TC,LI.NCH##
SETO TD,
TLNE W1,GWASCI ;ANY PURE ASCII CHARACTERS?
DPB TD,LI.PUR##
TLNE W1,GWALL
DPB TD,LI.ALL##
TLNN W1,GWNLIT ;NUMERIC?
JRST DA47.B ;NO
DPB TD,LI.NLT
TLNN W1,GWDP
DPB TD,LI.INT##
DA47.B: HRRZ TC,TBLOCK+13 ;NO. OF WORDS
JUMPE TC,JCE183 ;NULL LITERAL
ADDI TC,SZ.LIT-1(TA)
HRRZI TB,SZ.LIT(TA)
HRLI TB,LITVAL
BLT TB,(TC)
SKIPN FLG88## ;[674] IS THIS 88 LEVEL?
POPJ PP, ;[674] NO, DONE
LDB TC,LI.NLT## ;[674] TC: NUMERIC LITERAL FLAG, 1=YES, 0=NO
HRRZ TA,CURDAT## ;[674] POINT AT THE REAL ITEM (NOT 88 LEVEL)
LDB TD,DA.CLA## ;[674] GET ITS CLASS
CAIN TD,%%CL ;[700] IF CLASS NOT ASSIGNED YET...
PUSHJ PP,[LDB TE,DA.USG ;[700] GET USAGE AND TRY TO DEFAULT
CAIE TE,%US.IN ;[711] INDEX?
CAIN TE,%US.C1 ;[700] COMP-1?
MOVEI TD,%CL.NU ;[700] YES, SET NUMERIC CLASS
CAIN TE,%US.C2 ;COMP-2?
MOVEI TD,%CL.NU ; IS ALSO NUMERIC
POPJ PP,] ;[700] KEEP GOING
LDB TE,DA.EDT## ;[674] AND GET ITS EDIT FLAG
;[1106] If the class has not been able to be defaulted yet, it means
;[1106] that the item is subordinate to an INDEX item. We can't tell
;[1106] what class it will be until we see the next level number. It
;[1106] could be an elementary item or a group item!
;[1106] The value clauses have to be checked later (in CLEANC) after
;[1106] the usages are determined.
CAIN TD,%%CL ;[1106] Still no class?
POPJ PP, ;[1106] Can't check now
JUMPE TC,DA47.D ;[674] LITERAL IS NOT NUMERIC, MAKE SURE
;[674] ITEM IS NOT EITHER
;[674] HERE IF THE LITERAL IS NUMERIC
CAIN TD,%CL.NU ;[674] IF ITEM IS NUMERIC
JUMPE TE,CPOPJ ;[674] AND NOT EDITTED, ALL IS WELL
PJRST DA47.F ;[674] OTHERWISE, GIVE AN ERROR
;[674] HERE IF LITERAL IS NOT NUMERIC
DA47.D: CAIN TD,%CL.NU ;[674] IF THE ITEM IS NUMERIC AND
JUMPE TE,DA47.F ;[674] IS NOT EDITTED, GIVE AN ERROR
POPJ PP, ;[674] OTHERWISE, ALL IS WELL
;[674] CLASS OF 88 LEVEL ITEM INCONSISTENT WITH VALUE
DA47.F: HRRZI DW,E.241 ;[674] SET ERROR FLAG
LDB LN,GWLN ;[674] GET LINE OF BAD VALUE
LDB CP,GWCP ;[674] GET CHARACTER OF BAD VALUE
PUSHJ PP,D54E.1 ;[674] GIVE WARNING
EXP WARN## ;[674]
DA47.C: MOVE TA,[XWD CD.LIT,SZ.LIT]
PUSHJ PP,GETENT
HLR W1,TA
MOVEM TA,CURLIT
LDB TC,[POINT 9,W1,17]
DPB TC,LI.FCC##
SETO TC,
DPB TC,LI.FGC##
POPJ PP,
INTER. DA47.S
DA47.S: FLAGAT 8
;COPY CODE AT DA47.A AS IF A 1 WORD LITERAL
SETOM FLG88 ;SET 88 LEVEL LITERAL FLAG
HRRZ TA,W1 ;GET TABLE LINK
PUSHJ PP,LNKSET ;GET ADDRESS
LDB TB,MN.SYC## ;SYMBOLIC CHARACTER?
SKIPN TB ;YES
EWARNJ E.809 ;NO, WARN USER
DA47.T: LDB TC,MN.SCV## ;GET SYMBOLIC CHARACTER
ROT TC,-7 ;LEFT JUSTIFY IT
LDB TB,MN.ESC## ;GET EBCDIC FLAG
SKIPE TB
ROT TC,-2 ;IF EBCDIC MOVE 9 BITS
HRR TC,TB ;SAVE FLAG ALSO
PUSH PP,TC ;SAVE SYMBOLIC CHAR WHILE WE CAN GET TO IT
MOVE TA,[CD.LIT,,SZ.LIT+1]
PUSHJ PP,GETENT ;2 WORD LITERAL
HLR W1,TA
MOVEM TA,CURLIT
MOVEI TC,1
DPB TC,LI.NCH ;1 CHAR LITERAL
DPB TC,LI.ALL ;SET "ALL" BIT ON
POP PP,TB ;RECOVER CHAR PLUS EBCDIC FLAG
TRZE TB,-1 ;IS IT EBCDIC?
DPB TC,LI.EBC## ;YES
HLLZM TB,1(TA) ;STORE SYMBOLIC CHAR IN LITERAL
POPJ PP,
;ILLEGAL VALUE FOR CONDITION
INTER. DA47E.
DA47E.: SWOFF FREGWD ;CLEAR REGET ITEM BIT
TLO W1,GWFIGC ;SET FIG. CON. FLAG
MOVEI TB,SPACE. ;ASSUME "SPACES"
DPB TB,[POINT 9,W1,17]
PUSHJ PP,DA47.A ;[674] PUT ASSUMED VALUE IN CONTAB
EWARNJ E.258 ;"?LITERAL OR FIG. CON. REQUIRED"
INTER. DA48.
DA48.: SKIPN CURCON
POPJ PP,
MOVE TA,[XWD CD.CON,1]
PUSHJ PP,GETENT
HLRZ TB,CURLIT
ANDI TB,077777
MOVSM TB,(TA)
SETZM CURLIT
HRRZ TA,CURCON
LDB TB,CO.NVL##
HRRZI TB,1(TB)
DPB TB,CO.NVL
POPJ PP,
INTER. DA49.
DA49.: PUSHJ PP,DA48.
PUSHJ PP,DA47.A ;[674]
SKIPN TA,CURCON
POPJ PP,
LDB TB,CO.NVL
ADDI TB,SZ.CON-1(TA)
HLRZ TC,CURLIT
ANDI TC,077777
HLL TC,(TB)
TLO TC,400000
MOVEM TC,(TB)
SETZM CURLIT
POPJ PP,
INTER. DA51.
DA51.: SETZM RENAM1##
SETZM RENAM2##
TLNE W1,GWNOT
EWARNJ E.17
LDB TA,[POINT 15,W2,15]
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK
EWARNJ E.17
MOVEM TB,RENAM1
POPJ PP,
INTER. DA51A.
DA51A.: POPJ PP,
INTER. DA52.
DA52.: TLNE W1,GWNOT
EWARNJ E.17
LDB TA,[POINT 15,W2,15]
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK
EWARNJ E.17
MOVEM TB,RENAM2
POPJ PP,
INTER. DA53.
DA53.: SKIPE RENAM2
JRST DA53.2
SKIPN TA,RENAM1
JRST DA53.X
SETZ TB, ;CK RENAMED ITEM FOR
LDB TC,DA.PWA## ; PICTURE WORDS ALLOCATED
LDB TB,DA.SUB ; OR SUBSCRIPTING
JUMPN TB,D53E.2 ;[253] NO SUBCRIPTS ALLOWED IN RENAMED DATA
LDB TB,DA.LVL ;[253] CHECK LEVEL OF
CAIN TB,LVL.01 ;[253] RENAMED DATA
JRST D53E.1 ;[253] CANNOT BE 01
CAIE TB,LVL.77 ;[253] 77
CAIN TB,LVL.66 ;[253] OR 66
JRST D53E.1 ;[253] ILLEGAL
IMULI TC,SZ.DOC+SZ.MSK ;FOR RENAMING ITEM
JUMPE TC,DA53.1 ;NO EXTRAS NEEDED
PUSH PP,TC
MOVEI TA,(TC)
HRLI TA,CD.DAT
PUSHJ PP,GETENT
HLRZ TA,RENAM1
PUSHJ PP,LNKSET
HRRM TA,RENAM1
POP PP,TC
DA53.1: ADDI TC,SZ.DAT ;[253]
SKIPN TB,CURDAT ;[253]
POPJ PP,
LDB TD,DA.LNC ;[253] GET 66 ENTRY SOURCE ITEM
HRRZI TB,1(TB) ;WORD 2 OF 66 ENTRY
HRLI TB,1(TA) ;WORD 2 OF RENAMED ENTRY
ADDI TC,-2(TB) ;LAST WORD OF 66 ENTRY
BLT TB,(TC)
HRRZ TA,CURDAT
DPB TD,DA.LNC ;[253] KEEP ORIG 66 ENTRY SOURCE
SETZ TB,
DPB TB,DA.POP
DPB TB,DA.SON
DPB TB,DA.VAL
HRRZI TC,LVL.66 ;LEVEL 66
DPB TC,DA.LVL
SETO TC,
DPB TC,DA.FAL
D53.11: HLRZ TB,RENAM1
PUSHJ PP,FNDPOP
JRST DA53.X
HRLM TB,RENAM1
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST D53.12
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TC,DA.LVL
CAIE TC,LVL.01
JRST D53.11
;The level-01 item is in LH(RENAM1)
;The level-66 item is in LH(CURDAT)
; If this is the file section, store RENTAB entry.
HLRZ TB,RENAM1 ;Get TB=01 link
TSWF FFILSC; ;Are we in FILE SECTION?
PUSHJ PP,D53FS ;Yes, make RENTAB entry.
D53.12: HLRZ TB,RENAM1
HRRZ TA,CURDAT
DPB TB,DA.POP
DA53.X: SETZM CURDAT
POPJ PP,
DA53.2: HLRZ TA,RENAM1
PUSHJ PP,LNKSET
HRRM TA,RENAM1
LDB TB,DA.LVL
CAIN TB,LVL.01
JRST D53E.1 ;ILLEGAL LEVEL
CAIE TB,LVL.77
CAIN TB,LVL.66
JRST D53E.1
LDB TB,DA.SUB
JUMPN TB,D53E.2 ;MAY NOT RENAME ITEMS WITH OCCURS
HLRZ TB,RENAM1
D53R.1: PUSHJ PP,FNDPOP
JRST D53E.3 ;NO RECORD FOUND
HLRZ TC,RENAM2
CAIN TC,(TB)
JRST D53E.4 ;FIRST ITEM SUBSIDIARY TO SECOND
HRLZM TB,RNREC1##
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,RNREC1
LDB TC,DA.LVL
HLRZ TB,RNREC1
CAIE TC,LVL.01
JRST D53R.1 ;NOT YET UP TO RECORD
HLRZ TA,RENAM2
PUSHJ PP,LNKSET
HRRM TA,RENAM2
LDB TB,DA.LVL
CAIN TB,LVL.01
JRST D53E.1
CAIE TB,LVL.77
CAIN TB,LVL.66
JRST D53E.1
LDB TB,DA.SUB
JUMPN TB,D53E.2
HLRZ TB,RENAM2
D53R.2: PUSHJ PP,FNDPOP
JRST D53E.3
HLRZ TC,RENAM1
CAIN TC,(TB)
JRST D53E.4 ;SECOND ITEM SUBSIDIARY TO FIRST
HRLZM TB,RNREC2##
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,RNREC2
LDB TC,DA.LVL
HLRZ TB,RNREC2
CAIE TC,LVL.01
JRST D53R.2
HLRZ TC,RNREC1
CAIE TC,(TB)
JRST D53E.3 ;ITEMS NOT IN SAME RECORD
HRRZ TA,RENAM1
LDB TB,DA.LOC
LDB TC,DA.RES##
HRRZ TA,RENAM2
LDB TD,DA.LOC
LDB TE,DA.RES
SUBI TD,(TB) ;L2-L1
SUBI TC,(TE) ;R1-R2
IMULI TD,44
ADD TD,TC
JUMPLE TD,D53E.6 ;SECOND ITEM IS BEFORE FIRST
;27-APR-79 /DAW THIRD ATTEMPT AT GETTING THE SIZE RIGHT.
; 2ND ATTEMPT WAS ACK'S ON 21-MAR-75.
;DECIDE ON SOME FORM OF DISPLAY USAGE FOR THE ITEM.
HRRZ TA,RENAM2 ;POINT AT LAST ITEM
LDB TB,DA.USG## ;GET ITS USAGE
HRRZ TA,RENAM1 ;POINT AT THE FIRST ITEM BEING RENAMED.
CAIE TB,%US.D6 ;IF THE LAST ITEM IS DISPLAY-6
CAIN TB,%US.D7 ; OR DISPLAY-7, WE WILL
JRST D53R.7 ; USE ITS USAGE.
CAIE TB,%US.EB ;IF THE LAST ITEM IS DISPLAY-9
CAIN TB,%US.C3 ; OR COMP-3, WE WILL USE
JRST D53R.5 ; DISPLAY-9.
LDB TB,DA.USG## ;GET THE FIRST ITEM'S USAGE.
CAIE TB,%US.D6 ;IF THE FIRST ITEM IS DISPLAY-6
CAIN TB,%US.D7 ; OR DISPLAY-7, USE
CAIA ; ITS USAGE.
D53R.5: MOVEI TB,%US.EB ;OTHERWISE USE DISPLAY-9.
;PICK UP THE REST OF THE STUFF WE NEED FROM THE FIRST ITEM.
D53R.7: LDB TC,DA.LOC## ;GET THE STARTING LOC.
LDB TE,DA.RES## ; AND RESIDUE.
;PUT THE STUFF IN THE RENAMING ITEM.
HRRZ TA,CURDAT ;POINT AT IT.
DPB TB,DA.USG## ;SET ITS USAGE,
DPB TC,DA.LOC## ; LOCATION
DPB TE,DA.RES## ; AND RESIDUE.
;NOW WE JUST NEED SIZE OF THE TOTAL ITEM.
;WE KNOW WHERE FIRST ITEM STARTS. NOW FIND OUT WHERE
; THE LAST ITEM ENDS, AND FROM THAT INFO WE CAN CALCULATE
; THE SIZE OF THE RENAMED ITEM.
HRRZ TA,RENAM2 ;POINT AT LAST ITEM.
LDB TB,DA.USG## ;GET ITS USAGE
LDB TD,DA.EXS## ; AND SIZE.
XCT BIBYSZ(TB) ;GET THE ITEM'S ACTUAL SIZE AND
; THE NUMBER OF BITS PER BYTE.
;(TC) = NUMBER OF BITS PER BYTE.
;(TD) = NUMBER OF BYTES IN THE ITEM.
HRRZ TA,RENAM2 ;GET STARTING BIT POSITION FOR 2ND ITEM
LDB TB,DA.RES ;TB = # BITS LEFT OVER IN 1ST WORD OF ITEM
IDIV TB,TC ;GET TB= # BYTES LEFT OVER IN 1ST WORD OF ITEM
;TA= SMASHED
SUB TB,TD ;GET -NUMBER LEFT
JUMPG TB,D53DW1 ;ALL FIT IN THIS WORD, BITS LEFT OVER, TOO!
JUMPE TB,D53DW2 ;EXACT FIT - SET LOC TO NEXT WORD, RES TO ^D36
;TB= -# BYTES LEFT.
MOVM TD,TB ;TD= + # BYTES LEFT.
MOVEI TB,^D36 ;BITS/WORD
IDIV TB,TC ;TB= BYTES/WORD = (BITS/WORD) / (BITS/BYTE)
;TA= SMASHED
IMUL TB,TC ;BITS/WORD (^D36 IFF DIVISIBLE BY BYTE SIZE!)
IMUL TC,TD ;TC= TOTAL # BITS IN ITEM
IDIVI TC,(TB) ;TC= TOTAL # WORDS
;TB= BITS LEFT OVER
MOVEI TE,^D36 ;COMPUTE RES.END = ^D36- # BITS LEFT OVER
SUB TE,TB
HRRZI TD,1(TC) ;COMPUTE LOC.END = TOT # WORDS + LOC.BEG + 1
HRRZ TA,RENAM2
LDB TB,DA.LOC
ADD TD,TB
JRST D53DW3 ;DONE-- TE=RES.END, TD=LOC.END
D53DW1: HRRZ TA,RENAM2 ;POINT TO LAST ITEM
LDB TE,DA.RES ;RES.END = RES.BEG - TOTAL * # BITS/BYTE
IMUL TD,TC ;TD= TOTAL # BYTES * BITS/BYTE
SUB TE,TD ;TE= RES.END (WILL BE .GT. 0)
LDB TD,DA.LOC ;LOC.END = LOC.BEG
JRST D53DW3
D53DW2: HRRZ TA,RENAM2 ;POINT TO LAST ITEM
MOVEI TE,^D36 ;RES.END = ^D36
LDB TD,DA.LOC ;LOC.END = LOC.BEG + 1
AOJA TD,D53DW3 ;GO FIGURE OUT SIZE OF WHOLE THING
;HERE WITH TD:= COMPUTED LOC.END
; TE: = COMPUTED RES.END
D53DW3:
;** CAUTION: HORRIBLE THING ABOUT TO HAPPEN **:
; WE ARE DONE WITH "RENAM1" AND "RENAM2". SO TO GET SOME
; MORE ACS, WE WILL STORE OUR COMPUTED LOC.END AND RES.END
; AWAY IN RENAM1 AND RENAM2, RESPECTIVELY.
;(HEAVEN HELP THE PROGRAMMER WITHOUT A LISTING WHO TRIES
; TO USE DDT TO SEE WHAT IS GOING ON!)
MOVEM TD,RENAM1 ;STORE LOC.END
MOVEM TE,RENAM2 ;STORE RES.END
;NOW DECIDE HOW MANY BYTES THIS ITEM IS
HRRZ TA,CURDAT ;STORE INFO IN THE RENAMING ITEM
LDB TB,DA.USG ;GET ITS USAGE (STORED EARLIER..SOME
; FLAVOR OF DISPLAY!)
XCT BIBYSZ(TB) ;TC: = BITS/BYTE
LDB TD,DA.RES ;RES.ST
HRRZ TE,RENAM2 ;RES.END
SUB TD,TE ;RES.ST-RES.END
JUMPGE TD,D53DW4 ; EVEN # WORDS, OR # + REMAINDER
;ENDS BEFORE IT STARTS IN THE WORD!
; START OFF BY CALCULATING TE:= # BYTES LEFT OVER IN THE FIRST WORD,
; THEN ADD THIS TO RESULT OBTAINED WHEN WE START AT THE NEXT
; WORD BOUNDARY
LDB TE,DA.RES ;RES.ST = # BITS LEFT OVER IN 1ST WORD
IDIVI TE,(TC) ;TE:= # BYTES LEFT OVER IN 1ST WORD
MOVEI TD,^D36 ;TD:= RES.ST
LDB TA,DA.LOC ;TA:= LOC.ST
AOJA TA,D53DW5 ;PRETEND WE'RE AT START OF NEXT WORD
;EVEN # WORDS, OR # + REMAINDER
D53DW4: SETZ TE, ;TE= ACCUMULATED # BYTES
LDB TD,DA.RES ;TD:=RES.ST
LDB TA,DA.LOC ;TA:=LOC.ST
; JRST D53DW5 ;GO TO COMMON CODE
;COME HERE WITH TA= LOC.ST, TD=RES.ST, TE=# BYTES ACCUMULATED SO FAR
D53DW5: HRRZ TB,RENAM2 ;RES.END
SUB TD,TB ;RES.ST-RES.END (WILL BE POSITIVE NOW!)
PUSH PP,TC ;SAVE # BITS/BYTE
IDIVI TD,(TC) ;TD:= BYTES, TC:= REMAINDER
SKIPE TC ; ROUND UP ALWAYS!
ADDI TD,1
POP PP,TC ;RESTORE TC
ADD TE,TD ;ADD # BYTES AT END
;NOW TE= LEFTOVER BYTES AT BEGINNING + LEFTOVER BYTES AT END
; ADD TO THAT THE NUMBER OF BYTES FROM FULL WORDS, IF ANY
HRRZ TD,RENAM1 ;LOC.END
SUB TD,TA ;LOC.END-LOC.ST = # OF FULL WORDS USED
;MULTIPLY BY NUMBER OF BYTES/WORD AND ADD TO BYTE TOTAL
MOVEI TB,^D36 ;BITS IN A WORD
IDIVI TB,(TC) ;TB: = # BYTES/WORD
;TA = SMASHED
IMUL TD,TB ;GET # BYTES FROM THE FULL WORDS.
ADD TE,TD ;AND WE ARE NOW DONE!
HRRZ TA,CURDAT ;STORE SIZE AWAY
CAILE TE,MAXWSS## ;IF IT'S TOO BIG,
JRST D53E.7 ; GO COMPLAIN.
DPB TE,DA.INS## ;SET THE ITEM'S SIZE.
DPB TE,DA.EXS##
HLRZ TB,RNREC1 ;FATHER OF RENAMING ITEM IS THE RECORD
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
HRRZI TB,%CL.AN
DPB TB,DA.CLA ;CLASS IS ALPHANUMERIC
SETO TC, ;[253] SET AS DEFINED
DPB TC,DA.DEF ;[253]
TSWT FFILSC; ;Skip if we are in FILE SECTION
JRST D53DW6 ;Not
DPB TC,DA.DFS ;Set "defined in the file section"
LDB TB,DA.POP ;Get TB:= 01-item.
PUSHJ PP,D53FS ;Put item in RENAMES table
SETO TC, ;Get an "on" bit.
D53DW6: SKIPE LNKSEC ;[450] LINKAGE SECTION?
DPB TC,DA.LKS ;[450] YES, SET FLAG IN ENTRY.
SETZM CURDAT
POPJ PP,
;Routine to put item in RENAMES table.
;Call:
; CURDAT/ points to 66-item
; TB/ DATAB link of the 01 item
; PUSHJ PP,D53FS
; <return here>
;Uses TB,TC,TD,TE
D53FS: PUSH PP,TA ;Save TA
PUSH PP,TB ;01 item link is 0(pp)
D53FSA: MOVE TA,RENNXT ;Get next loc
MOVE TE,RENNXT ;Get another copy
ADD TE,[1,,1] ;Get new "next" loc
JUMPGE TE,D53FSE ; No more room, expand table
MOVEM TE,RENNXT ;Store new "next"
HLRZ TB,CURDAT ;Get 66-item link
DPB TB,RN.66
HRRZ TB,0(PP) ;Get 01-item link
DPB TB,RN.01
POP PP,TB ;restore TB
POP PP,TA ;Restore TA
POPJ PP, ;Return
D53FSE: PUSHJ PP,XPNREN ;Go expand the RENAMES table
JRST D53FSA ; and start again
D53E.1: HRRZI DW,E.253
JRST DA53.E
D53E.2: HRRZI DW,E.254
JRST DA53.E
D53E.3: HRRZI DW,E.255
JRST DA53.E
D53E.4: HRRZI DW,E.256
JRST DA53.E
D53E.6: HRRZI DW,E.257
JRST DA53.E
D53E.7: HRRZI DW,E.316
DA53.E: SKIPN TA,CURDAT
JRST FATAL
LDB LN,DA.LN
LDB CP,DA.CP
SETZM CURDAT
JRST FATAL
;ROUTINE TO FINISH UP PROCESSING A DATA ITEM (CHECK CONSISTANCY,
;ASSIGN DEFAULTS, ASSIGN STORAGE, ETC.)
INTER. DA54.
DA54.: SKIPN TA, CURDAT ;DO WE HAVE A CURRENT ITEM?
POPJ PP, ;NO, LEAVE.
LDB TB, [POINT 3,TA,2]
CAIE TB, CD.DAT ;IS HE IN DATAB.
SETZB TA, CURDAT ;NO, THEN THERE IS NO CURRENT ITEM.
JUMPE TA, CPOPJ ;IF THERE IS NO CURRENT ITEM, LEAVE.
LDB TB, DA.LVL## ;GET THE ITEM'S LEVEL.
CAIN TB, LVL.66 ;LEVEL 66?
POPJ PP, ;YES, LEAVE.
;NOTE: THE FOLLOWING TWO INSTRUCTIONS WERE IN THE ORIGINAL CODE SO
; THEY ARE LEFT HERE. I DON'T UNDERSTAND THEM, SINCE IF AN ITEM IS
; NOT DEFINED IT WOULD SEEM MORE REASONABLE TO SIMPLY RETURN RATHER
; THAN SEE IF IT HAS A VALUE CLAUSE AND IF IT DOES, WRITE IT OUT,
; ESPECIALLY SINCE NO STORAGE HAS BEEN ALLOCATED FOR THE ITEM.
LDB TB, DA.DEF##
JUMPE TB, D54.RX
;CHECK FOR ALL SUBORDINATE ITEMS TO A GROUP ITEM HAVING THE SAME LEVEL NUMBER
;IF NOT ISSUE A WARNING AND IGNORE THE PROBLEM
HLRZ TB,CURDAT ;GET TABLE LINK
PUSHJ PP,FNDPOP ;GET FATHER
JRST D54.DB ;NO FATHER
LDB TA,[POINT 3,TB,20] ;GET TABLE CODE JUST TO BE SAFE
CAIE TA,CD.DAT ;IT SHOULD BE
JRST D54.DB ;ITS NOT!
HRRZ TA,TB
PUSHJ PP,LNKSET ;CONVERT LINK TO ADDRESS
LDB TA,DA.SON ;GET FIRST SON
JUMPE TA,D54.DB ;MUST BE ONE
PUSHJ PP,LNKSET ;CONVERT TO ADDRESS
LDB TC,DA.LVL ;GET LEVEL OF FIRST SON
PUSH PP,TC ;SAVE IT
D54.DC: LDB TC,DA.FAL ;DOES IT HAVE A BROTHER?
JUMPN TC,D54.DA ;NO, GIVE UP
LDB TA,DA.BRO ;GET BROTHER
PUSHJ PP,LNKSET ;CONVERT TO ADDRESS
LDB TC,DA.LVL ;GET ITS LEVEL
CAMN TC,0(PP) ;SAME AS FIRST SON?
JRST D54.DC ;YES, TRY NEXT
MOVE TC,0(PP) ;NO, GET FIRST LEVEL
DPB TC,DA.LVL ;CHANGE WRONG ONE (SO WE DON'T PRINT IT AGAIN)
HRRZI DW,E.721
PUSHJ PP,D54E.8 ;WARN USER
JRST D54.DC ;TRY AGAIN
D54.DA: POP PP,(PP) ;CLEAR STACK
D54.DB: MOVE TA,CURDAT ;RELOAD CURRENT POINTER
SWON ELITEM; ;ASSUME THAT THIS IS AN
; ELEMENTARY ITEM.
LDB TB, DA.SON## ;GET THE ITEM'S SON LINK.
JUMPE TB, D54.JD ;IF THERE IS NO SON, THIS
; MUST BE AN ELEMENTARY ITEM
; GO PROCESS IT.
;WE HAVE A GROUP ITEM.
; (TA) = ADDRESS OF CURRENT ITEM.
SWOFF ELITEM; ;NOTE THAT IT IS NOT AN
; ELEMENTARY ITEM.
MOVEI TB, %CL.AN ;ALL GROUP ITEMS HAVE
DPB TB, DA.CLA## ;ALPHANUMERIC CLASS.
LDB TB, DA.USG## ;GET THE ITEM'S USAGE.
LDB TC, DA.PIC## ;IF THE ITEM DOESN'T HAVE
JUMPE TC, D54.DD ;A PICTURE, ALL IS WELL.
PUSHJ PP, D54E.B ;OTHERWISE COMPLAIN.
D54.DD: PUSHJ PP, D54I.D ;GO MAKE SURE THIS ITEM'S
; USAGE IS OK.
; (TA) = ADDRESS OF CURRENT ITEM
; (TB) = USAGE OF CURRENT ITEM
;HERE WE CHECK TO MAKE SURE THAT ALL OF OUR FIRST LEVEL SONS AGREE
; WITH OUR USAGE.
LDB TA, DA.SON## ;GET THE SON LINK.
D54.DH: ANDI TA, 77777 ;GET HIS DATAB OFFSET.
ADD TA, DATLOC## ;FORM THE SON'S OFFSET.
LDB TC, DA.USG## ;GET THE SON'S USAGE.
CAIN TB, (TC) ;IS IT THE SAME AS THE FATHER'S?
JRST D54.DP ;YES, ALL IS WELL.
CAIE TC, %US.D6 ;IF THE SON'S USAGE IS DISPLAY-6
CAIN TC, %US.D7 ; OR DISPLAY-7
JRST D54.DL ; IT'S BAD NEWS.
CAIN TC, %US.EB ;THE SON BEING DISPLAY-9
JRST D54.DL ; IS BAD NEWS ALSO.
CAIN TC, %US.C3 ;IF THE SON IS COMP-3 AND
CAIN TB, %US.EB ; THE FATHER IS DISPLAY-9 OR THE
JRST D54.DP ; SON IS ANY NON DISPLAY USAGE,
; ALL IS WELL. NOTE: FATHER BEING
; ONE FLAVOR OF DISPLAY AND SON
; BEING ANOTHER WOULD HAVE BEEN
; CAUGHT BY DA38.
D54.DL: PUSHJ PP, D54E.C ;OTHERWISE COMPLAIN.
D54.DP: LDB TC, DA.FAL## ;GET THE FATHER/BROTHER FLAG.
JUMPN TC, D54.DT ;IF THERE ARE NO MORE SONS, LEAVE.
LDB TA, DA.BRO## ;OTHERWISE GET THE BROTHER LINK
JRST D54.DH ; AND GO CHECK HIS USAGE.
D54.DT: HRRZ TA, CURDAT ;RESTORE THE CURRENT ITEM'S ADDRESS.
SKIPE REPSEC ;[315] IF IN REPORT SECTION, CHECK
PUSHJ PP, RPWGPC ;[315] GROUP LEVEL PARAMETERS.
HRRZ TA, CURDAT ;[315] RESTORE DATAB ADRESS
LDB TB, DA.USG## ;[315] AND USAGE.
;HERE WE FIGURE OUR WHERE THE ITEM STARTS.
; (TA) = CURRENT ITEM'S DATAB ADDRESS
; (TB) = CURRENT ITEM'S USAGE
LDB TA, DA.SON## ;GET THE SON LINK.
ANDI TA, 77777 ;GET HIS DATAB OFFSET.
ADD TA, DATLOC## ;FORM HIS ADDRESS.
LDB TC, DA.RES## ;GET HIS RESIDUE.
LDB TD, DA.SYR## ;IF HE WASN'T SYNCED RIGHT
JUMPE TD, D54.DX ; USE THE SON'S RESIDUE
MOVEI TC, 44 ;OTHERWISE MAKE THE FATHER
; START AT THE BEGINNING OF
; THE WORD.
D54.DX: LDB TD, DA.LOC## ;GET THE SON'S RUNTIME LOCATION.
HRRZ TA, CURDAT ;POINT AT THE CURRENT ITEM AGAIN.
DPB TC, DA.RES## ;SET HIS RESIDUE.
DPB TD, DA.LOC## ; AND HIS LOCATION.
;HERE WE FIGURE OUT THE ITEM'S LENGTH IN CHARACTERS.
; (TA) = CURRENT ITEM'S DATAB ADDRESS.
; (TB) = CUARRENT ITEM'S USAGE
; (TC) = CURRENT ITEM'S RESIDUE
; (TD) = CURRENT ITEM'S LOCATION
HRRZ TE, EAS1PC ;GET THE LOCATION OF THE CURRENT WORD.
SUBI TE, 1(TD) ;(TE) = NUMBER OF WORDS SPANNED.
HLRZ TD, EAS1PC ;NUMBER OF BITS USED IN THE
; CURRENT WORD.
ADDI TD, (TC) ;NUMBER OF BITS USED IN PARTIAL WORDS.
IMULI TE, 44 ;NUMBER OF BITS USED IN SPANNED WORDS.
ADDI TE, (TD) ;TOTAL NUMBER OF BITS USED.
IDIVI TE, 44 ;NUMBER OF WORDS USED.
IDIV TD, BITBYT(TB) ;NUMBER OF BYTES IN PARTIAL WORDS.
IMUL TE, BYTWRD(TB) ;NUMBER OF BYTES IN FULL WORDS.
ADDI TE, (TD) ;TOTAL NUMBER OF BYTES USED.
CAILE TE, MAXWSS ;IS IT LARGER THAN THE ALLOWED
; MAXIMUM?
PUSHJ PP, D54E.D ;YES, COMPLAIN.
DPB TE, DA.EXS## ;SET THE EXTERNAL AND
DPB TE, DA.INS## ; INTERNAL SIZES.
;CHECK FOR SYNCS AT A LOWER LEVEL.
; (TA) = CURRENT ITEM'S DATAB ADDRESS
; (TB) = CURRENT ITEM'S USAGE
LDB TC, DA.SLL## ;IF THE SYNC AT A LOWER LEVEL FLAG
JUMPN TC, D54.FL ; IS ALREADY ON, DON'T MESS WITH IT.
LDB TA, DA.SON## ;GET THE SON LINK.
D54.FD: ANDI TA, 77777 ;GET HIS DATAB OFFSET.
ADD TA, DATLOC## ;FORM HIS ADDRESS.
LDB TC, DA.SYR## ;GET HIS SYNC RIGHT FLAG
JUMPN TC, D54.FH ;IF IT'S ON GO SET HIS FATHER'S
; SLL FLAG OR IF HIS
LDB TC, DA.SYL## ; SYNC LEFT FLAG IS ON GO
JUMPN TC, D54.FH ; SET HIS FATHER'S SLL FLAG
LDB TC, DA.SLL## ; OR IF HIS SYNC AT A LOWER
JUMPN TC, D54.FH ; LEVEL FLAG IS ON GO SET HIS FATHERS.
LDB TD, DA.FAL## ;IF THERE ARE NO MORE SONS,
JUMPN TD, D54.FH ; LEAVE
LDB TA, DA.BRO## ;OTHERWISE GET THE BROTHER LINK
JRST D54.FD ; AND GO CHECK HIM FOR SYNCS.
D54.FH: HRRZ TA, CURDAT ;POINT AT THE CURRENT ITEM
DPB TC, DA.SLL## ;SET (OR CLEAR) THE SYNC AT A
; LOWER LEVEL FLAG.
;CHECK FOR DEPENDINGS AT A LOWER LEVEL.
; (TA) = CURRENT ITEM'S DATAB ADDRESS
; (TB) = CURRENT ITEM'S USAGE
D54.FL: LDB TC, DA.DLL## ;IF THE DEPENDING AT A LOWER LEVEL FLAG
JUMPN TC, D54.FN ; IS ALREADY ON, DON'T MESS WITH IT.
LDB TA, DA.SON## ;GET THE SON LINK.
D54.FK: ANDI TA, 77777 ;GET HIS DATAB OFFSET.
ADD TA, DATLOC## ;FORM HIS ADDRESS.
LDB TC, DA.DLL## ;IF HIS DEPENDING AT A LOWER
JUMPN TC, D54.FJ ;[1071] LEVEL FLAG IS ON GO SET HIS FATHERS.
LDB TD, DA.FAL## ;IF THERE ARE NO MORE SONS,
JUMPN TD, D54.FM ; LEAVE
D54.FI: LDB TA, DA.BRO## ;[1071] OTHERWISE GET THE BROTHER LINK
JRST D54.FK ; AND GO CHECK HIM FOR DEPENDING.
;[1071] CHECK THAT ANY OCCURS DEPENDING ITEM IS THE LAST THING IN THE RECORD.
D54.FJ: LDB TD,DA.FAL ;[1071] IF THERE ARE NO MORE SONS
JUMPN TD,D54.FM ;[1071] THEN ITS OK, VARIABLE BIT IS LAST
LDB TD,DA.RDF ;HOWEVER IF IT'S A REDEFINES
JUMPN TD,D54.FM ; ASSUME USER KNOWS WHAT HE'S DOING
HRRZI DW,E.646 ;[1071]
PUSHJ PP,D54E.8 ;[1071] WARN USER
SETZ TC, ;[1071] PRETEND THAT ITS NOT VARIABLE
JRST D54.FI ;[1071] AND TRY NEXT BROTHER
D54.FM: HRRZ TA, CURDAT ;POINT AT THE CURRENT ITEM
DPB TC, DA.DLL## ;SET (OR CLEAR) THE DEPENDING AT A
; LOWER LEVEL FLAG.
;HERE WE CHECK A BUNCH OF MISCELLANEOUS STUFF.
; (TA) = ADDRESS OF CURRENT ITEM.
; (TB) = USAGE OF CURRENT ITEM.
D54.FN: LDB TC, DA.BWZ## ;IF THERE WAS A BLANK WHEN
JUMPE TC, D54.FP ; ZERO CLAUSE
PUSHJ PP, D54E.E ; IT'S AN ERROR.
D54.FP: LDB TC, DA.JST## ;IF THERE WAS A JUSTIFIED
JUMPE TC, D54.FT ; CLAUSE
PUSHJ PP, D54E.F ; IT'S AN ERROR.
D54.FT: LDB TC, DA.SYL## ;IF THERE WAS A SYNC LEFT
LDB TD, DA.SYR## ; OR SYNC RIGHT
IORI TC, (TD) ; CLAUSE,
JUMPE TC, D54.FX ; IT'S AN
PUSHJ PP, D54E.G ; ERROR.
D54.FX: PUSHJ PP, D54J.D ;GO SEE IF THERE WAS A VALUE CLAUSE
; AT THIS LEVEL AND IF THERE WAS,
; CHECK IT OUT.
JRST D54.RX ;GO WORRY OVER PUTTING THE VALUE
; OUT, ALLOCATING MORE SPACE IF
; THERE WAS AN OCCURS, ETC.
;WE HAVE AN ELEMENTARY ITEM.
; (TA) = ADDRESS OF CURRENT ITEM.
D54.JD: SKIPE REPSEC ;[315] IF IN REPORT SECTION,
PUSHJ PP, RPWITC ;[315] CHECK ITEM LEVEL PARMS.
LDB TB, DA.USG## ;GET THE ITEM'S USAGE.
PUSHJ PP, D54I.D ;GO CHECK IT OUT OR DEFAULT
; IT, IF NECESSARY.
; (TA) = ADDRESS OF CURRENT ITEM
; (TB) = USAGE OF CURRENT ITEM
;CHECK PICTURE CLAUSE.
; IT MUST BE PRESENT UNLESS THE ITEM IS INDEX OR COMP-1.
LDB TC, DA.PIC## ;GET THE PICTURE FLAG.
CAIE TB, %US.IN ;IS THE ITEM INDEX OR
CAIN TB, %US.C1 ; COMP-1?
JRST D54.JH ;YES, GO WORRY OVER IT.
CAIN TB,%US.C2 ;OR COMP-2
JRST D54.JH
JUMPN TC, D54.JT ;IF THERE WAS A PICTURE CLAUSE,
; GO ON.
PUSHJ PP, D54E.R ;OTHERWISE GIVE AN ERROR MESSAGE
JRST D54.JT ; AND GO ON.
;WORRY OVER INDEX, COMP-1, AND COMP-2 ITEMS.
D54.JH: JUMPE TC, D54.JL ;IF THERE WAS NO PICTURE CLAUSE,
; ALL IS WELL
PUSHJ PP, D54E.B ;OTHERWISE COMPLAIN.
D54.JL: MOVEI TC, ^D8 ;ASSUME IT IS COMP-1.
CAIN TB, %US.C1 ;IS IT?
JRST D54.JP ;YES, GO ON.
MOVEI TC,^D18 ;TRY COMP-2
CAIN TB,%US.C2
JRST D54.JP ;IT IS
LDB TC, DA.EXS## ;IF THE ITEM IS INDEX AND HAS
CAIE TC, ^D10 ; A SIZE OF 10, IT'S A DATABASE KEY.
MOVEI TC, 5 ;OTHERWISE MAKE THE SIZE 5.
D54.JP: DPB TC, DA.EXS## ;PUT THE ITEM'S SIZE IN THE
DPB TC, DA.INS## ; DATAB ENTRY.
MOVEI TC, %CL.NU ;SET THE ITEM'S CLASS
DPB TC, DA.CLA## ; AS NUMERIC.
SETO TC, ;SET THE ITEM'S
DPB TC, DA.SGN## ; SIGNED FLAG.
JRST D54.JX ;SKIP CHECKING CLASS AND EDITING
; SINCE WE EITHER KNOW IT'S OK
; OR HAVE ALREADY GIVEN AN
; ERROR MESSAGE.
;CHECK ELEMENTARY ITEM'S CLASS AND EDITING.
; IF THE ITEM IS NOT DISPLAY, THE CLASS MUST BE NUMERIC AND THE
; ITEM CAN NOT BE EDITED.
D54.JT: LDB TC, DA.CLA## ;GET THE ITEM'S CLASS.
CAIN TC, %%CL ;DO WE KNOW ITS CLASS?
JRST D54.JX ;NO, THEN DON'T TRY TO CHECK IT.
CAIE TB, %US.D6 ;IF THE USAGE IS DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7, WE DON'T CARE
JRST D54.JX ; WHAT ITS CLASS IS.
CAIN TB, %US.EB ;DON'T CARE ABOUT DISPLAY-9
JRST D54.JX ; EITHER.
LDB TD, DA.EDT## ;GET THE EDIT FLAG.
CAIN TC, %CL.NU ;IF IT'S NOT NUMERIC OR
JUMPE TD, D54.JX ; IF IT'S EDITED
PUSHJ PP, D54E.S ; COMPLAIN.
;CHECK BLANK WHEN ZERO CLAUSE.
; (TA) = ADDRESS OF CURRENT ITEM
; (TB) = USAGE OF CURRENT ITEM.
D54.JX: LDB TC, DA.BWZ## ;IF THERE WAS NO BLANK WHEN ZERO
JUMPE TC, D54.LP ; CLAUSE, SKIP THIS TEST.
LDB TC, DA.CLA## ;GET THE ITEM'S CLASS.
CAIE TC, %CL.NU ;IS IT NUMERIC?
JRST D54.LD ;NO, ERROR.
LDB TC, DA.PWA## ;IS PIC MASK ALLOCATED?
JUMPN TC, D54.JY ;YES
PUSHJ PP, DA35.B ;NO, ALLOCATE IT SO EDIT CAN WORK
HRRZ TA, CURDAT ;PUT TA BACK
LDB TB, DA.USG ;AND TB
D54.JY: CAIE TB, %US.D6 ;IF IT'S DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7,
JRST D54.LP ; IT'S OK.
CAIE TB, %US.EB ;DISPLAY-9 IS OK TOO.
D54.LD: PUSHJ PP, D54E.T ;ANYTHING ELSE IS AN ERROR.
;CHECK JUSTIFIED CLAUSE.
; (TA) = ADDRESS OF CURRENT ITEM.
; (TB) = USAGE OF CURRENT ITEM.
D54.LP: LDB TC, DA.JST## ;IF THERE WAS NO JUSTIFIED
JUMPE TC, D54.LT ; CLAUSE, SKIP THIS TEST.
LDB TC, DA.CLA## ;IF THE ITEM'S CLASS
CAIN TC, %CL.NU ; IS NUMERIC,
PUSHJ PP, D54E.U ; IT' AN ERROR.
;DEFAULT SYNC CLAUSE, IF NECESSARY.
D54.LT: LDB TC, DA.SYL## ;IF THERE ALREADY WAS
LDB TD, DA.SYR## ;A SYNC SPECIFIED
IORI TC, (TD) ; DON'T
JUMPN TC, D54.LX ; DEFAULT IT.
CAIE TB, %US.D6 ;DISPLAY-6 AND
CAIN TB, %US.D7 ; DISPLAY-7 DON'T HAVE
JRST D54.LX ; TO BE SYNCED RIGHT.
CAIE TB, %US.EB ;NEITHER DOES DISPLAY-9
CAIN TB, %US.C3 ; OR COMP-3.
JRST D54.LX
SETO TC, ;EVERYTHING ELSE MUST
DPB TC, DA.SYR## ; BE SYNCED RIGHT.
;CHECK FOR VALUE AT A HIGHER LEVEL.
; (TA) = ADDRESS OF CURRENT ITEM
; (TB) = USAGE OF CURRENT ITEM.
D54.LX: LDB TC, DA.VHL## ;IF THERE IS NO VALUE AT A
JUMPE TC, D54.NH ; HIGHER LEVEL, SKIP THIS TEST.
LDB TC, DA.SYR## ;SYNCS ARE NOT ALLOWED.
JUMPN TC, D54.ND
LDB TC, DA.SYL##
JUMPN TC, D54.ND
LDB TC, DA.JST## ;JUSTIFICATION IS NOT ALLOWED.
JUMPN TC, D54.ND
CAIE TB, %US.D6 ;DISPLAY-6 AND
CAIN TB, %US.D7 ; DISPLAY-7
JRST D54.NH ; ARE OK
CAIE TB, %US.EB ;DISPLAY-9 IS OK TOO.
D54.ND: PUSHJ PP, D54E.V ;EVERYTHING ELSE IS AN ERROR.
D54.NH: PUSHJ PP, D54J.D ;GO SEE IF THERE IS A VALUE
; CLAUSE AT THIS LEVEL AND IF
; THERE IS, CHECK IT OUT.
;CHECK FOR DEFAULTING OF SIGN CLAUSE.
;NOTE, THIS CANNOT BE DONE CORRECTLY SINCE WE HAVE NO BITS FOR [TRAILING] ONLY
LDB TC,DA.SCF## ;IF THERE A SEPARATE SIGN?
JUMPN TC,D54.NI ;YES, CONTINUE
LDB TB,DA.CLA## ;GET CLASS
LDB TC,DA.USG## ;AND USAGE
CAIN TB,%CL.NU ;MUST BE NUMERIC
CAILE TC,%US.DS ;AND DISPLAY
JRST D54.NF ;NO
LDB TB,DA.EDT ;EDITED?
JUMPN TB,D54.NF ;YES, GIVE UP
LDB TB,DA.LVL## ;GET LEVEL
SOJLE TB,D54.NF ;GIVE UP IF AT TOP LEVEL
D54.NE: PUSHJ PP,NXTTRY ;GET FATHER OF CURRENT DATAB
JRST D54.NF ;DONE
LDB TB,[POINT 3,TBLOCK,20] ; GET TABLE CODE
JUMPE TB,D54.NF ;IF FATHER IN FILTAB, DONE
HLRZ TE,TA
TRZ TE,100000 ;SHUT OFF DATAB TABLE CODE
CAIG TE,1 ;POINTING TO DUMMY DATAB ENTRY ?
JRST D54.NF ; YES, DONE
LDB TB,DA.SCF ;SIGN BITS SPECIFIED?
JUMPE TB,D54.NE ;NOT YET
HRRZ TA,CURDAT ;YES, PUT BACK ORIGINAL
DPB TB,DA.SCF ;COPY BITS
LSH TB,1 ;ISOLATE DA.SSC
JUMPE TB,D54.NF ;JUMP IF NOT SEPARATE CHAR
PUSHJ PP,DA32.T ;YES, INCREMENT SIZE BY 1
D54.NF: HRRZ TA,CURDAT
LDB TB,DA.USG ;RESTORE CURRENT USAGE
;ALLOCATE STORAGE FOR AN ELEMENTARY ITEM.
D54.NI: LDB TC, DA.LVL## ;IF THE ITEM IS NOT
CAIE TC, LVL.01 ; LEVEL 1
CAIN TC, LVL.77 ; OR LEVEL 77
JRST D54.NK
JRST D54.NL ; GO ON.
;LEVEL 1 AND LEVEL 77 ITEMS MUST START ON A WORD BOUNDARY.
D54.NJ: LDB TB, DA.USG## ;REPORT WRITER COMES HERE TO
; ALLOCATE SOME STORAGE.
D54.NK: HLRZ TC, EAS1PC ;GET THE NUMBER OF BITS USED IN
; THE CURRENT WORD.
JUMPE TC, D54.NL ;IF NONE, ALL IS WELL.
AOS TC, EAS1PC ;OTHERWISE, BUMP UP TO THE NEXT WORD.
HRRZM TC, EAS1PC ;SET THE NUMBER OF BITS USED TO ZERO.
D54.NL: LDB TD, DA.EXS## ;GET THE ITEM'S SIZE.
;GET THE NUMBER OF BITS PER BYTE.
XCT BIBYSZ(TB)
; (TA) = CURRENT ITEM'S DATAB ADDRESS
; (TB) = CURRENT ITEM'S USAGE
; (TC) = NUMBER OF BITS PER BYTE
; (TD) = NUMBER OF BYTES REQUIRED TO HOLD THE ITEM
;WE DON'T HAVE ENOUGH AC'S SO SAVE SOME STUFF.
PUSH PP, TC
PUSH PP, BYTWRD(TB) ;NUMBER OF BYTES PER WORD.
MOVEI TB, (TD)
; (TA) = CURRENT ITEM'S DATAB ADDRESS.
; (TB) = NUMBER OF BYTES REQUIRED TO HOLD THE ITEM
; ((PP)) = NUMBER OF BYTES PER WORD.
; ((PP)-1) = NUMBER OF BITS PER BYTE
;IN THE FOLLOWING TA IS NOT MODIFIED AND TB THROUGH TE ARE USED AS TEMPS.
LDB TD, DA.SYL## ;IF THE ITEM DOESN'T
LDB TE, DA.SYR## ; HAVE TO BE
IORI TD, (TE) ; SYNCED, SKIP
JUMPE TD, D54.RD ; THE FOLLOWING.
;THE ITEM IS SYNCED, FORCE IT TO BEGIN ON A WORD BOUNDARY.
HLRZ TD, EAS1PC ;IF IT ALREADY DOES,
JUMPE TD, D54.NP ; GO ON.
AOS TD, EAS1PC ;OTHERWISE BUMP UP TO
HRRZM TD, EAS1PC ; THE NEXT WORD.
D54.NP: JUMPE TE, D54.RD ;IF THE ITEM ISN'T SYNCED
; RIGHT, GO ON.
;THE ITEM IS SYNCED RIGHT, SEE HOW MANY BITS TO WASTE.
MOVEI TD, (TB) ;BYTES REQUIRED.
IDIV TD, (PP) ;BYTES IN FIRST WORD = REM(BYTES
; REQUIRED / BYTES PER WORD)
; (TC) = NUMBER OF BYTES THAT WILL GO IN THE FIRST WORD.
JUMPE TC, D54.RD ;IF NONE, GO ON.
MOVE TD, (PP) ;(TD) = NUMBER OF BYTES PER WORD.
SUBI TD, (TC) ;(TD) = NUMBER OF BYTES TO WASTE.
IMUL TD, -1(PP) ;(TD) = NUMBER OF BITS TO WASTE.
HRLM TD, EAS1PC ;SET NUMBER OF BITS USED (WASTED)
; IN CURRENT WORD.
;NOTE: IN THE ABOVE WE CAN'T FIGURE OUT THE NUMBER OF BITS USED AND
; THEN SUBTRACT THIS FROM 36 TO GET THE NUMBER OF BITS WASTED BECAUSE
; THIS WOULD RIGHT JUSTIFY THE BYTES IN THE FIRST WORD WHICH WOULD
; SCREW UP GROUP MOVES FOR DISPLAY-7 ITEMS.
D54.RD: HLRZ TD, EAS1PC ;NUMBER OF BITS USED IN CURRENT WORD.
MOVEI TE, 44
SUBI TE, (TD) ;(TE) = BITS LEFT IN CURRENT WORD.
IDIV TE, -1(PP) ;(TE) = BYTES WE CAN FIT IN
; CURRENT WORD.
JUMPN TE, D54.RH ;IF WE CAN FIT SOMETHING IN THE
; CURRENT WORD, GO ON.
AOS TD, EAS1PC ;OTHERWISE, BUMP UP TO THE
; NEXT LOCATION.
HRRZM TD, EAS1PC
D54.RH: HRRZ TD, EAS1PC ;SET THE ITEM'S LOCATION.
DPB TD, DA.LOC##
HLRZ TD, EAS1PC ;AND RESIDUE.
MOVEI TC, 44
SUBI TC, (TD)
DPB TC, DA.RES##
; (TA) = ADDRESS OF THE CURRENT ITEM'S DATAB ENTRY
; (TB) = NUMBER OF BYTES REQUIRED TO HOLD THE ITEM
; (TE) = NUMBER OF BYTES WE CAN FIT IN THE CURRENT WOED.
; ((PP)) = NUMBER OF BYTES PER WORD
; ((PP)-1) = NUMBER OF BITS PER BYTE
PUSHJ PP, D54L.D ;GO ALLOCATE THE STORAGE.
; (TA) = ADDRESS OF THE CURRENT ITEM'S DATAB ENTRY
; (TB) = USAGE OF THE CURRENT ITEM.
; (TC), (TD), (TE) = ?
; THE ARGUMENTS THAT WERE ON THE STACK HAVE BEEN REMOVED.
;ELEMENTARY ITEM AND GROUP ITEM PROCESSING COME TOGETHER HERE.
; (TB) = CURRENT ITEM'S USAGE.
D54.RX: LDB TC, DA.VAL## ;IF THERE WAS NO VALUE
JUMPE TC, D54.TD ; CLAUSE, GO ON.
MOVEI TA, (TC) ;OTHERWISE GO
PUSHJ PP, PUTVLU ; WRITE IT OUT.
HRRZ TA, CURDAT ;RESTORE THE ADDRESS OF THE
LDB TB, DA.USG## ; CURRENT ITEM AND ITS USAGE.
;IF THE ITEM IS SYNCED, THE NEXT ITEM CAN NOT START IN THE SAME
; WORD THAT THE CURRENT ITEM ENDS IN.
D54.TD: LDB TC, DA.SYL## ;IF THE ITEM IS SYNCED
JUMPN TC, D54.TH ; LEFT, GO BUMP UP TO THE
; NEXT WORD.
LDB TC, DA.SYR## ;IF THE ITEM IS NOT SYNCED
JUMPE TC, D54.TL ; RIGHT, GO ON.
D54.TH: AOS TC, EAS1PC ;ASSUME WE HAVE TO BUMP UP
TLZN TC, -1 ;DO WE?
SOSA TC, EAS1PC ;NO, BACK UP
HRRZM TC, EAS1PC ;MAKE SURE THE NUMBER OF BITS
; USED IS ZERO.
;CHECK FOR OCCURS.
D54.TL: LDB TC, DA.OCC## ;IF THER WAS NO OCCURS CLAUSE
JUMPE TC, D54.TV ; ON THIS ITEM, GO ON.
;ALLOCATE MORE STORAGE FOR OCCURS.
LDB TC, DA.NOC## ;SEE HOW MANY OCCURANCES.
SOJLE TC, D54.TV ;IF IT ONLY OCCURED ONCE, WE
; HAVE ALREADY ALLOCATED SPACE
; FOR IT.
COMMENT \
CASES:
NO SYNC:
DISPLAY AND COMP-3 MAY START AND END ANYWHERE.
EVERYTHING ELSE IS SYNCED.
SYNCED ITEMS:
EACH OCCURANCE BEGINS IN THE SAME RELATIVE POSITION.
SYNC AT THIS LEVEL - MAY START ANYWHERE, ENDS ON A
WORD BOUNDARY.
SYNC AT LOWER LEVEL - MAY START AND END ANYWHERE.
ALGORITHM:
NO SYNC:
FIND ITEM'S SIZE IN BYTES, MULTIPLY BY NUMBER OF
OCCURANCES, LESS ONE, AND ALLOCATE THAT
MUCH MORE SPACE.
SYNCED ITEMS:
MOVE UP SO THAT WE START IN THE SAME RELATIVE POSITION
AS THE CURRENT ITEM, FIND THE ITEM'S SIZE IN
BYTES, MULTIPLY BY NUMBER OF OCCURANCES,
LESS ONE, RESTORE EAS1PC, AND ALLOCATE THE
SPACE.
NOTES:
1. THERE MAY BE WASTED BITS BETWEEN OCCURANCES OF AN
ITEM IF IT IS SYNCED OR HAS A SYNC AT A LOWER LEVEL.
2. THERE WILL BE NO WASTED BITS BETWEEN THE LAST OCCURANCE
OF THE CURRENT ITEM AND THE NEXT ITEM.
\
PUSH PP, EAS1PC ;SAVE THE CURRENT EAS1PC.
LDB TC, DA.SYL## ;IF THE ITEM IS SYNCED LEFT
JUMPN TC, D54.TP
LDB TC, DA.SYR## ;OR SYNCED RIGHT
JUMPN TC, D54.TP ;GO SEE IF WE HAVE TO MOVE UP.
LDB TC, DA.SLL## ;IF THE ITEM IS NOT SYNCED
JUMPE TC, D54.TT ; AT ALL, DON'T MOVE UP.
D54.TP: LDB TC, DA.RES## ;GET THE ITEM'S RESIDUE.
MOVEI TD, 44
SUBI TD, (TC) ;(TD) = NUMBER OF BITS USED
; BY THIS ITEM IN FIRST WORD.
HLRZ TC, EAS1PC ;(TC) = NUMBER OF BITS USED
; BY THIS ITEM IN LAST WORD.
CAIGE TD, (TC) ;ARE WE PAST THE STARTING POSITION?
AOS EAS1PC ;YES, BUMP UP TO NEXT WORD.
HRLM TD, EAS1PC ;MAKE SUBSEQUENT OCCURANCES
; START IN THE SAME POSITION.
;FIND THE ITEM'S SIZE IN BYTES.
D54.TT: LDB TC, DA.RES## ;GET NUMBER OF BITS USED IN
; FIRST WORD.
HLRZ TD, EAS1PC ;GET NUMBER OF BITS USED IN
; LAST WORD.
ADDI TD, (TC) ;(TD) = BITS USED IN FIRST AND
; LAST WORDS.
IDIV TD, BITBYT(TB) ;(TD) = BYTES IN FIRST AND LAST
; WORDS.
LDB TC, DA.LOC## ;GET STARTING POSITION.
HRRZ TE, EAS1PC ;GET CURRENT POSITION.
SUBI TE, 1(TC) ;(TE) = NUMBER OF WORDS SPANNED.
IMUL TE, BYTWRD(TB) ;(TE) = NUMBER OF BYTES IN
; SPANNED WORDS.
ADD TD, TE ;(TD) = SIZE OF ITEM IN BYTES.
POP PP, EAS1PC ;RESTORE EAS1PC.
;(TD) = SIZE OF FIRST THROUGH NTH OCCURANCE OF THE ITEM IN BYTES (NOTE
; THAT THIS SIZE MAY NOT BE THE SAME AS THE SIZE WE ALLOCATED ALREADY
; WHICH IS THE SIZE OF THE NTH OCCURANCE OF THE ITEM.)
LDB TC, DA.NOC## ;GET THE NUMBER OF OCCURANCES.
IMULI TD, -1(TC) ;(TD) = NUMBER OF CHARACTERS
; TO ALLOCATE.
CAILE TD,MAXWSS ;WILL IT FIT?
JRST D54E.D ;NO, TOO BIG
;SET UP FOR CALL TO ALLOCATION ROUTINE.
PUSH PP, BITBYT(TB) ;BITS PER BYTE.
PUSH PP, BYTWRD(TB) ;BYTES PER WORD.
MOVEI TB, (TD) ;(TB) = NUMBER OF BYTES TO ALLOCATE.
HLRZ TC, EAS1PC ;NUMBER OF BITS USED IN CURRENT
; WORD.
MOVEI TE, 44
SUBI TE, (TC) ;(TE) = NUMBER OF BITS LEFT IN
; CURRENT WORD.
IDIV TE, -1(PP) ;(TE) = NUMBER OF BYTES LEFT
; IN CURRENT WORD.
JUMPN TE, D54.TU ;IF WE CAN FIT SOMETHING IN THIS
; WORD, GO ON.
AOS EAS1PC ;OTHERWISE BUMP UP TO THE NEXT WORD.
HRRZS EAS1PC ;CLEAR THE NUMBER OF BITS USED
; IN THE CURRENT WORD.
D54.TU: PUSHJ PP, D54L.D ;GO ALLOCATE THE STORAGE.
;STORAGE HAS BEEN ALLOCATED FOR THE ITEM.
; (TA) = ADDRESS OF THE CURRENT ITEM'S DATAB ENTRY.
; (TB) = USAGE OF THE CURRENT ITEM.
;Check redefinition now, before sync-ing the 01 otherwise we
; can't give a warning if redefinition is more bytes, but same
; number of words. This could lead to peculiar results.
D54.TV: PUSHJ PP, D54.VH ;Check for redefines clause
;IF THE ITEM IS LEVEL 01 OR LEVEL 77 IT IS AUTOMATICALY SYNCED AND
; IF WE'RE IN THE FILE SECTION WE CAN ASSIGN THE RECORDING MODE.
LDB TC, DA.LVL## ;GET THE ITEM'S LEVEL.
CAIE TC, LVL.01 ;IF IT IS LEVEL 01
CAIN TC, LVL.77 ; OR LEVEL 77
JRST D54.TX ; GO SYNC IT, IF NECESSARY.
POPJ PP, ;DONE
;SEE IF WE HAVE TO SYNC THE ITEM.
D54.TX: AOS TC, EAS1PC ;ASSUME WE ARE NOT ALREADY SYNCED.
TLNN TC, -1 ;WERE WE?
SOSA EAS1PC ;YES, BACK UP.
HRRZM TC, EAS1PC ;SYNC THE ITEM.
;IF WE'RE IN THE FILE SECTION, SET THE RECORDING MODE.
LDB TC, DA.DFS## ;IF WE'RE NOT IN THE FILE
JUMPE TC, CPOPJ ; DONE
HRRZ TA, CURFIL## ;POINT AT THE CURRENT FILE TABLE.
JUMPE TA, D54.VD ;IF THERE IS NONE, GO ON.
MOVE TB, RUSAGE## ;GET THE RECORD USAGE.
MOVEI TC, %RM.6B ;ASSUME DISPLAY-6.
CAIN TB, %US.D7 ;IF THE RECORD IS DISPLAY-7,
MOVEI TC, %RM.7B ; THE RECORDING MODE IS ASCII.
CAIN TB, %US.EB ;IF THE RECORD IS DISPLAY-9
MOVEI TC, %RM.EB ; THE RECORDING MODE IS EBCDIC.
;SET THE RECORDING MODE.
DPB TC, FI.IRM## ;SET THE INTERNAL RECORDING MODE.
LDB TD, FI.RM2## ;IF HE DIDN'T SPECIFY AN
SKIPN TD ;EXTERNAL RECORDING MODE,
DPB TC, FI.ERM## ; SET IT.
;GET THE SIZE OF THE RECORD IN WORDS
;KEEP TRACK OF THE LARGEST SO THAT IF WE ARE IN DEBUG MODE
;WE CAN ALLOCATE ENOUGH SPACE FOR DEBUG-CONTENTS
HRRZ TA,CURDAT
SKIPN TB,RUSAGE ;GET RECORD USAGE
JRST D54.VD ;IGNORE IF NOT SET?
LDB TC,DA.EXS ;GET SIZE
CAILE TB,%US.EB ;ONLY FOR DISPLAY MODES
JRST D54.VD
IDIV TC,[EXP 6,5,4]-1(TB) ;GET SIZE IN WORDS
SKIPE TB
ADDI TC,1 ;COUNT REMAINDER
CAMLE TC,MAXDBC## ;BIGGEST YET?
MOVEM TC,MAXDBC ;YES
D54.VD: HRRZ TA, CURDAT ;RESTORE THE CURRENT ITEM'S
; DATAB ADDRESS.
POPJ PP, ;DONE
;CHECK REDEFINITIONS FOR SIZE.
D54.VH: LDB TC, DA.RDF## ;IF THIS ISN'T A REDEFINITION,
JUMPE TC, D54.VI ; SAVE SIZE IN CASE IT GETS REDEFINED
COMMENT \
CHECK TO MAKE SURE THAT THE SIZE OF THIS ITEM IS THE SAME AS
THE SIZE OF THE REDEFINED ITEM AND IF IT ISN'T MAKE SURE WE ALLOCATE
ENOUGH SPACE FOR THE LARGER OF THE TWO.
\
HLRZ TB, EAS1PC ;NUMBER OF BITS USED IN CURRENT WORD.
CAIG TB, ^D30 ;LESS THAN 6 LEFT?
JRST D54.VL ;NO, GO ON.
AOS TB, EAS1PC ;BUMP UP TO NEXT WORD.
HRRZM TB, EAS1PC
D54.VL: LDB TC, DA.LVL ;GET THE LEVEL NBR
MOVE TB, RDFDAT##(TC) ;GET THE OLD EAS1PC.
HLRZ TC, TB ;GET OLD NUMBER OF BITS LEFT.
CAILE TC, ^D30 ;IF THERE WERE LESS THAN SIX BITS
HRRZI TB, 1(TB) ; LEFT, BUMP UP TO THE NEXT WORD.
CAMN TB, EAS1PC ;IF THE CURRENT EAS1PC IS THE
POPJ PP, ; SAME AS THE OLD ONE, LEAVE.
;REDEFINITION IS NOT THE SAME SIZE AS THE REDEFINED ITEM.
IFN MCS,<
SKIPN COMSEC ;IS THIS IN THE COMMUNICATIONS SECTION?
JRST D54VL0 ;NO, GIVE USUAL ERROR MESSAGE
LDB TC,DA.LVL ;IS THIS A LEVEL 01? (IMPLICIT REDEFINITION).
CAIE TC,LVL.01
JRST D54VL0 ;NO, A REAL ERROR.
;JUST IGNORE THIS "ERROR"
;SINCE FCTC TESTS GET IT ON OUTPUT CD
;WHICH HAS NON-SUBSCRIPTED DEST TABLE
HRRZI DW,E.642 ;TELL HIM HIS SIZE IS WRONG WITHOUT MENTIONING
; REFERRING TO THE "REDEFINITION".
PUSHJ PP,D54E.8 ;. .
JRST D54VL3 ;SKIP OTHER ERROR.
;HERE TO GIVE USUAL REDEFINITION SIZE ERROR MESSAGE
D54VL0:
>
;IF ANSI-8x ITS OK TO BE LESS ALSO, BUT NOT GREATER
SKIPGE AS7482 ;WANT STRICT -74?
JRST D54VL2 ;YES, GIVE ERROR MESSAGE
;IF ANSI-8x ITS AN ERROR TO BE BIGGER
HRRZ TC,EAS1PC ;CURRENT ENDING LOCATION.
CAILE TC,(TB) ;IF THE CURRENT ENDING LOCATION IS GREATER THAN
JRST D54VL2 ; THE OLD ENDING LOCATION, ITS AN ERROR.
CAIE TC,(TB) ;IF THE CURRENT ENDING LOCATION
JRST D54VL1 ; IS LESS THAN THE OLD ONE, ALL IS WELL.
CAME TB,EAS1PC ;IF WE USED MORE BITS IN THE
JRST D54VL2 ; LAST WORD IN THE OLD EAS1PC, ITS ALSO AN ERROR.
D54VL1: SKIPN FLGSW ;WANT FLAGGER?
JRST D54VL3 ;NO
LDB LN,DA.LN ;SET UP LN
LDB CP,DA.CP ; & CP
MOVEI TA,%LV.8 ;THIS LEVEL
PUSHJ PP,FLG.ES ;SEE IF WE WANT IT
HRRZ TA,CURDAT ;RESTORE TA
JRST D54VL3 ;AND SKIP ERROR MESSAGE
D54VL2: PUSHJ PP, D54E.W ;GO COMPLAIN.
D54VL3: HRRZ TC, EAS1PC ;CURRENT ENDING LOCATION.
CAIGE TC, (TB) ;IF THE CURRENT ENDING LOCATION
JRST D54.VP ; IS LESS THAN THE OLD ENDING
; LOCATION, GO USE THE OLD ONE.
CAIE TC, (TB) ;IF THE CURRENT ENDING LOCATION
POPJ PP, ; IS GREATER THAN THE OLD ONE, ALL IS WELL.
CAMLE TB, EAS1PC ;IF WE USED MORE BITS IN THE
D54.VP: MOVEM TB, EAS1PC ; LAST WORD IN THE OLD EAS1PC, USE IT.
POPJ PP, ;RETURN.
D54.VI: SKIPN TE,EAS1PC ;
SKIPN LNKSEC ;IN LINKAGE SECTION?
CAIA ; NO
MOVE TE,LNK1PC ; YES, USE SAVED VALUE INSTEAD
LDB TC, DA.LVL ;GET THE CURRENT LEVEL NUMBER
MOVEM TE, RDFDAT(TC) ;SAVE OFF BY LVL NBR FOR REDEFINES
POPJ PP, ; TESTS, IF ANY
;ERROR ROUTINES:
;ROUTINE TO SAVE TA AND TB AND SET UP LN AND CP.
D54E.0: LDB LN, DA.LN## ;SET UP LN
LDB CP, DA.CP## ; AND CP.
D54E.1: EXCH TA, (PP) ;[674] SAVE TA
PUSH PP, TB ; AND TB.
PUSHJ PP, @(TA) ;GO GENERATE THE DIAG.
POP PP, TB ;RETURN TO HERE, RESTORE TB
POP PP, TA ; AND TA.
POPJ PP, ;RETURN TO CALLER.
;ROUTINE TO GENERATE A FATAL DIAGNOSTIC.
; (DW) = THE DIAG NUMBER.
D54E.2: HRRZ TA, CURDAT ;ENTER HERE IF TA IS NOT POINTING
; AT THE CURRENT DATAB ENTRY.
D54E.4: SETO TC, ;TURN ON THE ERROR IN DATA
DPB TC, DA.ERR## ; DIVISION FLAG.
PUSHJ PP, D54E.0 ;GO SET UP LN AND CP, SAVE TA
EXP FATAL## ; AND TB AND GO GENERATE THE DIAG.
;ROUTINE TO GENERATE A WARNING DIAGNOSTIC.
; (DW) = THE DIAG NUMBER.
D54E.6: HRRZ TA, CURDAT ;ENTER HERE IF TA IS NOT POINTING
; AT THE CURRENT DATAB ENTRY.
D54E.8: PUSHJ PP, D54E.0 ;GO SET UP LN AND CP, SAVE TA
EXP WARN## ; AND TB AND GENERATE THE DIAG.
COMMENT \ 21-MAR-75 /ACK
ALLOW USAGE INDEX AT GROUP LEVEL.
D54E.A: HRRZI DW, E.226 ;USAGE INDEX IS NOT ALLOWED AT
PJRST D54E.8 ; GROUP LEVEL.
\
D54E.B: HRRZI DW, E.221 ;PICTURE NOT PERMITTED.
SETZ TE,
DPB TE, DA.EXS##
DPB TE, DA.INS##
DPB TE, DA.EDT##
DPB TE, DA.NDP##
DPB TE, DA.DPR##
PJRST D54E.8
D54E.C: HRRZI DW, E.41 ;USAGE DISAGREES WITH GROUP'S.
PJRST D54E.4
D54E.D: HRRZI DW, E.316 ;SIZE OF A RECORD EXCEEDS MAXIMUM.
PJRST D54E.4
D54E.E: HRRZI DW, E.222 ;BLANK WHEN ZERO ON A GROUP.
SETZ TC,
DPB TC, DA.BWZ##
PJRST D54E.8
D54E.F: HRRZI DW, E.224 ;JUSTIFIED CLAUSE ON A GROUP ITEM.
SETZ TC,
DPB TC, DA.JST##
PJRST D54E.8
D54E.G: HRRZI DW, E.225 ;SYNC CLAUSE ON A GROUP ITEM.
SETZ TC,
DPB TC, DA.SYL##
DPB TC, DA.SYR##
PJRST D54E.8
D54E.I: HRRZI DW, E.237 ;VALUE CLAUSE IN FILE SECTION.
D54E.J: SETZ TC,
DPB TC, DA.VAL##
PJRST D54E.6
D54E.K: HRRZI DW, E.234 ;VALUE CLAUSE ON AN ITEM SUBORDINATE
PJRST D54E.J ; TO AN ITEM WITH A VALUE CLAUSE.
D54E.L: HRRZI DW, E.235 ;VALUE CLAUSE SUBORDINATE TO AN
PJRST D54E.J ; OCCURS CLAUSE.
D54E.M: HRRZI DW, E.270 ;VALUE CLAUSE SUBORDINATE TO
PJRST D54E.J ; A REDEFINITION.
D54E.N: HRRZI DW, E.329 ;NON SIXBIT CHARACTER IN LITERAL.
PJRST D54E.2
D54E.O: HRRZI DW, E.236 ;NUMERIC LITERAL IN VALUE
PJRST D54E.J ; CLAUSE FOR GROUP ITEM.
D54E.P: HRRZI DW, E.298 ;BAD FIGURATIVE CONSTANT FOR
PJRST D54E.J ; VALUE CLAUSE.
D54E.R: HRRZI DW, E.220 ;MISSING PICTURE.
PJRST D54E.4
D54E.S: HRRZI DW, E.244 ;PICTURE/USAGE CONFLICT.
PJRST D54E.4
D54E.T: HRRZI DW, E.223 ;BLANK WHEN ZERO ON A NON-NUMERIC
PJRST D54E.E+1 ; OR NON-DISPLAY ITEM.
D54E.U: HRRZI DW, E.69 ;JUSTIFIED CLAUSE ON A
PJRST D54E.F+1 ; NUMERIC ITEM.
D54E.V: HRRZI DW, E.247 ;ITEM HAS A VALUE AT A HIGHER
SETZ TC, ; LEVEL AND IS SYNCED,
DPB TC, DA.SYR## ; JUSTIFIED OR HAS
DPB TC, DA.SYL## ; WRONG USAGE.
DPB TC, DA.JST##
PJRST D54E.8
D54E.W: HRRZI DW, E.271 ;REDEFINITION IS NOT THE
PJRST D54E.8 ; SAME SIZE AS REDEFINED ITEM.
COMMENT \
THIS ROUTINE DEFAULTS, IF NECESSARY, THE USAGE OF THE CURRENT ITEM.
CALL:
PUSHJ PP, D54I.D
ENTRY CONDITIONS:
(TA) = ADDRESS OF THE CURRENT ITEM.
(TB) = USAGE OF THE CURRENT ITEM.
EXIT CONDITIONS:
(TA) = ADDRESS OF THE CURRENT ITEM
(TB) = USAGE OF THE CURRENT ITEM.
NOTES:
1. FOR GROUP ITEMS EVEN IF THE USAGE IS KNOWN
UPON ENTRY A DIFFERENT USAGE MAY BE RETURNED, SINCE
GROUP ITEMS MUST HAVE SOME FORM OF DISPLAY USAGE.
2. THE SUBROUTINE D54I.P IS USED TO CHECK THE
USAGE AND IF IT FINDS A VIABLE USAGE IT RETURNS TO
THE ROUTINE WHICH CALLED THIS ROUTINE.
3. A VIABLE USAGE IS:
FOR ELEMENTARY ITEMS - ANYTHING
FOR GROUP ITEMS - ANY DISPLAY USAGE
OR A USAGE FROM WHICH WE CAN INFER A DISPLAY
USAGE FOR THE ITEM.
\
D54I.D: MOVEI TC, (TB) ;SET UP FOR SUBROUTINE CALL.
JSP TD, D54I.P ;GO SEE IF WE HAVE A VIABLE USAGE.
;TRY TO DEFAULT TO AN ANCESTOR'S USAGE.
HLRZ TB, CURDAT ;GET LINK TO CURRENT ITEM.
D54I.F: PUSHJ PP, FNDPOP ;GO FIND FATHER.
JRST D54I.H ;NO FATHER, GO USE THE RECORD'S USAGE.
LDB TC, [POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TC, CD.DAT ;IS FATHER DATAB?
JRST D54I.H ;NO, GO USE THE RECORD'S USAGE.
LDB TA, [POINT 15,TB,35] ;GET FATHER'S DATAB OFFSET.
ADD TA, DATLOC## ;FORM FATHER'S ADDRESS.
LDB TC, DA.USG## ;GET FATHER'S USAGE.
JSP TD, D54I.P ;GO SEE IF HE HAS A VIABLE USAGE.
JRST D54I.F ;HE DOESN'T, GO CHECK HIS FATHER.
;CAN'T USE AN ANCESTOR'S USAGE.
D54I.H: SETZ TB, ;NOTE THAT WE DON'T HAVE A USAGE YET.
JRST D54I.T ;GO USE THE RECORD'S USAGE.
;ROUTINE TO SEE IF A USAGE IS VIABLE.
;CALL: JSP TD, D54I.P
;ENTRY CONDITIONS: (TC) = USAGE TO CHECK.
;EXIT CONDITIONS:
; IF THE USAGE IS NOT VIABLE SIMPLY RETURN TO CALL+1.
; IF THE USAGE IS VIABLE, RETURN TO CALLER'S CALLER WITH.
; (TA) = ADDRESS OF CURRENT ITEM.
; (TB) = USAGE OF CURRENT ITEM AND THE USAGE IN THE ITEM'S
; DATAB ENTRY.
D54I.P: CAIN TC, %%US ;IS THIS ANY KIND OF USAGE?
JRST (TD) ;NO, RETURN.
TSWF ELITEM; ;IS THIS AN ELEMENTARY ITEM?
JRST D54I.R ;YES, THEN ANY USAGE IS OK.
CAIE TC, %US.D6 ;DISPLAY-6
CAIN TC, %US.D7 ; OR DISPLAY-7
JRST D54I.R ; IS OK.
CAIN TC, %US.EB ;DISPLAY-9
JRST D54I.R ; IS OK TOO.
CAIE TC, %US.C3 ;IS IT COMP-3.
JRST (TD) ;NO, RETURN.
MOVEI TC, %US.EB ;COMP-3 IMPLIES DISPLAY-9.
D54I.R: HRRZI TB, (TC) ;SET UP FOR RETURN.
D54I.T: SKIPE TC, RUSAGE## ;DOES THE RECORD HAVE A USAGE?
JRST D54I.X ;YES, GO ON.
;SET THE RECORD'S USAGE. NOTE THAT IF A VIABLE USAGE HAS NOT BEEN GIVEN
; BY THE TIME WE SEE THE FIRST ELEMENTARY ITEM, WE WILL COME HERE.
CAIE TB, %US.D6 ;IF THE ITEM IS DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7
MOVEI TC, (TB) ; USE IT.
CAIE TB, %US.EB ;IF THE ITEM IS DISPLAY-9
CAIN TB, %US.C3 ; OR COMP-3
MOVEI TC, %US.EB ; USE DISPLAY-9.
SKIPN TC ;IF WE HAVE A RECORD USAGE NOW,
; GO ON OTHERWISE, DEFAULT IT
;WE HAVE TO DEFAULT THE RECORD'S USAGE.
HRRZ TC, DEFDSP ;GET THE DEFAULT
MOVEM TC, RUSAGE## ;SET THE RECORD'S USAGE.
;IF THE ITEM DOESN'T HAVE A USAGE BY NOW, GIVE IT THE RECORD'S USAGE.
; (TB) = THE ITEM'S USAGE, IF IT HAS ONE OR 0, IF IT DOESN'T.
; (TC) = THE RECORD'S USAGE.
D54I.X: SKIPN TB ;DOES THE ITEM HAVE A USAGE?
MOVEI TB, (TC) ;NO, GIVE IT THE RECORD'S USAGE.
HRRZ TA, CURDAT ;POINT AT THE CURRENT ITEM.
DPB TB, DA.USG## ;SET ITS USAGE.
POPJ PP, ;RETURN TO CALLER'S CALLER.
COMMENT \
THIS ROUTINE CHECKS FOR A VALUE CLAUSE AND IF ONE WAS PRESENT, CHECKS
THE CHARACTERISTICS OF THE VALUE TO MAKE SURE IT IS OK.
CALL:
PUSHJ PP, D54J.D
ENTRY CONDITIONS:
(TA) = ADDRESS OF THE CURRENT ITEM
(TB) = USAGE OF THE CURRENT ITEM.
EXIT CONDITIONS:
(TA) = ADDRESS OF THE CURRENT ITEM
(TB) = USAGE OF THE CURRENT ITEM.
NOTES:
1. THIS ROUTINE ONLY CHECKS THINGS IT DOESN'T WRITE THE
VALUE OUT.
\
D54J.D: LDB TC, DA.VAL## ;GET THE VALUE LINK.
JUMPE TC, CPOPJ ;IF THERE WAS NO VALUE CLAUSE, RETURN.
LDB TD, DA.DFS## ;IF WE'RE IN THE FILE SECTION,
PJUMPN TD, D54E.I ; IT'S AN ERROR.
LDB TD, DA.VHL## ;IT THERE IS A VALUE AT A HIGHER
PJUMPN TD, D54E.K ; LEVEL, IT'S AN ERROR.
LDB TD, DA.SUB## ;IF THERE IS AN OCCURS AT THIS
PJUMPN TD, D54E.L ; OR AT A HIGHER LEVEL, IT'S AN ERROR.
IFN MCS,<
SKIPE COMSEC ; ALLOW USER TO SET VALUE IF DEFINING
JRST D54JD0 ; OWN CD AREA
;NOTE: THIS WILL CAUSE TROUBLE UNLESS WE MAKE SURE THAT THERE ARE ONLY
; VALUE CLAUSES FOR ONE OF THE IMPLICITLY REDEFINED 01'S.
; THIS IS CURRENTLY NOT CHECKED FOR, SO USERS ARE ON THEIR OWN.
>
LDB TD, DA.RDF## ;IF THERE IS A REDEFINITION
PJUMPN TD, D54E.M ; AT THIS LEVEL
LDB TD, DA.RDH## ; OR AT A HIGHER LEVEL,
PJUMPN TD, D54E.M ; IT'S AN ERROR.
D54JD0: HRLM TC, CURLIT## ;MAKE THIS THE CURRENT LITERAL.
HRRZI TA, (TC)
PUSHJ PP, LNKSET
HRRM TA, CURLIT##
LDB TC, LI.PUR## ;GET THE NON-SIXBIT CHAR FLAG.
JUMPE TC, D54J.H ;IF EVERYTHING IS SIXBIT, ALL
; IS WELL.
CAIE TB, %US.D7 ;IF THE CURRENT ITEM IS
CAIN TB, %US.EB ; DISPLAY-7 OR DISPLAY-9
JRST D54J.H ; ALL IS WELL.
PJRST D54E.N ;OTHERWISE, GIVE AN ERROR.
D54J.H: LDB TC, LI.NLT## ;IF THE LITERAL IS NOT NUMERIC
JUMPE TC, D54J.L ; ALL IS WELL.
TSWT ELITEM; ;OTHERWISE, IF THE ITEM IS A
PJRST D54E.O ; GROUP ITEM, IT'S AN ERROR.
D54J.L: LDB TD, LI.FGC## ;IF THE LITERAL IS NOT A
JUMPE TD, D54J.T ; FIGURATIVE CONSTANT GO
; CHECK IT OUT.
;THE LITERAL IS A FIGURATIVE CONSTANT.
LDB TC, LI.FCC## ;SEE WHICH ONE IT IS.
HRRZ TA, CURDAT## ;POINT AT THE CURRENT ITEM.
LDB TD, DA.CLA## ;GET ITS CLASS.
CAIN TD, %CL.NU ;IS THE ITEM NUMERIC?
JRST D54J.P ;YES, GO CHECK IT.
CAIE TC, QUOTE. ;IS IT QUOTE
CAIN TC, SPACE. ; OR SPACE?
POPJ PP, ;YES, ALL IS WELL.
D54J.P: CAIE TC, HIVAL. ;IS IT HIGH VALUES
CAIN TC, LOVAL. ; OR LOW VALUES?
POPJ PP, ;YES, ALL IS WELL.
CAIN TC, ZERO. ;IS IT ZERO?
POPJ PP, ;YES, ALL IS WELL.
PJRST D54E.P ;ALL IS NOT WELL, COMPLAIN.
;HERE WE CHECK REGULAR LITERALS.
D54J.T: HRRZ TA, CURDAT## ;POINT AT THE CURRENT ITEM.
LDB TD, DA.CLA## ;GET ITS CLASS
LDB TE,DA.BWZ ;GET "BLANK WHEN ZERO" FLAG
SKIPN TE ;IF ON THEN ITS EDITED BY DEFINITION
LDB TE, DA.EDT## ;OTHERWISE GET ITS EDIT FLAG.
CAIN TD, %%CL ;DO WE KNOW ITS CLASS.
POPJ PP, ;NO, THEN DON'T CHECK ANY MORE.
JUMPE TC, D54J.X ;IF THE LITERAL IS NOT NUMERIC,
; GO MAKE SURE THAT THE ITEM
; ISN'T EITHER.
;THE LITERAL IS NUMERIC.
CAIN TD, %CL.NU ;IF THE ITEM IS NUMERIC
JUMPE TE,D54J.Y ; AND IS NOT EDITED, ALL IS WELL.
; OTHERWISE, IT IS AN ERROR.
D54E.Q: HRRZI DW, E.241 ;CLASS OF ITEM CONFLICTS WITH
PJRST D54E.J ; LITERAL IN VALUE CLAUSE.
;THE LITERAL IS NOT NUMERIC.
D54J.X: CAIN TD, %CL.NU ;IF THE ITEM IS NUMERIC AND
JUMPE TE, D54E.Q ; IS NOT EDITED, IT'S AN ERROR.
D54J.Y: SKIPL AS7482## ;IF COBOL-74
CAIE TD,%CL.NU ;OR NOT NUMERIC
POPJ PP, ;WE'RE DONE
HRRZ TA,CURLIT ;OTHERWISE
LDB TE,LI.ALL ;CHECK FOR "ALL"
HRRZ TA,CURDAT ;FIRST RESTORE CURRENT ITEM
JUMPE TE,CPOPJ ;NO, OK
MOVEI DW,E.826 ;CANNOT HAVE "ALL" WITH NUMERIC ITEM
JRST D54E.J
COMMENT \
SUBROUTINES TO SET THE NUMBER OF BYTES IN AN ITEM AND THE NUMBER OF
BITS PER BYTE.
CALLS:
JSP TE, D54K.D/D54K.H/D54K.L/D54K.P
ENTRY CONDITIONS:
(TA) = ITEM'S DATAB ADDRESS
(TB) = ITEM'S USAGE
(TC) = ?
(TD) = ITEM'S EXTERNAL SIZE
EXIT CONDITIONS:
(TA) = ITEM'S DATAB ADDRESS
(TB) = ITEM'S USAGE.
(TC) = NUMBER OF BITS PER BYTE
(TD) = NUMBER OF BYTES IN THE ITEM
NOTES:
1. THE NUMBER OF BYTES IN THE ITEM AND THE SIZE OF THESE
BYTES ARE ONLY USED TO CALCULATE THE AMOUNT OF STORAGE
REQUIRED TO HOLD THE ITEM. THEY ARE NOT THE ITEM'S
EXTERNAL OR INTERNAL SIZES (IE. A COMP ITEM WITH A
PICTURE OF 99 HAS AN EXTERNAL AND INTERNAL SIZE OF 2
BUT ITS SIZE IN BYTES IS 1 AND THE SIZE OF THAT
BYTE IS 36 BITS.
\
;COME HERE ON COMP ITEMS.
D54K.D: CAIG TD, ^D10 ;ONE OR TWO WORDS?
JRST D54K.L ;ONE, SAME AS INDEX AND COMP-1.
MOVEI TB, %US.2C ;TWO, MAKE IT TWO WORD COMP.
DPB TB, DA.USG##
;COME HERE ON 2 WORD COMP ITEMS.
D54K.H: MOVEI TD, 2 ;TWO BYTES
MOVEI TC, 44 ; OF 36 BITS EACH.
JRST (TE) ;RETURN.
;COME HERE ON 1 WORD COMP, COMP-1 AND INDEX ITEMS.
D54K.L: MOVEI TD, 1 ;ONE BYTE
MOVEI TC, 44 ; OF 36 BITS.
JRST (TE) ;RETURN.
;COME HERE ON COMP-3 ITEMS.
D54K.P: ADDI TD, 2 ;ADD 1 BYTE FOR THE SIGN AND
; ONE TO FORCE ROUNDING UP.
LSH TD, -1 ;NUMBER OF 9 BIT BYTES REQUIRED.
MOVEI TC, ^D9 ;9 BITS PER BYTE.
JRST (TE) ;RETURN.
COMMENT \
SUBROUTINE TO ALLOCATE STORAGE.
CALL:
PUSHJ PP, D54L.D
ENTRY CONDITIONS:
(TA) = ADDRESS OF THE CURRENT ITEM'S DATAB ENTRY
(TB) = NUMBER OF BYTES TO ALLOCATE
(TC) = ?
(TD) = ?
(TE) = NUMBER OF BYTES WE CAN FIT IN THE CURRENT WORD.
((PP)-1) = NUMBER OF BYTES PER WORD.
((PP)-2) = NUMBER OF BITS PER BYTE.
EXIT CONDITIONS:
(TA) = ADDRESS OF THE CURRENT ITEM'S DATAB ENTRY
(TB) = USAGE OF THE CURRENT ITEM
(TC), (TD), (TE) = ?
THE ARGUMENTS ON THE STACK HAVE BEEN REMOVED
EAS1PC HAS BEEN UPDATED
\
D54L.D: CAIL TE, (TB) ;IF WE CAN FIT THE WHOLE THING
JRST D54L.L ; IN THE CURRENT WORD, GO ON.
JUMPE TE, D54L.H ;IF WE CAN'T FIT ANYTHING IN THE
; CURRENT WORD, GO ON.
SUBI TB, (TE) ;ALLOCATE AS MUCH AS WE CAN IN
; THE CURRENT WORD.
AOS TD, EAS1PC ;BUMP UP TO THE NEXT WORD.
HRRZM TD, EAS1PC
D54L.H: MOVEI TC, (TB)
IDIV TC, -1(PP) ;(TC) = NUMBER OF WORDS TO ALLOCATE.
;(TB) = NUMBER OF BYTES TO GO
; INTO THE LAST WORD.
ADDB TC, EAS1PC ;ALLOCATE THE WORDS.
;11-MAY-79 /DAW: WE WILL CHECK THE LOW SEG SIZE EACH TIME WE GET
; HERE (ALLOCATION OF A MAJOR ITEM) TO MAKE SURE IT DOESN'T JUMP
; OVER THE MAXIMUM ALLOWED LOW SEG SIZE. IT WILL ALSO BE CHECKED
; IN PHASE G, BUT WRAPAROUND COULD OCCUR AND IN SOME RARE CASES THE
; ERROR MIGHT THEN GO UNDETECTED. LOCATION "FTOOBG" IS SET TO -1
; IF WE CAN CATCH THE ERROR HERE, SO PHASE G GETS A LITTLE HELP
; CATCHING THIS PROBLEM IF IT OCCURS.
HRRZ TC,TC ;GET PC
CAIL TC,MLOWSZ ;.GE. MAX LOWSEG SIZE?
SETOM FTOOBG## ;YES, MAKE SURE WE KNOW BY PHASE G.
D54L.L: IMUL TB, -2(PP) ;(TB) = NUMBER OF BITS TO ALLOCATE
; IN THE LAST WORD.
HLRZ TC, EAS1PC ;(TC) = NUMBER OF BITS ALREADY USED.
ADDI TC, (TB) ;TOTAL BITS USED IN THE LAST WORD.
HRLM TC, EAS1PC
CAIGE TC, 44 ;DID WE USE IT ALL UP?
JRST D54L.P ;NO, GO ON.
AOS TC, EAS1PC ;YES, BUMP UP TO THE NEXT WORD.
HRRZM TC, EAS1PC
D54L.P: POP PP, TC ;RETURN ADDRESS.
POP PP, TB ;RESTORE THE STACK.
POP PP, TB
LDB TB, DA.USG ;GET THE ITEM'S USAGE.
JRST (TC) ;RETURN.
D54ZZ.: BLOCK 0
;MAKE SURE THAT THE TABLES BELOW DON'T GET MESSED UP.
N==<%%US>!<%US.D6-1>!<%US.D7-2>!<%US.EB-3>!<%US.1C-4>
N==N!<%US.2C-5>!<%US.C1-6>!<%US.IN-7>!<%US.C3-10>!<%US.C2-11>
IFN N,<
PRINTX %D54ZZ. - TABLES ARE MESSED UP.
PASS2
END
>
;TABLE OF BYTES PER WORD.
BYTWRD: EXP 6 ;UNKNOWN
EXP 6 ;DISPLAY-6
EXP 5 ;DISPLAY-7
EXP 4 ;DISPLAY-9
EXP 1 ;ONE WORD COMP
EXP 1 ;TWO WORD COMP
EXP 1 ;COMP-1
EXP 1 ;INDEX
EXP 4 ;COMP-3
EXP 1 ;COMP-2
;TABLE OF BITS PER BYTE.
BITBYT: EXP 6 ;UNKNOWN
EXP 6 ;DISPLAY-6
EXP 7 ;DISPLAY-7
EXP 9 ;DISPLAY-9
EXP 44 ;ONE WORD COMP
EXP 44 ;TWO WORD COMP
EXP 44 ;COMP-1
EXP 44 ;INDEX
EXP 9 ;COMP-3
EXP 44 ;COMP-2
;TABLE OF ROUTINES TO GET THE NUMBER OF BITS PER BYTE AND IF NECESSARY
; CHANGE THE SIZE OF THE ITEM.
BIBYSZ: JRST [OUTSTR [ASCIZ /
?Compiler error - D54.NL - usage wasn't assigned/]
JRST KILL##]
HRRZI TC, 6 ;DISPLAY-6 ==> 6
HRRZI TC, 7 ;DISPLAY-7 ==> 7
HRRZI TC, ^D9 ;DISPLAY-9 ==> 9
JSP TE, D54K.D ;COMP (MAY BE 1 OR 2 WORDS.)
JSP TE, D54K.H ;2 WORD COMP.
JSP TE, D54K.L ;COMP-1.
JSP TE, D54K.L ;INDEX
JSP TE, D54K.P ;COMP-3.
JSP TE, D54K.H ;COMP-2
PUTVLU: JUMPE TA,CPOPJ
HRLZM TA,CURLIT
PUSHJ PP,LNKSET
HRRM TA,CURLIT
PUSHJ PP,ADJUST##
SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.ERR
JUMPN TB,CPOPJ ;DD ERROR --- IGNORE VALUE
LDB TB,DA.USG
JRST PVDPTB(TB) ;DISPATCH TO THE APPROPRIATE ROUTINE.
PUTC2: SKIPN SIGNED## ;IS IT IN BINARY OR IN THE FUNNY FORMAT.
JRST PUT1WC ;BINARY, GO PRETEND IT'S COMP.
SKIPN SVDADR
JRST PUTC21
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1##
SETZM SVDADR
PUTC21: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000
PUSHJ PP,PUTAS1 ;RELOC TO ITEM
MOVE CH,[XWD 600000+ASCF2,4] ;FLOATING POINT NUMBER HEADER
PUSHJ PP,PUT2W2 ;OUTPUT THE COMMON PART
MOVE CH,VALUE2+1
PUSHJ PP,PUTAS1
MOVE CH,VALUE2+2
JRST PUTAS1
PUTC1: SKIPN SIGNED## ;IS IT IN BINARY OR IN THE FUNNY FORMAT.
JRST PUT1WC ;BINARY, GO PRETEND IT'S COMP.
SKIPN SVDADR
JRST PUTC11
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1##
SETZM SVDADR
PUTC11: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000
PUSHJ PP,PUTAS1 ;RELOC TO ITEM
MOVE CH,[XWD 600000+ASCFLT,2] ;FLOATING POINT NUMBER HEADER
JRST PUT2W2
PUT2WC: SKIPN SVDADR
JRST PUT2W1 ;NOTHING SAVED
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1
SETZM SVDADR
PUT2W1: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000 ;RELOC TO ITEM
PUSHJ PP,PUTAS1
MOVE CH,[XWD 600000+ASCD2,2] ;2-WORD COMP HEADER
PUT2W2: PUSHJ PP,PUTAS1 ;PUT OUT HEADER
MOVE CH,VALUE1##
PUSHJ PP,PUTAS1
MOVE CH,VALUE2##
JRST PUTAS1
PUT1WC: SKIPN SVDADR
JRST PUT1W1 ;NOTHING SAVED
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1
SETZM SVDADR
PUT1W1: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000 ;RELOC TO ITEM
PUSHJ PP,PUTAS1
MOVE CH,[XWD 600000+ASCD1,1]
PUSHJ PP,PUTAS1 ;1-WORD COMP HEADER
MOVE CH,VALUE2
JRST PUTAS1
PUTDSP: SKIPN TA,SVDADR ;IF THERE ISN'T ANYTHING LEFT OVER
JRST P6 ; FROM THE LAST LITERAL, GO ON.
HRRZ TB,ITMLOC
CAIE TB,(TA)
JRST P5 ;DIFFERENT LOCATION
MOVE CH,SVDWRD
MOVE TE, CONVR2## ;GET THE CONVERSION INDEX.
MOVE TE, PVPTRS(TE) ;PICK UP THE APPROPRIATE POINTER.
HRRZ TB,ITMRES
CAILE TB,44
HRRZI TB,44
DPB TB,[POINT 6,TE,5] ;RESIDUE
HRRZI TC,44 ;NEXT WORD, IF ANY, WILL START
HRRZM TC,ITMRES ;IN BIT 0
P1: SOSGE NCHITM## ;IF THERE IS NO MORE ROOM IN THE
JRST P4 ; ITEM, GO ON.
PUSHJ PP,GETCHR## ;OTHERWISE, GET A CHAR AND
IDPB TC,TE ;PUT IT IN THE WORD.
LDB TB,[POINT 6,TE,5] ;RESIDUE
LDB TC,[POINT 6,TE,11] ;BYTE SIZE
CAIL TB,(TC)
JRST P1 ;IF THERE IS ROOM FOR MORE IN THIS WORD, LOOP.
;FIRST WORD IS FULL, WRITE IT OUT.
PUSHJ PP,PUTAS1
SETZ CH,
AOS SVDADR
;COME HERE TO START A NEW WORD FOR A NEW ITEM.
P1.5: SKIPG NCHITM ;IF THERE IS MORE ROOM IN THE ITEM GO ON.
JRST P7 ;OTHERWISE, NOTE THAT WE DON'T HAVE TO
; WRITE OUT MORE LATER ON AND RETURN.
HRRZI TC,44
SUB TC,ITMRES ;(TC) = # OF BITS USED IN THIS WORD.
CAIGE TC,0
SETZ TC,
MOVE TB,NCHWRD## ;GET BYTES PER WORD
IDIV TC,PVBPB-4(TB) ;DIVIDE BY BITS PER BYTE
ADD TC,NCHITM ;(TC) = # OF BYTES TO END OF ITEM FROM
; BEGINNING OF THIS WORD.
IDIV TC,NCHWRD ;(TC) = # OF WORDS NEEDED.
JUMPE TB,.+2
HRRZI TC,1(TC) ;THERE WILL BE SOMETHING LEFT OVER
; SO MAKE IT ONE WORD LONGER.
MOVE CH,CONVR2## ;GET THE CONVERSION INDEX.
HRLZ CH,PVASCD(CH) ;GET THE ASSEMBLY CODE.
HRRI CH,(TC)
PUSHJ PP,PUTAS1
MOVE TE, CONVR2## ;GET THE CONVERSION INDEX.
MOVE CH, PVBLKS(TE) ;GET SOME FORM OF BLANKS.
MOVE TE, PVPTRS(TE) ;GET THE APPROPRIATE POINTER.
HRRZ TB,ITMRES
DPB TB,[POINT 6,TE,5]
JRST P3
P2: AOS SVDADR
PUSHJ PP,PUTAS1
MOVE TE, CONVR2## ;GET THE CONVERSION INDEX.
MOVE CH, PVBLKS(TE) ;GET SOME FORM OF BLANKS.
MOVE TE, PVPTRS(TE) ;GET THE APPROPRIATE POINTER.
P3: SOSGE NCHITM
JRST P4
PUSHJ PP,GETCHR
IDPB TC,TE
LDB TB,[POINT 6,TE,5] ;RESIDUE
LDB TC,[POINT 6,TE,11] ;BYTE SIZE
CAIL TB,(TC)
JRST P3 ;ROOM FOR MORE IN THIS WORD
JRST P2 ;WORD IS FULL
P4: LDB TB,[POINT 6,TE,5]
CAIN TB,44
JRST P7
MOVEM CH,SVDWRD
HRLM TB,SVDADR
POPJ PP,
P5: MOVE CH,SVDWRD
PUSHJ PP,PUTAS1
P6: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000
PUSHJ PP,PUTAS1
HRRZ TB,ITMLOC##
HRRZM TB,SVDADR
HRRZ TB,ITMRES##
HRLM TB,SVDADR##
JRST P1.5
P7: SETZM SVDADR ;NOTE THAT WE DON'T HAVE TO
POPJ PP, ; WRITE OUT MORE LATER ON AND RETURN.
;MAKE SURE THAT THE TABLE BELOW DOESN'T GET MESSED UP.
N==<%%US>!<%US.D6-1>!<%US.D7-2>!<%US.EB-3>!<%US.1C-4>
N==N!<%US.2C-5>!<%US.C1-6>!<%US.IN-7>!<%US.C3-10>!<%US.C2-11>
IFN N,<
PRINTX %PVDPTB - TABLE IS MESSED UP.
PASS2
END
>
;DISPATCH TABLE - INDEX BY USAGE.
PVDPTB: POPJ PP, ;NOT DEFINED.
JRST PUTDSP ;DISPLAY-6.
JRST PUTDSP ;DISPLAY-7.
JRST PUTDSP ;DISPLAY-9.
JRST PUT1WC ;1-WORD COMP.
JRST PUT2WC ;2-WORD COMP.
JRST PUTC1 ;COMP-1.
JRST PUT1WC ;INDEX.
JRST PUTDSP ;COMP-3 (PRETEND IT'S DISPLAY-9)
JRST PUTC2 ;COMP-2.
;TABLES USED BY PUTDSP - INDEX BY CONVR2.
;BLANKS.
PVBLKS: BYTE (9)100,100,100,100 ;COMP-3.
Z ;SIXBIT.
ASCII / / ;ASCII.
BYTE (9)100,100,100,100 ;EBCDIC.
Z ;SIXBIT.
ASCII / / ;ASCII.
BYTE (9)100,100,100,100 ;EBCDIC.
;POINTERS.
PVPTRS: POINT 9,CH ;COMP-3.
POINT 6,CH ;SIXBIT.
POINT 7,CH ;ASCII.
POINT 9,CH ;EBCDIC.
POINT 6,CH ;SIXBIT.
POINT 7,CH ;ASCII.
POINT 9,CH ;EBCDIC.
;ASSEMBLY CODES.
PVASCD: EXP AS.EBC## ;COMP-3.
EXP AS.SIX## ;SIXBIT.
EXP AS.ASC## ;ASCII.
EXP AS.EBC## ;EBCDIC.
EXP AS.SIX## ;SIXBIT.
EXP AS.ASC## ;ASCII.
EXP AS.EBC## ;EBCDIC.
;NUMBER OF BITS PER BYTE - INDEX BY CHAR'S PER WORD - 4.
PVBPB: EXP 9 ;EBCDIC AND COMP-3.
EXP 7 ;ASCII.
EXP 6 ;SIXBIT.
SUBTTL REPORT WRITER SYNTAX
; CHECK REPORT ITEM FOR CORRECT PARAMETERS [315]
RPWITC: SKIPGE RPWERR ; [335] ANY FATAL REPORT GENERATOR
POPJ PP, ; [335]
LDB TB,DA.RPW ; [315] GET DATAB LINK TO REPORT ITEM
JUMPE TB,RPWITX ; [315] NOT A REPORT ITEM EXIT
HRLZM TB,CURRPW ; [315] KEEP IT
MOVE TA,RPWLOC ; [315] CONVERT RPWTAB RELATIVE
ADDI TA,(TB) ; [315] TO REAL ONE
HRRM TA,CURRPW ; [315] KEEP IT
PUSHJ PP,RPWLCH ; [315] CHECK LINE NUMBER IF ANY
PUSHJ PP,RWCLC ;[V10] GO CHECK LINE AND COLUMN CLAUSES.
LDB TB,RW.NLC ; [315] NEXT GROUP ILLEGAL
JUMPE TB,RPWITA ; [315] AT ITEM LEVEL
HRRZ TA,CURDAT ; [315] UNLESS ITEM IS
LDB TB,DA.LVL ; [315] AT 01 LEVEL
SOJN TB,RPWIT4 ; [315] ERROR
HRRZ TA,CURRPW ; [315] GET BACK REPORT ITEM
RPWITA: LDB TB,RW.SCD ; [315] GET "SOURCE" CODE
JUMPE TB,RPWIT2 ; [315] NONE- ERROR
CAIE TB,%RG.VL ; [315] VALUE ?
JRST RPWIT1 ; [315] NO- GO ON
LDB TB,RW.GPI ; [315] DO WE HAVE GROUP INDICATE?
JUMPE TB,RPWIT1 ; [315] IF ZERO- NO
; HERE IF GROUP INDICATE WITH A VALUE CLAUSE MAKE ENTRY INTO
; HLDTAB- IN CLEANC WE WILL CONVERT TO SOURCE ITEM FROM VALUE
MOVE TA,[CD.HLD,,SZ.HLD] ; [315] MAKE A HLDTAB ENTRY
PUSHJ PP,GETENT ; [315] GET THE SPACE
MOVEM TA,CURHLD ; [315] SAVE HLDTAB ADDRESS
HRRZI TD,%HL.GI ; [315] SET G.I. HLDTAB CODE
DPB TD,HL.COD ; [315] STORE IN HLDTAB
HLRZ TB,CURDAT ; [315] GET DATAB RELATIVE ADDRESS
DPB TB,HL.LNK ; [315] STORE INTO HLDTAB
HRRZ TA,CURDAT ; [315] GET REAL DATAB ADDRESS
LDB TB,DA.VAL ; [315] GET DATAB VALUE LINK
LDB TD,DA.LNC ; [315] GET LINE AND CHAR POS
SETZ TC, ; [315] CLEAR
DPB TC,DA.VAL ; [315] THE VALUE LINK IN DATAB
HRRZ TA,CURHLD ; [315] GET BACK HLDTAB ADDRESS
DPB TB,HL.NAM ; [315] STORE VALUE LINK HERE
DPB TD,HL.LNC ; [315] STORE LINE AND CHAR POS
HRRZ TA,CURRPW ; [315] GET REPORT TAB ITEM ADDR
MOVEI TB,%RG.SR ; [315] CHANGE SOURCE CODE FROM
DPB TB,RW.SCD ; [315] VALUE TO SOURCE
; THE NEW SOURCE ITEM TO MADE IN CLEANC
RPWIT1: LDB TB,RW.COL ; [315] GET COLUMN NUMBER
JUMPE TB,RPWITX ; [315] NONE-NO CHECK
SKIPE RWLCS.## ;IF HE HAS GIVEN A LINE CLAUSE
JRST RPWT1D ; ALL IS WELL.
SETOM RWLCS.## ;ONLY COMPLAIN ONCE.
HRRZI DW,E.497
JRST RPWITE
RPWT1D: LDB TC,RW.LCD ; [315] IF IT IS A NEW LINE
SKIPE TC ; [315] THEN START COLUMN NUMBER FROM ZERR
SETZM LASCOL ; [315]
CAMG TB,LASCOL ; [315] MUST BE GREATER THAN LAST COL IN GROUP
JRST RPWIT3 ; [315] IT ISNT-ERROR
MOVEM TB,LASCOL ; [315] OKAY- UPDATE LAST COL
RPWITX: MOVE TA,CURDAT ; [315] RESTORE DATAB ADDRESS
POPJ PP, ; [315] RPWITC EXIT POINT
RPWIT2: HRRZI DW,E.475 ; [315] NO SOURCE/VALUE/SUM ERROR
JRST RPWITE ; [315]
RPWIT3: HRRZI DW,E.474 ; [315] COLUMN NUMBER TOO LOW
JRST RPWITE ; [315]
RPWIT4: HRRZ TA,CURRPW ;[527] GET CORRECT TABLE
SETZ TB, ; [315] CLEAR NEXT GROUP
DPB TB,RW.NLC ; [315]
HRRZI DW,E.480 ; [315] NEXT GROUP ILLEGAL
; JRST RPWITE ; [315] GIVE ERROR MESSAGE AND EXIT
RPWITE: MOVE TA,CURDAT ; [315] GET DATAB ADDRESS
LDB LN,DA.LN ; [315] GET LINE NUMBER
LDB CP,DA.CP ; [315] GET CHARACTER POSITION
JRST FATAL ; [315] FATAL ERROR AND RETURN
; CHECK REPORT GROUP FOR CORRECT PARAMETERS [315]
RPWGPC: SETZM LASCOL ; [315] CLEAR LAST COLUMN AT GROUP LEVEL
SKIPGE RPWERR ; [335] ANY FATAL REPORT GENERATOR
POPJ PP, ; [335]
LDB TB,DA.RPW ; [315] GET DATAB LINK TO REPORT ITEM
JUMPE TB,RPWITX ; [315] NOT A REPORT GROUP EXIT
HRLZM TB,CURRPW ; [315] KEEP IT
MOVE TA,RPWLOC ; [315] CONVERT RPWTAB RELATIVE
ADDI TA,(TB) ; [315] TO REAL ONE
HRRM TA,CURRPW ; [315] KEEP IT
PUSHJ PP,RPWLCH ; [315] CHECK LINE NUMBER IF ANY
LDB TB,RW.SCD ; [315] GET SOURCE CODE
JUMPN TB,RPWGE1 ; [315] ERROR IF AT GROUP LEVEL
RPWGP1: LDB TB,RW.COL ; [315] COLUMN NUMBER
JUMPN TB,RPWGE2 ; [315] IS ILLEGAL
PUSHJ PP,RWCLC ;[V10] GO CHECK LINE AND COLUMN CLAUSES.
RPWGP2: LDB TB,RW.GPI ; [315] GROUP INDICATE
JUMPN TB,RPWGE3 ; [315] IS ILLEGAL
RPWGP3: LDB TB,RW.RSF ; [315] RESET ON FINAL
LDB TC,RW.RSI ; [315] OR RESET ON IDENTIFIER
JUMPN TB,RPWGE4 ; [315] ARE BOTH
JUMPN TC,RPWGE4 ; [315] ILLEGAL
RPWGP4: LDB TB,RW.NLC ; [315] NEXT GROUP ILLEGAL
JUMPE TB,RPWITX ; [315] NONE OKAY
HRRZ TA,CURDAT ; [315] NEXT GROUP OKAY
LDB TB,DA.LVL ; [315] ONLY AT 01 LEVEL
CAIN TB,LVL.01 ; [315]
JRST RPWITX ; [315] 01 OKAY EXIT
HRRZ TA,CURRPW ;[527] GET CORRECT TABLE
SETZ TB, ; [315] CLEAR
DPB TB,RW.NLC ; [315] NEXT GROUP CODE
MOVEI DW,E.480 ; [315] NEXT GROUP ERROR
RPWGEE: MOVE TA,CURDAT ; [315] GET DATAB ADDRESS
LDB LN,DA.LN ; [315] GET LINE NUMBER
LDB CP,DA.CP ; [315] GET CHARACTER POSITION
HRRZ TA,CURRPW ; [315] RESTORE REPORT ITEM FOR MORE CHECKS
JRST FATAL ; [315] FATAL ERROR AND RETURN
RPWGE1: SETZ TB, ; [315] CLEAR
DPB TB,RW.SCD ; [315] SOURCE TYPE
MOVEI DW,E.479 ; [315] SOURCE / SUM / VALUE ERROR
PUSHJ PP,RPWGEE ; [315] GIVE ERROR MESSAGE
JRST RPWGP1 ; [315] DO MORE ERROR CHECKING
RPWGE2: SETZ TB, ; [315] CLEAR
DPB TB,RW.COL ; [315] COLUMN NUMBER
MOVEI DW,E.478 ; [315] COLUMN ERROR NUMBER
PUSHJ PP,RPWGEE ; [315] GIVE ERROR MESSAGE
JRST RPWGP2 ; [315] DO MORE ERROR CHECKING
RPWGE3: SETZ TB, ; [315] CLEAR
DPB TB,RW.GPI ; [315] GROUP INDICATE
MOVEI DW,E.477 ; [315] ERROR NUMBER
PUSHJ PP,RPWGEE ; [315] ERROR MESSGE
JRST RPWGP3 ; [315] MORE ERROR CHECKING
RPWGE4: SETZ TB, ; [315] CLEAR
DPB TB,RW.RSF ; [315] RESET CODES
DPB TB,RW.RSI ; [315]
MOVEI DW,E.476 ; [315] ERROR MESSAGE
PUSHJ PP,RPWGEE ; [315]
JRST RPWGP4 ; [315] MORE ERROR CHECKING
; CHECK LINE PARAMETER TO SEE IF WITHIN BOUNDS
RPWLCH: LDB TD,RW.TYP ; [315] LINE TYPE
JUMPE TD,CPOPJ ; [315] NONE-EXIT
LDB TC,RW.LCD ; [315] GET LINE CODE
CAIE TC,%RG.LN ; [315] DO WE HAVE LINE INTEGER?
POPJ PP, ; [315] NOT LINE INTEGER
LDB TC,RW.LIN ; [315] GET LINE NUMBER
PUSHJ PP,GETRDL ; [315] MAKE PTR TO RD ENTRY
LDB TB,RW.PAG## ; [315] GET PAGE-LIMIT
JUMPE TB,RPWLHX ; [315] NONE-SPECIFIED NO CHECKS THEN
CAIE TD,%RG.RH ; [315] REPORT HEADING
CAIN TD,%RG.RF ; [315] OR REPORT FOOTING?
JRST RPWLH3 ; [315] YES CHECK IT
CAIN TD,%RG.PH ; [315] PAGE-HEADING ?
JRST RPWLH4 ; [315] YES CHECK IT
CAIG TD,%RG.DE ; [315] CONTROL HEADING OR DETAIL LINE?
JRST RPWLH5 ; [315] YES CHECK IT
CAIN TD,%RG.CF ; [315] CONTROL FOOTING?
JRST RPWLH6 ; [315] YES CHECK IT
; [315] THEN IT IS PAGE FOOTING
LDB TB,RW.CFL ; [315] PAGE FOOTING MUST BE
LDB TD,RW.PAG ; [315] FROM FOOTING TO PAGE-LIMIT
MOVEI DW,E.487 ; [315] SET UP ERROR NUMBER
JRST RPWLH7 ; [315] GO CHECK
RPWLH3: LDB TB,RW.PHL ; [315] RH OR RF- MUST BE FROM HEADING
LDB TD,RW.PAG ; [315] TO PAGE-LIMIT
MOVEI DW,E.486 ; [315] SET UP ERROR NUMBER
JRST RPWLH7 ; [315] GO CHECK IT
RPWLH4: LDB TB,RW.PHL ; [315] PH MUST BE FROM HEADING
LDB TD,RW.FDE ; [315] TO FIRST DETAIL
MOVEI DW,E.485 ; [315] GET ERROR NUMBER
JRST RPWLH7 ; [315] GO CHECK IT
RPWLH5: LDB TB,RW.FDE ; [315] CH OR DE MUST BE FROM FIRST DETAIL
LDB TD,RW.LDE ; [315] TO LAST DETAIL
MOVEI DW,E.484 ; [315] GET ERROR NUMBER
JRST RPWLH7 ; [315] CHECK IT
RPWLH6: LDB TB,RW.FDE ; [315] CF MUST BE FROM FIRST DETAIL
LDB TD,RW.CFL ; [315] TO FOOTING
MOVEI DW,E.483 ; [315] GET ERROR NUMBER
RPWLH7: CAML TC,TB ; [315] LINE NUMBER WITHIN RANGE SET UP
CAMLE TC,TD ; [315] UPPER LIMIT
; [315] OKAY- STORE LINE NUMBER
JRST RPWGEE ; [315] NO- GIVE ERROR AND RETURN
RPWLHX: HRRZ TA,CURRPW ;RESTORE PTR TO GROUP ITEM
DPB TC,RW.LIN ;OK, STORE IT
POPJ PP, ; [315] RETURN
RWCLC: HRRZ TA, CURDAT ;[V10] POINT AT DATAB.
LDB TB, DA.LVL## ;[V10] GET THE LEVEL.
SOJN TB, RWCLCH ;[V10] IF IT'S NOT 01, GO ON.
SKIPE RWLCS.## ;[V10] IF WE HAVE SEEN A
SKIPE RWCCS.## ;[V10] LINE CLAUSE BUT NOT A
JRST RWCLCH ;[V10] COLUMN CLAUSE, WARN THE
HRRZI DW, E.586 ;[V10] USER THAT WE'RE GOING
LDB LN, DA.LN## ;[V10] TO SKIP LINES WITHOUT
LDB CP, DA.CP## ;[V10] PRINTING ANYTHING.
PUSHJ PP, WARN##
RWCLCH: HRRZ TA, CURRPW ;[V10] POINT AT THE RPWTAB ENTRY.
POPJ PP, ;[V10] RETURN.
INTER. DA55.
DA55.: PUSHJ PP,DA47.A ;[674]
DA55.A: SKIPN TA,CURDAT
JRST DA55.X
LDB TB,DA.VAL
JUMPN TB,JCE16.
HLRZ TB,CURLIT
DPB TB,DA.VAL
SKIPN REPSEC ;DOING A REPORT ITEM?
JRST DA55.X ;NO
HRRZ TA,CURRPW ;GET RPWTAB PTR
HRRZI TB,%RG.VL ;GET VALUE CODE
DPB TB,RW.SCD ;PUT IN SOURCE CODE FIELD
DA55.X: SKIPE LNKSEC ;LINKAGE SECTION?
EWARNJ E.89 ;?VALUES ILLEGAL IN LINKAGE SECTION
POPJ PP,
INTER. DA55.Y
DA55.Y: SKIPN REPSEC ;DOING A REPORT ITEM ?
POPJ PP, ;NO
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.COL ;SEE IF COLUMN NUMBER SPECIFIED
JUMPN TB,CPOPJ ;YES, EXIT
LDB TA,RW.DAT ;GET DATAB PNTR
JUMPE TA,CPOPJ ; SHOULD NOT HAPPEN, BUT EXIT IF IT DOES
PUSHJ PP,LNKSET ;GET REAL ADDRESS
LDB TB,DA.VAL
JUMPE TB,CPOPJ ;IF NO VALUE CLAUSE SPECIFIED EXIT
EWARNJ E.750 ; ELSE, WARN USER
INTER. DA55.S
DA55.S: FLAGAT 8
;COPY CODE AT DA47.A AS IF A 1 WORD LITERAL
SETZM FLG88 ;CLEAR 88 LEVEL LITERAL FLAG
HRRZ TA,W1 ;GET TABLE LINK
PUSHJ PP,LNKSET ;GET ADDRESS
LDB TB,MN.SYC## ;SYMBOLIC CHARACTER?
SKIPN TB ;YES
EWARNJ E.809 ;NO, WARN USER
PUSHJ PP,DA47.T ;STORE SYMBOLIC CHAR
JRST DA55.A
INTER. DA56.
DA56.: PUSHJ PP,DA11.
HRRZ TA,CURDAT ;[243] GET CURRENT DATAB ADDRESS
LDB TB,DA.ERR ;[243] DID WE HAVE AN ERROR (USER)
JUMPE TB,DA56.1 ;[243] NO GO ON
SETZ TC, ;[243] YES DATAB TABLE NOT EXTENED FOR OCCURS
JRST DA56.B ;[243] GO TO CLEAR NO. OF OCCURS AND EXIT
DA56.1: MOVE TC,0(SAVPTR) ;[243] NO OF OCCURS
CAIGE TC,1
EWARNJ E.25
CAIG TC,77777
JRST DA56.A
EWARNW E.593
HRRZI TC,77777
HRRZM TC,0(SAVPTR)
DA56.A: HRRZ TA,CURDAT
LDB TB,DA.NOC
CAIG TC,(TB)
EWARNJ E.272
DA56.B: DPB TC,DA.NOC ;[243] NEW LABEL
POPJ PP,
INTER. DA57.
DA57.: PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.DP ;DEPENDING-FOR-OCCURS CODE
DPB TB,HL.COD
HLRZ TB,CURDAT ;STORE DATAB LINK IN HLDTAB
DPB TB,HL.LNK
HLRZ TA,CURDAT
PUSHJ PP,LNKSET
SETO TB,
DPB TB,DA.DLL## ;MARK THAT AN OCCURS DEPENDING HAS BEEN SEEN
POPJ PP,
;SD SORT-FILE-NAME
INTER. DA58.
DA58.: SKIPN TA,CURFIL
POPJ PP,
SETO TB,
DPB TB,FI.DSD## ;DEFINED IN AN SD
SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
LDB LN,FI.LN## ;GET LN & CP
LDB CP,FI.CP## ; OF SELECT CLAUSE
MOVEI TA,%LV.HI
PUSHJ PP,FLG.ES## ;AND FLAG IT AT HIGH-INTERMEDIATE
MOVE TA,CURFIL
LDB LN,FI.ALN## ;SEE IF WE HAVE TO FLAG "SAME [RECORD] AREA"
JUMPE LN,CPOPJ ;NO
LDB CP,FI.ACP##
LDB TA,FI.RLC## ;GET [RECORD] FLAG
SKIPN TA
SKIPA TA,[%LV.HI] ;HIGH-INTERMEDIATE IF "SAME AREA"
MOVEI TA,%LV.H ;HIGH IF [RECORD]
JRST FLG.ES
;PUT DATA-NAME QUALIFIER IN NEXT WORD OF HLDTAB
INTER. DA60.
DA60.: PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
MOVE TA,CURHLD ;GET # OF QUALIFIERS BEFORE THIS
LDB TB,HL.QAL
AOJ TB, ;INCREMENT COUNT
DPB TB,HL.QAL ;& PUT BACK
ROT TB,-1 ;DIV BY 2
HLRZ TC,CURNAM ;GET NAMTAB LINK
JUMPL TB,DA60.A ;IF BIT0 ON, USE ODD HALF-WORD
ADDI TA,1(TB) ;PTR TO EVEN HALF-WORD
HRRM TC,(TA) ;STORE IN EVEN HALF
POPJ PP,
DA60.A: PUSH PP,CURHLD ;SAVE PTR TO HLDTAB ENTRY
MOVE TA,[XWD CD.HLD,1] ;GET ONE MORE WORD FOR THE ENTRY
PUSHJ PP,GETENT
HLRZ TC,CURNAM ;GET NAMTAB LINK
HRLZM TC,(TA) ;STORE NAMTAB LINK IN ODD HALF
POP PP,CURHLD ;RESTORE HLDTAB PTR
POPJ PP,
;STORE NAMTAB RELATIVE ADDRESS FOR NEW NAME
DA60S.: TLNN W1,GWNOT ;NAME IN NAMTAB?
JRST DA60SA ;YES
PUSHJ PP,BLDNAM ;NO, BUILD NAMTAB ENTRY
MOVEM TA,CURNAM ;SAVE ADDR
HLRZS TA ;LINK TO RIGHT HALF
DPB TA,[POINT 15,W2,15] ;& TO W2 IN CASE ANYBODY WANTS IT
POPJ PP,
DA60SA: LDB TA,[POINT 15,W2,15] ;GET NAMTAB REL ADDR
HRLZM TA,CURNAM ;& SAVE
POPJ PP,
INTER. DA61.
DA61.: FLAGAT NS
MOVEI TA,%HL.VP ;'VALUE OF PROJECT-PROGRAMMER' FLAG
MOVEM TA,PNTS
POPJ PP,
;BUILD REPORT TABLE ENTRY & LINK FILE TO REPORT
INTER. DA62A.
DA62A.: FLAGAT RP
SKIPN TA,CURFIL ;POINT TO CURRENT FILE
POPJ PP,
LDB TB,FI.DRL ;HAVE WE ALREADY SEEN A DATA RECORD CLAUSE?
JUMPE TB,CPOPJ ;NO
EWARNJ E.749 ;YES, WARN USER
INTER. DA62.
DA62.: PUSHJ PP,DA62S.
HLRZ TB,CURFIL ;STORE FILTAB LINK IN RPWTAB
DPB TB,RW.FIL##
HRRZ TA,CURFIL ;GET FILTAB PTR
HLRZ TB,CURRPW ;STORE RPWTAB LINK IN FILTAB
DPB TB,FI.RPG##
SETO TB, ;FORCE ASCII MODE FOR FILE
DPB TB,FI.ADV## ;BY SETTING WRITE-ADVANCING FLAG
POPJ PP,
DA62S.: PUSHJ PP,BLDNAM ;PUT USERN. IN NAMTAB
HLRZ TB,TA ;SAVE NAMTAB LINK
DPB TB,[POINT 15,W2,15]
MOVE TA,[XWD CD.RPW,SZ.RPD] ;GET AN RPWTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURRPW ;SAVE RPWTAB PTR
LDB TB,[POINT 20,W2,35] ;STORE LINE POSITION IN RPWTAB
DPB TB,RW.LNC##
LDB TB,[POINT 15,W2,15] ;GET BACK NAMTAB LINK
DPB TB,RW.NAM## ;STORE NAMTAB LINK IN RPWTAB
ADD TB,NAMLOC## ;MAKE ABS. NAMTAB PTR
HLRM TA,(TB) ;STORE RPWTAB LINK IN NAMTAB
HLRZ TB,CURRPW ;GET LINK TO CURRENT RPWTAB ENTRY
SKIPN TC,LASTRD ;GET LINK TO PREVIOUS RD
JRST DA62SX ;NO PREVIOUS
HRRZ TA,RPWLOC ;MAKE ABS. PTR TO PREV. ENTRY
ADDI TA,(TC)
DPB TB,RW.BRO## ;LINK OLD ENTRY TO NEW
DA62SX: MOVEM TB,LASTRD ;REMEMBER CURR. ENTRY FOR NEXT TIME
MOVE TA,CURRPW ;RESTORE PTR TO CURRENT
POPJ PP,
INTER. DA62XE
DA62XE: MOVEI DW,E.359 ; [335] ILLEGAL REPORT NAME
DA62XF: SETOM RPWERR ; [335] SET REPORT GENERATOR FATAL FLAG
JRST FATALW ; [335] FATAL ERROR
;INIT REPORT SECTION
INTER. DA63.
DA63.: SETZM LNKSEC ;CLR LINKAGE SECTION FLAG
SKIPL TA,PCHOLD ;RESET EAS1PC TO PREVIOUS
MOVEM TA,EAS1PC ; IF CHANGED BY LINKAGE SECTION
SETOM PCHOLD
SKIPN FILSEC ;FILE SECTION SEEN?
JRST DA63E. ;NO
SWOFF FFILSC ;CLR FILE SECTION FLAG
SETOM REPSEC## ;SET REPORT SECTION FLAG
SETZM RPWRDL ;CLR RD RPWTAB LINK STORAGE
POPJ PP,
DA63E.: HRRZI NODE,DD204E## ;NEXT SYNTAX NODE IS DD204E
HRRZM NODE,(NODPTR) ;TO SKIP TO NEXT SECTION
EWARNJ E.339 ;FILE SECTION NOT SEEN MSG
;INIT RD
INTER. DA64.
DA64.: SETZM RPTCID## ; [415] CLEAR CONTROL ID LEVEL
LDB TB,[POINT 15,W2,15] ;GET BACK NAMTAB LINK
ADD TB,NAMLOC ;MAKE ABS NAMTAB PTR
HRRZ TA,(TB) ;GET RPWTAB LINK TO RD ENTRY
HRLI TA,(TA) ;IN BOTH HALVES
TRZE TA,700000 ;TABLE CODE = RPWTAB?
EWARNJ E.359 ;?REPORT-NAME EXPECTED
MOVE TB,RPWLOC## ;MAKE FULL RPWTAB PTR
ADDI TA,(TB)
MOVEM TA,CURRPW ;SAVE PTR TO CURRENT RPWTAB ENTRY
TLO W2,GWDEF ;PUT DEFINING REF. IN CREF TABLE
PUSHJ PP,PUTCRF
MOVE TA,CURRPW ;RESTORE PTR TO NEW ENTRY
HLRZM TA,RPWRDL ;& SAVE LINK FOR GROUP ITEMS
LDB TB,[POINT 20,W2,35] ;STORE LINE POSITION IN RPWTAB
DPB TB,RW.LNC##
SETO TB,
DPB TB,RW.DEF## ;SET REPORT HAS AN RD CLAUSE
MOVSI TB,[SIXBIT /PAGE:COUNTER/]
PUSHJ PP,DA64S. ;MAKE PAGE-COUNTER ENTRY IN DATAB
DPB TB,RW.PC## ;PUT DATAB LINK IN RPWTAB
HRRZ TA,CURDAT ;DEFAULT PAGE-CTR SIZE IS 10
HRRZI TB,^D10
DPB TB,DA.EXS
DPB TB,DA.INS
MOVSI TB,[SIXBIT /LINE:COUNTER/]
PUSHJ PP,DA64S. ;MAKE LINE-COUNTER ENTRY IN DATAB
DPB TB,RW.LC## ;PUT DATAB LINK IN RPWTAB
HRRZ TA,CURDAT ;GET DATAB PTR
HRRZI TB,2 ;LINE-COUNTER IS SIZE 2
DPB TB,DA.EXS
DPB TB,DA.INS
MOVE TA,[CD.LIT,,SZ.LIT+1] ;PUT A -1 IN LITAB
PUSHJ PP,GETENT
MOVEM TA,CURLIT
MOVE TB,[2,,1] ;SET UP SIZE OF CODE WORD
MOVEM TB,(TA)
DPB TB,LI.NLT## ;MAKE NUMERIC
MOVSI TB,(ASCII /-1/) ;"-1" TO 2ND WORD OF ENTRY
MOVEM TB,1(TA)
HLRZ TB,CURLIT ;PUT LITAB LINK IN DATAB ENTRY
HRRZ TA,CURDAT
DPB TB,DA.VAL ;AS A VALUE OF -1 TO MEAN NO INITIATE YET
HRRZ TA,CURRPW ;GET ADDRESS OF CURRENT RD ENTRY
LDB TA,RW.FIL ;GET FILTAB LINK
ADD TA,FILLOC ;MAKE REAL ADDRESS
SETOM TB
LDB TC,FI.ONE##
SKIPE TC ;ONE RD ENTRY SEEN YET ?
DPB TB,FI.MRE## ;YES, SET FLAG THAT AT MORE THAN ONE RD
; PROCESSED FOR THIS FILE
DPB TB,FI.ONE ;SIGNAL THAT FIRST RD SEEN
JRST DA8. ;ALLOCATE LINE-COUNTER
;MAKE PAGE/LINE-COUNTER ENTRY IN DATAB
DA64S.: HRRI TB,NAMWRD
BLT TB,NAMWRD+1 ;PUT 'XXXX-COUNTER' IN NAME STORE
SETZM NAMWRD+2 ;CLR REST OF NAMWRD
MOVE TA,[NAMWRD+2,,NAMWRD+3]
BLT TA,NAMWRD+5
PUSHJ PP,DA8. ;ALLOCATE PREVIOUS ITEM
HRRZI TB,LVL.01 ;MAKE COUNTER AN 01 LEVEL ITEM
MOVEM TB,(SAVPTR)
PUSHJ PP,DA26N.
HRRZS REPSEC ;PRETEND ITS AN ORDINARY W-S ITEM
PUSHJ PP,DA27. ;CREATE DATAB ENTRY
SETOM REPSEC ;RESET REPORT SECTION FLAG
HRRZ TA,CURDAT ;PTR TO COUNTER DATAB ENTRY
HRRZI TB,%CL.NU ;SET NUMERIC CLASS IN DATAB
DPB TB,DA.CLA
HRRZI TB,%US.1C ;& 1-WORD COMP USAGE
DPB TB,DA.USG
SETO TB,
DPB TB,DA.PIC ;& PIC SEEN BIT
DPB TB,DA.SGN ;& SIGNED BIT
DPB TB,DA.FAL ;& FATHER BIT
DPB TB,DA.LPC## ;THIS IS A LINE- OR PAGE-COUNTER
HRRZ TB,RPWRDL ;RD ENTRY IS THE FATHER LINK
DPB TB,DA.POP
PUSHJ PP,GETRDL ;GET RPWTAB PTR
HLRZ TB,CURDAT ;PUT PAGE/LINE-CTR DATAB LINK IN RPWTAB ENTRY
POPJ PP,
;GET RPWRDL & CONVERT IT TO AN ABSOLUTE PTR
GETRDL: HRRZ TA,RPWLOC ;TABLE BASE
ADD TA,RPWRDL ;PLUS RELATIVE ADDR
POPJ PP,
;SET UP REPORT NAME FOR RD, WHERE REPORT NAME NOT
;SPECIFIED IN A REPORT CLAUSE OF THE FILE SECTION
INTER. DA64E.
DA64E.: PUSHJ PP,DA62S. ; [335] SET UP REPORT TABLE
SKPNAM ; [335] GO ON
INTER. DA64XE
DA64XE: MOVEI DW,E.342 ; [335] ?NOT NAMED IN FILE SECTION.
JRST DA62XF ; [335] SET REPORT WRITER FATAL FLAG
;GET PAGE LIMIT
INTER. DA66.
DA66.: PUSHJ PP,DA11. ;GET THE INTEGER
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TC,RW.PAG ;PAGE LIMIT CLAUSE SEEN ALREADY?
JUMPN TC,JCE16. ;YES, DUPLICATE CLAUSE
MOVE TC,(SAVPTR) ;GET VALUE OF PAGE LIMIT
JUMPLE TC,DA66E ;MUST BE .GT. 0
CAILE TC,777 ;MUST BE .LT. 512
DA66E: EWARNJ E.344 ;?PAGE-LIMIT MUST BE LESS THAN 512
DPB TC,RW.PAG ;STORE PAGE LIMIT
MOVEI TD,2 ;MAKE LINE-CTR SIZE AGREE WITH PG-LIM
CAIL TC,^D100
MOVEI TD,3
CAIGE TC,^D10
MOVEI TD,1
LDB TC,RW.LC
HRRZI TA,(TC)
PUSH PP,TD
PUSHJ PP,LNKSET
POP PP,TD
DPB TD,DA.EXS
DPB TD,DA.INS
POPJ PP,
;GET PAGE HEADING LINE NUMBER
INTER. DA67.
DA67.: MOVE TB,RW.PHL## ;PTR TO HEADING-LINE FIELD IN RPWTAB ENTRY
DA67X.: MOVEM TB,PNTS ;SAVE FIELD PTR
PUSHJ PP,DA11. ;GET VALUE OF INTEGER
MOVE TC,(SAVPTR)
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TB,RW.PAG ;GET PAGE LIMIT
CAIGE TB,(TC) ;INDICATED LINE .LE. PAGE LIMIT?
EWARNJ E.343 ;NO
DPB TC,PNTS ;YES, STORE NUMBER IN INDICATED FIELD
POPJ PP,
;GET FIRST DETAIL LINE NUMBER
INTER. DA68.
DA68.: MOVE TB,RW.FDE## ;PTR TO FIRST DETAIL FIELD IN RPWTAB ENTRY
JRST DA67X.
;GET LAST DETAIL LINE NUMBER
INTER. DA69.
DA69.: MOVE TB,RW.LDE ;PTR TO LAST DETAIL FEILD
JRST DA67X.
;GET PAGE FOOTING LINE NUMBER
INTER. DA70.
DA70.: MOVE TB,RW.CFL## ;PTR TO FOOTING-LINE FIELD IN RPWTAB
JRST DA67X.
;CONTROL 'FINAL'
INTER. DA71.
DA71.: MOVE TA,[CD.RCO,,SZ.RCO] ;CREATE AN RCOTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURRCO## ;SAVE RCOTAB PTR
HLRZ TC,TA ;PUT LINK TO CONTROL ENTRY INTO RD ENTRY
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TB,RW.CID ;IS THIS THE FIRST CONTROL?
JUMPE TB,DA71.C ;YES
EWARNW E.346 ; [315] NO, FINAL MUST BE FIRST
HLRZS TC,
DPB TC,RW.FCI##
MOVE TA,TC
ADD TA,RCOLOC##
DPB TB,RC.BR1
MOVE TA,TB
MOVE TB,TC
DPB TB,RW.BRO##
POPJ PP,
DA71.C: DPB TC,RW.CID## ;SAVE LINK TO RCOTAB
DPB TC,RW.FCI ;SAVE LINK AS FIRST CONTROL IDENTIFIER ALSO
POPJ PP,
;CONTROL <DATA-NAME>
INTER. DA72.
DA72.: PUSHJ PP,DA72N ; [315] READ IDENTIFIER WITH ALL QUALS
CAIN TE,<CD.DAT>B20+1 ; [423] IF DUMMY BECAUSE BAD QUALIFIERS
POPJ PP, ; [423] QUIT NOW TO PREVENT COMPILER CRASH IN D54.NJ
PUSH PP,TE ; [315] SAVE DATAB LINK
MOVEM TE,SAVDAT## ; [315] SAVE DATAB LINK FOR RWPDAT
PUSHJ PP,SAVTHM ; [315] SAV CURRENT SOURCE INPUT
PUSHJ PP,RPWDAT ; [315] GO ENTER A NEW DATA ENTRY INTO DATAB
PUSHJ PP,D54.NJ ; [315] PUT NEW ENTRY INTO ASY FIL
SETOM REPSEC ; [315] SET US BACK TO REPORT SECTION
MOVE TA,[CD.RCO,,SZ.RCO] ;CREATE A NEW RCOTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURRCO ;SAVE RCOTAB LINK
POP PP,TE ;STORE DATAB LINK
HRLZM TE,(TA) ;IN CONTROL ENTRY
HLRZ TB,TA ;GET CNTRL ENTRY LINK
HLRZ TD,CURDAT ; [315]GET PREVIOUS DATAB ADR
HRRM TD,(TA) ; [315] STORE IT
PUSH PP,TB
MOVE TB,TE ; GET POINTER TO CURRENT DATAB ENTRY
PUSH PP,TA
DA72.X: MOVE CT,TB ; NO, SAVE LAST DATAB LINK
PUSHJ PP,FNDPOP ; GET FATHER
JRST .+3 ; NO FATHER, EXIT LOOP
TRNN TB,700000 ; POINTING AT A DATAB (NOT RPW ENTRY)?
JRST DA72.X ; YES, LOOP
POP PP,TA
POP PP,TB
DPB CT,RC.FAL## ; STORE FATHER
PUSHJ PP,GETRDL ; [315] GET RD RPWTAB PTR
PUSHJ PP,RETHM ; [315] GET BACK SOURCE INPUT FOR GETITM REGET
LDB TC,RW.NCI## ; ADD ONE TO NUMBER OF CONTROL IDENTIFIERS
AOS TC
DPB TC,RW.NCI
LDB TC,RW.CID
JUMPN TC,DA72.A ; THIS THE 1ST CONTROL ID?
DPB TB,RW.CID ; YES, STORE LINK TO LAST CTRL ID IN RPWTAB
DPB TB,RW.FCI ; STORE LINK TO LAST CONTROL IDENTIFIER
POPJ PP,
DA72.A: LDB TC,RW.FCI
DPB TB,RW.FCI
MOVE TA,TB
ADD TA,RCOLOC
DPB TC,RC.BR1##
MOVE TA,TC
ADD TA,RCOLOC
DPB TB,RC.BRO##
; CHECK FOR DUPLICATE ENTRY, IF THERE IS AN EXISTING ENTRY, GENERATE WARNING
MOVE TA,TB ; GET ADDRESS OF NEW NODE
ADD TA,RCOLOC ; MAKE ABSOLUTE
LDB TE,RC.DCI## ; GET DATAB LINK FOR COMPARISON
DA72.B: LDB TA,RC.BR1 ; GET BROTHER
JUMPE TA,CPOPJ ; IF NO MORE BROTHERS, EXIT
ADD TA,RCOLOC ; MAKE BROTHER LINK ABSOLUTE
LDB TD,RC.DCI ; GET BROTHER'S DATAB LINK
CAME TD,TE ; IS BROTHER DATAB LINK THE SAME ?
JRST DA72.B ; NO, REPEAT FOR NEXT BROTHER
EWARNJ E.772 ; YES, GENERATE WARNING AND RETURN
DA72N: DMOVEM W1,HLDSRC## ; [315]SAVE CURRENT SOURCE INPUTS
MOVEM CT,HLDSRC+2 ; [315]
PJRST DA96. ; [315] GO GET ANY QUALIFERS AND RETURN
SAVTHM: EXCH W1,HLDSRC ; [315] SAV NEW SOURCE GET BACK ORIGINAL CID
EXCH W2,HLDSRC+1 ; [315]
EXCH CT,HLDSRC+2 ; [315]
MOVE TE,[NAMWRD,,HLDNAM##] ; [315] SAVE SOURCE NAME FOR
BLT TE,HLDNAM+4 ; [315] LATER GETITM REGET
POPJ PP, ; [315] RETURN
RETHM: DMOVE W1,HLDSRC ; [315] RESTORE LAST SOURCE ITEM
MOVE CT,HLDSRC+2 ; [315]
MOVE TE,[HLDNAM,,NAMWRD] ; [315]
BLT TE,NAMWRD+4 ; [315] LAST SOURCE ITEM GOTTEN IN DA96.
MOVEM CT,ITEMCT## ; [315]
POPJ PP, ; [315] IS RESTORED FOR A GETITM REGET.
; THIS ROUTINE PUTS A RPWITM ENTRY INTO DATAB HAVING PARRAMETERS
; SIMULAR TO THE CURRENT DATAB ITEM WHOSE RELATIVE ADDRESS IS IN LOCATION SAVDAT
INTER. RPWDAT
RPWDAT: MOVE TA,['RWITM;'] ; [315] GET FAKE NAME
MOVEM TA,NAMWRD ; [315] STORE IT
PUSHJ PP,SIXDIG ; [315] GET NEXT DIGIT (IN SIXBIT)
MOVEM TA,NAMWRD+1 ; [315] MAKE DATA NAME 'RWITM-NNNNNN'
SETZM NAMWRD+2 ; [315] CLEAR REST OF NAME
MOVE TA,[NAMWRD+2,,NAMWRD+3] ; [315]
BLT TA,NAMWRD+5 ; [315]
MOVEI TB,LVL.01 ; [315] SET LEVEL TO 01
MOVEM TB,(SAVPTR) ; [315]
PUSHJ PP,DA26N. ; [315] SET 01 LEVEL AND USAGE
SETZM REPSEC ; [315] TURN OFF REPORT SECTION MOMENTARILY TO AVOID ANY RPTAB ENTRY
PUSHJ PP,DA27. ; [315] SET UP DATAB ENTRY FOR NEW ENTRY- NEW ITEM ADDRESS RETURN IN CURDAT
SETZM CURFIL ; [315] MAKE SURE NO FILE IS INVOLVED
HRRZ TA,SAVDAT ; [315] GET CURRENT DATAB RELATIVE ADDRESS
PUSHJ PP,LNKSET ; [315] GET ITS REAL ADDRESS
HRRM TA,SAVDAT ; [315] NOW SAVE THE REAL ADDRESS
LDB TB,DA.CLA ; [315] GET CURRENT CLASS
LDB TC,DA.SGN ; [315] GET CURRENT SIGN
LDB TD,DA.BWZ ; [315] GET CURRENT BLANK WHEN ZERO
LDB TE,DA.EDT ; [315] GET CURRENT EDITING PARAMETER
HRRZ TA,CURDAT ; [315] GET NEW ITEM ADDRESS
DPB TB,DA.CLA ; [315] COPY CLASS
DPB TC,DA.SGN ; [315] COPY SIGN
DPB TD,DA.BWZ ; [315] COPY BLANK WHEN ZERO
DPB TE,DA.EDT ; [315] COPY EDIT
JUMPE TE,RPWDT1 ; [315] IF NO EDIT GO ON
MOVE TA,[CD.DAT,,SZ.DOC+SZ.MSK] ; [603] [315] EDIT- NEED TO
PUSHJ PP,GETENT ; [315] INCREASE SIZE OF DATAB TABLE
HRLZ TB,SAVDAT ; [315] GET CURRENT ADDRESS
HRR TB,CURDAT ; [315] GET NEW ADDRESS
ADD TB,[XWD 7,7] ; [315] SET EACH TO 8TH WORD
HRRZ TC,CURDAT ; [315] SET UP LAST NEW ADDRESS
BLT TB,14(TC) ; [315] COPY 8TH - 13 TH WORD OF CURRENT INTO NEW (I.E) EDIT PARAMS
RPWDT1: HRRZ TA,SAVDAT ; [315] GET CURRENT ITEM
LDB TB,DA.JST ; [315] GET JUSTIFICATION
LDB TC,DA.USG ; [315] GET USAGE
LDB TD,DA.DPR ; [315] GET DECIMAL PLACE
HRRZ TA,CURDAT ; [315] GET NEW ITEM
DPB TB,DA.JST ; [315] COPY JUSTIFIED
DPB TC,DA.USG ; [315] COPY USAGE
DPB TD,DA.DPR ; [315] COPY DECIMAL PLACE
HRRZ TA,SAVDAT ; [315] GET CURRENT ADDRESS
LDB TB,DA.NDP ; [315] GET NUMBER OF DECIMAL PLACES
LDB TC,DA.INS ; [315] GET INTERNAL SIZE
LDB TD,DA.EXS ; [315] GET EXTERNAL SIZE
HRRZ TA,CURDAT ; [315] GET NEW ITEM
DPB TB,DA.NDP ; [315] COPY NUMBER OF DECIMAL PLACES
DPB TC,DA.INS ; [315] COPY INTERNAL SIZE
DPB TD,DA.EXS ; [315] COPY EXTERNAL SIZE
SETO TB, ; [315] TURN ON FOLLOWING
DPB TB,DA.FAK ; [315] ITEM IS FAKE
DPB TB,DA.PIC ; [315] PICTURE IS DESCRIBED HERE
POPJ PP, ; [315] RETURN
;CHECK FOR ILLEGAL CLAUSE IN REPORT SECTION
INTER. DA73.F
DA73.F: HRRZ TA,CURDAT ;POINT TO DATAB
LDB TB,DA.LVL ;GET LEVEL NUMBER
CAIE TB,LVL.01 ;LEVEL 01
CAIN TB,LVL.77 ; AND 77
FLAGAT NS ; ARE NON-STANDARD
SKPNAM
INTER. DA73.
DA73.: SKIPN REPSEC ;IN REPORT SECTION?
POPJ PP, ;NO
EWARNW E.348 ;CLAUSE ILLEGAL IN REPORT SECT.
DA73.X: HRRZI NODE,DD115.## ;CONTINUE AT NODE DD115.
HRRZM NODE,(NODPTR)
POPJ PP,
DA73.L: HLRZ TA,CURDAT ;GET CURRENT DATAB ENTRY
PUSHJ PP,LNKSET
LDB TB,DA.LVL ;GET LEVEL OF CURRENT DATAB ENTRY
CAIG TB,1 ;01 LEVEL ?
POPJ PP, ;YES
DA73L1: LDB TB,DA.FAL
JUMPE TB,DA73L2 ;NOT FATHER LINK
LDB TA,DA.POP ;GET DATAB ENTRY FOR FATHER
PUSHJ PP,LNKSET
PUSH PP,TA
LDB TA,DA.RPW ;GET RPWTAB LINK
ADD TA,RPWLOC
LDB TC,RW.LCD
SKIPE TC ;LINE CODE SEEN FOR FATHER ?
EWARNW E.773 ;YES
POP PP,TA
JUMPE TC,CPOPJ ;ERROR GENERATED, EXIT
LDB TC,DA.LVL ;GET LEVEL NUMBER
CAILE TC,1 ;FINISHED ?
JRST DA73L1 ;NO, GO REPEAT TEST
POPJ PP, ;FINISHED, EXIT
DA73L2: LDB TA,DA.BRO ;GET BROTHER LINK
SKIPN TA ;FINISHED ?
POPJ PP, ;YES, EXIT
PUSHJ PP,LNKSET
JRST DA73L1
DA73.N: HLRZ TB,CURDAT ;GET RELATIVE ADDRESS OF CURRENT DATAB ENTRY
DA73N1: PUSHJ PP,FNDPOP ;GET FATHER
POPJ PP, ;NO FATHER, EXIT
TRNN TB,700000 ;POINTING AT A DATAB (I.E. NOT DUMMY OR RPWTAB ENTRY)
POPJ PP, ;NO, EXIT
PUSH PP,TB
MOVE TA,TB
PUSHJ PP,LNKSET ;GET REAL ADDRESS OF FATHER
LDB TA,DA.RPW ;GET RPWTAB ENTRY
ADD TA,RPWLOC
SETO TB,
DPB TB,RW.RLS## ;SET LINE SEEN AT LOWER LEVEL FLAG
POP PP,TB
JRST DA73N1
;CHECK FOR ILLEGAL CLAUSE OUTSIDE REPORT SECTION
INTER. DA74.
DA74.: SKIPE REPSEC ;IN REPORT SECTION?
POPJ PP, ;YES, CLAUSE IS OK
DA74.X: EWARNW E.350 ;NO, ILLEGAL CLAUSE
JRST DA73.X ;GO TO SYNTAX NODE DD144.
;IF REPORT ITEM HAS NO NAME,
;PUT NAME 'RWITM.######' ON REPORT GROUP ITEM
FAKNAM: HRRZ TA,CURDAT ;DATAB ADDR
LDB TC,DA.NAM ;HAVE A REAL NAME?
JUMPN TC,CPOPJ ;YES
PUSHJ PP,RPWNAM ;MAKE NAMTAB ENTRY "RWITM.######"
HLRZS TA ;LINK DATAB ENTRY TO NAMTAB
HLL TA,CURDAT
PUSHJ PP,PUTLNK
HRRZ TA,CURDAT ;PUT NAMTAB LINK IN DATAB
HRRZ TB,NAMADR##
HRRZ TC,NAMLOC
SUBI TB,(TC)
DPB TB,DA.NAM
LDB TB,DA.SNL## ;REMOVE ITEM FROM NO-NAME CHAIN
HRRZM TB,(TC)
SETZ TB, ;CLR SAME NAME LINK
DPB 15,DA.SNL
SETO TB, ;SET FAKE NAME BIT
DPB TB,DA.FAK##
POPJ PP,
;MAKE A "RWITM.######" ENTRY IN NAMTAB
RPWNAM::MOVE TA,['RWITM;'] ;FIRST WORD OF SIXBIT NAME
MOVEM TA,NAMWRD
PUSHJ PP,SIXDIG ;SECOND WORD OF NAME
MOVEM TA,NAMWRD+1
SETZM NAMWRD+2 ;CLR REST OF NAMWRD
MOVE TA,[NAMWRD+2,,NAMWRD+3]
BLT TA,NAMWRD+5
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM ;PUT NAME IN NAMTAB
MOVEM TA,NAMADR ;SAVE NAMTAB PTR
POPJ PP,
;GENERATE A 6-DIGIT SIXBIT NUMBER ONE LARGER THAN THE LAST
SIXDIG: MOVE TA,SIXHLD## ;GET LAST NUMBER RETURNED
ADD TA,[464646464647]
MOVE TB,TA
TDZ TB,[171717171717]
MOVE TC,TB
LSH TC,-3
OR TB,TC
SUB TA,TB
ADD TA,[202020202020]
MOVEM TA,SIXHLD ;STORE NEW NUMBER
POPJ PP,
;REPORT LINE IS NEXT PAGE
INTER. DA75.
DA75.: PUSHJ PP,DA73.L ;CHECK ALL HIGHER LEVELS FOR LINE CLAUSE
PUSHJ PP,DA73.N ;SET FLAGS IN RPWTAB FOR LINE SEEN
SETOM RPWPFL ;SET FLAG FIRST LINE CLAUSE NOT RELATIVE
HRRZ TA,CURRPW ;PTR TO REPORT GROUP ENTRY
DMOVEM LN,RPWLN## ;SAVE LN AND CP FOR POSSIBLE ERROR
HRRZI DW,E.771 ;GET ERROR MESSAGE
LDB TB,RW.TYP ;GET TYPE
CAIN TB,%RG.RH ;TYPE RH ?
SKIPA ;YES
CAIN TB,%RG.PH ;TYPE PH ?
SKIPA ;YES
CAIN TB,%RG.PF ;TYPE PF ?
PUSHJ PP,WARN ; TYPE WAS RH,PH, OR PF
MOVEI TB,%RG.NP ;GET NEXT PAGE CODE
DA75.X: SETOM RWLCS. ;NOTE THAT WE HAVE SEEN A LINE CLAUSE.
HRRZ TA,CURRPW ;PTR TO REPORT GROUP ENTRY
LDB TC,RW.LCD## ;LINE CODE SEEN BEFORE?
JUMPN TC,JCE16. ;YES, DUPLICATE CLAUSE
DPB TB,RW.LCD ;NO, STORE IT
POPJ PP,
;Here to save LN & CP of NEXT when we don't know if PAGE or GROUP follows
INTER. DA75A.
DA75A.: DMOVEM LN,RPWLN2## ;SAVE LN & CP
POPJ PP,
;REPORT LINE IS <INTEGER>
INTER. DA76.
DA76.: PUSHJ PP,DA73.L ;CHECK ALL HIGHER LEVELS FOR LINE CLAUSE
PUSHJ PP,DA73.N ;SET FLAGS IN RPWTAB FOR LINE SEEN
SETOM RPWPFL ;SET FLAG FIRST LINE CLAUSE NOT RELATIVE
PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE POSITIVE
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.LIN## ;LINE # THERE ALREADY?
JUMPN TB,JCE16. ;YES, DUP. CLAUSE
PUSHJ PP,GETRDL ;MAKE PTR TO RD ENTRY
LDB TB,RW.PAG## ; [315] GET PAGE-LIMIT
HRRZ TA,CURRPW ; GET BACK REORT ITEM
JUMPE TB,.+3 ; IF NO PAGE-LIMIT- NO CHECK
CAILE TC,(TB) ; LINE MUST BE L.E. TO PAGE-LIMIT
EWARNJ E.352 ; IT IS NOT
DPB TC,RW.LIN ; OKAY STORE LINE NUMBER
HRRZI TB,%RG.LN ; GET LINE # CODE
JRST DA75.X ; STORE IT AND RETURN
;REPORT LINE IS PLUS <INTEGER>
INTER. DA77.
DA77.: PUSHJ PP,DA73.L ;CHECK ALL HIGHER LEVELS FOR LINE CLAUSE
PUSHJ PP,DA73.N ;SET FLAGS IN RPWTAB FOR LINE SEEN
DMOVEM LN,RPWLN ;SAVE LN & CP FOR POSSIBLE ERROR
HRRZ TA,CURDAT ;GET CURRENT DATAB ENTRY
DA77.A: LDB TB,DA.LVL
CAIN TB,1 ;01 LEVEL ?
JRST DA77.B ;YES
HLRZ TB,CURDAT
PUSHJ PP,FNDPOP ;GET FATHER
JRST DA77.C ;SHOULD NEVER HAPPEN, ALWAYS SHOULD HAVE FATHER
CAIGE TB,1 ;POINTING TO DUMMY ENTRY ?
JRST DA77.C ;YES, SHOULD NEVER HAPPEN
MOVE TA,TB
PUSHJ PP,LNKSET
JRST DA77.A
DA77.B: LDB TA,DA.RPW ;GET RPWTAB LINK
ADD TA,RPWLOC ;ADD OFFSET
LDB TA,RW.TYP ;GET TYPE
SKIPN RPWPFL ;FIRST LINE CLAUSE NOT RELATIVE
CAIE TA,%RG.PF ;OR REPORT TYPE NOT PAGE FOOTING
SKIPA ;YES
EWARNW E.781 ;FIRST LINE CLAUSE RELATIVE, AND TYPE IS PF
SETOM RPWPFL ;SET SO NO MORE ERRORS FOR THIS 01 ENTRY
DA77.C: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE POS.
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.LIN ;LINE # GIVEN ALREADY?
JUMPN TB,JCE16. ;YES
DPB TC,RW.LIN ;NO, STORE IT
HRRZI TB,%RG.PI ;PLUS INTEGER CODE
JRST DA75.X
;PICTURE SEEN, CHECK IF IN RPW AND LEVEL 01. IF IT IS, THEN ERROR
INTER. DA78.
DA78.: SKIPN REPSEC ;IN REPORT SECTION ?
POPJ PP, ;NO, RETURN
HRRZ TA,CURDAT ;GET ENTRIES DATAB LINK
LDB TA,DA.LVL ;GET LEVEL NUMBER
CAIN TA,1 ;01 LEVEL ?
EWARNW E.780 ;YES, GENERATE ERROR
POPJ PP, ;EXIT
;NEXT GROUP IS
INTER. DA79.
DA79.: DMOVEM LN,RPWLN1## ;SAVE LN & CP OF NEXT GROUP STATEMENT
DA79.C: HRRZ TA,CURRPW ;PTR TO CURRENT RPWTAB ENTRY
LDB TB,RW.TYP ;GET TYPE
CAIN TB,%RG.RF ;REPORT FOOTING ?
PUSHJ PP,DA79.B ;YES, GENERATE WARNING
JRST DA74.
DA79.A: HRRZI DW,E.776
TRNA
DA79.B: HRRZI DW,E.777
DMOVE LN,RPWLN1 ;RESTORE LN AND CP TO NEXT GROUP STATEMENT
PJRST WARN
;Here when we could not decide earlier if we had NEXT PAGE or NEXT GROUP
INTER. DA79A.
DA79A.: DMOVE TB,RPWLN2 ;GET LN & CP OF NEXT
DMOVEM TB,RPWLN1 ;STORE FOR NEXT GROUP NOW
JRST DA79.C ;CONTINUE AS IF CALLED FROM NODE DD257.
;NEXT GROUP IS NEXT PAGE
INTER. DA80.
DA80.: HRRZ TA,CURRPW ;PTR TO REPORT GROUP ENTRY
LDB TC,RW.TYP ;GET TYPE
CAIN TC,%RG.PF ;PAGE FOOTING ?
PUSHJ PP,DA79.A ;YES, GENERATE WARNING AND CONTINUE
MOVEI TB,%RG.NP ;GET NEXT PAGE CODE
DA80.X: HRRZ TA,CURRPW ;PTR TO REPORT GROUP ENTRY
LDB TC,RW.NLC## ;NEXT GROUP CODE SEEN BEFORE?
JUMPN TC,JCE16. ;YES, CLAUSE DUPLICATED
DPB TB,RW.NLC ;NO, STORE IT
POPJ PP,
;NEXT GROUP IS <INTEGER>
INTER. DA81.
DA81.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE .GT. 0
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.NXT## ;NEXT GROUP CLAUSE SEEN ALREADY?
JUMPN TB,JCE16. ;YES
PUSHJ PP,GETRDL ; [315] GET RD ADDRESS
LDB TB,RW.PAG ;INTEGER MUST BE .LE. PAGE LIMIT
SKIPN TB ;PAGE LIMIT SEEN ?
EWARNW E.782 ;NO, GENERATE WARNING
JUMPE TB,.+3
CAILE TC,(TB)
EWARNJ E.352 ;TOO BIG
HRRZ TA,CURRPW ; [315] GET RPWTAB ADDRESS
DPB TC,RW.NXT ;OK, STORE IT
HRRZI TB,%RG.LN ;LINE # CODE
JRST DA80.X
;NEXT GROUP IS PLUS <INTEGER>
INTER. DA82.
DA82.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE .GT. 0
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.NXT ;NEXT GROUP CLAUSE SEEN ALREADY?
JUMPN TB,JCE16. ;YES
DPB TC,RW.NXT ;STORE INTEGER
HRRZI TB,%RG.PI ;GET PLUS INTEGER CODE
JRST DA80.X
;SET GROUP INDICATE BIT
INTER. DA83.
DA83.: SKIPN REPSEC ;IN REPORT SECTION?
JRST DA74.X ;NO, SHOULDN'T BE HERE
HRRZ TA,CURRPW ;REPORT GROUP RPWTAB PTR
LDB TB,RW.TYP ; [315] G.I. LEGAL ONLY FOR
CAIE TB,%RG.DE ; [315] TYPE DETAIL
EWARNJ E.482 ; [315] ILLEGAL
SETO TB, ;SET GROUP INDICATE BIT
DPB TB,RW.GPI##
POPJ PP,
;RESET ON FINAL
INTER. DA84.
DA84.: HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.RSF## ;RESET ON FINAL SEEN BEFORE?
JUMPN TB,JCE16. ;YES
LDB TB,RW.RSI## ;RESET ON IDENTIFIER SEEN?
JUMPN TB,JCE16. ;YES
LDB TB,RW.TYP ;MAKE SURE IT'S CF (OR NOT YET SPECIFIED)
CAIE TB,0
CAIN TB,%RG.CF
JRST .+2 ;OK
EWARNJ E.368 ;?RESET ON ITEM OTHER THAN CF
SETZ TE, ; [315] MAKE SURE WE HAVE A CONTROL
PUSHJ PP,FNDCNT ; [315] FINAL
EWARNJ E.481 ; [315] NO- ERROR
HRRZ TA,CURRPW ; [315] GET BACK PTR TO REPORT ITEM
SETO TB, ;NO, SET RESET ON FINAL BIT
DPB TB,RW.RSF
POPJ PP,
;RESET ON <IDENTIFIER>
INTER. DA85.
DA85.: PUSHJ PP,DA96. ;READ FULL IDENTIFIER
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.RSF ;RESET ON FINAL SEEN BEFORE?
JUMPN TB,JCE16. ;YES
LDB TB,RW.RSI ;RESET ON IDENTIFIER SEEN?
JUMPN TB,JCE16. ;YES
LDB TB,RW.TYP ;MAKE SURE IT'S CF (OR NOT YET SPECIFIED)
JUMPE TB,DA85.X ;NOT YET SPECIFIED, CK IT AT DA94.
CAIE TB,%RG.CF ;CF?
JRST JCE368 ;?RESET ON ITEM OTHER THAN CF
PUSHJ PP,FNDCNT ;LOOK FOR MATCHING CONTROL ENTRY
JRST JCE369 ;?NOT A CONTROL
HRRZ TC,TB ;[1452][1475]
HRRZ TD,RCOLOC ;[1452]
SUB TC,TD ;[1452][1475] MAKE ADDRESS OF CONTROL ENTRY RELATIVE
CAML TC,THSCTL ;[1452][1475] IS RESET CONTROL HIGHER THAN CURRENT ITEMS CONTROL?
JRST JCE370 ;NO
DA85.X: HRRZ TA,CURRPW ;GET BACK PTR TO CURRENT RPW ITEM
SETO TB, ;SET RESET FLAG
DPB TB,RW.RSI
DPB TE,RW.RES## ;STORE DATAB LINK TO RESET IDENTIFIER
POPJ PP,
JCE357: SETZM RPTCID ; [415] CLEAR CID LEVEL NUMBER
HRRZI DW,E.357
JRST FATAL
JCE367: HRRZI DW,E.367
JRST FATAL
JCE368: HRRZI DW,E.368
JRST FATAL
JCE369: HRRZI DW,E.369
JRST FATAL
JCE472: HRRZI DW,E.472 ; [315]
JRST FATAL ; [315]
JCE473: HRRZI DW,E.473 ; [315]
JRST FATAL ; [315]
JCE489: HRRZI DW,E.489 ;[215]
JRST FATAL ;[215]
JCE490: HRRZI DW,E.490 ;[215]
JRST FATAL ;[215]
JCE491: HRRZI DW,E.491 ;[215]
JRST FATAL ;[215]
;LOCATE CONTROL ENTRY FOR DATAB ITEM IN TE
;SKIP RETURNS WITH LINK TO CONTROL ENTRY IN TB IF FOUND
FNDCNT: HRRZ TA,CURRPW ;PTR TO CURRENT GROUP ENTRY
LDB TB,RW.RDL ;MAKE PTR TO RD ENTRY
HRRZ TA,RPWLOC
ADDI TA,(TB)
LDB TB,RW.CID ;GET LINK TO 1ST CONTROL
FNDCN1: ADD TB,RCOLOC
HRRZS TB ;CLR LEFT HALF
HLRZ TD,(TB) ;GET DATAB LINK FROM CONTROL ENTRY
CAIN TD,(TE) ;IS IT THE ONE?
JRST CPOPJ1 ;YES
MOVE TA,TB
LDB TB,RC.BRO ;GET BROTHER
JUMPN TB,FNDCN1 ;GO BACK TO TRY NEXT ONE
POPJ PP, ;NO MORE -- TAKE ERROR RETURN
;GET COLUMN NUMBER
INTER. DA86.
DA86.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE POSITIVE
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.COL## ;COLUMN # ALREADY GIVEN?
JUMPN TB,JCE16. ;YES
DPB TC,RW.COL ;YES, STORE IT IN RPWTAB
SETOM RWCCS.## ;NOTE THAT WE HAVE SEEN A COLUMN CLAUSE.
POPJ PP,
;SET REPORT ITEM TYPE
INTER. DA87.
DA87.: PUSHJ PP,GETRDL ;[1373] GET RD POINTER
SETO TC, ;[1373] INDICATE HAVE SEEN A REPORT
DPB TC,RW.RHL## ;[1373] HEADING
MOVEI TC,%RG.RH ;[1373] REPORT HEADING TYPE CODE
DA87.X: HRRZ TA,CURRPW ;PTR TO RPWTAB ENTRY
LDB TB,RW.TYP## ;TYPE STORED ALREADY?
JUMPN TB,JCE16. ;YES
DPB TC,RW.TYP ;NO, STORE IT
MOVEM TC,LASTYP ;REMEMBER LAST TYPE SEEN
HRRZI DW,E.771
DMOVE LN,RPWLN ;RESTORE POINTER TO LINE CLAUSE
CAIE TC,%RG.RF ;TYPE REPORT FOOTING ?
JRST DA87.A ;NO
LDB TB,RW.NLC
SKIPE TB ;NEXT GROUP STATEMENT SEEN ?
PUSHJ PP,DA79.B ;YES, GENERATE WARNING
DA87.A: LDB TA,RW.RDL ;GET RPWTAB RD ENTRY
ADD TA,RPWLOC ;ADD OFFSET
LDB TB,RW.PAG ;GET PAGE CLAUSE
CAIN TC,%RG.PH ;TYPE PH ?
JRST .+3 ;YES, CHECK FOR PAGE CLAUSE PRESENT
CAIE TC,%RG.PF ;TYPE PF ?
JRST .+3 ;NO, DO NOT CHECK FOR PAGE CLAUSE PRESENT
SKIPN TB ;ANY PAGE CLAUSE ?
EWARNW E.783 ;NO, GENERATE WARNING
HRRZ TA,CURRPW ;GET CURRENT RPWTAB ENTRY
LDB TB,RW.NLC
CAIN TC,%RG.RH ;TYPE RH ?
SKIPA
CAIN TC,%RG.PH ;OR PH ?
SKIPA
CAIN TC,%RG.PF ;OR PF ?
SKIPA ;YES
POPJ PP, ;NO, RETURN
CAIN TB,%RG.NP ;LINE NEXT PAGE SEEN ?
PUSHJ PP,WARN ;YES
CAIE TC,%RG.PF ;TYPE PAGE FOOTING
POPJ PP, ;NO
LDB TB,RW.NLC
CAIN TB,%RG.NP ;NEXT GROUP IS NEXT PAGE SEEN ?
PUSHJ PP,DA79.A ;YES, GENERATE WARNING
LDB TB,RW.LCD
CAIE TB,%RG.PI ;LINE STATEMENT A RELATIVE LINE CLAUSE ?
POPJ PP, ;NO
DMOVE LN,RPWLN ;RESTORE LINE NUMBER OF LINE CLAUSE
HRRZI DW,E.781
PUSHJ PP,WARN ;GENERATE WARNING
POPJ PP,
INTER. DA88.
DA88.: MOVEI TC,%RG.PH ;PAGE HEADING TYPE
JRST DA87.X
INTER. DA89.
DA89.: MOVEI TC,%RG.CH ;CONTROL HEADING TYPE
JRST DA87.X
INTER. DA90.
DA90.: MOVEI TC,%RG.DE ;DETAIL TYPE
JRST DA87.X
INTER. DA91.
DA91.: MOVEI TC,%RG.CF ;CONTROL FOOTING TYPE
JRST DA87.X
INTER. DA92.
DA92.: MOVEI TC,%RG.PF ;PAGE FOOTING
JRST DA87.X
INTER. DA93.
DA93.: MOVEI TC,%RG.RF ;REPORT FOOTING
JRST DA87.X
;CH/CF IDENTIFIER
INTER. DA94.
DA94.: PUSHJ PP,DA96. ;GET FULL IDENTIFIER
DA94.1: PUSHJ PP,FNDCNT ;FIND CORRESPONDING CONTROL ENTRY
JRST JCE357 ;?THIS DATA ITEM IS NOT A CONTROL
MOVEM TC,RPTCID## ; [415] STORE CURRENT LEVEL OF THE CF
HRRZ TC,TB ;[1452][1475]
HRRZ TD,RCOLOC ;[1452]
SUB TC,TD ;[1452][1475] MAKE ADDRESS OF CONTROL ENTRY RELATIVE
HRRZM TC,THSCTL ;[1452][1475]SAVE ADDR OF CORRESP CONTROL ENTRY
MOVE TA,CURRPW ;GET BACK PTR TO RPW ITEM ENTRY
LDB TC,RW.TYP ;CH OR CF?
CAIE TC,%RG.CH
JRST DA94.A ;CF
HLRZ TC,1(TB) ; [315] IF CH GROUP ALREADY THERE
JUMPN TC,JCE472 ; [315] THEN THIS IS DUPLICATE CONTROL HEADING FOR THIS ID
HLLM TA,1(TB) ;STORE RPWTAB LINK TO CH ITEM
POPJ PP,
DA94.A: HRRZ TC,1(TB) ; [315] IF CF GROUP ALREADY THERE
JUMPN TC,JCE473 ; [315] THEN THIS IS DUPLICATE CONTROL FOOTING FOR THIS ID
HLRM TA,1(TB) ;STORE RPWTAB LINK TO CF
LDB TC,RW.RST## ;[651] GET RW.RSF+RW.RSI
JUMPE TC,CPOPJ ;NO RESET FLAGS
MOVEM TE,(SAVPTR) ;SAVE LINK TO CURRENT ITEMS CONTROL
LDB TE,RW.RES ;GET RESET LINK TO DATAB
PUSHJ PP,FNDCNT ;LOCATE CONTROL ENTRY MATCHING RESET
JRST JCE369 ;NO SUCH CONTROL (CHECKED AT DA85.)
HRRZ TC,TB ;[1452][1475]
HRRZ TD,RCOLOC ;[1452]
SUB TC,TD ;[1452][1475] MAKE ADDRESS OF CONTROL ENTRY RELATIVE
CAMGE TC,THSCTL ;[1452][1475] IS RESET CONTROL HIGHER THAN CURRENT CONTROL
POPJ PP, ;YES
JCE370: HRRZI DW,E.370
JRST FATAL
;CH/CF FINAL
INTER. DA95.
DA95.: HRRZ TA,CURRPW ;PTR TO RPWTAB
SETOB TB,TE ;SET FINAL CONTROL FLAG
DPB TB,RW.FNC##
AOJA TE,DA94.1 ;FINAL HAS "DATAB LINK" OF 0
;READ & FIND A DEFINED DATA-NAME WITH ALL QUALIFIERS
;RETURNS TE=DATAB LINK
INTER. DA96.
DA96.: SETZM TBLOCK## ;CLR TBLOCK
MOVE TA,[TBLOCK,,TBLOCK+1]
BLT TA,TBLOCK+24
MOVEM W2,TBLOCK+4 ;FACTS ABOUT DATA-NAME TO TBLOCK SETUP
MOVEM LN,(SAVPTR) ;SAVE LINE POSITION
MOVEM CP,1(SAVPTR)
DA96.1: PUSHJ PP,GETITM ;READ NEXT SOURCE WORD
CAIN TYPE,LPREN. ; LEFT PAREN [247]
JRST DA96.4 ; YES HANDLE SUBSCRIPTING [247]
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,JCE104 ;QUALIFIER MUST BE DEFINED
MOVEM TB,TBLOCK+4(TA) ;STORE NAMTAB LINK OF QUAL IN TBLOCK
JRST DA96.1 ;ANY MORE QUALS?
DA96.2: MOVE LN,(SAVPTR) ;RESTORE LINE POSITION OF ITEM IN CASE ERROR
MOVE CP,1(SAVPTR)
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 [247]
PUSH PP,TE ;SAVE LINK POINTER [247]
HRRZI TA,(TE) ;SET UP CALL TO LNKSET [247]
PUSHJ PP,LNKSET ;GET DATAB ADDRESS [247]
POP PP,TE ; GET IT BACK [247]
LDB TB,DA.SUB. ; IS ITEM SUBSCRIPTED [247]
MOVEI DW,E.275 ;GET ERROR FOR SUBSCRIPTING [247]
SKIPE REPSEC ; IN REPORT SECTION [247]
JUMPN TB,DA96.3 ; SUBCRIPTS ARE ILLEGAL [247]
POPJ PP, ;RETURN WITH DATAB LINK IN TE
JCE104: MOVEI DW,E.104 ; UNDEFINED [247]
DA96.3: PUSHJ PP,FATAL ;[247] GIVE MESSAGE
MOVEI TE,<CD.DAT>B20+1 ;AIM AT DUMMY ENTRY
POPJ PP,
DA96.4: SKIPN REPSEC ; IN REPORT SECTION [247]
JRST DA96.2 ; NO GO ON [247]
DA964A: PUSHJ PP,GETITM ; GET NEXT SOURCE ITEM [247]
CAIE TYPE,ENDIT. ; EOF ON SOURCE? [247]
CAIN TYPE,PRIOD. ; PERIOD? [247]
JRST DA964B ; YES
CAIE TYPE,RPREN. ; RIGHT PAREN ? [247]
JRST DA964A ; LOOP TO GET NEXT SOURCE ITEM [247]
SKIPA ; YES DONT REGET IT [247]
DA964B: SWON FREGWD ; SET TO REGET THIS ITEM [247]
MOVE LN,(SAVPTR) ; GET BACK POSITION OF ITEM [247]
MOVE CP,1(SAVPTR) ; AND ITS CHAR POS [247]
MOVEI DW,E.275 ; SUBCRIPTS NOT ALLOWED [247]
PUSHJ PP,DA96.3 ; GIVE ERROR [247]
PUSHJ PP,FINDAT ; LOOK FOR DATAB LINK [247]
JUMPN DW,DA96.3 ; ERROR [247]
POPJ PP, ; [247]
;LINK REPORT ITEM TO SOURCE
; The full identifier, possibly with subscripts, has been parsed.
INTER. DA97.
DA97.: HRRZ W1,CURRPW ;ABS. PTR TO RPWTAB ENTRY
ADDI W1,.RWSRC ; STORE THE ITEM HERE
PUSHJ PP,DA230. ; STORE THE IDENTIFIER
;RESTORE "CURDAT" SO IT GETS A USAGE WHEN TREES POP BACK TO CALL DA8.
HLRZ TA,CURDTT## ;LH OF LINK
HRLM TA,CURDAT
PUSHJ PP,LNKSET ;GET ABS ADDR.
HRRM TA,CURDAT
HRRZ TA,CURRPW ;GET PTR AGAIN (USE TA THIS TIME)
ADDI TA,.RWSRC
HRRZ TE,1(TA)
PUSH PP,TE ;SAVE IT
HRRZI TA,(TE) ;GET PTR TO DATAB ENTRY
PUSHJ PP,LNKSET
POP PP,TE
LDB TB,DA.RPW## ;RPW LINK SHOULD BE 0 (I.E. W-S OR FILE)
JUMPN TB,JCE367 ;?SOURCE ITEM MUST BE IN FILE OR W-S SECTION
SETO TB, ;SET SOURCE FOR DETAIL BIT
DPB TB,DA.RDS
HRRZ TA,CURRPW ;PTR TO RPWTAB ENTRY
LDB TB,RW.SCD## ;SEEN SOURCE, ETC YET?
JUMPN TB,JCE16. ;YES, DUPLICATE ITEM
HRRZI TB,%RG.SR ;SAY IT HAS A SOURCE CLAUSE
DPB TB,RW.SCD
DPB TE,RW.SLK## ;STORE SOURCE LINK TO DATAB
LDB TD,RW.DAT## ;GET LINK TO CORRESP DATAB ENTRY
LDB TB,RW.RDL## ;& LINK TO CORRESP RD ENTRY
HRRZ TA,RPWLOC ;MAKE ABS. PTR TO RD ENTRY
ADDI TA,(TB)
LDB TB,RW.PC ;GET LINK TO THIS REPORT'S PAGE-CTR
CAIE TB,(TE) ;IS THIS SOURCE THE PAGE-CTR?
POPJ PP, ;NO
PUSH PP,TE ;SAVE LINK TO PAGE-CTR
HRRZI TA,(TD) ;MAKE PTR TO DATAB ENTRY
PUSHJ PP,LNKSET
LDB TB,DA.INS ;GET ITS SIZE
POP PP,TE
PUSH PP,TB ;SAVE SIZE OF DATAB ENTRY
HRRZI TA,(TE) ;MAKE ABS PTR TO PAGE-CTR
PUSHJ PP,LNKSET
LDB TC,DA.INS ;GET PAGE-CTR'S SIZE
CAIN TC,^D10 ;1ST TIME THRU?
SETZ TC, ;YES, PAGE-CTR IS 0
POP PP,TB ;GET BACK SIZE OF DATAB ENTRY
CAIG TB,(TC) ;PAGE CTR ALREADY BIGGER?
POPJ PP, ;YES
DPB TB,DA.EXS ;NO, PAGE-CTR MUST GROW
DPB TB,DA.INS
POPJ PP,
;ADVANCE TO NEXT ITEM
INTER. DA98.
DA98.: SWOFF FREGWD ;CLR REGET BIT
JRST GETITM ;GET NEXT ITEM
;PROCESS MISSING OPTIONAL DATA-NAME FOR ITEM
INTER. DA99.
DA99.: SKIPN REPSEC ;REPORT SECTION?
JRST DA99.8 ;NO, OPTIONAL IN -8x
SETZB TA,NAMWRD ;YES, INDICATE REPORT ITEM HAS NO NAME
DPB TA,[POINT 15,W2,15]
JRST DA27. ;STORE FAKE REPORT WRITER NAME
INTER. DA99A.
DA99A.: SKIPN REPSEC ;IN REPORT SECTION?
JRST DA99.8 ;NO, OPTIONAL IN -8x
SETZB TA,NAMWRD ;YEAS, INDICATE ITEM HAS NO NAME
DPB TA,[POINT 15,W2,15]
JRST DA29. ;STORE FAKE REPORT WRITER NAME
DA99.8: FLAGAT 8 ;NO, SIGNAL -8x STANDARD
POPJ PP, ;AND RETURN
;CHECK REDEFINES CLAUSE FOR REPORT SECTION ITEM
INTER. DA100.
DA100.: SKIPE REPSEC ;IN REPORT SECTION?
EWARNJ E.348 ;YES, ILLEGAL
POPJ PP,
;PROCESS SUM IDENTIFIER
INTER. DA101.
DA101.: HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.NSI## ;GET NUMBER OF SUM IDENTIFIERS SEEN
ADDI TB,1 ;INCREMENT
DPB TB,RW.NSI ;& REPLACE
ROT TB,-1 ;MOVE BIT 35 TO BIT 0
MOVEM TB,CTR ;SAVE LEFT/RIGHT FLAG
JUMPGE TB,DA101A ;IF EVEN, USE RT HF OF CURRENT ENTRY
MOVE TA,[XWD CD.RPW,1] ;IF ODD, GET ANOTHER RPWTAB WORD
PUSHJ PP,GETENT
HLRZM TA,(SAVPTR) ;SAVE RPWTAB LINK
DA101A: PUSHJ PP,DA60S. ;SAVE NAMTAB ENTRY ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZ TB,(SAVPTR) ;STORE RPWTAB LINK IN HLDTAB
DPB TB,HL.LNK
HRRZI TB,%HL.SL ;GET SUM ID (LH) FLAG
SKIPL CTR ;LEFT OR RIGHT HALF STORE?
HRRZI TB,%HL.SR ;RT., GET SUM ID (RH) FLAG
DPB TB,HL.COD ;STORE HLDTAB CODE
POPJ PP,
;SUM UPON CLAUSE
INTER. DA102.
DA102.: PUSHJ PP,DA60S. ;SAVE NAMTAB ENTRY ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.UP ;SET 'SUM UPON' CODE
DPB TB,HL.COD
PUSH PP,TA
MOVE TA,[CD.RPW,,SZ.RPU] ;GET AN UPON DATA ENTRY IN RPWTAB
PUSHJ PP,GETENT
HLRZ TB,TA ;STORE RPWTAB LINK IN HLDTAB
POP PP,TA
DPB TB,HL.LNK
LDB TA,HL.NAM ;GET NAMTAB ENTRY
ADD TA,NAMLOC
HRRZ TC,(TA) ;GET ADDRESS OF DATAB ENTRY
MOVE TA,TC
PUSHJ PP,LNKSET ;MAKE REAL ADDRESS
LDB TA,DA.RPW ;GET RPWTAB LINK
ADD TA,RPWLOC ;MAKE LINK REAL ADDRESS
LDB TD,RW.TYP ;GET TYPE OF REPORT GROUP
CAIE TD,%RG.DE ;DETAIL GROUP ?
EWARNJ E.364 ;NO, GENERATE FATAL ERROR AND RETURN
MOVE TA,TB ;TA CONTAINS NEW ADDRESS OF RPWTAB UPON ENTRY
ADD TA,RPWLOC
DPB TC,RW.UP1## ;STORE POINTER TO RPWTAB ENTRY
SETO TB,
DPB TB,RW.RSU## ;SET REFERENCED-BY-SUM-UPON
HRRZ TA,CURRPW ;GET LINK TO CURRENT RPWTAB ENTRY
LDB TB,RW.NUP## ;GET NUMBER OF UPON DATA ITEMS
ADDI TB,1 ;INCREMENT
DPB TB,RW.NUP
POPJ PP,
;SET UP FOR SUM CLAUSE
INTER. DA103.
DA103.: HRRZ TA,CURRPW ;PTR TO RPWTAB
LDB TB,RW.SCD ;SEEN SUM, ETC YET?
JUMPN TB,JCE16. ;YES, DUP. CLAUSE
LDB TC,RW.TYP ; [315] SUM CLAUSE ALLOWED
CAIE TC,%RG.CF ; [315] ONLY FOR CF
EWARNJ E.363 ; [315]- ERROR
HRRZI TB,%RG.SM ;NO, INDICATE ITEM HAS A SUM CLAUSE
DPB TB,RW.SCD
LDB TE,RW.DAT ;GET LINK TO CORRESP. DATAB ITEM
PUSH PP,TE ;SAVE
MOVE TA,[CD.HLD,,SZ.HLD] ;GET A HLDTAB ENTRY
PUSHJ PP,GETENT
HRRZI TB,%HL.SC ;SET "BUILD-SUM-CTR" CODE
DPB TB,HL.COD
POP PP,TE
DPB TE,HL.LNK ;& PUT IN LINK TO DATAB ITEM
HRRZ TC,RPTCID ; [415] GET LEVEL NUMBER
DPB TC,HL.CID## ; [415] STORE INTO HLDTAB
HRRZ TC,RPWRDL ; [415] GET RD LINK
DPB TC,HL.RD## ; [415] STORE INTO HLDTAB
POPJ PP,
;SET DEFAULTS FOR PAGE LIMIT CLAUSE
INTER. DA104.
DA104.: PUSHJ PP,GETRDL ;GET PTR TO RPWTAB GROUP ENTRY
LDB TB,RW.PHL ;GET PAGE HEADING LINE #
JUMPN TB,.+3 ;SET?
MOVEI TB,1 ;NO, MAKE IT 1
DPB TB,RW.PHL
LDB TC,RW.FDE ;GET FIRST DETAIL LINE #
JUMPN TC,.+3 ;SET?
MOVEI TC,(TB) ;NO, DEFAULT = PHL
DPB TC,RW.FDE
CAMLE TB,TC ;[215] HEADING .LE. FIRST DETAIL?
JRST JCE489 ;[215] NO IS AN ERROR
LDB TB,RW.PAG ;PAGE LIMIT
LDB TC,RW.LDE## ;LAST DETAIL
LDB TD,RW.CFL ;FOOTING
JUMPN TC,DA104A ;LDE SET?
JUMPN TD,.+2 ;NO, CFL SET?
MOVEI TD,(TB) ;NO, NEITHER SET. MAKE BOTH = PAGE LIMIT
MOVEI TC,(TD) ;MAKE LDE = CFL
JRST .+3
DA104A: JUMPN TD,DA104B ;LDE SET. IS CFL SET?
MOVEI TD,(TC) ;NO, MAKE CFL = LDE
DPB TC,RW.LDE ;STORE VALUES
DPB TD,RW.CFL
DA104B: CAMLE TC,TD ;[215] LDE .LE. CFL?
JRST JCE491 ;[215] NO - SO ERROR
LDB TB,RW.FDE ;[215]
CAMLE TB,TC ;[215] FDE .LE. LDE?
JRST JCE490 ;[215] NO - SO ERROR
POPJ PP,
;CK FOR MISSING PERIOD ON DATA ITEM
INTER. DA105.
DA105.: CAIE TYPE,INTGR.
CAIN TYPE,2000+INTGR.
JRST DA105B
CAIN TYPE,2000+FD. ;[1376] IS IT FD?
JRST DA105A ;[1376] REGET WORD?
CAIE TYPE,2000+PROC.
CAIN TYPE,2000+WORKI.
JRST DA105A
CAIE TYPE,2000+REPOR.
CAIN TYPE,2000+LINKG.
DA105A: SWONS FREGWD;
EWARNJ E.18 ;IMPROPER CLAUSE
PUSHJ PP,CE125. ;PERIOD ASSUMED
JRST DA107. ;POP UP A LEVEL IN TREE
DA105B: LDB TB,GWVAL ;GET THE INTEGER
MOVEM TB,CTR
HRRZI TA,LITVAL
PUSHJ PP,GETVAL##
CAIN TC,^D77
JRST DA105A
CAIL TC,1
CAILE TC,^D49
EWARNJ E.18 ;IMPROPER CLAUSE
JRST DA105A ;THEN PERIOD ASSUMED ERROR
;STORE CODE LINK
INTER. DA106X
DA106X: HRRZ TA,CURRPW ;GET CURRENT ENTRIES RPWTAB LINK
LDB TA,RW.FIL ;GET FILTAB LINK
ADD TA,FILLOC## ;MAKE IT ABSOLUTE
LDB TB,FI.COD
LDB TC,FI.MRE
SKIPE TB ;CODE CLAUSE SEEN FOR OTHER REPORTS ?
SETZ TC, ;YES
JUMPN TC,DA106E ;IF MORE THAN ONE REPORT IN THIS FILE, GIVE WARNING
SETO TB,
DPB TB,FI.COD## ;SET CODE CLAUSE SEEN FOR THIS FILE
POPJ PP,
DA106E: EWARNW E.778 ;CODE CLAUSE MUST APPEAR FOR ALL OR NONE
POPJ PP,
INTER. DA106.
DA106.: FLAGAT 68
LDB TA,[POINT 15,W2,15] ;NAMTAB LINK
HRRZI TB,CD.MNE
PUSHJ PP,FNDLNK
TRN
HLRZS TB
DA106S: PUSHJ PP,GETRDL ;GET PTR TO RD ENTRY
DPB TB,RW.COD##
POPJ PP,
INTER. DA106A
DA106A: HLRZ TB,W1 ;GET LENGTH OF LITERAL
ANDI TB,777
CAIN TB,2 ;SHOULD BE EXACTLY 2 CHARACTERS
JRST DA106B ;IT IS
HRRZI DW,E.746 ;NO WARN
PUSHJ PP,DA24X.
DA106B: MOVE TA,[CD.MNE,,SZ.MNE]
PUSHJ PP,GETENT ;FAKE UP A MNEMONIC TABLE ENTRY
MOVSI TB,700000
MOVEM TB,(TA) ;SET CODE
HLRZ TB,LITVAL ;GET LITERAL
LSH TB,-4 ;ONLY 2 CHARACTERS
HRL TB,MTCODE ;AND SET CODE BIT
MOVEM TB,1(TA)
HLRZ TB,TA ;GET MNEMONIC TABLE ADDRESS
JRST DA106S ;AN STORE IN CURRENT RPWTAB
;END OF DATA ITEM
;IF IN REPORT SECTION AND ITEM HAS NO NAME, GIVE IT ONE
INTER. DA107.
DA107.: SKIPN REPSEC ;IN REPORT SECTION?
JRST DA0. ;NO, POP UP A LEVEL IN TREE
PUSHJ PP,FAKNAM ;YES
HRRZ TA,CURDAT ;GET DATAB LINK TO CURRENT DATA NAME
LDB LN,DA.LN ;RESTORE LN
LDB CP,DA.CP ; AND CP OF DATA ITEM
HRRZI DW,E.784 ;GET READY FOR POSSIBLE ERROR
LDB TB,DA.PIC
HRRZ TA,CURRPW ;GET RPWTAB LINK TO CURRENT DATA NAME
LDB TC,RW.GPI ;GROUP INDICATE SEEN FOR THIS DATA ITEM ?
JUMPE TC,DA0. ;NO, EXIT
LDB TC,RW.COL
SKIPE TB ;PICTURE CLAUSE SEEN ?
SKIPN TC ;AND COLUMN CLAUSE SEEN ?
PUSHJ PP,WARN ;NO, GENERATE WARNING
JRST DA0. ;NOW POP UP A LEVEL IN TREE
SUBTTL TABLE HANDLING SYNTAX
;ASCENDING KEY FOR OCCURS
INTER. DA108.
DA108.: HRRZI TB,%HL.KY ;ASC. KEY CODE
DA108X: FLAGAT HI
MOVEM TB,TBLOCK ;SAVE CODE UNTIL NAME SEEN
POPJ PP,
;DESCENDING KEY FOR OCCURS
INTER. DA109.
DA109.: HRRZI TB,%HL.DY ;DESC. KEY CODE
JRST DA108X
;ASCENDING/DESCENDING KEY FOR OCCURS
INTER. DA110.
DA110.: PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZ TB,TBLOCK ;STORE KEY CODE
DPB TB,HL.COD
HRRZ TA,CURDAT## ;PTR TO DATAB ENTRY
LDB TB,DA.PWA ;PIC WORDS ALLOCATED?
JUMPN TB,DA110A ;YES
MOVE TA,[CD.DAT,,SZ.MSK] ;NO, DO IT
PUSHJ PP,GETENT
HRRZ TA,CURDAT
SETO TB, ;& SAY SO
DPB TB,DA.PWA
DA110A: LDB TB,DA.KEY## ;INCREMENT KEY CTR
ADDI TB,1
CAIG TB,377 ;[1346] UP TO 255 KEYS ALLOWED
JRST DA110C ;[1346]
MOVEI DW,E.756 ;[1346] ELSE QUANTITY GETS TRUNCATED
PUSHJ PP,FATALW ;[1346]
DA110C: DPB TB,DA.KEY ;[1346]
SOJE TB,DA110B ;[220] IS THIS THE MAJOR KEY?
LDB TB,[POINT 15,(TA),17] ;[220] NO, GET THE GROUP'S NAMTAB REL ADR.
HLRZ TC,CURNAM ;[220] GET THE CURRENT ITEM'S NAMTAB REL ADR.
CAIE TB,(TC) ;[220] ARE THEY THE SAME ITEM?
JRST DA110B ;[220] NO, NO PROBLEMS.
;[220] WE GET HERE IF WE HAVE A MINOR KEY WHICH IS ALSO THE SUBJECT OF THE OCCURS.
;[220] ERROR MESSAGE: FATAL - A GROUP ITEM MAY NOT BE A MINOR KEY
MOVEI DW,E.151 ;[220] SET UP ERROR NUMBER.
PUSHJ PP,FATALW ;[220] GO PUT IT IN THE ERROR FILE.
DA110B: MOVE TA,[CD.DAT,,1] ;GET A WORD ON DATAB ENTRY FOR KEY
PUSHJ PP,GETENT
HLRZ TB,TA ;SAVE DATAB ADDR
HLRZ TC,CURHLD
HRRZ TA,HLDLOC## ;MAKE ABS. PTR TO HLDTAB ENTRY
ADDI TA,(TC)
DPB TB,HL.LNK ;STORE DATAB PTR IN HLDTAB
POPJ PP,
;INITIALIZE LINKAGE SECTION
INTER. DA112.
DA112.: SETOM LNKSEC## ;SET LINKAGE SECTION FLAG
SETOM SUBPRG## ;THIS IS A SUBPROGRAM
MOVE TB,EAS1PC ;SAVE DATA PC WHILE DOING
MOVEM TB,PCHOLD ; LINKAGE SECTION
JRST DA3.0 ;REST IS LIKE WORKING-STORAGE
SUBTTL DBMS SYNTAX
;ACTIONS FOR INVOKE VERB
IFN DBMS,<
INTER. DA113.
DA113.: SKIPE SCHSEC## ;SCHEMA SECTION SEEN BEFORE
EWARNW E.408 ;YES, GIVE ERROR
FLAGAT DB
PUSHJ PP,DA119B ;[476] SEE IF ANY OTHER SECTIONS SEEN
SETOM SCHSEC
SETZM INVSEE## ;[%316]
SETZM ACCSEE## ;[%316]
SETZM DBCNTC## ;CLEAR COUNT OF "INVOKE"/ACCESS'S
POPJ PP, ;[%316] DELAY FUDGED SECTION SETTING TILL INVOKE OR ACCESS SEEN
INTER. DA114A
DA114A: DMOVEM LN,INVLN## ;SAVE LN AND CP FOR INVOKE
SKIPE DBCNTC## ;[%316] ERROR IF NON-0, DELAY MSG
POPJ PP, ;[%316]
SETOM INVSEE##
PUSHJ PP,DA10. ;[%316] DOWN FROM DA113--PRETEND THAT IT'S A W-S SECTION
JRST DA3. ;[%316] DITTO
INTER. DA114B
;[%316] DA114B NEW--FOR ACCESS. NOTE 114. MADE 114A FOR SYMMET.
DA114B: DMOVEM LN,INVLN## ;SAVE LN AND CP FOR INVOKE
SKIPE DBCNTC## ;[%316] ERROR IF NON-0, DELAY MSG
POPJ PP, ;[%316]
SETOM ACCSEE##
PUSHJ PP,DA10. ;[%316] PRETEND THAT IT'S A LINKAGE SECTION
JRST DA112. ;[%316] DITTO
INTER. DA115.
DA115.: MOVE TA,[NAMWRD,,S.SCH##] ;[%316] MAKE IT HANDLE 30-CHARACTER SUBSCHEMAS
BLT TA,S.SCH##+4 ;[%316]30 SIXBIT CHARS IN 5 WORDS
POPJ PP, ;[%316]PASS THRU FOR COMPAT WITH PREPRO
INTER. DA116.
DA116.: MOVE TA,NAMWRD
MOVEM TA,SCHEMA##
POPJ PP, ;[%316]PASS THRU FOR COMPAT WITH PREPRO
INTER. DA117.
DA117.: MOVE TA,NAMWRD
MOVEM TA,PKEY##
POPJ PP, ;[%316]PASS THRU FOR COMPAT WITH PREPRO
;THIS ACTION SETS UP THE WORLD FOR GETITM TO CONTINUE READING
;FROM THE NEW ###DBC.TMP FILE.
INTER. DA119.
DA119.: AOS TA,DBCNTC ;BUMP COUNT OF "INVOKE"'S
CAILE TA,1 ;[%316]NEW RULE IS AT MOST ONE INV. PER P-U
JRST E.MXIN
PUSHJ PP,DDL.## ;CREATE DDL FILES
IFE TOPS20,<
CALLI TC,$PJOB ;GET JOB NUMBR
MOVEI TD,3
IDIVI TC,^D10
ADDI TB,"0"-40
LSHC TB,-6
SOJG TD,.-3 ;LH OF TA HAS # IN DECIMAL
HRRI TA,'DBC' ;GET REST OF FILENAME
MOVEM TA,DBBLCK##
HRLZI TA,'TMP' ;GET EXTENSION
MOVEM TA,DBBLCK+1
SETZM DBBLCK+2
SETZM DBBLCK+3
SETZM DBOPBK## ;SET MODE TO ASCII
MOVSI TA,'DSK'
MOVEM TA,DBOPBK+1 ;PUT DEVICE NAME IN
HRRZI TA,DBBUFH##
MOVEM TA,DBOPBK+2 ;PUT BUFFER HEADER ADDR IN
MOVE TA,[POINT 7,DBUFF1+3]
MOVEM TA,DBBUFH+1
MOVE TA,[XWD 201,DBUFF1+1]
MOVEM TA,DBUFF1+1
OPEN DBCHAN,DBOPBK ;TRY AN OPEN
JRST OPNERR
MOVE TA,[XWD 400000,DBUFF1##+1]
MOVEM TA,DBBUFH
LOOKUP DBCHAN,DBBLCK ;IS FILE THERE?
JRST NOTFND
IN DBCHAN, ;GET A BUFFER
TRNA ;OK
JRST INPERR
>
IFN TOPS20,<
PUSHJ PP,SETDBS## ;OPEN "DBC" FILE FOR READ
>
SETOM FINVOK## ;SET INVOKE FLAG
SETOM FINVD## ;TELL COBOLD TO READ FILE.
TSWFZ FSEQ ;[453] IS /S SWITCH ON--IF YES TURN IT OFF
SETOM DBONLY## ;[453] IT WAS ON, REMEMBER IT
POPJ PP,
E.MXIN: OUTSTR [ASCIZ /?CBLTMI--too many "INVOKES" specified
?Cannot continue
/]
IFE TOPS20,<
CALLI $EXIT
>
IFN TOPS20,<
HALTF%
JRST .-1
>
IFE TOPS20,<
OPNERR: OUTSTR [ASCIZ /?FATAL--OPEN/]
ALLERR: OUTSTR [ASCIZ / error on file /]
SETZ TA,
MOVEI TE,3
MOVE TD,[POINT 7,TA]
MOVE TC,[POINT 6,DBBLCK]
ALL2: ILDB TB,TC
ADDI TB,40
IDPB TB,TD
SOJG TE,ALL2
OUTSTR TA
OUTSTR [ASCIZ /DBC.TMP
?Cannot continue
/]
CALLI $EXIT
NOTFND: OUTSTR [ASCIZ "?FATAL--LOOKUP"]
JRST ALLERR
INPERR: MOVE TA,PKEY ;[513] GET PRIVACY KEY
AOJE TA,[EWARNJ E.429] ;[513] PRIV KEY OF -1 = BAD KEY
OUTSTR [ASCIZ /?FATAL--INPUT/]
JRST ALLERR
>
DA119A: SKIPE SCHSEC## ;[476] SCHEMA SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
DA119B:
IFN MCS,<
SKIPN CSSEEN## ;[476] COMM. SECTION SEEN?
>
DA119C: SKIPE WRKSEC## ;[476] WORKING-STORAGE SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
SKIPGE LNKSSN## ;[763] [476] LINKAGE SECTION SEEN ?
SKIPGE ACCSEE## ;[476] ACCESS VERB USED?
SKIPE REPSSN## ;[763] [476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
POPJ PP, ;[476] OK, RETURN
>
SUBTTL MCS SYNTAX
IFN MCS,<
INTER. DA120.
DA120.: SKIPE CSSEEN## ;COMM SEC SEEN?
EWARNJ E.432
SETOM CSSEEN
FLAGAT HI
SKIPE REPSSN ;COMM SECTION IS LAST EXCEPT FOR REPORT SECTION
EWARNJ E.470
SETOM LSTW77## ;[476] CLEAR IN CASE WORKING-STORAGE SEEN
SWOFF FFILSC
SETZM REPSEC
SETZM LNKSEC
IFN DBMS,< ;[503]
SKIPE INVSEE## ;[412] IF INVOKE SEEN,W-S SEC STUFF DONE
POPJ PP, ;[412] DON'T DO IT AGAIN
> ;[503]
SKIPL TA,PCHOLD
MOVEM TA,EAS1PC
SETOM PCHOLD
SKIPE WRKSEC ;HAVE WE SEEN WORK-SEC?
POPJ PP, ;YES, DON'T DO ANYTHING
PUSHJ PP,DA10. ;NO, PRETEND THIS IS IT
JRST DA3.
INTER. DA121.
DA121.: TLO W2,GWDEF
PUSHJ PP,PUTCRF ;PUT OUT CREF LISTING
PUSHJ PP,TRYNAM ;CD-NAME IN NAMTAB?
PUSHJ PP,BLDNAM ;PUT IT IN
MOVEM TA,CURNAM
HLRZS TA
DPB TA,[POINT 15,W2,15] ;SET UP W2
MOVE TA,[XWD CD.CD,SZ.CD] ;GET CDTAB CODE AND SIZE
PUSHJ PP,GETENT
MOVEM TA,CURCD##
LDB TB,[POINT 15,W2,15]
CLEARM (TA) ;CLEAR 1ST WORD
DPB TB,CD.NAM## ;PUT IN NMTAB LINK
LDB TB,[POINT 20,W2,35] ;GET LN,CP
MOVEM TB,1(TA)
HLR TA,CURNAM
PJRST PUTLNK ;SET SAME-NAME CHAIN
INTER. DA122.
DA122.: MOVE TA,CURCD
SKIPE FINITL## ;HAVE WE SEEN INITIAL BEFORE?
EWARNJ E.446 ;YES, BOOBOO
MOVEM TA,FINITL ;SAVE ADDR OF INITIAL ENTRY
MOVEI TB,1
DPB TB,CD.INT## ;THIS ALSO CLEARS INPUT BIT
POPJ PP,
INTER. DA123.
DA123.: MOVEI TA,CDBLK##
HRLI TA,^D-11 ;SET UP TO CLEAR CDBLK
CLEARM (TA)
AOBJN TA,.-1
CLEARM CDINDX## ;CLEAR INDEX TOO
POPJ PP,
INTER. DA124.
DA124.: HRRZI TA,^D10
SAVIDX: MOVEM TA,CDINDX ;SAVE CDBLK INDEX
POPJ PP,
INTER. DA125.
DA125.: CLEARM CDINDX
JRST DA7. ;REGET WORD
INTER. DA126.
DA126.: CLEARM CDINDX
POPJ PP,
INTER. DA127.
DA127.: HRRZI TA,1
JRST SAVIDX
INTER. DA128.
DA128.: HRRZI TA,2
JRST SAVIDX
INTER. DA129.
DA129.: HRRZI TA,3
JRST SAVIDX
INTER. DA130.
DA130.: HRRZI TA,6
JRST SAVIDX
INTER. DA131.
DA131.: HRRZI TA,4
JRST SAVIDX
INTER. DA132.
DA132.: HRRZI TA,5
JRST SAVIDX
INTER. DA133.
DA133.: HRRZI TA,7
JRST SAVIDX
INTER. DA134.
DA134.: HRRZI TA,^D8
JRST SAVIDX
INTER. DA135.
DA135.: HRRZI TA,^D9
JRST SAVIDX
INTER. DA136.
DA136.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
MOVEI TB,CDBLK##
ADD TB,CDINDX
HLRZ TA,TA ;GET REL. ADDR
SKIPE (TB) ;ENTRY ALREADY GIVEN?
EWARNW E.447 ;YES
DPB TA,[POINT 15,W2,15]
MOVEM W2,(TB) ;PUT INTO CDBLK
POPJ PP,
INTER. DA137.
DA137.: MOVE TA,CDINDX
CAIL TA,^D12 ;12 DATA-NAMES?
EWARNJ E.434 ;YES
PUSHJ PP,DA136.
AOS CDINDX ;BUMP INDEX
POPJ PP,
INTER. DA138.
DA138.: HRRZ TA,CURCD
MOVEI TB,1
DPB TB,CD.OUT##
MOVEI TA,CDBLK
HRLI TA,^D-11 ;SET UP TO CLEAR CDBLK
CLEARM (TA)
AOBJN TA,.-1
POPJ PP,
;MACRO TO DISTINGUISH BETWEEN INPUT OR OUTPUT CD:
DEFINE IFINP(.A)
<HRRZ TC,CURCD
SKIPL 1(TC)
JRST .A>
INTER. DA139.
DA139.: MOVEI TA,1 ;DA26.
MOVEM TA,DATLVL
MOVEM TA,LEVEL
SETZM RUSAGE ;---
PUSH PP,FLGSW ;SAVE FIPS FLAGGING BITS
SETZM FLGSW ;IGNORE POSSIBLE FLAGGER ERRORS
MOVE TA,[SIXBIT /FILLER/]
MOVEM TA,NAMWRD
CLEARM NAMWRD+1
TLO W2,GWDEF ;MAKE IT DEFINED
MOVEI CT,FILLE. ;MAKE IT "FILLER"
PUSHJ PP,DA27A ;DA27A
MOVE TA,CURDAT
HLRZ TD,CURCD
DPB TD,DA.POP## ;SET FATHER LINK
SETO TD,
DPB TD,DA.FAL ;SET FATHER BIT
CLEAR TD,
DPB TD,DA.CLA## ;CLASS
MOVE TA,CURDAT ;REPLACE TA
MOVEI TD,2
DPB TD,DA.USG ;USAGE
PUSHJ PP,DA30N. ;DA30N
MOVEI TE,CDBLK ;TE==CDBLK PTR
HRRZ TB,CURCD
ADDI TB,2 ;TB==CDTAB + 2
LDB TD,[POINT 7,-1(TB),35] ;SET UP LN,CP
DPB TD,DA.CP
LDB TD,[POINT 13,-1(TB),28]
DPB TD,DA.LN
TLO TB,442200 ;MAKE IT A XWD BYTE PTR
HLRZ TD,CURDAT
IDPB TD,TB ;PUT IN CD LINK
IFINP DA139A
ADDI TB,2 ;BUMP CDTAB PTR BY 5 XWD'S
IBP TB
ADDI TE,3 ;BUMP CDBLK PTR BY 3
DA139A: IFINP D139AA
CAIE TE,CDBLK+8 ;IF THIS IS ENTRY 8 OR 9...
CAIN TE,CDBLK+9
SKIPA TD,[3] ;...THEN MAKE IT LEVEL 3
D139AA: MOVEI TD,2 ;DA11.
MOVEM TD,(SAVPTR)
PUSHJ PP,PUSHEM
PUSHJ PP,DA28. ;DA28.
PUSHJ PP,POPEM
IFINP D139AB
CAIN TE,CDBLK+6 ;IF ENTRY 6, GO BUILD SPECIAL ENTRY
JRST D139OC
D139AB: MOVEI CT,USERN.
SKIPE W2,(TE) ;GET CDBLK ENTRY
JRST DA139B ;OK, WE HAVE ONE
MOVE TD,[SIXBIT /FILLER/]
MOVEM TD,NAMWRD
CLEARM NAMWRD+1
MOVEI CT,FILLE. ;MARK TYPE AS FILLER SO WE DON'T CREF IT
PUSHJ PP,PUSHEM
PUSHJ PP,TRYNAM ;IN NAMTAB? (IT SHOULD BE)
PUSHJ PP,BLDNAM
PUSHJ PP,POPEM
HLRZS TA ;GET REL. ADDR
HRRZ TD,CURCD
LDB TD,[POINT 20,1(TD),35] ;GET LN,CP
DPB TD,[POINT 20,(TE),35] ;PUT INTO CDBLK
DPB TA,[POINT 15,W2,15] ;SET NAMTAB LINK
DA139B: HLRZ W1,CURCD
PUSHJ PP,PUSHEM
PUSHJ PP,DA29. ;DA29.
MOVE TE,0(PP) ;RECOVER TE
IFINP DA139C
CAIN TE,CDBLK+3 ;IF ENTRY 3, SET DEFAULT VALUE
SKIPE CDBLK+6 ;IF DESTINATION TABLE IS ZERO
JRST DA139C
MOVE TA,[CD.LIT,,SZ.LIT]
PUSHJ PP,GETENT ;GET SPACE FOR DEFAULT VALUE
MOVSI TB,1201
MOVEM TB,0(TA) ;STORE BITS
MOVSI TB,(ASCII/1/)
MOVEM TB,1(TA) ;STORE VALUE
HLRZ TB,TA ;GET REL LOCATION
HRRZ TA,CURDAT
DPB TB,DA.VAL ;STORE VALTAB LINK
DA139C: PUSHJ PP,DA30N. ;DA30N
PUSHJ PP,POPEM
HLRZ TA,CURDAT ;GET REL ADDR
IDPB TA,TB ;PUT INTO CDTAB
HRR TA,CURDAT ;GET ABS ADDR
IFINP .+3
MOVEI TD,OUTPIC-3(TE) ;SET UP WITH OUTPUT PIC TABLE
SKIPA
MOVEI TD,INPIC(TE)
SUBI TD,CDBLK ;THIS GIVES ADDRESS IN INPIC
MOVE TD,(TD) ;GET INPIC ENTRY
DPB TD,DA.EXS ;EXTERNAL SIZE
DPB TD,DA.INS ;INTERNAL SIZE
SKIPL TD ;NUMERIC?
TDZA TC,TC ;NO, ALPHANUMERIC
MOVEI TC,2
DPB TC,DA.CLA ;SET CLASS
MOVEI TC,2 ;DISPLAY-7
DPB TC,DA.USG
LSH TC,-1 ;MAKE IT A "1"
DPB TC,DA.PIC ;PIC SEEN
LDB TC,[POINT 13,(TE),28] ;LN
DPB TC,DA.LN
LDB TC,[POINT 6,(TE),35] ;CP
DPB TC,DA.CP
AOS TE ;BUMP CDBLK PTR
CAIGE TE,CDBLK+^D11 ;THRU CDBLK?
JRST DA139A ;NO
POP PP,FLGSW ;TURN ON FLAGGER AGAIN
JRST DA8. ;********EXIT*********
D139OC: MOVE TA,[SIXBIT /FILLER/]
MOVEM TA,NAMWRD
CLEARM NAMWRD+1
PUSHJ PP,PUSHEM
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZS TA ;GET REL ADDR.
DPB TA,[POINT 15,W2,15]
MOVEI CT,FILLE.
HLRZ W1,CURCD ;AND TABLE LINK
PUSHJ PP,DA29.
PUSHJ PP,DA30N. ;BUILD FILLER
PUSHJ PP,POPEM
HRRZ TA,HLDSAV## ;GET SAVED HLDTAB ENTRY
JUMPE TA,D13902
HLRZ TD,CURDAT ;GET CURRENT DATAB PTR
HLRZ TC,CDBLK+7 ;GET COUNTER
DPB TD,HL.LNK ;PUT DATAB LINK IN HLDTAB
ADDI TA,2
SOJG TC,.-2
SETZM HLDSAV ;CLEAR IT
D13902: HRRZ TC,CURCD
LDB TD,[POINT 13,1(TC),28]
HRR TA,CURDAT
DPB TD,DA.LN ;FIX LN,CP
LDB TD,[POINT 6,1(TC),35]
DPB TD,DA.CP
MOVE TC,(TE) ;GET # OF OCCURANCES
ADDI TE,2 ;BUMP CDBLK PTR TO WORD 8
JUMPE TC,DA139A ;IF NO OCCUR.,DON'T DO ANY MORE
MOVEM TC,(SAVPTR)
PUSHJ PP,PUSHEM
PUSHJ PP,D33MCS ;FIX DATAB ENTRY
PUSHJ PP,POPEM
MOVE TA,CURDAT ;GET LEVEL 2 DATAB LINK
HRRZ TC,CDBLK+7 ;GET INDEX POINTER
SKIPE TC ;NO INDEXED BY PHRASE
DPB TC,DA.XBY## ;PUT "INDXD BY" IN DATAB
JRST DA139A
INTER. DA140.
DA140.: PUSHJ PP,DA11. ;GET INTEGER VALUE
JUMPLE TC,JCE25. ;VALUE MUST BE BETWEEN 1 AND 50
CAILE TC,^D50
; CAIE TC,1 ;ONLY 1 ALLOWED
EWARNW E.445
MOVEM TC,CDBLK+6
POPJ PP,
INTER. DA141.
DA141.: SETOM COMSEC## ;SET COMM. SECTION ACTIVE
PUSHJ PP,DA34.
CLEARM COMSEC ;THIS IS ONLY PLACE WE NEED IT
HLRZ TA,CDBLK+7 ;GET INDEX COUNT
AOS TA ;BUMP IT
HRLM TA,CDBLK+7
CAIE TA,1 ;IS THIS THE FIRST ONE?
POPJ PP,
HLRZ TA,CURHLD ;YES, SAVE HLDTAB LINK
HRRM TA,CDBLK+7
MOVE TB,CURHLD
MOVEM TB,HLDSAV## ;SAVE 1ST HLDTAB ENTRY PTR
POPJ PP,
INTER. DA142.
DA142.: SWON FREGWD
JRST DA135.
INTER. DA143.
DA143.: SETOM COMSEC ;SET COMM.SECTION ACTIVE
JRST DA7.
INTER. DA144.
DA144.: CLEARM COMSEC ;CLEAR COMM. SECTION ACTIVE
POPJ PP,
PUSHEM: POP PP,TD
PUSH PP,TB
PUSH PP,TE
JRST (TD)
POPEM: POP PP,TD
POP PP,TE
POP PP,TB
JRST (TD)
;THIS IS A TABLE INDICATING THE DATA TYPE AND LENGTH OF EACH
;ENTRY IN THE CDBLK. THE RIGHT HALF IS THE LENGTH AND BIT 0
;IS THE CLASS----0=ALPHANUMERIC
; 1=NUMERIC
NUMERIC==400000
INPIC: XWD 0,^D12
XWD 0,^D12
XWD 0,^D12
XWD 0,^D12
XWD NUMERIC,6
XWD NUMERIC,^D8
XWD 0,^D12
XWD NUMERIC,4
XWD 0,1
XWD 0,2
XWD NUMERIC,6
;SAME TABLE FOR OUTPUT PICS (1ST 3 ENTRIES OF CDBLK DON'T HAVE ENTRIES
;IN THIS TABLE.
OUTPIC: XWD NUMERIC,4
XWD NUMERIC,4
XWD 0,2
Z ;DUMMY ENTRY
Z
XWD 0,1
XWD 0,^D12
IFE TOPS20,<
XWD 0,^D8 ;MCS-10 EXTENSION
>
IFN TOPS20,<
XWD 0,^D12 ;TCS-20 EXTENSION
>
>;END IFN MCS
SUBTTL RECORDING MODE CLAUSE.
; ASCII
INTER. DA145.
DA145.: HRRZI TB, %RM.7B
JRST DA150D
; STANDARD-ASCII
INTER. DA146.
DA146.: HRRZI TB, %RM.SA
JRST DA150D
; SIXBIT
INTER. DA147.
DA147.: HRRZI TB, %RM.6B
JRST DA150D
; BINARY
INTER. DA148.
DA148.: HRRZI TB, %RM.BN
JRST DA150D
; F, V OR ERROR.
INTER. DA149.
DA149.: HLRZ TC, NAMWRD## ;SEE WHAT WE GOT.
CAIE TC, (SIXBIT /F/) ;WAS IT F OR
CAIN TC, (SIXBIT /V/) ; V?
SWOFFS FREGWD; ;YES, DON'T REGET IT.
EWARNJ E.578 ;NO, GO COMPLAIN.
HRRZ TA, CURFIL## ;GET THE FILE TABLE ADDRESS.
LDB TB, FI.RM2## ;DO WE ALREADY HAVE A RM?
JUMPN TB, JCE16. ;IF WE DO, GO COMPLAIN.
LDB TB, FI.VRS ;WAS 'VARYING' SPECIFIED?
LDB TD, FI.VLR ;WAS 'REC CTN nn TO nn' SPECIFIED?
SKIPN TB ;
SKIPE TD ;
SKIPA ;
JRST D149.A ;NEITHER WERE SPECIFIED
CAIN TC, (SIXBIT /F/) ;
EWARNW E.584 ;YES, ERROR IF RECORDING MODE F
D149.A: SETO TB, ;GET SOME ONES.
CAIN TC, (SIXBIT /V/) ;VARIABLE LENGTH?
DPB TB, FI.VLR## ;YES, TURN ON THE VLR FLAG.
HRRZI TB, %RM.EB ;MAKE IT EBCDIC.
;SET THE RECORDING MODE.
DA150D: HRRZ TA, CURFIL## ;GET THE FILE TABLE'S ADDRESS.
LDB TC, FI.RM2## ;IF WE ALREADY HAVE A RM
JUMPN TC, DA150C ; MAKE SURE ITS THE SAME OR ELSECOMPLAIN.
DPB TB, FI.ERM## ;SET IT.
SETO TB, ;NOTE THAT WE HAVE ONE.
DPB TB, FI.RM2##
POPJ PP, ;RETURN.
DA150C: LDB TC,FI.ERM ;GET CURRENT RECORDING MODE
CAME TC,TB ;SAME AS WHAT WE WANT?
JCE16.: EWARNJ E.16 ;NO, DUPLICATE CLAUSE
POPJ PP, ;YES, ALLOW IT
;SET THE BYTE MODE.
INTER. DA150B
DA150B: HRRZ TA,CURFIL## ;GET THE FILE TABLE'S ADDRESS.
SETO TB,
DPB TB,FI.BM## ;SET BYTE MODE
POPJ PP, ;RETURN.
SUBTTL COBOL-74 SYNTAX
;SET LINAGE SEEN IN FILE TABLE
INTER. DA200.
DA200.: FLAGAT HI
HRRZ TA,CURFIL
SETO TB,
DPB TB,FI.LCP## ;SET LINAGE COUNTER REQUIRED
POPJ PP,
DA200V: TLNN W1,GWNLIT ;IS ITEM NUMERIC LITERAL?
JRST DA200Z ;NO
TLNE W1,GWDP ;IS IT INTEGER?
JRST DA200Z ;NO
LDB TB,GWVAL ;NO. OF CHARACTERS
MOVEM TB,CTR##
HRRZI TA,LITVAL##
PJRST GETVAL
DA200Z: EWARNW E.25
SETZ TC,
POPJ PP,
;STORE LINES PER PAGE
INTER. DA201.
DA201.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA202A
INTER. DA202.
DA202.: PUSHJ PP,DA200V ;GET VALUE
DA202A: HRRZ TA,CURFIL
DPB TC,FI.LPP## ;STORE NO. OF LINES PER PAGE
POPJ PP,
;STORE FOOTING AT
INTER. DA203.
DA203.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA204A
INTER. DA204.
DA204.: PUSHJ PP,DA200V ;GET VALUE
DA204A: HRRZ TA,CURFIL
DPB TC,FI.WFA## ;STORE WITH FOOTING AT LINE NUMBER
POPJ PP,
;STORE LINES AT TOP
INTER. DA205.
DA205.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA206A
INTER. DA206.
DA206.: PUSHJ PP,DA200V ;GET VALUE
DA206A: HRRZ TA,CURFIL
DPB TC,FI.LAT## ;STORE NO. OF LINES AT TOP
POPJ PP,
;STORE LINES AT BOTTOM
INTER. DA207.
DA207.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA208A
INTER. DA208.
DA208.: PUSHJ PP,DA200V ;GET VALUE
DA208A: HRRZ TA,CURFIL
DPB TC,FI.LAB## ;STORE NO. OF LINES AT BOTTOM
POPJ PP,
;DEBUG-ITEM
DA210.: MOVE TB,[SIXBIT /DEBUG:/]
MOVEM TB,NAMWRD
MOVE TB,[SIXBIT /ITEM/]
MOVEM TB,NAMWRD+1
SETZM NAMWRD+2
MOVE TA,[NAMWRD+2,,NAMWRD+3]
BLT TA,NAMWRD+5 ;CLEAR REST OF NAMWRD
PUSHJ PP,TRYNAM ;SEE IF NAME ALREADY EXISTS
TRNA ;NO
EWARNJ E.731 ;YES, ERROR
PUSH PP,EAS1PC ;SAVE CURRENT LOCATION FOR DEBUG-CONTENTS-INDEX
AOS EAS1PC ;ALLOW 1 WORD FOR IT
PUSHJ PP,DA211. ;PUT ENTRY IN DATAB
HLRZM TA,DEBSW ;SAVE LINK TO DEBUG-ITEM
PUSH PP,DEBSW ;SAVE TABLE LINK
MOVE TB,[44,,^D90]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
LDB TB,DA.BRO
DPB TB,DA.SON ;MAKE THE BROTHER BE THE SON
SETZ TB,
DPB TB,DA.BRO
DPB TB,DA.SLL ;SET SINC AT LOWER LEVEL FOR DEBUG-CONTENTS
MOVEI TB,%CL.AN ;ALPHANUMERIC
DPB TB,DA.CLA
MOVE TB,[SIXBIT /LINE/]
PUSHJ PP,DA212. ;PUT DEBUG-LINE IN SYMBOL TABLE
MOVE TB,[44,,6]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
PUSHJ PP,DA214. ;SET ALPHANUMERIC CLASS AND PIC SEEN.
AOS EAS1PC
MOVE TB,[SIXBIT /NAME/]
PUSHJ PP,DA212. ;PUT DEBUG-NAME IN SYMBOL TABLE
PUSHJ PP,DA214. ;SET ALPHANUMERIC CLASS AND PIC SEEN.
MOVE TB,[36,,^D30]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
MOVEI TB,5
ADDM TB,EAS1PC
MOVE TB,[SIXBIT /SUB:1/]
PUSHJ PP,DA212. ;PUT DEBUG-SUB-1 IN SYMBOL TABLE
PUSHJ PP,DA213. ;SET SIZE AND VARIOUS FLAGS
AOS EAS1PC
MOVE TB,[SIXBIT /SUB:2/]
PUSHJ PP,DA212. ;PUT DEBUG-SUB-2 IN SYMBOL TABLE
PUSHJ PP,DA213. ;SET SIZE AND VARIOUS FLAGS
AOS EAS1PC
MOVE TB,[SIXBIT /SUB:3/]
PUSHJ PP,DA212. ;PUT DEBUG-SUB-3 IN SYMBOL TABLE
PUSHJ PP,DA213. ;SET SIZE AND VARIOUS FLAGS
AOS EAS1PC
AOS EAS1PC ;SYNCHRONIZE LEFT (I.E. WASTE 5 BYTES)
MOVSI TB,'TS '
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /CONTEN/]
PUSHJ PP,DA212. ;PUT DEBUG-CONTENTS IN SYMBOL TABLE
MOVE TB,[44,,^D30]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
PUSHJ PP,DA214. ;SET ALPHANUMERIC CLASS AND PIC SEEN.
PUSHJ PP,DA216A ;SET VARIOUS BITS
;NOW DEFINE THE VARIOUS REDEFINITIONS OF DEBUG-CONTENTS
MOVE TB,[SIXBIT /TS:DIS/]
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /PLAY:6/]
MOVEM TB,NAMWRD+3
PUSHJ PP,DA211.
MOVE TB,[44,,^D30]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
PUSHJ PP,DA216A ;SET VARIOUS BITS
AOS NAMWRD+3 ;DEBUG-CONTENTS-DISPLAY-7
PUSHJ PP,DA211.
MOVE TB,[44,,^D25]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.D7
PUSHJ PP,DA216. ;SET VARIOUS BITS
MOVEI TB,2 ;DEBUG-CONTENTS-DISPLAY-9
ADDM TB,NAMWRD+3
PUSHJ PP,DA211.
MOVE TB,[44,,^D20]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.EB
PUSHJ PP,DA216. ;SET VARIOUS BITS
MOVE TB,[SIXBIT /TS:1:W/]
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /ORD:CO/]
MOVEM TB,NAMWRD+3
MOVSI TB,'MP '
MOVEM TB,NAMWRD+4
PUSHJ PP,DA211. ;DEBUG-CONTENTS-1-WORD-COMP
MOVE TB,[44,,^D10]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.1C
PUSHJ PP,DA217. ;SET VARIOUS BITS
MOVEI TB,'2:W'
HRRM TB,NAMWRD+2 ;DEBUG-CONTENTS-2-WORD-COMP
PUSHJ PP,DA211.
MOVE TB,[44,,^D18]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.2C
PUSHJ PP,DA217. ;SET VARIOUS BITS
MOVEI TB,'COM'
HRRM TB,NAMWRD+2
MOVSI TB,'P:1'
MOVEM TB,NAMWRD+3 ;DEBUG-CONTENTS-COMP-1
PUSHJ PP,DA211.
MOVE TB,[44,,^D10]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.C1
PUSHJ PP,DA217. ;SET VARIOUS BITS
AOS NAMWRD+3 ;DEBUG-CONTENTS-COMP-2
PUSHJ PP,DA211.
MOVE TB,[44,,^D18]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.C2
PUSHJ PP,DA217. ;SET VARIOUS BITS
AOS NAMWRD+3 ;DEBUG-CONTENTS-COMP-3
PUSHJ PP,DA211.
MOVE TB,[44,,^D18]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.C3
PUSHJ PP,DA217. ;SET VARIOUS BITS
;NOW GENERATE DEBUG-CONTENTS-INDEX
;NOTE THIS IS NOT PART OF DEBUG-ITEM
;AND IS AT DEBUG-ITEM MINUS 1
;FIRST ACCOUNT FOR LARGEST FILE DATA RECORD WE HAVE SEEN
MOVE TB,MAXDBC ;GET MAX RECORD
SUBI TB,^D30/6 ;SIZE WE WOULD LIKE TO USE
SKIPLE TB ;IGNORE IF WE HAVE ENOUGH
ADDM TB,EAS1PC ;OTHERWISE USE EXTRA
MOVEI TB,^D10 ;ACCOUNT FOR INITIAL SIZE OF DEBUG-CONTENTS
ADDB TB,EAS1PC
EXCH TB,-1(PP) ;SWAP WITH ORIGINAL EAS1PC
MOVEM TB,EAS1PC ;FROM BEFORE DEBUG-ITEM
MOVE TB,[SIXBIT /TS:IND/]
MOVEM TB,NAMWRD+2
MOVSI TB,'EX '
MOVEM TB,NAMWRD+3 ;DEBUG-CONTENTS-INDEX
SETZM NAMWRD+4
PUSHJ PP,DA211.
MOVE TB,[44,,5]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
POP PP,TB ;GET FATHER LINK
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.SYR ;SET SYNCHRONIZED RIGHT
MOVEI TB,%US.IN
DPB TB,DA.USG ;RESET USAGE
POP PP,EAS1PC ;RESTORE LOCATION COUNTER
POPJ PP,
DA212.: MOVEM TB,NAMWRD+1 ;FINISH OFF NAME
DA211.: MOVEI TB,LVL.01 ;PRETEND ITS LEVEL 01
MOVEM TB,(SAVPTR)
SETZB W1,W2 ;CLEAR THE FLAGS
MOVEI TYPE,USERN. ;ITEM IS A USER-NAME
PUSHJ PP,DA26N.
PUSHJ PP,DA27. ;CREATE DATAB ENTRY
MOVE TA,CURDAT ;POINT TO DATAB
HLRZ TB,TA ;GET TABLE ENTRY
ADDI TB,7 ;ADVANCE TO NEXT ITEM
DPB TB,DA.BRO ;SINCE IT WILL BE BROTHER EVENTUALLY
POPJ PP,
DA213.: MOVE TB,[30,,5] ;BYTE OFFSET ,, SIZE
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
MOVEI TB,%CL.NU ;NUMERIC
DPB TB,DA.CLA
SETO TB,
DPB TB,DA.SGN ;SIGNED
DPB TB,DA.SSC ;SEPARATE SIGN CHAR.
DPB TB,DA.LSC ;LEADING SIGN CHAR.
JRST DA214A
DA214.: MOVEI TB,%CL.AN ;ALPHANUMERIC
DPB TB,DA.CLA
DA214A: SETO TB,
DPB TB,DA.PIC ;INDICATE PICTURE SEEN
MOVEI TB,02
DPB TB,DA.LVL ;RESET THE LEVEL TO 02
POPJ PP,
DA215.: DPB TB,DA.EXS ;EXTERNAL
DPB TB,DA.INS ;INTERNAL
HLRZ TB,TB
DPB TB,DA.RES ;BYTE RESIDUE
MOVE TB,EAS1PC ;GET BASE
DPB TB,DA.LOC ;STORE IT
MOVEI TB,%US.D6 ;DISPLAY-6
DPB TB,DA.USG
POPJ PP,
DA216.: DPB TB,DA.USG ;RESET USAGE
DA216A: MOVE TB,-1(PP) ;GET FATHER LINK
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.SYL ;SET SYNCH LEFT
POPJ PP,
DA217.: DPB TB,DA.USG ;RESET USAGE
MOVEI TB,%CL.NU
DPB TB,DA.CLA ;SET NUMERIC
MOVE TB,-1(PP) ;GET FATHER LINK
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.SYR ;SET SYNCH RIGHT
DPB TB,DA.SGN ;SET SIGNED
POPJ PP,
SUBTTL ROUTINES TO PARSE A DATANAME ALLOWING QUALIFIERS, SUBSCRIPTS
; These are essentially the same as some of the Phase D routines
;This is the PA2. routine
INTER. DA220. ;DATANAME OR INTEGER PARSED
DA220.: TLNE W1,GNLIT ;IS ITEM AN INTEGER?
JRST D220L ;YES
;Item must be in NAMTAB.
D220S: TLZ W1,4000 ;'ROUNDED BIT'
DMOVEM W1,ARG1## ;SAVE ITEM
POPJ PP,
D220L: LDB TB,GWVAL ;NO. OF CHARACTERS
PUSHJ PP,DA24S. ;SET UP COUNT AND POINTERS FOR LITER TO VALTAB MOVE
MOVEM TB,TBLOCK+1 ;STORE POINTER TO LITERAL (WHY?)
D220LQ: SOJL TD,D220S ;JUMP TO STORE ITEM IN ARG1 WHEN ALL CHARS MOVED
ILDB TE,TB ;GET CHARACTER
IDPB TE,TC ;SAVE
JRST D220LQ
;This is the PA171. routine
INTER. DA221.
DA221.: HRRZ TC,NQUAL##
LSH TC,1
CAIL TC,144 ;SIZE OF TABLE
EWARNJ E.190 ;?TOO MANY QUALIFIERS
MOVE TA,ARG1
MOVEM TA,QUALT(TC)
MOVE TA,ARG1+1
MOVEM TA,QUALT+1(TC)
SETZM ARG1
SETZM ARG1+1
AOS NQUAL
POPJ PP,
;This is the PA170. routine
INTER. DA222.
DA222.: SETZM GOTQUA##
SKIPN TA,NQUAL
JRST D222.1
CAIE TA,1
JRST D222.5
MOVE TA,QUALT##
TLNN TA,GWFIGC
JRST D222.5
LDB TB,[POINT 9,TA,17]
D222.5: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB POINTER
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK
JRST D222.0 ;MAY BE CONDITION-NAME
D222A: HLRM TB,QUALT
PUSHJ PP,DOQUAL
JRST D222B
SKIPN GOTQUA ;ANY OTHER DATA NAME WITH SAME QUALIFICATION ?
JRST D222D ;NO
PUSH PP,TA
PUSHJ PP,LNKSET ;GET REAL ADDRESS OF DATAB ENTRY
LDB TC,DA.LPC
POP PP,TA
SKIPE TC ;QUALIFICATION A LINE COUNTER OR PAGE COUNTER ?
SKIPN REPSEC ;AND IN REPORT SECTION ?
JRST D222.2 ;NO, INSUFFICIENT QUALIFICATION
PUSHJ PP,LNKSET
LDB TA,DA.NAM ;GET NAMTAB ENTRY
ADD TA,NAMLOC ;CREATE REAL ADDRESS
LDB TA,[POINT 18,0(TA),35] ;GET DATAB LINK
HRRZM TA,GOTQUA
HRLZM TA,CURDAT
PUSHJ PP,LNKSET
HRRM TA,CURDAT
HRRZI TA,1
HRRZM TA,CURQUA ;CURRENT ENTRY
HRRZM TA,QUALT
HLRZ TA,CURDAT
JRST D222O
D222D: HRRZM TA,GOTQUA ;TA CONTAINS QUALT ON RETURN
D222B: 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 D222A ;GO SEE IF THIS NAME WORKS.
CAIE TB,CD.CON ;IF IT WAS CONTAB, WE'RE THROUGH.
JRST D222.0 ;GO LOOK AT CONTAB.
D222C: SKIPN TA,GOTQUA ;ANY FOUND?
JRST D222.1 ;NO
D222O: HLL TA,QUALT
MOVEM TA,ARG1
MOVE TA,QUALT+1
MOVEM TA,ARG1+1
SETZM NQUAL
POPJ PP,
D222.0: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB PTR.
HRRZI TB,CD.CON
PUSHJ PP,FNDLNK
JRST D222C ;NO CONTAB LINK
JRST D222A
D222.1: HRRZI DW,E.104 ;NOT DEFINED
JRST D222E
D222.2: HRRZI DW,E.60
D222E: LDB LN,[POINT 13,QUALT+1,28]
LDB CP,[POINT 7,QUALT+1,35]
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
PUSHJ PP,FATAL
>
MOVEI TA,<CD.DAT>B20+1 ;ASSUME DUMMY DATAB ENTRY
MOVEM TA,QUALT
JRST D222O
;THE following code copied (temporarily) from COBOLD.MAC:
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: MOVE TA,QUALT
POP PP,TE
JRST 1(TE)
NOPOP: MOVE TA,QUALT
POPJ PP, ;FAILURE EXIT
GETPOP: SKIPN TA,CURDAT
POPJ PP,
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
;** END OF CODE COPIED FROM COBOLD **
; This is the PA205. routine
INTER. DA223. ;LEFT PAREN TO START SUBSCRIPTS
DA223.: SETZM NSBSC1##
MOVE TA,[XWD NSBSC1,SBSCR1##]
BLT TA,SBSCR1+MAXSUB*4-1
PUSHJ PP,DA222.
MOVE TA,[XWD ARG1,ARG3##]
BLT TA,ARG3+1
POPJ PP,
;This is the PA263. routine
INTER. DA224. ; Improper subscript error
DA224.: MOVEI W1,<CD.DAT>B20+1 ;USE DUMMY DATA ITEM FOR SUBSCRIPT
TLZ W2,777770
DMOVEM W1,ARG1 ;NO NEED TO GIVE DIAGNOSTIC MESSAGE, PHASE E DOES IT ALREADY
SWOFF FREGWD ;GO ON TO NEXT SOURCE ITEM
HRRZI TA,(W1) ; SET UP DUMMY RELATIVE ADDRESS
PUSHJ PP,LNKSET ; GET DATAB ADR FOR DUMMY
HRRM TA,CURDAT ; STORE IT
HRLM W1,CURDAT ; PUT BACK DATAB RELATIVE ADDR
POPJ PP,
;This is the PA206. routine
INTER. DA225. ;Count another subscript
DA225.: AOS TA,NSBSC1
CAILE TA,MAXSUB
JRST [MOVEI TA,MAXSUB ;RESTORE TO MAXIMUM
MOVEM TA,NSBSC1 ;LIMIT
EWARNJ E.277] ;TOO MANY SUBSCRIPTS
ASH TA,2
HRRZI TA,SBSCR1-4(TA)
HRRZI TB,1(TA)
HRLI TA,ARG1
BLT TA,(TB)
POPJ PP,
;This is the PA206A routine
INTER. DA225A
DA225A: SKIPN REPSEC ;IN REPORT SECTION ?
JRST D225A ;NO
HRRZ TA,ARG1
PUSHJ PP,LNKSET ;GET ACTUAL ADDRESS OF SUBSCRIPT DATAB ENTRY
LDB TA,DA.LPC
LDB TB,DA.SCT##
SKIPN TB ;IS SUBSCRIPT A SUM CLAUSE ?
SKIPE TA ;OR IS SUBSCRIPT A LINE OR PAGE COUNTER ?
EWARNW E.785 ;YES, GENERATE WARNING
D225A: HRRZ TA,ARG1 ;GET SUBSCRIPT RELATIVE DATAB ADDRESS
PUSHJ PP,LNKSET ;GET REAL ADDRESS
MOVEM TA,CURDAT ;NOW STORE IT
LDB TB,DA.SUB## ;IS SUBSCRIPT SUBSCRIPTED?
SKIPE TB ;ERROR IF SO
EWARNW E.495 ;ERROR MESSAGE
JRST DA225. ;OK GO ON
;This is the PA220. routine
INTER. DA226.
DA226.: MOVE TA,[XWD ARG3,ARG1]
BLT TA,ARG1+1
POPJ PP,
;This is the PA234. routine
INTER. DA227. ;PLUS follows subscript
DA227.: MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVSI TB,400000 ;CLR BIT 0 OF 1ST WORD IN ENTRY
ANDCAM TB,SBSCR1-4(TA) ; TO INDICATE PLUS
POPJ PP,
;This is the PA235. routine
INTER. DA228. ;MINUS follows subscript
DA228.: 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,
;This is the PA236. routine
INTER. DA229. ;INTEGER TO BE ADDED TO SUBSCRIPT
DA229.: PUSHJ PP,DA220. ;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,
;PA21.-type routine, Call: w1/ addr where item and subscripts
; should be written
DA230.: SETZM TBLOCK+7 ;FLAG SAYS THIS IS NOT A SUBSCRIPT
D230.0: HRRZ TB,ARG1 ;R.H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
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 D230.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,D230.E
D230.B: TLNE TD,GWALL ;'ALL' ITEM?
TLO TA,GNALL ;YES--SET ALL BIT
SETZM ARG1
SETZM ARG1+1
JRST DA231. ;OUTPUT ARG1
D230.A: TLNN TD,GWFIGC ;IS ITEM A FIG. CONSTANT?
JRST D230.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 ;ZERO((E)S)
CAIN TC,SPACE.
HRLZI TE,GNFCS ;SPACE(S)
IOR TA,TE ;SET APPROPRIATE BITS
JRST D230.B
D230.C: TLNN TE,400000 ;FLOTAB ENTRY?
JRST D230.D ;NO
SETZM NSBSC1
TLO TB,100000 ;YES--SET BIT IN OPERAND WORD
JRST PUTFT
D230.D: HRRZI TC,(TD) ;TABLE LINK
JUMPE TC,D230.E ;NULL
LSH TC,-17 ;TABLE TYPE CODE
CAIN TC,CD.CON ;CONTAB?
JRST PUTFT ;YES, DON'T CLR NSBSC1
CAIN TC,CD.DAT ;DATAB?
JRST .+3
SETZM NSBSC1
JRST PUTFT ;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,10000 ;YES
TLNE TD,40000 ;SYNC RIGHT?
TLO TA,4000 ;YES
TLNE TD,10 ;JUST RIGHT?
TLO TA,1000 ;YES
TLO TA,2000 ;SET NUMERIC BIT
TLNE TD,400000 ;NOT NUMERIC
TLNE TD,200000 ;SKIP IF NUMERIC
TLZ TA,2000 ;TURN OFF NUMERIC BIT
TRNE TD,400000 ;DD ERROR?
TLO TB,400000 ;YES
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,D230.E
SKIPN TD,NSBSC1 ;NUMBER OF SUBSCRIPTS
JRST DA231. ;NONE, WRITE OUT INFO
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]
PUSHJ PP,DA231.
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 DA230. WE ARE DOING A SUBSCRIPT
PUSHJ PP,D230.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,DA230.
JRST PUTFT1
PUTFT2: MOVE TA,[XWD NSBSC1,SBSCR1]
MOVEI TB,MAXSUB*4-1
BLT TA,SBSCR1(TB)
POPJ PP,
D230.E: OUTSTR [ASCIZ/?DA230.: null table link
/]
EWARNJ E.263
;This is the equivalent of PUTGEN for phase C.
;Input: TA/ FIRST WORD , TB/ 2ND WORD, W1/ INDEX WHERE TO PUT IT
DA231.: MOVEM TA,(W1) ;STORE FIRST WORD
MOVEM TB,1(W1) ;STORE 2ND WORD
ADDI W1,2 ;BUMP W1 FOR NEXT TIME
POPJ PP, ;RETURN
;Here when parsed ALTERNATE and expecting RECORD KEY IS
INTER. DA511.
DA511.: FLAGAT H
MOVE TA,CURFIL
LDB TB,FI.ORG ;GET FILE ORGANIZATION
CAIE TB,%ACC.I ;MAKE SURE THIS IS AN INDEXED FILE
CAIN TB,%%ACC ;OR NOT SPECIFIED YET
CAIA ;ALL OK
EWARNJ E.624 ;"ALTERNATE KEY ONLY ALLOWED WITH INDEXED FILES"
SETOB TB,RMSFLS## ;MAKE SURE RMS BIT IS SET, AND SET "RMS FILES" FLAG
DPB TB,FI.RMS##
DPB TB,FI.AKS## ;SET "ALTERNATE KEYS SPECIFIED" FOR THIS FILE
POPJ PP, ;RETURN OK
;Saw FILE-STATUS
INTER. DA512.
DA512.: PUSHJ PP,DA25F. ;TEST FIPS FLAGGER
HRRZ TA,CURFIL ;GET FILTAB ABS ADR.
LDB TB,FI.PFS## ;GET FIRST STATUS WORD LINK.
JUMPN TB,DA512A ;IF WE ALREADY HAVE ONE - DUP CLAUSE.
MOVE TB,FI.SPT## ;GET BYTE POINTER TO ENTRIES.
MOVEM TB,SAVLST## ;SAVE IT.
HRREI TB,-11 ;-MAXIMUM NUMBER OF NAMES ALLOWED.
MOVEM TB,SAVLST+1 ;SAVE IT.
POPJ PP, ;GO LOOK FOR NAMES.
;DUPLICATE CLAUSE - SKIP TO NEXT NON USER-NAME
DA512A: MOVEI TB,1
MOVEM TB,SAVLST+1 ;FORCE SKIPPING.
JRST JCE16. ;GO GIVE ERROR MSG.
;SAW THE NAME OF A FILE STATUS ITEM.
INTER. DA513.
DA513.: AOSGE TA,SAVLST+1 ;DO WE HAVE AN ERROR CONDITION.
JRST DA513A ;NO.
JUMPN TA,CPOPJ ;FIRST TIME?
EWARNJ E.227 ;YES, TOO MANY NAMES.
DA513A: PUSHJ PP,DA709S ;GET THE NAMTAB ADDRESS.
PUSHJ PP,DA706S ;SET UP THE HLDTAB ENTRY.
MOVE TA,CURHLD ;GET THE HLDTAB ADDRESS.
MOVEI TB,%HL.ER ;I AM A FILE-STATUS.
DPB TB,HL.COD ;PUT IT IN HLDTAB.
MOVS TB,CURFIL ;GET THE FILTAB ADDRESS.
DPB TB,HL.LNK ;FILTAB LINK TO HLDTAB.
EXCH TA,TB
MOVSS TA,TA
MOVSS TB,TB
IDPB TB,SAVLST ;HLDTAB LINK TO APPROPRIATE
; FILTAB LOCATION.
SKIPN FLGSW## ;NEED TO FLAG EXTENSIONS?
POPJ PP, ;GO LOOK FOR MORE NAMES OR FOR
; SOME QUALIFICATION.
HRRZ TB,SAVLST+1 ;SEE IF SECOND TIME THROUGH
CAIN TB,-7 ;SO WE GIVE ERROR ONLY ONCE
FLAGAT NS ;FLAG AS NON-STANDARD EXTENSION
POPJ PP, ;NO
;SAW SOME QUALIFICATION.
INTER. DA514.
DA514.: SKIPLE SAVLST+1 ;DO WE HAVE AN ERROR CONDITION?
POPJ PP, ;YES, IGNORE QUALS.
JRST DA709. ;GO SAVE THE QUALS.
;REPORT WRITER SYNTAX FOR COBOL-74
; Check for
; In CONTROL FOOTING, PAGE HEADING, PAGE FOOTING, and REPORT FOOTING
; report groups, SOURCE clauses and USE statements may not reference:
;
; a) Grop data-item containing control data-item
; b) Data-items subordinate to control data-item.
; c) A redefinition or renaming of any part of a control data-item.
;
; In a PAGE HEADING and PAGE FOOTING report groups, SOURCE clauses and
; USE statements must not reference control data-names.
;
DA515.: HRRZS TB,W1 ; GET SOURCE ITEMS FATHER
DA516.: MOVE CT,TB ; SAVE LAST DATAB LINK
PUSHJ PP,FNDPOP ; GET FATHER
JRST .+3 ; NO FATHER, EXIT
TRNN TB,700000 ; POINTING AT A DATAB (NOT RPW ENTRY)?
JRST DA516. ; YES, GET FATHER
HRRZ TA,RCOLOC ; GET RCOTAB STARTING ADDRESS
HRRZ TE,RCONXT##
CAML TA,TE ; ANY CONTROL IDENTIFIERS ?
POPJ PP, ; NO, EXIT
ADDI TA,1 ; GET FIRST IDENTIFIER
DA517.: LDB TB,RC.FAL ; GET FATHER
CAMN TB,CT ; SAME FATHER AS SOURCE ITEM ?
JRST DA519. ; YES
DA518.: ADDI TA,SZ.RCO ; GET NEXT IDENTIFIER, AND TEST IT
HRRZ TE,RCONXT
CAML TA,TE ; ANY MORE ENTRIES ?
POPJ PP, ; NO, RETURN
JRST DA517.
;FATHER OF SOURCE CLAUSE MATCHES A FATHER OF AN RCOTAB ENTRY, CHECK
;TO SEE IF IN COMMON BRANCH.
DA519.: MOVE TC,TA ; SAVE CONTROL IDENTIFIER LINK
HLRZ TA,CURDAT ; GET DATAB LINK TO ITEM CONTAINING SOURCE
JUMPE TA,CPOPJ ; SHOULD NEVER HAPPEN
PUSHJ PP,LNKSET
LDB TA,DA.RPW ; GET RPWTAB ENTRY FOR ITEM
ADD TA,RPWLOC ; MAKE REAL ADDRESS
LDB TB,RW.TYP ; GET ITEM'S TYPE
CAIE TB,%RG.PH
CAIN TB,%RG.PF
JRST DA520. ; IF PH, OR PF CHECK SOURCE ITEM
CAIE TB,%RG.CF
CAIN TB,%RG.RF
JRST DA521. ; IF CF, OR RF, CHECK SOURCE ITEM
POPJ PP, ; IF NOT PH, PF, CF, OR RF DON'T CONTINUE
;CHECK TO SEE IF SOURCE ITEM IS A CONTROL IDENTIFIER
DA520.: MOVE TA,TC ; RESTORE
LDB TA,RC.DCI ; GET CONTROL IDENTIFIER DATAB LINK
CAMN TA,W1 ; IS CONTROL IDENTIFIER THE SAME AS SOURCE
EWARNJ E.788 ; RETURN IF ERROR FOUND
DA521.: MOVE TA,W1 ; GET DATAB POINTER TO SOURCE ITEM
PUSHJ PP,LNKSET ; MAKE ABSOLUTE ADDRESS
LDB TB,DA.LVL ; GET LEVEL OF SOURCE ITEM
PUSH PP,TA ; SAVE TA FOR LATER USE
MOVE TA,TC ; GET ABSOLUTE ADDRESS OF CONTROL IDENTIFIER
LDB TA,RC.DCI ; GET DATAB LINK
PUSHJ PP,LNKSET ; MAKE ABSOLUTE ADDRESS
PUSH PP,TA ; SAVE ADDRESS OF CONTROL IDENTIFIER
LDB TD,DA.LVL ; GET LEVEL OF CONTROL IDENTIFIER
CAMGE TB,TD ; LEVEL OF SOURCE GREATER THAN THAT OF CONTROL?
JRST DA522. ; YES, CHECK TO SEE IF SOURCE IS THE FATHER
CAMLE TB,TD ; LEVEL OF SOURCE LESS THAN THAT OF CONTROL?
JRST DA523. ; YES, CHECK TO SEE IF SOURCE IS A SON
POP PP,TA ; DUMP SAVED ITEMS
POP PP,TA
MOVE TA,TC ; RESTORE POINTER INTO RCOTAB AND
JRST DA518. ; GO TRY NEXT IDENTIFIER
DA522.: POP PP,TB ; RESTORE CONTROL IDENTIFIER
POP PP,CT ; RESTORE SOURCE DATAB LINK
MOVE TA,CT
LDB W2,DA.LVL ; GET LEVEL OF SOURCE ITEM
SUB CT,DATLOC ; MAKE SOURCE DATAB LINK RELATIVE
IORI CT,AS.DAT
SUB TB,DATLOC ; MAKE CONTROL DATAB LINK RELATIVE
IORI TB,AS.DAT
DA522A: PUSHJ PP,FNDPOP ; GET FATHER
JRST DA524. ; NO FATHER, TRY TEST FOR NEXT CONTROL ID
CAMN CT,TB ; IS CONTROL IDENTIFER A SON ?
EWARNJ E.789 ; YES GIVE WARNING AND RETURN
MOVE TA,TB
PUSHJ PP,LNKSET ; GET ABSOLUTE ADDRESS
LDB TA,DA.LVL ; GET LEVEL
CAIGE W2,TA ; ARE THEY AT THE SAME LEVEL?
JRST DA522A ; NO
JRST DA524. ; YES, GET NEXT ENTRY
DA523.: POP PP,CT ; RESTORE CONTROL IDENTIFIER
POP PP,TB ; RESTORE SOURCE DATAB LINK
MOVE TA,CT
LDB W2,DA.LVL ; GET LEVEL OF CONTROL IDENTIFIER
SUB CT,DATLOC ; MAKE DATAB CONTROL ID, RELATIVE
IORI CT,AS.DAT
SUB TB,DATLOC ; MAKE SOURCE DATAB ENTRY RELATIVE
IORI TB,AS.DAT
DA523A: PUSHJ PP,FNDPOP ; GET FATHER OF SOURCE IDENTIFIER
JRST DA524. ; NO FATHER, TRY TEST FOR NEXT CONTROL ID
CAMN CT,TB ; IS THE CONTROL IDENTIFIER THE FATHER ?
EWARNJ E.790 ; YES, GENERATE WARNING
MOVE TA,TB
PUSHJ PP,LNKSET ; GET ABSOLUTE ADDRESS
LDB TA,DA.LVL ; GET LEVEL OF SOURCE
CAIGE W2,TA ; ARE THEY AT THE SAME LEVEL
JRST DA523A ; NO
DA524.: MOVE TA,TC ; RESTORE POINTER INTO RCOTAB AND
JRST DA518. ; GO TRY NEXT IDENTIFIER
SUBTTL ANS-82 SYNTAX
;CHECK FOR MORE THAN 1 ACCESS MODE SETTING PER FILE
INTER. DA700.
DA700.: HRRZ TA,CURFIL ;AIM AT CURRENT FILTAB ENTRY
LDB TB,FI.FAM ;GET CURRENT SETTING OF ACCESS MODE BITS
JUMPN TB,JCE16. ;'DUPLICATE CLAUSE'
POPJ PP, ;AT INITIAL SETTING
;SET SEQUENTIAL ACCESS MODE
INTER. DA701.
DA701.: MOVEI TB,%FAM.S
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST DA700X ;NO
PUSHJ PP,DA700X ;SETS UP TA = CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;SET RANDOM ACCESSS MODE
INTER. DA702.
DA702.: MOVEI TB,%FAM.R
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST DA700X ;NO
PUSHJ PP,DA700X ;SETS UP TA = CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;SET DYNAMIC ACCESS MODE
INTER. DA703.
DA703.: MOVEI TB,%FAM.D
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST DA700X ;NO
PUSHJ PP,DA700X ;SETS UP TA = CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[CPOPJ ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
DA700X: HRRZ TA,CURFIL
DPB TB,FI.FAM## ;STORE IN FILTAB
POPJ PP,
;SAVE RELATIVE KEY CODE FOR HLDTAB
INTER. DA705.
DA705.: FLAGAT LI
HRRZ TA,CURFIL ;ABS. ADDR. OF FILTAB ENTRY
LDB TB,FI.ORG ;GET ORGANIZATION
CAIE TB,%%ACC ;IS IT "DEFAULT"?
CAIN TB,%ACC.R ;NO, IS IT RELATIVE?
JRST DA705A ;YES, OK
MOVEI DW,E.595 ;NO, ERROR - WRONG TYPE KEY
PUSHJ PP,FATALW## ;FLAG IT
HRRZI TB,%HL.SY
TRNA
DA705A: HRRZI TB,%HL.AK ;GET CODE
DA705B: MOVEM TB,CTR ;STORE CODE IN HLDTAB
POPJ PP,
;PUT KEY DATA-NAME IN HLDTAB
INTER. DA706.
DA706.: PUSHJ PP,DA709S ;SAVE NAMTAB ADDR
PUSHJ PP,DA706S ;SET UP HLDTAB ENTRY
HRRZ TB,CTR ;GET KEY CODE
DPB TB,HL.COD ;& PUT IT IN HLDTAB
HLRZ TB,CURFIL ;STORE FILTAB LINK IN HLDTAB
DPB TB,HL.LNK
POPJ PP,
;SET UP HLDTAB ENTRY
DA706S: MOVE TA,[XWD CD.HLD,SZ.HLD] ;GET A HLDTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURHLD ;SAVE ADDR
HLRZ TB,CURNAM ;PUT LINK TO NAMTAB IN HLDTAB
DPB TB,HL.NAM
DPB W2,HL.LNC ;ALSO POSITION OF ITEM IN SOURCE
SETZ TB, ;CLR # OF QUALIFIERS
DPB TB,HL.QAL
POPJ PP,
;STORE ALTERNATE RECORD KEY DATA-NAME
INTER. DA707.
DA707.: PUSHJ PP,DA709S ;SAVE NAMTAB ADDR
PUSHJ PP,DA707A ;SETUP ALTERNATE KEY ENTRY
PUSHJ PP,DA706S ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.KA ;GET KEY CODE
DPB TB,HL.COD ;& PUT IN HLDTAB
HLRZ TB,CURAKT ;GET CURRENT ALTERNATE KEY
DPB TB,HL.LNK ;STORE AKTTAB LINK IN HLDTAB
POPJ PP, ;RETURN
;SET UP AKTTAB ENTRY
DA707A: MOVE TA,[XWD CD.AKT,SZ.AKT] ;GET AN AKTTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURAKT## ;SAVE ADDR
HLRZ TB,CURFIL ;PUT FILTAB ADDR IN AKTTAB
DPB TB,AK.FLK##
POPJ PP, ;RETURN
;SET "DUPLICATES" BIT
INTER. DA708.
DA708.: HRRZ TA,CURAKT ;GET CURRENT ACTUAL KEY TABLE ADDR
SETO TB, ;TURN ON "DUPLICATES" BIT
DPB TB,AK.DUP##
POPJ PP, ;RETURN
;PUT DATA-NAME QUALIFIER IN NEXT WORD OF HLDTAB
INTER. DA709.
DA709.: PUSHJ PP,DA709S ;SAVE NAMTAB ADDR
MOVE TA,CURHLD ;GET # OF QUALIFIERS BEFORE THIS
LDB TB,HL.QAL
AOJ TB, ;INCREMENT COUNT
DPB TB,HL.QAL ;& PUT BACK
ROT TB,-1 ;DIV BY 2
HLRZ TC,CURNAM ;GET NAMTAB LINK
JUMPL TB,DA709A ;IF BIT0 ON, USE ODD HALF-WORD
ADDI TA,1(TB) ;PTR TO EVEN HALF-WORD
HRRM TC,(TA) ;STORE IN EVEN HALF
POPJ PP,
DA709A: PUSH PP,CURHLD ;SAVE PTR TO HLDTAB ENTRY
MOVE TA,[XWD CD.HLD,1] ;GET ONE MORE WORD FOR THE ENTRY
PUSHJ PP,GETENT
HLRZ TC,CURNAM ;GET NAMTAB LINK
HRLZM TC,(TA) ;STORE NAMTAB LINK IN ODD HALF
POP PP,CURHLD ;RESTORE HLDTAB PTR
POPJ PP,
;STORE NAMTAB RELATIVE ADDRESS FOR NEW NAME
DA709S: TLNN W1,GWNOT ;NAME IN NAMTAB?
JRST DA709N ;YES
PUSHJ PP,BLDNAM ;NO, BUILD NAMTAB ENTRY
MOVEM TA,CURNAM ;SAVE ADDR
HLRZS TA ;LEAVE LINK IN RIGHT HALF
DPB TA,[POINT 15,W2,15] ;& IN W2
POPJ PP,
DA709N: LDB TA,[POINT 15,W2,15] ;GET NAMTAB REL ADDR
HRLZM TA,CURNAM ;& SAVE
POPJ PP,
INTER. DA710A
DA710A: PUSHJ PP,DA13A. ;RECOVER FROM SCANNING ERROR
SKPNAM
;SAVE RECORD KEY CODE FOR HLDTAB
INTER. DA710.
DA710.: HRRZI TB,%HL.RC ;GET CODE
MOVEM TB,CTR ;STORE CODE IN HLDTAB
PUSHJ PP,DA706. ;COMPLETE THE ACTION
JRST DA711. ;CHECK FIPS FLAGGER
;Store CHARACTERS over wrong use of RECORDS
INTER. DA711A
DA711A: PUSHJ PP,DA13A. ;RECOVER FROM SCANNING ERROR
SKPNAM ;BUT FLAG THIS USE OF RECORD
;Flag RECORD at 8x level
INTER. DA711.
DA711.: SETZM (SAVPTR) ;MAKE SURE LOWER BOUND IZ ZERO
SETO TB,
SKIPE TA,CURFIL
DPB TB,FI.VRS## ;SIGNAL VARYING SYNTAX SEEN
SKIPN FLGSW ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVEI TA,%LV.8
HLRZ LN,RCLNCP##
HRRZ CP,RCLNCP
JRST FLG.ES
;Flag RECORD at FIPS levels for RECORD CONTAINS integer-1 TO integer-1
INTER. DA712.
DA712.: PUSHJ PP,DA11. ;STORE LITERAL
SKIPN FLGSW ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
MOVE TA,[%LV.L ;SEQUENTIAL
%LV.LI ;RELATIVE
%LV.H](TB) ;INDEXED
HLRZ LN,RCLNCP##
HRRZ CP,RCLNCP
JRST FLG.ES
;Routines to handle contained programs
INTER. DA720.
DA720.: FLAGAT 8
EWARNJ E.899 ;NOT YET IMPLEMENTED
INTER. DA721.
DA721.: FLAGAT 8
EWARNJ E.899 ;NOT YET IMPLEMENTED
INTER. DA722.
DA722.: FLAGAT 8
EWARNJ E.899 ;NOT YET IMPLEMENTED
INTER. DA723.
DA723.: FLAGAT 8
SKPNAM
INTER. DA724.
DA724.: FLAGAT 8
EWARNW E.899 ;NOT YET IMPLEMENTED
SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.LVL
CAIE TB,LVL.01 ;ONLY LEGAL FOR LEVEL 01
EWARNJ E.838 ; SO GIVE ERROR
POPJ PP,
SUBTTL COMMON ROUTINES
INTER. DCA1.
DCA1.:
IFN DBMS,< ;[507]
PUSHJ PP,DA119A ;[476] CHECK PROPER SEQUENCE
> ;[507]
PUSHJ PP,DA10.
JRST DA2.
INTER. DCA2.
DCA2.: SKIPE WRKSEC ;WORKING-STORAGE SECTION ALREADY SEEN?
EWARNJ E.402 ;YES, CAN'T DUPLICATE
SETOM WRKSEC ;[710] NOW SET FLAG TO SHOW WE'VE SEEN IT
SKIPE REPSSN## ;[763] [476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
IFN DBMS,<
SKIPE INVSEE## ;SCHEMA SECTION SEEN?
POPJ PP, ;YES, DON'T SET UP
>
IFN MCS,<
SKIPE CSSEEN ;COMMUNICATION SECTION SEEN?
POPJ PP, ;YES, DON'T SET UP
>
PUSHJ PP,DA10.
JRST DA3.
INTER. DCA3.
DCA3.: PUSHJ PP,DA5.
JRST DA0.
INTER. DCA4.
DCA4.: PUSHJ PP,DA7.
JRST DA0.
INTER. DCA5.
DCA5.: PUSHJ PP,DA11.
JRST DA28.
INTER. DCA6.
DCA6.: SKIPE REPSSN## ;[763] REPORT SECTION ALREADY SEEN?
EWARNJ E.171 ;[763] YES, CAN'T DUPLICATE
SETOM REPSSN ;[763] NOW SET FLAG TO SHOW WE'VE SEEN IT
SETOM BLDIX ;[1335] TURN ON BUILD INDICES FLAG
SKIPL TA,PCHOLD ;[1515] If linkage section preceded,
MOVEM TA,EAS1PC ;[1515] then next core offset is in
SETOM PCHOLD ;[1515] PCHOLD
MOVE TA,CURHLD ;[1335] SAVE CURHLD
MOVEM TA,HLDSAV## ;[1362] [1335] MAKE EXTERNAL
HRRZ TA,HLDLOC ;[1335] FIND START OF HLDTAB
ADDI TA,1 ;[1335]
MOVEM TA,CURHLD ;[1366] [1335] STORE IN CURHLD
PUSHJ PP,CLNHLD## ;[1335] BUILD DATAB ENTRIES FOR INDICES
MOVE TA,HLDSAV ;[1335] RESTORE CURHLD
MOVEM TA,CURHLD ;[1335]
SETZM BLDIX ;[1335] TURN OFF FLAG
PUSHJ PP,DA10R.
JRST DA63.
INTER. DCA7.
DCA7.: SKIPE LNKSSN## ;[763] LINKAGE SECTION ALREADY SEEN?
EWARNJ E.171 ;[763] YES, CAN'T DUPLICATE
SETOM LNKSSN ;[763] NOW SET FLAG TO SHOW WE'VE SEEN IT
FLAGAT LI
IFN DBMS,< ;[%316]FOR ACCESS
SKIPE ACCSEE## ;[%316]
JRST [SETZM ACCSEE## ;[476] CLEAR ACCESS FLAG
SETOM LNKSEC## ;[476]
SETOM SUBPRG ;[476] THIS IS A SUBPROGRAM FLAG
MOVE TB,EAS1PC ;[476] SAVE DATA PC
MOVEM TB,PCHOLD ;[476] WHILE DOING LINKAGE SECTION
POPJ PP,] ;[476]
> ;[%316]
SKIPE REPSSN## ;[763] [476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
PUSHJ PP,DA10.
JRST DA112.
INTER. DCA10.
DCA10.: PUSHJ PP,DA9.
JRST DA58.
;This is the PCA42. routine
INTER. DCA11.
DCA11.: PUSHJ PP,DA220. ;PA2. routine
JRST DA221. ;PA171. routine
;Here to save CURDAT of the RD GROUP item in CURDTT,
; then call action routine
INTER. DCA12.
DCA12.: MOVE TE,CURDAT##
MOVEM TE,CURDTT##
SETZM NSBSC1## ;CLEAR SUBSCRIPT COUNT
PUSH PP,W1
PUSH PP,W2
PUSHJ PP,DA515. ;CHECK SOURCE ITEM
POP PP,W2
POP PP,W1
JRST DA220. ;PA2. routine
SUBTTL ERROR ROUTINES FOR DD SYNTAX SCAN
INTER. CE111.
CE111.: TLNE W1,GWRESV
EWARNJ E.103
EWARNJ E.104
INTER. CE125.
CE125.: MOVE CP,BLNKCP##
MOVE LN,BLNKLN##
HRRZI DW,E.125
JRST WARN
END COBOLC