Trailing-Edge
-
PDP-10 Archives
-
ap-c800d-sb
-
cobolc.mac
There are 20 other files named cobolc.mac in the archive. Click here to see a list.
; UPD ID= 1999 on 8/12/79 at 3:43 PM by W:<WRIGHT>
TITLE COBOLC V12A
SUBTTL DATA DIV. SYNTAX SCAN W.NEELY/CAM/SEB
;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, 1979 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
RPW==:RPW
SERCH==:SERCH
DBMS==:DBMS
DEBUG==:DEBUG
MCS==:MCS
TCS==:TCS
;EDITS
;V12A*****************
;NAME DATE COMMENTS
;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 CATASTROPHIE 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.
; SPR 14254
;**; 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.
;EDIT110 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.
TWOSEG
SALL
RELOC 400000
ENTRY COBOLC
EXTERN CTREE,CPOPJ,CPOPJ1
INTERN D54.NJ ; [315]
COBOLC: JRST 1,.+1 ;ENABLE CONCEALED MODE
SETFAZ C;
SETZM FILSEC ;CLR FILE-SECTION-SEEN FLAG
SETZM WRKSEC## ;CLR WORKING-STORAGE-SECTION-SEEN FLAG
IFN RPW,<
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.##
TTCALL 3,[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 EAS1PC
SETZM EAS2PC
SETOM PCHOLD##
SETZM SVDADR
SETZM CFLM
SETZM WSAS1P
SETZM IDXLST##
SETOM LSTW77## ;LAST LEVEL NUMBER WAS NOT 77.
IFN RPW,<
SETZM LASTRD## ;INIT LAST RD PTR
>
POPJ PP,
INTER. DA2.
DA2.: SWON FFILSC;
SETOM FILSEC## ;SET FILE-SECTION-SEEN FLAG
IFN RPW,<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##
SETZM EAS1PC
SETZM EAS2PC
SETZM CFLM
POPJ PP,
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;
IFN RPW,<SETZM REPSEC> ;CLR REPORT SECTION FLAG
MOVE TA,WSAS1P
MOVEM TA,EAS1PC
SETZM EAS2PC
SETZM CFLM
SETZM LAST01##
POPJ PP,
;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: 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,2000+ENDIT.
CAIN TYPE,ENDIT. ;EOF?
POPJ PP, ;YES
CAMN LN,TBLOCK
JRST DA5.B
MOVEM LN,TBLOCK
CAIE TYPE,2000+LINKG.
CAIN TYPE,2000+FILE.
JRST DA5.X
CAIN TYPE,2000+WORKI.
JRST DA5.X
CAIN TYPE,2000+PROC.
JRST DA5.X
CAIN TYPE,2000+SCHEM.
JRST DA5.X
IFN MCS!TCS,<
CAIN TYPE,2000+COMM. ;COMMUNICATION?
JRST DA5.X ;YES
CAIN TYPE,2000+CD.
JRST DA5.X
>
CAIN TYPE,2000+FD.
JRST DA5.X
CAIN TYPE,PRIOD.
JRST DA5.0
CAIE TYPE,INTGR.
CAIN TYPE,2000+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.
IFN RPW,<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
DA9.1: SETO TB,
DPB TB,FI.FDD
DPB W2,FI.LNC##
SETZM EAS1PC##
SETZM EAS2PC
SETZM CFLM
POPJ PP,
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.LNC
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.ACC##
HRRZI TC,1
DPB TC,FI.NDV##
MOVE TA,[XWD CD.VAL,1]
PUSHJ PP,GETENT
MOVE TB,[ASCII /*****/]
HRRZI TC,4
DPB TC,[POINT 7,TB,6]
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. DA10.
DA10.: PUSHJ PP,DA8.
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 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
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.
SETOI 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?
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 TA,FI.DRL ;[723] SO FIND MAX. 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.F ;[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
HRRZ TA,CURFIL ;[706]
JRST DA10.F ;[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
PUSHJ PP,FATAL ;[624] RECORD CONTAINS CLAUSE IN FD
HRRZ TA,CURFIL ;[624]
DA10.F: HRRZ TB,TBLOCK ;[624]
DPB TB,FI.MRS
SETZ TB,
LDB TC,FI.LBL
CAIN TC,%LBL.S ;STANDARD LABELS?
HRRZI TB,^D80 ;SIZE OF STANDARD LABEL
HRRZM TB,TBLOCK
LDB TA,FI.LRL## ;LABEL RECORD LINK
JUMPE TA,DA10.C ;NO NON-STANDARD LABELS
D10B.1: HRLZM TA,CURDAT
PUSHJ PP,LNKSET
HRRM TA,CURDAT
LDB TB,DA.DEF
JUMPN TB,.+3
PUSHJ PP,D10E.1
JRST D10B.2
LDB TB,DA.EXS
SKIPN TC,TBLOCK
HRRZM TB,TBLOCK
CAMN TB,TBLOCK ;SAME SIZE RECORDS?
JRST D10B.3 ;YES
CAMLE TB,TBLOCK
HRRZM TB,TBLOCK
SETO TB,
HRRZ TA,CURFIL
DPB TB,FI.VLR
D10B.2: HRRZ TA,CURDAT
D10B.3: LDB TB,DA.FAL
JUMPN TB,DA10.C ;NO MORE LABEL RECORDS
LDB TA,DA.BRO
JUMPN TA,D10B.1
DA10.C: HRRZ TA,CURFIL
HRRZ TB,TBLOCK
DPB TB,FI.LRS## ;MAXIMUM LABEL RECORD SIZE
;[236] LDB TC,FI.MRS ;COMPARE LABEL SIZE AGAINST DATA SIZE
;[236] CAMG TC,TB
;[236] DPB TB,FI.MRS ;LABEL IS BIGGER--REPLACE MRS
JRST DA10.X
D10E.1: HRRZ TA,CURDAT
LDB LN,DA.LN##
LDB CP,DA.CP
HRRZI DW,E.104 ;'NOT DEFINED'
JRST FATAL
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,
INTER. DA11.
DA11.: TLNN W1,GWNLIT ;IS ITEM NUMERIC LITERAL?
JRST DA11.E ;NO
TLNE W1,GWDP ;IS IT INTEGER?
JRST DA11.E ;NO
HLRZ TB,W1
ANDI TB,177 ;NO. OF CHARACTERS
MOVEM TB,CTR##
HRRZI TA,LITVAL##
PUSHJ PP,GETVAL
DA11.A: MOVEM TC,0(SAVPTR)
POPJ PP,
DA11.E: EWARNW E.25
SETZ TC,
JRST DA11.A
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.: 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## ;DATA RECORD SIZE
CAIGE TC,(TB)
DPB TB,FI.MRS
POPJ PP,
INTER. DA16.
DA16.: MOVE TA,FI.DRL ;DATA RECORD LINK
MOVEM TA,PNTS##
MOVE TA,DA.DRC##
MOVEM TA,PNTS2##
SKIPN TA,CURFIL
POPJ PP,
SETO TB,
DPB TB,FI.DRC##
POPJ PP,
INTER. DA17.
DA17.: MOVE TA,FI.LRL ;LABEL RECORD LINK
MOVEM TA,PNTS
MOVE TA,DA.LRC##
MOVEM TA,PNTS2
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##
MOVE TA,CURFIL
JUMPE TA,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. 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
IFN ANS68,<
INTER. DA21.
DA21.: HRRZI TC,%LBL.N ;'NON-STANDARD LABELS' CODE
MOVE TA,FI.LRL
MOVEM TA,PNTS
MOVE TA,DA.LRC
MOVEM TA,PNTS2
JRST CHKLBL
>
INTER. DA22.
DA22.: MOVEI TA,%HL.VI ;'VALUE OF IDENTIFICATION' FLAG
MOVEM TA,PNTS
POPJ PP,
INTER. DA23.
DA23.: 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
CAIG TB,^D9 ;9 CHARS OR LESS?
JRST DA24I1 ;YES
MOVEI TB,^D9 ;NO, TRUNCATE
HRRZI DW,E.238 ;& WARN
PUSHJ PP,DA24X.
MOVEM TB,TBLOCK+2
JRST DA24I2
DA24I1: MOVEM TB,TBLOCK+2 ;SAVE TRUE SIZE
CAIL TB,^D9 ;LESS THAN 9 CHARS?
JRST DA24I2 ;NO
HRRZI DW,E.334 ;YES, WARN
PUSHJ PP,DA24X.
MOVEI TB,^D9
DA24I2: PUSHJ PP,DA24S. ;SET PTRS & CTR
SETZM TBLOCK+1 ;CLR NON-STANDARD CHAR FLAG
MOVE TD,TBLOCK+2 ;GET TRUE SIZE
DA24I3: SOJGE TD,DA24I4 ;SKIP IF NOT FINISHED WITH REAL CHARS
MOVEI TE,40 ;GET A SPACE TO PAD OUT TO 9 CHARS
JRST DA24I6
DA24I4: ILDB TE,TB ;GET LITERAL CHAR
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: 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
SKIPE TBLOCK+1 ;NEED A NON-STD CHAR WARNING?
PUSHJ PP,DA24W. ;YES
MOVE 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 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,5
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 7,(TA),6] ;'PUT' POINTER
MOVE TD,TBLOCK ;SIZE
DPB TD,TC
POPJ PP,
;ISSUE A WARNING FOR NON-STD CHAR IN VALUE ITEM
DA24W.: HRRZI DW,E.242 ;NON-STD CHAR
DA24X.: LDB LN,[POINT 13,W2,28] ;GET LINE POSITION
LDB CP,[POINT 7,W2,35]
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,5400 ;PUT A "0" IN VALTAB
MOVEM TB,(TA)
EWARNJ E.335 ;FATAL ERROR
INTER. DA25.
DA25.: 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,
;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.
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
JRST DA26.1 ;NO
CAILE TC,^D49 ;YES, ONLY 1-49 ARE LEGAL.
JRST DA26.E ;COMPLAIN.
CAIE TC,1 ;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,^D49 ;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,^D49
HRRZI TC,LVL.01
MOVEM TC,0(SAVPTR)
DA26.X: PUSHJ PP,SAVLVL ;LEAVE TRACKS FOR REDEFINES
SETZM RUSAGE## ;INIT GROUP ITEM USAGE CHECK
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: 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:
IFN RPW,<
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.:
IFN RPW,<
SKIPL REPSEC ;IN REPORT SECTION AND NOT PAGE- OR LINE-CTR?
JRST .+3 ;NO
SKIPN NAMWRD ;YES, DOES ITEM HAVE A NAME?
JRST DA27.S ;NO
>
IFN ANS68,<
MOVE TB,NAMWRD ;[672] DON'T LET HIM DEFINE TALLY
CAMN TB,[SIXBIT /TALLY/] ;[672]
JRST [EWARNW E.283 ;[672] ?IMPROPER NAME FOR INDEPENDENT ITEM
JRST DCA3.] ;[672] SKIP TO PERIOD AND POP NODE IN TREE
>;END IFN ANS68
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,
IFN RPW,<
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,DA27.C
CAMN TB,TBLOCK
JRST DA27.F ;IT IS A DATA RECORD
PUSHJ PP,FNDBRO## ;FIND BROTHER LINK
JRST DA27.C ;NONE
JRST DA27.A
DA27.C: HRRZ TA,CURFIL
LDB TB,FI.LRL ;LABEL RECORDS CHAIN
D27.C1: JUMPE TB,D27.E2
CAMN TB,TBLOCK
JRST DA27.F ;IT IS A LABEL RECORD
PUSHJ PP,FNDBRO
JRST D27.E2
JRST D27.C1
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!TCS,<
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
IFN RPW,<
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: MOVE TA,[XWD CD.DAT,SZ.DAT+SZ.DOC+SZ.MSK]
PUSHJ PP,D27N.1
HLRZ TB,CURFIL
JUMPE TB,JCE13.
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,
JCE13.: MOVEI DW,E.13 ;NO FILE NAME FOR THIS RECORD [175]
JRST FATALW## ; FATAL ERROR AND FFATAL SW ON [175]
JCE16.: EWARNJ E.16 ;DUPLICATE CLAUSE
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,1
JRST DA28.A
CAIG TA,^D49 ;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:
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
JRST DA28.0 ;NO
CAIG TA,^D49 ;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)
POPJ PP,
DA28.R: CAIN TA,^D66
JRST DA28.S ;LEVEL 66
CAIG TA,^D49
POPJ PP,
DA28.E: EWARNW E.64 ;LEVEL NUMBER NOT LEGAL
HRRZ TA,LEVEL
CAILE TA,0
CAILE TA,^D49
DA28.F: HRRZI TA,LVL.01
MOVEM TA,0(SAVPTR)
JRST DA28.A
DA28.S: HRRZI NODE,DD86A.##
HRRZM NODE,0(NODPTR)
JRST DA7.
;SET UP DATAB ENTRY FOR ALL ITEMS BELOW 01 LEVEL
INTER. DA29.
DA29.:
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
JRST .+3 ;NO
SKIPN NAMWRD ;YES, DOES ITEM HAVE A NAME?
JRST DA29.0 ;NO
>
;[373] TLNN W1,GWNOT
;[373] JRST DA29.0
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
;[373] TLZ W1,GWNOT
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.
; MAKE SURE THE CURRENT ITEM IS NOT INDEX SINCE, FOR SOME STRANGE
; REASON, "USAGE IS INDEX" IS NOT ALLOWED AT THE GROUP LEVEL.
DA29.A:
IFN RPW,<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
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.
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.
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.
CAIN TB,0 ;MUST HE BE?
JRST RPWPOP ;NO, 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. ;NO FATHER, REENTER.
LDB TA,[POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TA,CD.DAT ;IS HE DATAB?
JRST DA29. ;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. ;REENTER.
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
; DEL [253] SETO TC,
; DEL [253] DPB TC,DA.DEF
; DEL [253] DPB TC,DA.CLA
;/ACK 11-FEB-75 THE FOLLOWING TWO INSTR'S WERE MOVED TO
; DA53. AS PER JC.
; TSWF FFILSC; ;ARE WE IN THE FILE SECTION.
; DPB TC,DA.DFS ;YES, REMEMBER IT.
D29XIT: HRRI TA,(TB) ;SET UP OUR NAMTAB LINK.
PUSHJ PP,PUTLNK ;GO LINK THIS DATAB ENTRY INTO THE SAME
; NAME CHAIN.
RPWPOP:
IFN RPW,<
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
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
IFN ANS68,< ;ANSI-68 RESTRICTION
LDB TB,DA.SUB##
JUMPN TB,JCE269 ;NOT PERMITTED ON OCCURS ITEM
>;END IFN ANS68
SKIPN TB,EAS1PC ;[***]
SKIPN LNKSEC ;[***] IN LINKAGE SECTION?
CAIA ;[***] NO
MOVE TB,LNK1PC ;[***] YES, USE SAVED VALUE INSTEAD
MOVE TE,RDFLVL##
MOVEM TB,RDEFPC##(TE)
AOS TE,RDFLVL ;UPDATE LVL COUNT
CAIL TE,RDFSIZ## ;SEE IF TOO DEEP
JRST [SOS RDFLVL
EWARNJ E.268]
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
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.:
IFN RPW,<
SKIPE REPSEC ;NOT NEEDED IN REPORT SECTION
JRST DA7.
>
IFN MCS!TCS,<
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
CLEAR TD,
DPB TD,DA.CLA## ;CLASS
MOVEI TD,2
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
IFN ANS74,<
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.: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,DA.JST##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.JST
POPJ PP,
IFN ANS74,<
;SIGN CLAUSE
INTER. DA32.C
DA32.C: MOVE TA,CURDAT
JUMPE TA,CPOPJ
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: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,DA.LSC##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.LSC
POPJ PP,
;SEPARATE SIGN
INTER. DA32.S
DA32.S: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,DA.SSC##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.SSC
LDB TB,DA.PIC ;PICTURE SEEN?
JUMPE TB,CPOPJ ;NOT YET
HRLI TB,LVL.01 ;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. ;SEE IF NEXT ITEM IS A 'TO' [243]
MOVEI TB,1 ;IF NO MINIMUM IS 1 ;[243]
CAIN TYPE,TO. ; IS NEXT SOURCE ITEM 'TO' [243]
SETZ TB, ; YES, ALLOW 0 [243]
MOVE TC,0(SAVPTR) ; GET USERS NO. OF OCCURS [243]
CAIGE TC,(TB) ;SEE IF NO. OF OCCURS LEGAL [243]
JRST JCE25 ; ILLEGAL [243]
CAIG TC,77777
JRST DA33.A
;[471] MOVEI DW,E.299 ; TOO MANY [243]
MOVEI DW,E.593 ;[471] TO MANY FOR "OCCURS"
PUSHJ PP,DA24X. ; GIVE ERROR AND COME BACK [243]
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 ;GET POINTER TO DATA ITEM [243]
SETO TB, ;THEN SET [243]
DPB TB,DA.ERR ; ERROR BIT [243]
MOVEI DW,E.25 ; GIVE ERROR MESSAGE AND RETURN [243]
JRST DA24X. ;[243]
;THIS ROUTINES LOOKS AHEAD AT NEXT SOURCE ITEM [243]
DANXT.: MOVEM W2,1(SAVPTR) ;SAVE CURRENT SOURCE ITEM [243]
PUSHJ PP,GETITM ; GET NEXT SOURCE ITEM [243]
SWON FREGWD ;SET SW TO REGET SAME ITEM FOR SYNTAX SCAN [243]
MOVE W2,1(SAVPTR) ;RESTORE CURRENT SOURCE [243]
POPJ PP, ;[243]
;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!TCS,<
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
CAIN TB,%US.C1 ;COMP-1?
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
IFN ANS74,<
;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
>;END IFN ANS74
IFN ANS68,<
HRRZ TB,INSIZE##
DPB TB,DA.INS## ;INTERNAL SIZE
HRRZ TB,EXSIZE##
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.: MOVE TA,CURDAT
JUMPE TA,CPOPJ ;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.
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.
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.
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.
POPJ PP, ;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 SETUSG
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. DA41.
DA41.: HRRZI TC,%US.C1 ;USAGE 'COMP-1'
JRST SETUSC
INTER. DA42.
DA42.: HRRZI TC,%US.C3 ;USAGE 'COMP-3'.
JRST SETUSG
INTER. DA43.
DA43.: HRRZI TC,%US.IN ;USAGE 'INDEX'
SETUSC:
IFE RPW,<
JRST SETUSG
>
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
JRST SETUSG ;NO
EWARNW E.349 ;?ILLEGAL USAGE IN REPORT GROUP
JRST DA73.X ;NEXT NODE IS DD144.
>
;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.: 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 SETUSG
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)
JRST PUTLNK##
;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
HLRZ TC,W1
ANDI TC,177 ;SIZE
HRLM TC,TBLOCK+13 ;SAVE NO. OF CHARACTERS
IDIVI TC,5
JUMPE TB,.+2
HRRZI TC,1(TC)
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
POPJ PP,] ;[700] KEEP GOING
LDB TE,DA.EDT## ;[674] AND GET ITS EDIT FLAG
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,[POINT 13,W2,28] ;[674] GET LINE OF BAD VALUE
LDB CP,[POINT 7,W2,35] ;[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,
;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,
IFN ANS74,<
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 ; NO SUBCRIPTS ALLOWED IN RENAMED DATA [253]
LDB TB,DA.LVL ; CHECK LEVEL OF [253]
CAIN TB,LVL.01 ; RENAMED DATA [253]
JRST D53E.1 ; CANNOT BE 01 [253]
CAIE TB,LVL.77 ; 77 [253]
CAIN TB,LVL.66 ; OR 66 [253]
JRST D53E.1 ; ILLEGAL [253]
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 ; GET 66 ENTRY SOURCE ITEM [253]
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 ; KEEP ORIG 66 ENTRY SOURCE [253]
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
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.5 ;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
ADDI TD,1
; JRST 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
ADDI TA,1 ;PRETEND WE'RE AT START OF NEXT WORD
JRST D53DW5 ;GO TO COMMON CODE
;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
SETZM CURDAT
SETO TC, ; SET AS DEFINED [253]
DPB TC,DA.DEF ; [253]
TSWF FFILSC; ;ARE WE IN THE FILE SECTION?
DPB TC,DA.DFS ;YES, REMEMBER THAT.
SKIPE LNKSEC ;[450] LINKAGE SECTION?
DPB TC,DA.LKS ;[450] YES, SET FLAG IN ENTRY.
POPJ PP,
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.5: HRRZI DW,377
JRST DA53.E
D53E.6: HRRZI DW,E.257
JRST DA53.E
D53E.7: HRRZI DW,E.316
DA53.E: SKIPN TA,CURDAT
JRST D53E.X
LDB LN,DA.LN
LDB CP,DA.CP
D53E.X: 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 ORIGIONAL 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
IFN ANS74,<
;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.
IFN RPW,< 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.FM ; LEVEL FLAG IS ON GO SET HIS FATHERS.
LDB TD, DA.FAL## ;IF THERE ARE NO MORE SONS,
JUMPN TD, D54.FM ; LEAVE
LDB TA, DA.BRO## ;OTHERWISE GET THE BROTHER LINK
JRST D54.FK ; AND GO CHECK HIM FOR DEPENDING.
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:
IFN RPW,<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.
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 AND COMP-1 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.
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.
SETO TD, ;HOWEVER ALWAYS TURN ON
DPB TD, DA.EDT## ;EDIT FLAG (PER NAVY AUDIT TEST)
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 DO 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 THER IS A VALUE
; CLAUSE AT THIS LEVEL AND IF
; THERE IS, CHECK IT OUT.
;ALLOCATE STORAGE FOR AN ELEMENTARY ITEM.
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.
;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.
D54.TV: 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.
JRST D54.VH ; OTHERWISE, GO ON.
;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, D54.VH ; SECTION, GO ON.
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.
D54.VD: HRRZ TA, CURDAT ;RESTORE THE CURRENT ITEM'S
; DATAB ADDRESS.
;CHECK REDEFINITIONS FOR SIZE.
D54.VH: LDB TC, DA.RDF## ;IF THIS ISN'T A REDEFINITION,
JUMPE TC, CPOPJ ; WE ARE THROUGH - LEAVE.
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: SOSGE TB, RDFLVL ;BACK UP ONE LEVEL.
JRST [SETZM RDFLVL ;BACKED UP TOO FAR - DEEP SNEEKERS!!
EWARNJ E.380]
MOVE TB, RDEFPC(TB) ;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.
PUSHJ PP, D54E.W ;GO COMPLAIN.
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.
;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.Q: HRRZI DW, E.241 ;CLASS OF ITEM CONFLICTS WITH
PJRST D54E.J ; LITERAL IN 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.
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,
IFN MCS!TCS,<
SKIPN COMSEC ; ALLOW USER TO SET VALUE IF DEFINING
; OWN CD AREA
>
PJUMPN TD, D54E.M ; IT'S AN ERROR.
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.EDT## ; AND 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, CPOPJ ; AND IS NOT EDITED, ALL IS WELL.
PJRST D54E.Q ;OTHERWISE, IT IS AN ERROR.
;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.
POPJ PP, ;OTHERWISE, ALL IS WELL, RETURN.
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>
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
;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
;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.
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.
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 602000,2] ;FLOATING POINT NUMBER HEADER
JRST PUT21A
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 604000,2] ;2-WORD COMP HEADER
PUT21A: 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 610000,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>
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)
;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.
;POINTERS.
PVPTRS: POINT 9,CH ;COMP-3.
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.
;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
IFN RPW, <
; 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,RPWIT9 ; [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,RPWIT9 ; [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
RPWIT9: 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,RPWGPX ; [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,RPWGPX ; [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 RPWGPX ; [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
JRST RPWGEE ; [315] ERROR MESSAGE THEN EXIT
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
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
RPWGPX: MOVE TA,CURDAT ; [315] RESTORE DATAB ADDRESS
POPJ PP, ; [315] RPWGPC EXIT POINT
; CHECK LINE PARAMETER TO SEE IF WITHIN BOUNDS
RPWLCH: LDB TD,RW.TYP ; [315] LINE TYPE
JUMPE TD,RPWLHP ; [315] NONE-EXIT
LDB TC,RW.LCD ; [315] GET LINE CODE
CAIE TC,%RG.LN ; [315] DO WE HAVE LINE INTEGER?
JRST RPWLHP ; [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
RPWLHP: 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.
> ; [315] END OF IFN RPW
INTER. DA55.
DA55.: PUSHJ PP,DA47.A ;[674]
SKIPN TA,CURDAT
JRST DA55.X
LDB TB,DA.VAL
JUMPN TB,JCE16.
HLRZ TB,CURLIT
DPB TB,DA.VAL
IFN RPW,<
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. DA56.
DA56.: PUSHJ PP,DA11.
HRRZ TA,CURDAT ; GET CURRENT DATAB ADDRESS [243]
LDB TB,DA.ERR ; DID WE HAVE AN ERROR (USER) [243]
JUMPE TB,DA56.1 ; NO GO ON ;[243]
SETZ TC, ; YES DATAB TABLE NOT EXTENED FOR OCCURS [243]
JRST DA56.B ; GO TO CLEAR NO. OF OCCURS AND EXIT [243]
DA56.1: MOVE TC,0(SAVPTR) ; NO OF OCCURS [243]
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 ;NEW LABEL [243]
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,
INTER. DA58.
DA58.: SKIPN TA,CURFIL
POPJ PP,
SETO TB,
DPB TB,FI.DSD## ;DEFINED IN AN SD
POPJ PP,
;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.: MOVEI TA,%HL.VP ;'VALUE OF PROJECT-PROGRAMMER' FLAG
MOVEM TA,PNTS
POPJ PP,
;BUILD REPORT TABLE ENTRY & LINK FILE TO REPORT
IFN RPW,<
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 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.338 ; [335] BAD TABLE
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##
MOVE TB,[XWD [SIXBIT /PAGE:COUNTER/],NAMWRD]
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
MOVE TB,[XWD [SIXBIT /LINE:COUNTER/],NAMWRD]
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,[001002,,1] ;SET UP CODE WORD
MOVEM TB,(TA)
MOVE 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
JRST DA8. ;ALLOCATE LINE-COUNTER
;MAKE PAGE/LINE-COUNTER ENTRY IN DATAB
DA64S.: 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.RPW,,SZ.RPC] ;GET A CONTROL ENTRY IN RPWTAB
PUSHJ PP,GETENT
MOVEM TA,CURRPW ;SAVE RPWTAB PTR
HLRZ TC,TA ;PUT LINK TO CONTROL ENTRY INTO RD ENTRY
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TB,RW.NCI ;IS THIS THE FIRST CONTROL?
JUMPE TB,.+2 ;YES
EWARNW E.346 ; [315] NO, FINAL MUST BE FIRST
DPB TC,RW.CID##
HRRZI TC,1 ;INDICATE 1ST CONTROL ENTRY
DA71.X: DPB TC,RW.NCI##
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.RPW,,SZ.RPC] ;GET A CONTROL ENTRY IN RPWTAB
PUSHJ PP,GETENT
MOVEM TA,CURRPW ;SAVE RPWTAB PTR
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
PUSHJ PP,GETRDL ; [315] GET RD RPWTAB PTR
PUSHJ PP,RETHM ; [315] GET BACK SOURCE INPUT FOR GETITM REGET
LDB TC,RW.NCI ;# OF CTRL IDENTIFIERS SEEN
SKIPN TC ;THIS THE 1ST CONTROL ID?
DPB TB,RW.CID ;YES, STORE LINK TO 1ST CTRL ID IN RPWTAB
AOJA TC,DA71.X ;INCREMENT CTRL-ID CTR
DA72N: MOVEM W1,HLDSRC## ; [315]SAVE CURRENT SOURCE INPUTS
MOVEM W2,HLDSRC+1 ; [315]
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: ; [315] RESTORE LAST SOURCE ITEM
MOVE W1,HLDSRC ; [315]
MOVE W2,HLDSRC+1 ; [315]
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
>; [315] END OF IFN RPW
;CHECK FOR ILLEGAL CLAUSE IN REPORT SECTION
INTER. DA73.
DA73.:
IFN RPW,<
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,
;CHECK FOR ILLEGAL CLAUSE OUTSIDE REPORT SECTION
IFN RPW,<
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.: 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,
;REPORT LINE IS <INTEGER>
INTER. DA76.
DA76.: 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,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
;NEXT GROUP IS NEXT PAGE
INTER. DA80.
DA80.: 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
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
CAML TB,THSCTL ;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 TC,RW.NCI ;GET NUMBER OF CONTROLS
LDB TB,RW.CID ;GET LINK TO 1ST CONTROL
ADD TB,RPWLOC
HRRZS TB ;CLR LEFT HALF
FNDCN1: HLRZ TD,(TB) ;GET DATAB LINK FROM CONTROL ENTRY
CAIN TD,(TE) ;IS IT THE ONE?
JRST CPOPJ1 ;YES
ADDI TB,3 ;NO, ADVANCE TO NEXT CONTROL
SOJG TC,FNDCN1 ;GO BACK TO TRY NEXT ONE
HRRZ TC,RPWLOC ;REDUCE RPW ADDR TO RPW LINK
SUBI TB,(TC)
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.: MOVEI TC,%RG.RH ;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
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
HRRZM TB,THSCTL ;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.)
CAMGE TB,THSCTL ;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
SETO TB, ;SET FINAL CONTROL FLAG
DPB TB,RW.FNC##
SETZ TE, ;FINAL HAS "DATAB LINK" OF 0
JRST DA94.1
>;END IFN RPW
;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
IFN RPW,<
INTER. DA97.
DA97.: PUSHJ PP,DA96. ;GET FULL SOURCE IDENTIFIER
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 DATA-NAME FOR ITEM
INTER. DA99.
DA99.:
IFN RPW,<
SKIPE REPSEC ;REPORT SECTION?
JRST DA99.R ;YES
>
EWARNW E.283 ;NO, ?DATA-NAME EXPECTED
HRRZI NODE,DD91P.## ;MAKE DD91. THE NEXT NODE IN TREE
DA99.X: HRRZM NODE,(NODPTR)
JRST DA7. ;SET TO REGET WORD
IFN RPW,<
DA99.R: SETZB TA,NAMWRD ;INDICATE REPORT ITME HAS NO NAME
DPB TA,[POINT 15,W2,15]
HRRZI NODE,DD89P.## ;CONTINUE AT NODE DD89.
JRST DA99.X
>
INTER. DA99A.
DA99A.:
IFN RPW,<
SKIPE REPSEC ;IN REPORT SECTION?
JRST DA99.Q ;YES
>
EWARNW E.17 ;NO, ?DATA-NAME EXPECTED
HRRZI NODE,DD98P.## ;NEXT NODE IS DD98.
JRST DA99.X
IFN RPW,<
DA99.Q: SETZB TA,NAMWRD ;INDICATE ITEM HAS NO NAME
DPB TA,[POINT 15,W2,15]
HRRZI NODE,DD95P.## ;CONTINUE AT NODE DD95.
JRST DA99.X
>
;CHECK REDEFINES CLAUSE FOR REPORT SECTION ITEM
INTER. DA100.
DA100.:
IFN RPW,<
SKIPE REPSEC ;IN REPORT SECTION?
EWARNJ E.348 ;YES, ILLEGAL
>
POPJ PP,
;PROCESS SUM IDENTIFIER
IFN RPW,<
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
HLRZ TB,CURRPW ;STORE RPWTAB LINK IN HLDTAB
DPB TB,HL.LNK
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
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: HLRZ TB,W1 ;GET THE INTEGER
ANDI TB,177
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
;THIS TEST IS HERE BECAUSE ANS-68 COPY AT 01 LEVEL
;DIFFERS FROM ANS-74 IN THAT PERIOD IS ASSUMED
;IS THIS IS THE CASE THEN JUST IGNORE "PERIOD ASSUMED" ERROR
IFN ANS68,<
MOVE TC,LEVEL ;GET LEVEL OF PREVIOUS
CAIN TC,LVL.01 ;IF NOT 01
TSWT FRLIB ;AND CURRENTLY READING FROM LIBRARY
>
JRST DA105A ;THEN PERIOD ASSUMED ERROR
IFN ANS68,<
SWON FREGWD
JRST DA107. ;POP UP A LEVEL AND CONTINUE
>
;STORE CODE LINK
IFN RPW,<
INTER. DA106.
DA106.: LDB TA,[POINT 15,W2,15] ;NAMTAB LINK
HRRZI TB,CD.MNE
PUSHJ PP,FNDLNK
JFCL
PUSHJ PP,GETRDL ;GET PTR TO RD ENTRY
HLRZS TB
DPB TB,RW.COD##
POPJ PP,
>
;END OF DATA ITEM
;IF IN REPORT SECTION AND ITEM HAS NO NAME, GIVE IT ONE
INTER. DA107.
DA107.:
IFN RPW,<
SKIPE REPSEC ;IN REPORT SECTION?
PUSHJ PP,FAKNAM ;YES
>
JRST DA0. ;NOW POP UP A LEVEL IN TREE
IFN SERCH,<
;ASCENDING KEY FOR OCCURS
INTER. DA108.
DA108.: HRRZI TB,%HL.KY ;ASC. KEY CODE
DA108X: 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
DPB TB,DA.KEY
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: ;[220]
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
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: MOVEM LN,INVLN## ;SAVE LN AND CP FOR INVOKE
MOVEM CP,INVCP##
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: MOVEM LN,INVLN## ;SAVE LN AND CP FOR INVOKE
MOVEM CP,INVCP##
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. DA116A
DA116A: PUSHJ PP,FIXPPN ;GET 1ST PART OF PPN
HRLM TA,DB.PPN## ;STORE IN LH OF PPN WORD
POPJ PP,
INTER. DA116B
DA116B: PUSHJ PP,FIXPPN ;GET PROGRAMMER NUMBER
HRRM TA,DB.PPN ;STORE IN RH OF PPN WORD
POPJ PP,
;THIS SUBROUTINE CONVERTS THE SIXBIT PPN INTEGER IN LITVAL
;INTO A BINARY NUMBER IN THE RH OF TA.
FIXPPN: HLRZ TB,W1 ;GET LENGTH
ANDI TB,777 ;ISOLATE IT
TLNE W1,GWNLIT ;NUMERIC LITERAL?
TLNE W1,GWDP ;DECIMAL POINT?
EWARNJ E.336
CAILE TB,6 ;6 DIGITS?
EWARNJ E.336
SETZ TA, ;CLEAR TOTAL
MOVE TD,[POINT 7,LITVAL]
FIXLUP: SOJL TB,CPOPJ ;EXIT IF COUNT EXHAUTED
ILDB TC,TD ;GET DIGIT
CAIL TC,"0"
CAILE TC,"7"
EWARNJ E.336 ;NOT OCTAL DIGIT
SUBI TC,"0"
LSH TA,3 ;MOVE TOTAL LEFT
ADD TA,TC ;ADD DIGIT TO TOTAL
JRST FIXLUP
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
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
SETOM FINVOK## ;SET INVOKE FLAG
SETOM FINVD## ;TELL COBOLD TO READ FILE.
TLZE SW,20 ;[453] IS /S SWITCH ON--IF YES TURN IT OFF
SETOM DBONLY## ;[453] IT WAS ON, REMEMBER IT
POPJ PP,
E.MXIN: TTCALL 3,[ASCIZ /?CBLTMI--TOO MANY "INVOKES" SPECIFIED
/]
JRST ALLERR
OPNERR: TTCALL 3,[ASCIZ /?FATAL--OPEN/]
ALLERR: TTCALL 3,[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
TTCALL 3,TA
TTCALL 3,[ASCIZ /DBC.TMP
/]
TTCALL 3,[ASCIZ "?CANNOT CONTINUE
"]
CALLI $EXIT
NOTFND: TTCALL 3,[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
TTCALL 3,[ASCIZ /?FATAL--INPUT/]
JRST ALLERR
DA119A: SKIPE SCHSEC## ;[476] SCHEMA SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
DA119B:
IFN MCS!TCS,<
SKIPN CSSEEN## ;[476] COMM. SECTION SEEN?
>
DA119C: SKIPE WRKSEC## ;[476] WORKING-STORAGE SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
SKIPGE LNKSEC## ;[476] LINKAGE SECTION SEEN ?
SKIPGE ACCSEE## ;[476] ACCESS VERB USED?
SKIPE REPSEC## ;[476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
POPJ PP, ;[476] OK, RETURN
>
SUBTTL MCS/TCS SYNTAX
IFN MCS!TCS,<
INTER. DA120.
DA120.: SKIPE CSSEEN## ;COMM SEC SEEN?
EWARNJ E.432
SETOM CSSEEN
IFN DBMS,< ;[507]
PUSHJ PP,DA119C ;[476] CHECK FOR PROPER SEQUENCE
> ;[507]
SETOM LSTW77## ;[476] CLEAR IN CASE WORKING-STORAGE SEEN
SWOFF FFILSC
IFN RPW,<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
IFN MCS,<
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 ;---
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: SKIPE W2,(TE) ;GET CDBLK ENTRY
JRST DA139B ;OK, WE HAVE ONE
MOVE TD,[SIXBIT /FILLER/]
MOVEM TD,NAMWRD
CLEARM NAMWRD+1
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
MOVEI CT,USERN.
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
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
IFN MCS,<
CAILE TC,^D50
>
IFN TCS,<
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 TCS,<
XWD 0,^D8 ;MCS-10 EXTENSION
>
IFN TCS,<
XWD 0,^D12 ;TCS-20 EXTENSION
>
>
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.
SETOI 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, JCE16. ; GO COMPLAIN.
DPB TB, FI.ERM## ;SET IT.
HRRZI TB, %RM.DC ;NOTE THAT WE HAVE ONE.
DPB TB, FI.RM2##
POPJ PP, ;RETURN.
;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
IFN ANS74,<
;SET LINAGE SEEN IN FILE TABLE
INTER. DA200.
DA200.: 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
HLRZ TB,W1
ANDI TB,177 ;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,
>
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 ;W-S SEEN?
EWARNJ E.402 ;YES, CANT DUPLICATE
SETOM WRKSEC ;[710] NOW SET FLAG TO SHOW WE'VE SEEN IT
SKIPE REPSEC## ;[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!TCS,<
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.
IFN RPW,<
INTER. DCA6.
DCA6.: PUSHJ PP,DA10.
JRST DA63.
>
INTER. DCA7.
DCA7.:
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 LNKSEC## ;[476] LINKAGE SECTION SEEN?
EWARNJ E.171 ;[476] YES, ERROR
SKIPE REPSEC## ;[476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
PUSHJ PP,DA10.
JRST DA112.
INTER. DCA10.
DCA10.: PUSHJ PP,DA9.
JRST DA58.
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