Trailing-Edge
-
PDP-10 Archives
-
BB-H580C-SB_1981
-
cobolc.mac
Click cobolc.mac to
see without markup as text/plain
There are 15 other files named cobolc.mac in the archive. Click here to see a list.
; UPD ID= 3569 on 6/8/81 at 1:37 PM by NIXON
TITLE COBOLC V12B
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, 1981 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
RPW==:RPW
DBMS==:DBMS
DEBUG==:DEBUG
MCS==:MCS
TCS==:TCS
;EDITS
;NAME DATE COMMENTS
;DAW 31-DEC-80 [1106] Don't give wrong error message when 88 level
; item has value clause and item is subordinate to an item
; whose usage is INDEX.
;DMN 14-NOV-80 [1071] GIVE ERROR MESSAGE WHEN VARIABLE PART IS NOT THE LAST THING IN RECORD.
;CLRH 9-APR-80 [1011] FIX EDIT 733 TO NOT REQUIRE DATA RECORD IF FD HAS
; A REPORT CLAUSE.
;DMN 28-MAR-80 [1003] FIX DUPLICATE CREF DEFINITION WHEN LEVEL # DECREASES.
;DMN 30-JAN-80 [763] CHECK FOR DUPLICATE LINKAGE AND REPORT SECTIONS.
;DMN 29-JAN-80 [760] MAKE "BLANK WHEN ZERO" WORK AGAIN FOR NUMERIC SENDING ITEM.
;DMN 24-OCT-79 [751] BAD DATAB DEFINITION IF FD NAME MATCHES PROGRAM ID.
;DMN 13-SEP-79 [733] GIVE ERROR IF NO DATA RECORD IN FD.
;V12A SHIPPED
;DMN 8-AUG-79 [723] FIX EDIT 706 TO POINT TO CORRECT RECORD
;DAW 22-MAY-79 [711] FIX ANOTHER ERROR IN 674 (INDEX ITEMS)
;DMN 16-MAY-79 [710] SET FLAG SHOWING WORKING-STORAGE SEEN
;CLRH 3-MAY-79 [706] CHECK RECORD CONTAINS CLAUSE AGAINST MAX. RECORD SIZE.
;DAW 27-APR-79 [700] FIX UNDESERVED ERROR FOR COMP-1 ITEMS WHEN
; EDIT 674 IS INSTALLED
;CLRH 3-APR-79 [674] GENERATE ERROR FOR BAD VALUE CLAUSE OF 88 LEVEL ITEM
;DAW 29-MAR-79 [672] FIX ILL MEM REF WHEN SOMEONE DEFINES A DATANAME "TALLY".
;DMN 6-MAR-79 [651] USE CORRECT BYTE POINTER TO TEST RPW CONTROL FLAGS
;DAW 21-FEB-79 [635] FIX WRONG SIZE COMPUTATION FOR ITEMS RENAMING ITEM-1 THRU ITEM-2
;V12******************
;DMN 5-JAN-79 [624] RECORD SIZE MUST MATCH RECORD CONTAINS IN F MODE FILE
;DMN 28-NOV-78 [603] FIX ILL UUO WHEN "CONTROL" IN "RD" REFERS TO EDITED ITEM.
;V11******************
;NAME DATE COMMENTS
;EHM 16-DEC-78 [527] FIX 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.
; EDIT 247 FLAGS ERROR FOR ITEMS IN REPORT SECTION THAT ARE SUBCRIPTED.
; EDIT 243 FIXES PHASE E CRASHES BECAUSE OF ERROR IN OCCURS N
; TO P CLAUSE - ALSO ALLOWS N TO BE 0.
;[237] /JEF COBOLC.MAC, DIAGS.MAC QAR-2918
; IDENTIFIERS GIVEN IN THE CONTROL CLAUSE MUST BE DEFINED
; ONLY IN THE FILE OR WORKING SECTIONS.
;[236] /ACK COBOLC.MAC, CLEAND.MAC
; RESERVE SPACE FOR LABEL RECORD IF LARGER THAN FD
; BUT DONT CHANGE FILE TABLE MAX-REC-SIZE
;[220] /ACK GENERATE AN ERROR IF A MINOR KEY IS THE SUBJECT OF AN OCCURS.
; EDIT 215 REPORT-WRITER CHECK THAT HEADER .LE. FIRST-DETAIL .LE. LAST-DETAIL .LE. FOOTING
; EDIT 175 PREVENT ASSEMBLY IF A RECORD ASSOCIATED WITH AN FD HAS NO FILE NAME
; EDIT 174 FIXES RD FILNAME COPY .
; EDIT 164A FIX TO 164
; EDIT 164 FLAG AS FATAL ANY DEPENDING ITEM NOT 1-WORD COMP OR
; SUBSCRIPTED OR IN LINK SECTION.
; EDIT 162 GIVE WARNING THE FOLLOWING MAY NOT BE IN LINKAGE SECTION
; VALUE OF ID, DATE-WRITTEN, OR USER-NAME
; FILE-LIMITS, ACTUAL-KEY OR SYMBOLIC-KEY
; EDIT 152 FIXES ILLEGAL MEM REF FOR UNDEFINED VALUES OF ID
; DATE-WRITTEN, AND PPN.
; EDIT 110 NO MULTIPLE WORKING STORAGE
; RESERVE ALTERNATE AREAS GIVES TOO MANY BUFFERS
; ALTER STATEMENT GETS ERROR IF PRG COMPILED WITH /A.
; LAST STATEMENT IN PARA IS AN OPEN NOT TERMINATED BY A PERIOD GETS NO WARNING.
TWOSEG
SALL
RELOC 400000
ENTRY COBOLC
EXTERN CTREE,CPOPJ,CPOPJ1
EXTERN DA.DEF,DA.INS,DA.EXS,DA.OCC,DA.FAL,DA.RDS,DA.LN,DA.CP
EXTERN DA.BWZ,DA.DPR,DA.EDT,DA.ERR,DA.JST,DA.NAM,DA.NDP,DA.NOC,DA.PIC
EXTERN DA.PWA,DA.SGN,DA.SUB,DA.USG,DA.VAL
EXTERN HL.COD,HL.LNK,HL.LNC,HL.NAM,HL.QAL
EXTERN CFLM,CURCON,DATLVL,EAS2PC,FATALW,LEVEL
EXTERN PUTCRF,PUTLNK
EXTERN RDFLVL,RPWRDL,RUSAGE,THSCTL
EXTERN CURRPW
EXTERN LNKSET
EXTERN RENLOC,RENNXT,RN.01,RN.66,XPNREN
INTERN D54.NJ ; [315]
COBOLC: SETFAZ C;
SETZM FILSEC ;CLR FILE-SECTION-SEEN FLAG
SETZM WRKSEC## ;CLR WORKING-STORAGE-SECTION-SEEN FLAG
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.##
OUTSTR [ASCIZ /COBOLC--lost; too many POPJ's
/]
JRST KILL##
SUBTTL ACTIONS FOR DD SYNTAX PROCESSING
;COME HERE TO POP UP ONE LEVEL IN THE SYNTAX TREE.
INTER. DA0.
DA0.: POP NODPTR,NODE ;POP UP CURRENT NODE
IFN DEBUG,<PUSHJ PP,PTPOP.##> ;IF TRACING, PRINT NODE POPING UP TO
POPJ PP,
;COME HERE AFTER WE SEE "DATA DIVISION" TO INITIALIZE.
INTER. DA1.
DA1.: SWOFF FFILSC; ;'FILE SECTION' FLAG
MOVE SAVPTR,ISVPTR ;SAVE LIST POINTER
HRRZI TA,1
PUSH SAVPTR,TA
SETZM RDFLVL ;CLR REDEFINES NESTING LEVEL
SETZM CURFIL
SETZM CURDAT
SETZM CURCON
SETZM CURVAL##
SETZM CURNAM##
SETZM 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:
IFN ANS74,<
SKIPN DEBSW## ;NEED DEBUG CODE?
JRST DA4.A3 ;NO
MOVE TB,[NAMWRD,,TBLOCK] ;NEED TO SAVE CURRENT NAME
BLT TB,TBLOCK+4 ;SINCE TRACE CODE WILL PRINT IT AGAIN
PUSH PP,FLGSW ;SAVE CURRENT STATE
SETZM FLGSW ;ZERO SO WE DON'T FLAG DEBUG-ITEM
PUSH PP,W1 ;SO TRACING IS CORRECT
PUSH PP,W2 ;...
PUSHJ PP,DA210. ;ALLOCATE DEBUG-ITEM
POP PP,W2
POP PP,W1
POP PP,FLGSW
MOVS TB,[NAMWRD,,TBLOCK]
BLT TB,NAMWRD+4 ;RESTORE PREVIOUS NAME
DA4.A3:>
PUSHJ PP,CLEANC## ;DO CLEANC HERE SO SUM-CTRS GET ALLOCATED
SKIPN SVDADR ; [315] SEE IF ANY "VALUE" ITEM LEFT
JRST D4.12 ; [315] NONE LEFT
MOVE CH,SVDWRD## ; [315] GET THE LAST "VALUE" DATA
PUSHJ PP,PUTAS1 ; [315] PUT INTO AS1 FILE
SETZM SVDADR ; [315] CLEAR IT
D4.12: HRLZI CH,AS.REL##
HRRI CH,1+AS.DAT##
PUSHJ PP,PUTAS1
HRRZ CH,EAS1PC
DA4.A: HRRZM CH,TBLOCK
MOVE CH,[XWD AS.REL+1,AS.MSC##]
PUSHJ PP,PUTAS1
HRRZ CH,TBLOCK
CAILE CH,077777
HRRZI CH,077777
IORI CH,AS.DOT##
PUSHJ PP,PUTAS1
HRRZ CH,TBLOCK
SUBI CH,077777
JUMPG CH,DA4.A
PUSHJ PP,CLRNAM## ;DELETE UNNECESSARY RESERVED WORDS
ENDFAZ C;
INTER. DA5.
DA5.: MOVEM LN,TBLOCK
DA5.0: MOVEM TYPE,TBLOCK+1
PUSHJ PP,GETITM##
CAIE TYPE,AMRGN.+ENDIT.
CAIN TYPE,ENDIT. ;EOF?
POPJ PP, ;YES
CAMN LN,TBLOCK
JRST DA5.B
MOVEM LN,TBLOCK
CAIE TYPE,AMRGN.+LINKG.
CAIN TYPE,AMRGN.+FILE.
JRST DA5.X
CAIE TYPE,AMRGN.+WORKI.
CAIN TYPE,AMRGN.+PROC.
JRST DA5.X
IFN DBMS,<
CAIE TYPE,AMRGN.+SCHEM.
>
CAIN TYPE,AMRGN.+FD.
JRST DA5.X
IFN MCS!TCS,<
CAIE TYPE,AMRGN.+COMM. ;COMMUNICATION?
CAIN TYPE,AMRGN.+CD.
JRST DA5.X ;YES
>
CAIN TYPE,PRIOD.
JRST DA5.0
CAIE TYPE,INTGR.
CAIN TYPE,AMRGN.+INTGR.
JRST DA5.X
DA5.B: CAIN TYPE,PIC.
PUSHJ PP,PSCAN##
JRST DA5.0
DA5.X: MOVE TA,TBLOCK+1
CAIE TA,PRIOD.
PUSHJ PP,CE125.
SKPNAM
INTER. DA7.
DA7.: SWON FREGWD;
POPJ PP,
INTER. DA6.
DA6.: SWOFF FREGWD;
POPJ PP,
INTER. DA8.
DA8.: HLRZ TB,CURDAT
JUMPE TB,DA8.X
PUSHJ PP,DA54.
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
IFN ANS74,<
SKIPN FLGSW## ;NEED FIPS FLAGGER?
JRST DA9.1 ;NO
LDB LN,[POINT 13,W2,28] ;GET LN
LDB CP,[POINT 7,W2,35] ; & CP
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
PUSHJ PP,@[TST.L## ;SEQUENTIAL
TST.LI## ;RELATIVE
TST.H## ;INDEXED
CPOPJ](TB)
MOVE TA,CURFIL ;TA WAS DESTROYED BY TEST
>
DA9.1: SETO TB,
DPB TB,FI.FDD
DPB W2,FI.FLC##
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.FLC
HRRZI TC,%%RM
LDB TE,FI.RM2## ;RECORDING MODE CLAUSE SEEN?
SKIPN TE ;YES, DON'T CHANGE
DPB TC,FI.ERM##
DPB TC,FI.IRM##
HRRZI TC,%%LBL
DPB TC,FI.LBL##
HRRZI TC,%%ACC
DPB TC,FI.ACC##
HRRZI TC,1
DPB TC,FI.NDV##
AOS TC,NFILES## ;GET # OF FILES; BUMP COUNTER
DPB TC,FI.NUM## ;STORE # IN FILE TABLE
MOVE TA,[XWD CD.VAL,1]
PUSHJ PP,GETENT
MOVE TB,[ASCII /*****/]
HRRZI TC,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
IFN ANS74,<
INTER. DA10R.
DA10R.: FLAGAT RP
JRST DA10.
INTER. DA10S.
DA10S.: FLAGAT HI
SKPNAM
>
INTER. DA10.
DA10.: PUSHJ PP,DA8.
D10A.0: MOVE TA,CURFIL
JUMPE TA,DA10.X
HRRZ TB,CFLM
HRRZI TD,(TB)
HRRZ TC,EAS2PC
SUBI TD,(TC)
CAIGE TD,5
HRRZI TB,5(TC)
MOVE TE,EAS1PC
TLNE TE,777777
HRRZI TE,1(TE)
CAIGE TB,(TE)
HRRZI TB,(TE)
HRRZM TB,EAS1PC
SETZM EAS2PC
SETZM CFLM
HRRZ TA,CURFIL
SETZM TBLOCK
LDB 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?
JUMPE TC,DA10.F ;LAST RECORD WAS A RENAMES SO IGNORE IT
CAIN TB,(TC) ;[624]
JRST DA10.F ;[624] YES, SO NO PROBLEM
LDB TB,FI.ERM ;[624] GET ITS RECORDING MODE.
CAIN TB,%RM.EB ;[706] IF THE RECORDING MODE IS EBCDIC,
JRST DA10.G ;[706] GO CHECK FOR VARIABLE LENGTH
HRRZ TA,CURFIL ;[723] [706] OTHERWISE, IT IS NOT EBCDIC,
LDB TA,FI.DRL ;[723] SO FIND MAX. RECORD
JUMPE TA,[HRRZ TA,CURFIL ;[733] POINT TO FD
LDB TB,FI.RPG ;[1011] IF ITS A REPORT FILE
JUMPN TB,DA10.K ;[1011] THEN ITS OK NOT TO HAVE A DATA-RECORD
MOVEI DW,E.201 ;[733] NO DATA RECORD
LDB LN,FI.FLN## ;[733]
LDB CP,FI.FCP## ;[733]
JRST DA10.J] ;[733] GIVE ERROR MESSAGE
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
DA10.J: PUSHJ PP,FATAL ;[733] [624] RECORD CONTAINS CLAUSE IN FD
HRRZ TA,CURFIL ;[624]
DA10.F: HRRZ TB,TBLOCK ;[624]
DPB TB,FI.MRS
DA10.K: SETZ TB, ;[1011]
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.: TLNE W1,GWNLIT ;IS ITEM NUMERIC LITERAL?
TLNE W1,GWDP ;YES, 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
MOVEM TC,0(SAVPTR)
POPJ PP,
DA11.E: SETZB TC,0(SAVPTR)
EWARNJ E.25
INTER. DA12.
DA12.: SETZ TC,
PUSH SAVPTR,TC
PUSHJ PP,DA11.
POP SAVPTR,TC
CAML TC,0(SAVPTR)
MOVEM TC,0(SAVPTR)
POPJ PP,
INTER. DA13.
DA13.: 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##
SETO TB,
SKIPE TA,CURFIL
DPB TB,FI.DRC##
IFN ANS68,<
POPJ PP,
>
IFN ANS74,<
JRST DA25F. ;TEST FOR FIPS FLAGGER
>
IFN ANS68,<
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##
SKIPN TA,CURFIL
JRST DA18.X
MOVE TA,CURDAT
DPB TB,PNTS2 ;SET 'LABEL RECORD' OR 'DATA RECORD' BIT
MOVE TA,CURFIL
LDB TB,PNTS ;GET 'DATA RECORD' OR 'LABEL RECORD' PTR
JUMPE TB,DA18.V ;THIS IS FIRST SUCH RECORD
HLRZ TC,CURDAT
DPB TC,PNTS
MOVE TA,CURDAT
DA18.Q: DPB TB,DA.BRO ;BROTHER LINK
DA18.W: LDB TB,[POINT 15,W2,15]
HRRI TA,(TB)
JRST PUTLNK
DA18.T: PUSHJ PP,FNDNXT##
JRST DA18.P
LDB TC,DA.LVL## ;LEVEL OF ITEM
CAIE TC,1 ;RECORD
JRST DA18.T ;NO
MOVEM TA,TBLOCK
MOVEM TB,TBLOCK+1
HLRS TB ;GET RELATIVE ADDRESS IN R. H.
PUSHJ PP,FNDPOP ;FIND FATHER LINK
HLRZ TC,CURFIL
CAMN TB,TC ;CURRENT FILE?
EWARNJ E.35 ;YES
MOVE TA,TBLOCK
MOVE TB,TBLOCK+1
JRST DA18.T
DA18.V: HLRZ TB,CURDAT
DPB TB,PNTS
SETO TB,
MOVE TA,CURDAT
DPB TB,DA.FAL ;'FATHER LINK' FLAG
HLRZ TB,CURFIL
JRST DA18.Q
DA18.X: MOVE TA,CURDAT
JRST DA18.W
INTER. 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.: FLAGAT NS
MOVEI TA,%HL.VD ;'VALUE OF DATE-WRITTEN' FLAG
MOVEM TA,PNTS
POPJ PP,
;GET LITERAL VALUE OF IDENTIFICATION
INTER. DA24I.
DA24I.: HLRZ TB,W1 ;GET LENGTH OF LITERAL
ANDI TB,777
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
;TEST FOR LEVEL 1 SYNTAX (I.E. SEQ 1, REL 1, IDX 1)
IFN ANS74,<
INTER. DA25F.
DA25F.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[TST.L ;SEQUENTIAL
TST.LI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
;TEST FOR LEVEL 2 SYNTAX (I.E. SEQ 2, REL 2, IDX 2)
INTER. DA25G.
DA25G.: SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
MOVE TA,CURFIL
LDB TB,FI.ORG## ;GET FILE ORGANIZATION
JRST @[TST.HI ;SEQUENTIAL
TST.HI ;RELATIVE
TST.H ;INDEXED
CPOPJ](TB)
>;END IFN ANS74
INTER. DA25.
DA25.:
IFN ANS74,<
PUSHJ PP,DA25G. ;SEE IF FIPS FLAGGER WANTED
>
PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZ TB,PNTS ;STORE 'VALUE OF XXX' FLAG
DPB TB,HL.COD
HLRZ TB,CURFIL ;STORE FILTAB LINK IN HLDTAB
DPB TB,HL.LNK
POPJ PP,
;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,LVL.49 ;YES, ONLY 1-49 ARE LEGAL.
JRST DA26.E ;COMPLAIN.
CAIE TC,LVL.01 ;IF IT'S 01, NOTE THAT WE
JRST DA26.A ; HAVEN'T SEEN A LINE OR
SETZM RWLCS.## ; COLUMN CLAUSE YET.
SETZM RWCCS.##
JRST DA26.A
>
DA26.1: CAIN TC,^D66
JRST DA26.R ;LEVEL 66
CAILE TC,LVL.49 ;49. IS MAX. LEVEL NUMBER
CAIN TC,^D77 ;EXCEPT FOR 77
JRST DA26.A
DA26.E: EWARNW E.64
HRRZ TC,LEVEL
CAILE TC,0
CAILE TC,LVL.49
HRRZI TC,LVL.01
MOVEM TC,0(SAVPTR)
DA26.X: PUSHJ PP,SAVLVL ;LEAVE TRACKS FOR REDEFINES
SETZM RUSAGE## ;INIT GROUP ITEM USAGE CHECK
IFN ANS74,<
SKIPN FLGSW## ;FIPS FLAGGER REQUESTED?
POPJ PP, ;NO
LDB TB,GWVAL## ;GET SIZE OF LITERAL
CAIE TB,2 ;MUST BE TWO CHARACTERS
PUSHJ PP,FLG.HI## ;NO, FLAG AT HIGH-INTERMEDIATE LEVEL
>
POPJ PP,
DA26.A: CAIN TC,^D77 ;77.
HRRZI TC,LVL.77
MOVEM TC,LEVEL
CAIE TC,LVL.01
CAIN TC,LVL.77 ;77-LEVEL ITEM
JRST DA26.X
HRRZI TC,LVL.01
MOVEM TC,LEVEL
EWARNJ E.48
DA26.R:
IFN ANS74,<
SKIPE FLGSW## ;FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
>
HRRZI TC,LVL.66
HRRZM TC,LEVEL
HRRZI NODE,DD165.##
HRRZM NODE,0(NODPTR)
POPJ PP,
;REMEMBER THIS DATA LEVEL FOR REDEFINES
;ALSO IF LEVEL INCREASING, CLEAN UP PART OF TABLE BELOW THIS
SAVLVL:
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: HLRZ TB,CURFIL ;[751] GET FILE TABLE POINTER
JUMPE TB,D27.E5 ;[751] ERROR IF NOT DEFINED
MOVE TA,[XWD CD.DAT,SZ.DAT+SZ.DOC+SZ.MSK]
PUSHJ PP,D27N.1
HLRZ TB,CURFIL
HRRZ TA,CURDAT
DPB TB,DA.POP##
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.DRC
DPB TB,DA.PWA
HRRZ TA,CURFIL
LDB TB,FI.DRL
HLRZ TC,CURDAT
DPB TC,FI.DRL
JUMPE TB,D27E22
HRRZ TA,CURDAT
DPB TB,DA.BRO
SETZ TB,
DPB TB,DA.FAL
HRRZ TA,CURFIL
D27E22: LDB TB,FI.DRC
JUMPE TB,D27F.1
EWARNW E.228
JRST D27F.1
DA27.F: HRLZM TB,CURDAT
HRRZI TA,(TB)
PUSHJ PP,LNKSET##
HRRM TA,CURDAT
LDB TC,DA.DEF
SETO TB,
DPB TB,DA.DEF
HRRZ TB,LEVEL
DPB TB,DA.LVL
DPB W2,DA.LNC
JUMPN TC,JCE16.
D27F.1: HRRZ TB,EAS2PC##
EXCH TB,EAS1PC
TLZE TB,777777
HRRZI TB,1(TB)
CAMLE TB,CFLM
HRRZM TB,CFLM
POPJ PP,
D27.E5: PUSHJ PP,DA27.S ;[751] BUILD SMALL DATAB ENTRY
MOVEI DW,E.13 ;NO FILE NAME FOR THIS RECORD [175]
JRST FATALW ; FATAL ERROR AND FFATAL SW ON [175]
JCE25.: EWARNJ E.25 ;?POSITIVE INTEGER REQUIRED
JCE183: EWARNJ E.183
JCE268: EWARNJ E.268
JCE269: EWARNJ E.269
;PAGE-COUNTER OR LINE-COUNTER INDEPENDENTLY DEFINED IN WORKING-STORAGE
D27.E3: LDB LN,DA.LN ;GET POSITION OF W-S ITEM
LDB CP,DA.CP
HRRZI DW,E.399
JRST FATAL
;CHECK LEVEL NUMBER FOR ALL ITEMS BELOW 01 LEVEL
INTER. DA28.
DA28.: SKIPG TA,0(SAVPTR)
JRST DA28.E ;ERROR IF .LE. 0
CAIN TA,LVL.01
JRST DA28.A
CAIG TA,LVL.49 ;IF THE LEVEL INDICATES A SPECIAL
SKIPGE LSTW77## ; ITEM, OR THE LAST ITEM WAS NOT
JRST DA28.5 ; A LEVEL 77 ITEM, GO ON.
EWARNW E.567 ;COMPLAIN. A LEVEL 77 ITEM WAS
; FOLLOWED BY AN ITEM WITH A LEVEL
; BETWEEN 02 AND 49.
HRLZI TA,(<SIXBIT '01'>) ;FAKE AN 01 LEVEL.
MOVEM TA,NAMWRD##
HRLZI TA,(<ASCII "01">)
MOVEM TA,LITVAL
JRST DA28.F ;GO PRETEND IT'S AN 01.
DA28.5:
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
JRST DA28.0 ;NO
CAIG TA,LVL.49 ;YES, ONLY 01-49 ALLOWED
POPJ PP, ;OK
JRST DA28.E ;TOO BIG
>
DA28.0: PUSHJ PP,SAVLVL ;LEAVE TRACKS FOR REDEFINES
MOVE TA,(SAVPTR) ;RESTORE TRUE LEVEL #
CAIE TA,^D77 ;LEVEL 77
JRST DA28.B
TSWF FFILSC;
EWARNW E.46
DA28.A: PUSHJ PP,DA7.
JRST DA0.
DA28.B: CAIE TA,^D88 ;88-LEVEL?
JRST DA28.R
HRRZI NODE,DD93A.## ;YES
HRRZM NODE,(NODPTR)
IFN ANS74,<
SKIPE FLGSW## ;FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
>
POPJ PP,
DA28.R: CAIN TA,^D66
JRST DA28.S ;LEVEL 66
IFN ANS74,<
SKIPN FLGSW## ;FIPS FLAGGER REQUESTED?
JRST DA28.D ;NO
LDB TB,GWVAL## ;GET SIZE OF LITERAL
CAIG TA,LVL.10 ;YES, SEE IF IN NUCLEUS 2 (GT 10)
CAIE TB,2 ;OR NOT TWO CHARACTERS
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
DA28.D:>
CAIG TA,LVL.49
POPJ PP,
DA28.E: EWARNW E.64 ;LEVEL NUMBER NOT LEGAL
HRRZ TA,LEVEL
CAILE TA,0
CAILE TA,LVL.49
DA28.F: HRRZI TA,LVL.01
MOVEM TA,0(SAVPTR)
JRST DA28.A
DA28.S: HRRZI NODE,DD86A.##
HRRZM NODE,0(NODPTR)
IFN ANS74,<
SKIPE FLGSW## ;FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
>
JRST DA7.
;SET UP DATAB ENTRY FOR ALL ITEMS BELOW 01 LEVEL
INTER. DA29.
DA29.:
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
JRST .+3 ;NO
SKIPN NAMWRD ;YES, DOES ITEM HAVE A NAME?
JRST DA29.0 ;NO
>
TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
HRRZI TB,(TYPE) ;IF ITEM IS FILLER, SKIP PUTCRF
ANDI TB,1777
CAIE TB,FILLE.
PUSHJ PP,PUTCRF
TLZN W1,GWNOT ;[373] IF DEFINED ALREADY
JRST DA29.0 ;[373] THEN DON'T ENTER AGAIN
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TB,TA
DPB TB,[POINT 15,W2,15]
;NOTE: COMMENTS ADDED 9-FEB-75 /ACK
; ACTUALLY THE WHOLE THING SHOULD BE REWRITTEN, BUT THERE IS NO TIME.
DA29.0: HRRZ TC,0(SAVPTR) ;GET THE LEVEL NUMBER.
CAIN TC,^D66 ;LEVEL 66?
JRST DA29.R ;YES, GO WORRY OVER RENAME STUFF.
CAIN TC,^D77 ;LEVEL 77?
HRRZI TC,LVL.01 ;YES, PRETEND IT'S LEVEL 01 FOR A WHILE.
HRRZ TA,CURDAT ;GET THE CURRENT ITEM'S DATAB ADR.
JUMPE TA,DA29.A ;NO CURRENT ITEM.
LDB TB,DA.LVL ;PICK UP THE CURRENT ITEM'S LEVEL NUMBER.
CAIL TB,(TC) ;IS THE CURRENT ITEM'S LEVEL NUMBER
; LESS THAN THE NEW ITEM'S?
JRST DA29.B ;NO, NEW ITEM SAME OR LOWER LEVEL NUMBER
;WE GET HERE IF THE LEVEL NUMBER OF THE NEW ITEM IS GREATER THAN THE
; LEVEL NUMBER OF THE CURRENT ITEM.
DA29.A:
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.
IFN ANS74,<
SKIPN FLGSW## ;FIPS FLAGGER REQUESTED?
JRST D29.B2 ;NO
MOVE TA,CURDAT ;YES, RESET TO DATA-ITEM
LDB TB,DA.SNL ;IS THIS A DUPLICATE NAME?
JUMPE TB,D29.B2 ;NO
HRRZI TB,(TYPE) ;(EXCEPT FILLERS)
ANDI TB,1777
CAIN TB,FILLE.
JRST D29.B2 ;NOT FILLER
MOVE LN,WORDLN## ;SET UP LN &
MOVE CP,WORDCP## ; CP
PUSHJ PP,FLG.HI## ;FLAG AT HIGH-INTERMEDIATE LEVEL
D29.B2:>
HLRZ TB,CURDAT ;GET THE ITEM'S DATAB LINK.
PUSHJ PP,FNDPOP ;FIND ITS FATHER.
JRST RPWPOP ;NO FATHER, LEAVE.
LDB TC,[POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TC,CD.DAT ;IS HE IN DATAB?
JRST RPWPOP ;NO, LEAVE.
HRLZM TB,TBLOCK+13 ;SAVE FATHER LINK.
HRRZI TA,(TB) ;SET UP FOR LNKSET CALL.
PUSHJ PP,LNKSET ;GO CONVERT LINK TO AN ADDRESS.
HRRM TA,TBLOCK+13 ;RESTORE FATHER'S LINK.
LDB TD,DA.RDF## ;GET FATHER'S REDEFINITION FLAG.
CAIN TD,0 ;DID FATHER HAVE A REDEFINITION CLAUSE?
LDB TD,DA.RDH## ;NO, GET FATHER'S REDEFINES AT A
; HIGHER LEVEL FLAG.
LDB TB,DA.VAL ;GET FATHER'S VALUE FLAG.
LDB TC,DA.VHL ;AND HIS VALUE AT A HIGHER LEVEL FLAG.
CAIE TB,0 ;DID FATHER HAVE A VALUE CLAUSE?
SETO TC, ;YES, REMEMBER THAT.
HRRZ TA,CURDAT ;GET ITEM'S DATAB ADDRESS.
DPB TC,DA.VHL ;SET VALUE AT A HIGHER LEVEL FLAG APPROPRIATELY.
DPB TD,DA.RDH ;SET REDEFINES AT HIGHER LEVEL FLAG APPROPRIATELY.
MOVE TA,TBLOCK+13 ;GET FATHER'S DATAB ADDRESS.
LDB TB,DA.SUB ;GET FATHER'S "I MUST BE SUBSCRIPTED" FLAG.
JUMPE TB,RPWPOP ;NOT, SO LEAVE.
LDB TD,DA.OCH## ;GET FATHER'S LINK TO HIGHER LEVEL OCCURS.
LDB TE,DA.OCC ;GET FATHER'S "I HAVE OCCURS" FLAG.
CAIE TE,0 ;DID HE HAVE AN OCCURS CLAUSE?
HLRZ TD,TBLOCK+13 ;YES, GET FATHER'S DATAB LINK.
PUSH PP,TD ;SAVE LINK TO WHOEVER HAD THE OCCURS CLAUSE.
MOVE TA,[CD.DAT,,SZ.DOC] ;MAKE DATAB WORDS 8,9.
PUSHJ PP,GETENT
POP PP,TD ;GET LINK TO WHOEVER HAD THE OCCURS CLAUSE.
HRRZ TA,CURDAT ;GET ITEM'S DATAB ADR.
DPB TD,DA.OCH ;SET THE LINK TO HIGHER LEVEL OCCURS.
SETO TE, ;GET SOME ONES.
DPB TE,DA.SUB ;TURN ON "I MUST BE SUBSCRIPTED" FLAG.
JRST RPWPOP ;EXIT
;WE COME HERE TO FINISH OFF AN ITEM AND ITS ANCESTORS.
DA29.C: PUSHJ PP,DA54. ;GO FINISH OFF THE CURRENT ITEM.
HLRZ TB,CURDAT ;GET THE CURRENT ITEM'S LINK.
SETZM CURDAT ;NO CURRENT ITEM FOR A WHILE.
PUSHJ PP,FNDPOP ;FIND EX-CURRENT ITEM'S FATHER.
JRST DA29.0 ;[1003] NO FATHER, REENTER.
LDB TA,[POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TA,CD.DAT ;IS HE DATAB?
JRST DA29.0 ;[1003] NO, REENTER.
HRLZM TB,CURDAT ;FATHER BECOMES CURRENT ITEM.
HRRZ TA,TB ;SET UP TO CONVERT A LINK TO AN ADR.
PUSHJ PP,LNKSET ;GO DO IT TO IT.
HRRM TA,CURDAT ;SET FATHER'S ADDRESS.
JRST DA29.0 ;[1003] REENTER.
COMMENT \
WE COME TO DA29.R TO PROCESS LEVEL 66 ITEMS. WE GET HERE WHEN WE
HAVE SEEN THE FOLLOWING:
66 DATA-NAME
WHAT WE DO IS:
FINISH PROCESSING THE LAST ITEM VIA DA54., MAKE THE LAST ITEM'S
FATHER THE CURRENT ITEM, IF HE IS A DATAB ITEM, AND REENTER DA29.
EVENTUALLY CURDAT WILL BE ZERO INDICATING THAT THERE ARE NO MORE ITEMS
TO BE FINISHED UP AND WE WILL COME BACK HERE WHERE WE WILL SET UP THE
DATAB ENTRY FOR THE LEVEL 66 ITEM WE SAW.
\
DA29.R: SKIPE CURDAT ;DO WE HAVE A CURRENT ITEM?
JRST DA29.C ;YES GO FINISH IT UP.
MOVE TA,[XWD CD.DAT,SZ.DAT] ;GET A DATAB ENTRY.
PUSHJ PP,GETENT
MOVEM TA,CURDAT ;MAKE THIS THE CURRENT ITEM.
DPB W2,DA.LNC ;SET LN/CP.
LDB TB,[POINT 15,W2,15] ;GET OUR NAMTAB LINK.
DPB TB,DA.NAM ;PUT IT IN OUR DATAB ENTRY.
HRRZI TC,CD.DAT ;I AM A DATAB ENTRY.
DPB TC,[POINT 3,(TA),2]
HRRZI TC,LVL.66 ;SET OUR LEVEL NUMBER TO 76. (SHOULD BE
; 102 BUT THE FIELD IS ONLY 6 BITS.)
DPB TC,DA.LVL
D29XIT: HRRI TA,(TB) ;SET UP OUR NAMTAB LINK.
PUSHJ PP,PUTLNK ;GO LINK THIS DATAB ENTRY INTO THE SAME
; NAME CHAIN.
RPWPOP:
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
IFN MCS!TCS,<
SKIPN COMSEC; ;IN COMMUNICATIONS SECTION?
JRST DA30X1 ;NO
HRRZ TA,LAST01 ;YES, WE MAY HAVE ALREADY FAKED A REDEFINE
HLRZ TB,CURDAT ; OF THE 01 AT D27N.1 - MAKE SURE WE'RE NOT
CAMN TA,TB ; HERE A SECOND TIME BECAUSE OF "REDEFINES"!
EWARNJ E.640 ; CLAUSE SPECIFIED.
DA30X1:
>;END IFN MCS!TCS
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
IFN ANS74,<
LDB TD,DA.RDH ;IS THERE A REDEFINITION AT A HIGHER LEVEL?
JUMPE TD,DA30.3 ;NO
SKIPE FLGSW## ;YES, FIPS FLAGGER REQUESTED?
PUSHJ PP,FLG.HI## ;YES, FLAG AT HIGH-INTERMEDIATE LEVEL
DA30.3:>
MOVE TB,DATLVL ;IF 01 LEVEL
CAIN TB,LVL.01 ;SAVE LINK
HLRZM TA,LAST01
POPJ PP,
;ITEM IS NOT A REDEFINITION -- REMEMBER THIS
INTER. DA30N.
DA30N.:
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!FT68274,<
LDB TB,DA.PWA## ;SEE IF PICTURE ALLOCATED
JUMPE TB,CPOPJ ;NOT YET
LDB TB,DA.FSC## ;GET SUPPRESSION CHAR
CAIN TB,'*' ;IS IT *
EWARNJ E.701 ;YES, GIVE ERROR
>
POPJ PP,
;JUSTIFIED RIGHT
INTER. DA32.
DA32.: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.JST##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.JST
POPJ PP,
IFN ANS74,<
;SIGN CLAUSE
INTER. DA32.C
DA32.C: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.PIC##
JUMPE TB,CPOPJ ;NOT YET SEEN PICTURE
LDB TB,DA.SGN## ;SIGNED
JUMPN TB,CPOPJ ;YES
DA32.E: EWARNJ E.710
;LEADING SIGN
INTER. DA32.L
DA32.L: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.LSC##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.LSC
POPJ PP,
;SEPARATE SIGN
INTER. DA32.S
DA32.S: SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.SSC##
JUMPN TB,JCE16. ;DUPLICATED
SETO TB,
DPB TB,DA.SSC
LDB TB,DA.PIC ;PICTURE SEEN?
JUMPE TB,CPOPJ ;NOT YET
HRLI TB,1 ;YES, GET [1,,1]
ADDM TB,@DA.EXS## ;YES, SIZE IS BIGGER BY 1 CHAR
POPJ PP,
>
INTER. DA33.
DA33.: PUSHJ PP,DA11. ;GET NUMBER OF OCCURRENCES
D33MCS: PUSHJ PP,DANXT. ;[243] SEE IF NEXT ITEM IS A 'TO'
MOVEI TB,1 ;[243] IF NO MINIMUM IS 1
CAIN TYPE,TO. ;[243] IS NEXT SOURCE ITEM 'TO'
SETZ TB, ;[243] YES, ALLOW 0
MOVE TC,0(SAVPTR) ;[243] GET USERS NO. OF OCCURS
CAIGE TC,(TB) ;[243] SEE IF NO. OF OCCURS LEGAL
JRST JCE25 ;[243] ILLEGAL
CAIG TC,77777
JRST DA33.A
MOVEI DW,E.593 ;[471] TO MANY FOR "OCCURS"
PUSHJ PP,DA24X. ;[243] GIVE ERROR AND COME BACK
HRRZI TC,77777 ;ONLY 32K OCCURRENCES ALLOWED
HRRZM TC,0(SAVPTR)
DA33.A: HRRZ TA,CURDAT
LDB TB,DA.OCC
JUMPN TB,JCE16.
HRRZ TC,0(SAVPTR)
DPB TC,DA.NOC
LDB TB,DA.PWA ;DATAB WORDS 8,9 CREATED YET?
LDB TC,DA.SUB
IORI TB,(TC)
JUMPN TB,.+4 ;YES
MOVE TA,[CD.DAT,,SZ.DOC] ;NO, DO IT
PUSHJ PP,GETENT
HRRZ TA,CURDAT ;RESTORE TA
SETO TB,
DPB TB,DA.OCC
DPB TB,DA.SUB
POPJ PP,
JCE25: HRRZ TA,CURDAT ;[243] GET POINTER TO DATA ITEM
SETO TB, ;[243] THEN SET
DPB TB,DA.ERR ;[243] ERROR BIT
MOVEI DW,E.25 ;[243] GIVE ERROR MESSAGE AND RETURN
JRST DA24X. ;[243]
;[243] THIS ROUTINES LOOKS AHEAD AT NEXT SOURCE ITEM
DANXT.: MOVEM W2,1(SAVPTR) ;[243] SAVE CURRENT SOURCE ITEM
PUSHJ PP,GETITM ;[243] GET NEXT SOURCE ITEM
MOVE W2,1(SAVPTR) ;[243] RESTORE CURRENT SOURCE
JRST DA7. ;[243] SET SW TO REGET SAME ITEM FOR SYNTAX SCAN
;SET UP INDEX FOR "INDEXED BY" CLAUSE
INTER. DA34.
DA34.: PUSHJ PP,DA60S. ;SAVE NAMTAB LINK IN CURNAM
HRRZI TB,CD.DAT ;(USING TA LEFT BY DA60S.)
PUSHJ PP,FNDLNK
JRST DA34.B ;NO LINK
EWARNJ E.297 ;BAD NAME
DA34.B: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.IX ; BECAUSE PUTTING INDEX IN DATAB NOW
DPB TB,HL.COD ; MIGHT PUT IT BETWEEN THE ITEM INDEXED
IFN MCS!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
CAIE TB,%US.C1 ;COMP-1?
CAIN TB,%US.C2 ; OR COMP-2?
JRST DA35.E ;YES
DPB SW,DA.CLA ;BITS 34-35 OF SW ARE CLASS
SETZ TB,
TSWF FSIGN; ;SIGNED?
SETO TB, ;YES
DPB TB,DA.SGN##
;STORE THE SIZE
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.: SKIPN TA,CURDAT
POPJ PP, ;NO DATTAB LINK
LDB TB,DA.SYL## ;SYNC LEFT?
JUMPN TB,JCE18. ;YES--ERROR
LDB TB,DA.SYR## ;ALREADY SYNC RIGHT?
JUMPN TB,JCE16. ;YES
SETO TB,
DPB TB,DA.SYR
POPJ PP,
INTER. DA37.
DA37.: MOVE TA,CURDAT
JUMPE TA,CPOPJ
LDB TB,DA.SYR
JUMPN TB,JCE18.
LDB TB,DA.SYL
JUMPN TB,JCE16.
SETO TB,
DPB TB,DA.SYL
POPJ PP,
INTER. DA38.
DA38.: HRRZI TC,%US.D7 ;USAGE CODE 'DISPLAY-7'
;FALL INTO SET USAGE ROUTINE.
IFN ANS68,<JRST SETUSG>
;SET THE USAGE OF A DATAB ITEM AND DETERMINE IF IT IS CONSISTANT WITH
; ITS ANCESTOR'S USAGES.
SETUSF: FLAGAT NS
SETUSG: HRRZ TA, CURDAT ;GET THE ADDRESS OF THE CURRENT ITEM.
JUMPE TA, CPOPJ ;IF THERE IS NO CURRENT ITEM LEAVE.
LDB TB, DA.USG## ;GET THE USAGE FIELD.
IFN TCS!MCS,<
;24-SEP-80 /DAW THERE MAY HAVE ALREADY BEEN A DEFAULT USAGE (DISPLAY-7)
; ASSIGNED FOR THE 01 LEVEL. IF HE ALSO SPECIFIES A USAGE, A WARNING
; WILL BE GIVEN AND THE USAGE CLAUSE WILL BE IGNORED.
CAIN TB,%%US ;USAGE ALREADY DEFINED?
JRST SETSG0 ;NO, OK
CAMN TB,TC ;SAME USAGE?
JRST SETSG0 ;YES, DON'T COMPLAIN
EWARNW E.641 ;GIVE WARNING
MOVE TC,TB ;ASSUME THE DEFAULT
SETSG0:
>;END IFN TCS!MCS
IFE TCS!MCS,<
CAIE TB, %%US ;DO WE ALREADY HAVE A USAGE?
EWARNJ E.16 ;YES, COMPLAIN.
>
HRRZM TC, TBLOCK ;SAVE THE SON'S USAGE.
;IF WE DON'T HAVE A USAGE FOR THE RECORD YET, SEE IF WE CAN USE THIS ONE.
SKIPE TB, RUSAGE## ;DO WE HAVE A USAGE FOR THE REC?
JRST DA38.5 ;YES, GO ON.
;SEE IF WE CAN USE THIS USAGE.
CAIE TC, %US.D6 ;IF THE USAGE IS DISPLAY-6
CAIN TC, %US.D7 ; OR DISPLAY-7, THE RECORD
MOVEI TB, (TC) ; IS ALSO.
CAIE TC, %US.EB ;IF THE USAGE IS DISPLAY-9 OR
CAIN TC, %US.C3 ; COMP-3, THE RECORD IS
MOVEI TB, %US.EB ; DISPLAY-9.
MOVEM TB, RUSAGE## ;SET THE RECORD'S USAGE.
;HERE WE ARE GOING TO TRY TO FIND AN ANCESTOR FOR WHICH A USAGE
; CLAUSE WAS GIVEN.
DA38.5: HLRZ TB, CURDAT ;GET LINK TO CURRENT ITEM.
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 SETUSF
INTER. DA39A.
DA39A.: HRRZ TC,DEFDSP## ;USAGE 'DISPLAY', GET DEFAULT
JRST SETUSG ;GO SET IT.
INTER. DA40.
DA40.: HRRZI TC,%US.1C ;USAGE 'COMP'
JRST SETUSC
INTER. DA41A.
DA41A.: HRRZI TC,%US.C2 ;USAGE 'COMP-2'
JRST DA41. ;MAKE COMP-2 BE COMP-1 FOR 12B
JRST SETUSN
INTER. DA41.
DA41.: HRRZI TC,%US.C1 ;USAGE 'COMP-1'
SETUSN: FLAGAT NS
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.
>
INTER. DA42.
DA42.: HRRZI TC,%US.C3 ;USAGE 'COMP-3'.
JRST SETUSF
INTER. DA43.
DA43.: HRRZI TC,%US.IN ;USAGE 'INDEX'
JRST SETUSC
;THIS ACTION IS USED FOR DATABASE-KEY PROCESSING. THE
;DATAB ENTRY IS SET UP WITH A SIZE OF 10 AND LATER, (AT DA54.Y)
;THE ENTRY IS CHECKED FOR THIS.
INTER. DA43A.
DA43A.: FLAGAT DB
PUSHJ PP,DA43. ;PERFORM NORMAL INDEX STUFF
HRRZ TA,CURDAT ;GET CURRENT DATAB ENTRY
MOVEI TB,^D10
DPB TB,DA.EXS## ;CHANGE EXTERNAL SIZE
DPB TB,DA.INS## ;AND INTERNAL SIZE
POPJ PP,
INTER. DA43B.
DA43B.: HRRZI TC,%US.EB ;USAGE 'DISPLAY-9'.
JRST SETUSF
INTER. DA46.
DA46.: TLO W2,GWDEF ;PUT DEFINING REFERENCE ON CREF FILE
PUSHJ PP,PUTCRF
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
MOVEM TA,CURNAM
HLRZS TA
DPB TA,[POINT 15,W2,15]
TLZ W1,GWNOT
HRRZI TB,CD.CON
PUSHJ PP,FNDLNK
JRST DA46.B ;NO CONDITION OF THIS NAME
DA46.A: MOVE TA,TB
LDB TC,CO.DAT##
HLRZ TD,CURDAT
CAIN TC,(TD)
EWARNJ E.230 ;DUPLICATE CONDITION FOR THIS DATTAB ITEM
PUSHJ PP,FNDNXT
JRST DA46.B ;NO MORE
JRST DA46.A
DA46.B: MOVE TA,[XWD CD.CON,SZ.CON]
PUSHJ PP,GETENT
MOVEM TA,CURCON##
HLRZ TB,CURNAM
ANDI TB,77777
IORI TB,CD.CON*1B20
MOVSM TB,(TA)
HLRZ TA,CURDAT##
JUMPE TA,DA46.J ;IF THERE ISN'T A DATAB ITEM
; THERE, GO USE THE DUMMY.
DA46.F: ANDI TA,77777 ;GET THE ITEM'S ADDRESS.
ADD TA,DATLOC##
LDB TB,DA.LVL## ;PICK UP IT'S LEVEL NUMBER.
CAIE TB,LVL.01 ;IF WE ARE AT THE TOP OF
CAIN TB,LVL.77 ; THE TREE, ALL IS WELL,
JRST DA46.N ; GO ON.
LDB TA,DA.POP## ;PICK UP THE FATHER/BROTHER LINK.
JUMPN TA,DA46.F ;IF IT EXISTS, GO SEE IF WE ARE
; AT THE TOP OF THE TREE.
DA46.J: SKIPA TB,[EXP CD.DAT*1B20+1] ;OTHERWISE USE THE DUMMY.
DA46.N: HLRZ TB,CURDAT## ;PICK UP THE DATAB ITEM'S LINK AGAIN.
MOVE TA,CURCON## ;POINT AT THE CONTAB ENTRY.
DPB TB,CO.DAT
LDB TB,CO.NAM##
HRRI TA,(TB)
IFN ANS74,<
SKIPN FLGSW ;DO WE NEED THE FIPS FLAGGER?
>
JRST PUTLNK##
IFN ANS74,<
PUSHJ PP,PUTLNK ;YES
HLRZ TA,CURDAT ;NOW SEE IF DATAB IS FILLER
JUMPE TA,CPOPJ ;JUST A DUMMY
PUSHJ PP,LNKSET ;GET DATAB ENTRY
LDB TB,DA.NAM ;GET NAMTAB LINK
ADD TB,NAMLOC ;PLUS BASE
HLRZ TB,(TB) ;LOOK FOR "FILLER"
CAIE TB,1B20+FILLE.
POPJ PP,
LDB LN,DA.LN
LDB CP,DA.CP
JRST FLG.HI
>
;STORE VALUE ON CONTAB ENTRY FOR 88 ITEM
INTER. DA47.
DA47.: SETOM FLG88## ;[674] SET 88 LEVEL LITERAL FLAG
CAIA ;[674] AND SKIP
DA47.A: SETZM FLG88## ;[674] CLEAR 88 LEVEL LITERAL FLAG
TLNE W1,GWFIGC ;[674] FIGURATIVE CONSTANT?
JRST DA47.C ;YES
TLNN W1,GWLIT
EWARNJ E.45 ;LITERAL EXPECTED
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
CAIN TE,%US.C2 ;COMP-2?
MOVEI TD,%CL.NU ; IS ALSO NUMERIC
POPJ PP,] ;[700] KEEP GOING
LDB TE,DA.EDT## ;[674] AND GET ITS EDIT FLAG
;[1106] If the class has not been able to be defaulted yet, it means
;[1106] that the item is subordinate to an INDEX item. We can't tell
;[1106] what class it will be until we see the next level number. It
;[1106] could be an elementary item or a group item!
;[1106] The value clauses have to be checked later (in CLEANC) after
;[1106] the usages are determined.
CAIN TD,%%CL ;[1106] Still no class?
POPJ PP, ;[1106] Can't check now
JUMPE TC,DA47.D ;[674] LITERAL IS NOT NUMERIC, MAKE SURE
;[674] ITEM IS NOT EITHER
;[674] HERE IF THE LITERAL IS NUMERIC
CAIN TD,%CL.NU ;[674] IF ITEM IS NUMERIC
JUMPE TE,CPOPJ ;[674] AND NOT EDITTED, ALL IS WELL
PJRST DA47.F ;[674] OTHERWISE, GIVE AN ERROR
;[674] HERE IF LITERAL IS NOT NUMERIC
DA47.D: CAIN TD,%CL.NU ;[674] IF THE ITEM IS NUMERIC AND
JUMPE TE,DA47.F ;[674] IS NOT EDITTED, GIVE AN ERROR
POPJ PP, ;[674] OTHERWISE, ALL IS WELL
;[674] CLASS OF 88 LEVEL ITEM INCONSISTENT WITH VALUE
DA47.F: HRRZI DW,E.241 ;[674] SET ERROR FLAG
LDB LN,[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 ;[253] NO SUBCRIPTS ALLOWED IN RENAMED DATA
LDB TB,DA.LVL ;[253] CHECK LEVEL OF
CAIN TB,LVL.01 ;[253] RENAMED DATA
JRST D53E.1 ;[253] CANNOT BE 01
CAIE TB,LVL.77 ;[253] 77
CAIN TB,LVL.66 ;[253] OR 66
JRST D53E.1 ;[253] ILLEGAL
IMULI TC,SZ.DOC+SZ.MSK ;FOR RENAMING ITEM
JUMPE TC,DA53.1 ;NO EXTRAS NEEDED
PUSH PP,TC
MOVEI TA,(TC)
HRLI TA,CD.DAT
PUSHJ PP,GETENT
HLRZ TA,RENAM1
PUSHJ PP,LNKSET
HRRM TA,RENAM1
POP PP,TC
DA53.1: ADDI TC,SZ.DAT ;[253]
SKIPN TB,CURDAT ;[253]
POPJ PP,
LDB TD,DA.LNC ;[253] GET 66 ENTRY SOURCE ITEM
HRRZI TB,1(TB) ;WORD 2 OF 66 ENTRY
HRLI TB,1(TA) ;WORD 2 OF RENAMED ENTRY
ADDI TC,-2(TB) ;LAST WORD OF 66 ENTRY
BLT TB,(TC)
HRRZ TA,CURDAT
DPB TD,DA.LNC ;[253] KEEP ORIG 66 ENTRY SOURCE
SETZ TB,
DPB TB,DA.POP
DPB TB,DA.SON
DPB TB,DA.VAL
HRRZI TC,LVL.66 ;LEVEL 66
DPB TC,DA.LVL
SETO TC,
DPB TC,DA.FAL
D53.11: HLRZ TB,RENAM1
PUSHJ PP,FNDPOP
JRST DA53.X
HRLM TB,RENAM1
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT
JRST D53.12
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TC,DA.LVL
CAIE TC,LVL.01
JRST D53.11
;The level-01 item is in LH(RENAM1)
;The level-66 item is in LH(CURDAT)
; If this is the file section, store RENTAB entry.
HLRZ TB,RENAM1 ;Get TB=01 link
TSWF FFILSC; ;Are we in FILE SECTION?
PUSHJ PP,D53FS ;Yes, make RENTAB entry.
D53.12: HLRZ TB,RENAM1
HRRZ TA,CURDAT
DPB TB,DA.POP
DA53.X: SETZM CURDAT
POPJ PP,
DA53.2: HLRZ TA,RENAM1
PUSHJ PP,LNKSET
HRRM TA,RENAM1
LDB TB,DA.LVL
CAIN TB,LVL.01
JRST D53E.1 ;ILLEGAL LEVEL
CAIE TB,LVL.77
CAIN TB,LVL.66
JRST D53E.1
LDB TB,DA.SUB
JUMPN TB,D53E.2 ;MAY NOT RENAME ITEMS WITH OCCURS
HLRZ TB,RENAM1
D53R.1: PUSHJ PP,FNDPOP
JRST D53E.3 ;NO RECORD FOUND
HLRZ TC,RENAM2
CAIN TC,(TB)
JRST D53E.4 ;FIRST ITEM SUBSIDIARY TO SECOND
HRLZM TB,RNREC1##
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,RNREC1
LDB TC,DA.LVL
HLRZ TB,RNREC1
CAIE TC,LVL.01
JRST D53R.1 ;NOT YET UP TO RECORD
HLRZ TA,RENAM2
PUSHJ PP,LNKSET
HRRM TA,RENAM2
LDB TB,DA.LVL
CAIN TB,LVL.01
JRST D53E.1
CAIE TB,LVL.77
CAIN TB,LVL.66
JRST D53E.1
LDB TB,DA.SUB
JUMPN TB,D53E.2
HLRZ TB,RENAM2
D53R.2: PUSHJ PP,FNDPOP
JRST D53E.3
HLRZ TC,RENAM1
CAIN TC,(TB)
JRST D53E.4 ;SECOND ITEM SUBSIDIARY TO FIRST
HRLZM TB,RNREC2##
HRRZI TA,(TB)
PUSHJ PP,LNKSET
HRRM TA,RNREC2
LDB TC,DA.LVL
HLRZ TB,RNREC2
CAIE TC,LVL.01
JRST D53R.2
HLRZ TC,RNREC1
CAIE TC,(TB)
JRST D53E.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
AOJA TD,D53DW3 ;GO FIGURE OUT SIZE OF WHOLE THING
;HERE WITH TD:= COMPUTED LOC.END
; TE: = COMPUTED RES.END
D53DW3:
;** CAUTION: HORRIBLE THING ABOUT TO HAPPEN **:
; WE ARE DONE WITH "RENAM1" AND "RENAM2". SO TO GET SOME
; MORE ACS, WE WILL STORE OUR COMPUTED LOC.END AND RES.END
; AWAY IN RENAM1 AND RENAM2, RESPECTIVELY.
;(HEAVEN HELP THE PROGRAMMER WITHOUT A LISTING WHO TRIES
; TO USE DDT TO SEE WHAT IS GOING ON!)
MOVEM TD,RENAM1 ;STORE LOC.END
MOVEM TE,RENAM2 ;STORE RES.END
;NOW DECIDE HOW MANY BYTES THIS ITEM IS
HRRZ TA,CURDAT ;STORE INFO IN THE RENAMING ITEM
LDB TB,DA.USG ;GET ITS USAGE (STORED EARLIER..SOME
; FLAVOR OF DISPLAY!)
XCT BIBYSZ(TB) ;TC: = BITS/BYTE
LDB TD,DA.RES ;RES.ST
HRRZ TE,RENAM2 ;RES.END
SUB TD,TE ;RES.ST-RES.END
JUMPGE TD,D53DW4 ; EVEN # WORDS, OR # + REMAINDER
;ENDS BEFORE IT STARTS IN THE WORD!
; START OFF BY CALCULATING TE:= # BYTES LEFT OVER IN THE FIRST WORD,
; THEN ADD THIS TO RESULT OBTAINED WHEN WE START AT THE NEXT
; WORD BOUNDARY
LDB TE,DA.RES ;RES.ST = # BITS LEFT OVER IN 1ST WORD
IDIVI TE,(TC) ;TE:= # BYTES LEFT OVER IN 1ST WORD
MOVEI TD,^D36 ;TD:= RES.ST
LDB TA,DA.LOC ;TA:= LOC.ST
AOJA TA,D53DW5 ;PRETEND WE'RE AT START OF NEXT WORD
;EVEN # WORDS, OR # + REMAINDER
D53DW4: SETZ TE, ;TE= ACCUMULATED # BYTES
LDB TD,DA.RES ;TD:=RES.ST
LDB TA,DA.LOC ;TA:=LOC.ST
; JRST D53DW5 ;GO TO COMMON CODE
;COME HERE WITH TA= LOC.ST, TD=RES.ST, TE=# BYTES ACCUMULATED SO FAR
D53DW5: HRRZ TB,RENAM2 ;RES.END
SUB TD,TB ;RES.ST-RES.END (WILL BE POSITIVE NOW!)
PUSH PP,TC ;SAVE # BITS/BYTE
IDIVI TD,(TC) ;TD:= BYTES, TC:= REMAINDER
SKIPE TC ; ROUND UP ALWAYS!
ADDI TD,1
POP PP,TC ;RESTORE TC
ADD TE,TD ;ADD # BYTES AT END
;NOW TE= LEFTOVER BYTES AT BEGINNING + LEFTOVER BYTES AT END
; ADD TO THAT THE NUMBER OF BYTES FROM FULL WORDS, IF ANY
HRRZ TD,RENAM1 ;LOC.END
SUB TD,TA ;LOC.END-LOC.ST = # OF FULL WORDS USED
;MULTIPLY BY NUMBER OF BYTES/WORD AND ADD TO BYTE TOTAL
MOVEI TB,^D36 ;BITS IN A WORD
IDIVI TB,(TC) ;TB: = # BYTES/WORD
;TA = SMASHED
IMUL TD,TB ;GET # BYTES FROM THE FULL WORDS.
ADD TE,TD ;AND WE ARE NOW DONE!
HRRZ TA,CURDAT ;STORE SIZE AWAY
CAILE TE,MAXWSS## ;IF IT'S TOO BIG,
JRST D53E.7 ; GO COMPLAIN.
DPB TE,DA.INS## ;SET THE ITEM'S SIZE.
DPB TE,DA.EXS##
HLRZ TB,RNREC1 ;FATHER OF RENAMING ITEM IS THE RECORD
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
HRRZI TB,%CL.AN
DPB TB,DA.CLA ;CLASS IS ALPHANUMERIC
SETO TC, ;[253] SET AS DEFINED
DPB TC,DA.DEF ;[253]
TSWT FFILSC; ;Skip if we are in FILE SECTION
JRST D53DW6 ;Not
DPB TC,DA.DFS ;Set "defined in the file section"
LDB TB,DA.POP ;Get TB:= 01-item.
PUSHJ PP,D53FS ;Put item in RENAMES table
SETO TC, ;Get an "on" bit.
D53DW6: SKIPE LNKSEC ;[450] LINKAGE SECTION?
DPB TC,DA.LKS ;[450] YES, SET FLAG IN ENTRY.
SETZM CURDAT
POPJ PP,
;Routine to put item in RENAMES table.
;Call:
; CURDAT/ points to 66-item
; TB/ DATAB link of the 01 item
; PUSHJ PP,D53FS
; <return here>
;Uses TB,TC,TD,TE
D53FS: PUSH PP,TA ;Save TA
PUSH PP,TB ;01 item link is 0(pp)
D53FSA: MOVE TA,RENNXT ;Get next loc
MOVE TE,RENNXT ;Get another copy
ADD TE,[1,,1] ;Get new "next" loc
JUMPGE TE,D53FSE ; No more room, expand table
MOVEM TE,RENNXT ;Store new "next"
HLRZ TB,CURDAT ;Get 66-item link
DPB TB,RN.66
HRRZ TB,0(PP) ;Get 01-item link
DPB TB,RN.01
POP PP,TB ;restore TB
POP PP,TA ;Restore TA
POPJ PP, ;Return
D53FSE: PUSHJ PP,XPNREN ;Go expand the RENAMES table
JRST D53FSA ; and start again
D53E.1: HRRZI DW,E.253
JRST DA53.E
D53E.2: HRRZI DW,E.254
JRST DA53.E
D53E.3: HRRZI DW,E.255
JRST DA53.E
D53E.4: HRRZI DW,E.256
JRST DA53.E
D53E.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 FATAL
LDB LN,DA.LN
LDB CP,DA.CP
SETZM CURDAT
JRST FATAL
;ROUTINE TO FINISH UP PROCESSING A DATA ITEM (CHECK CONSISTANCY,
;ASSIGN DEFAULTS, ASSIGN STORAGE, ETC.)
INTER. DA54.
DA54.: SKIPN TA, CURDAT ;DO WE HAVE A CURRENT ITEM?
POPJ PP, ;NO, LEAVE.
LDB TB, [POINT 3,TA,2]
CAIE TB, CD.DAT ;IS HE IN DATAB.
SETZB TA, CURDAT ;NO, THEN THERE IS NO CURRENT ITEM.
JUMPE TA, CPOPJ ;IF THERE IS NO CURRENT ITEM, LEAVE.
LDB TB, DA.LVL## ;GET THE ITEM'S LEVEL.
CAIN TB, LVL.66 ;LEVEL 66?
POPJ PP, ;YES, LEAVE.
;NOTE: THE FOLLOWING TWO INSTRUCTIONS WERE IN THE ORIGINAL CODE SO
; THEY ARE LEFT HERE. I DON'T UNDERSTAND THEM, SINCE IF AN ITEM IS
; NOT DEFINED IT WOULD SEEM MORE REASONABLE TO SIMPLY RETURN RATHER
; THAN SEE IF IT HAS A VALUE CLAUSE AND IF IT DOES, WRITE IT OUT,
; ESPECIALLY SINCE NO STORAGE HAS BEEN ALLOCATED FOR THE ITEM.
LDB TB, DA.DEF##
JUMPE TB, D54.RX
IFN ANS74!FT68274,<
;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.FJ ;[1071] LEVEL FLAG IS ON GO SET HIS FATHERS.
LDB TD, DA.FAL## ;IF THERE ARE NO MORE SONS,
JUMPN TD, D54.FM ; LEAVE
D54.FI: LDB TA, DA.BRO## ;[1071] OTHERWISE GET THE BROTHER LINK
JRST D54.FK ; AND GO CHECK HIM FOR DEPENDING.
;[1071] CHECK THAT ANY OCCURS DEPENDING ITEM IS THE LAST THING IN THE RECORD.
D54.FJ: LDB TD,DA.FAL ;[1071] IF THERE ARE NO MORE SONS
JUMPN TD,D54.FM ;[1071] THEN ITS OK, VARIABLE BIT IS LAST
LDB TD,DA.RDF ;HOWEVER IF IT'S A REDEFINES
JUMPN TD,D54.FM ; ASSUME USER KNOWS WHAT HE'S DOING
HRRZI DW,E.646 ;[1071]
PUSHJ PP,D54E.8 ;[1071] WARN USER
SETZ TC, ;[1071] PRETEND THAT ITS NOT VARIABLE
JRST D54.FI ;[1071] AND TRY NEXT BROTHER
D54.FM: HRRZ TA, CURDAT ;POINT AT THE CURRENT ITEM
DPB TC, DA.DLL## ;SET (OR CLEAR) THE DEPENDING AT A
; LOWER LEVEL FLAG.
;HERE WE CHECK A BUNCH OF MISCELLANEOUS STUFF.
; (TA) = ADDRESS OF CURRENT ITEM.
; (TB) = USAGE OF CURRENT ITEM.
D54.FN: LDB TC, DA.BWZ## ;IF THERE WAS A BLANK WHEN
JUMPE TC, D54.FP ; ZERO CLAUSE
PUSHJ PP, D54E.E ; IT'S AN ERROR.
D54.FP: LDB TC, DA.JST## ;IF THERE WAS A JUSTIFIED
JUMPE TC, D54.FT ; CLAUSE
PUSHJ PP, D54E.F ; IT'S AN ERROR.
D54.FT: LDB TC, DA.SYL## ;IF THERE WAS A SYNC LEFT
LDB TD, DA.SYR## ; OR SYNC RIGHT
IORI TC, (TD) ; CLAUSE,
JUMPE TC, D54.FX ; IT'S AN
PUSHJ PP, D54E.G ; ERROR.
D54.FX: PUSHJ PP, D54J.D ;GO SEE IF THERE WAS A VALUE CLAUSE
; AT THIS LEVEL AND IF THERE WAS,
; CHECK IT OUT.
JRST D54.RX ;GO WORRY OVER PUTTING THE VALUE
; OUT, ALLOCATING MORE SPACE IF
; THERE WAS AN OCCURS, ETC.
;WE HAVE AN ELEMENTARY ITEM.
; (TA) = ADDRESS OF CURRENT ITEM.
D54.JD:
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.
CAIN TB,%US.C2 ;OR COMP-2
JRST D54.JH
JUMPN TC, D54.JT ;IF THERE WAS A PICTURE CLAUSE,
; GO ON.
PUSHJ PP, D54E.R ;OTHERWISE GIVE AN ERROR MESSAGE
JRST D54.JT ; AND GO ON.
;WORRY OVER INDEX, COMP-1, AND COMP-2 ITEMS.
D54.JH: JUMPE TC, D54.JL ;IF THERE WAS NO PICTURE CLAUSE,
; ALL IS WELL
PUSHJ PP, D54E.B ;OTHERWISE COMPLAIN.
D54.JL: MOVEI TC, ^D8 ;ASSUME IT IS COMP-1.
CAIN TB, %US.C1 ;IS IT?
JRST D54.JP ;YES, GO ON.
MOVEI TC,^D18 ;TRY COMP-2
CAIN TB,%US.C2
JRST D54.JP ;IT IS
LDB TC, DA.EXS## ;IF THE ITEM IS INDEX AND HAS
CAIE TC, ^D10 ; A SIZE OF 10, IT'S A DATABASE KEY.
MOVEI TC, 5 ;OTHERWISE MAKE THE SIZE 5.
D54.JP: DPB TC, DA.EXS## ;PUT THE ITEM'S SIZE IN THE
DPB TC, DA.INS## ; DATAB ENTRY.
MOVEI TC, %CL.NU ;SET THE ITEM'S CLASS
DPB TC, DA.CLA## ; AS NUMERIC.
SETO TC, ;SET THE ITEM'S
DPB TC, DA.SGN## ; SIGNED FLAG.
JRST D54.JX ;SKIP CHECKING CLASS AND EDITING
; SINCE WE EITHER KNOW IT'S OK
; OR HAVE ALREADY GIVEN AN
; ERROR MESSAGE.
;CHECK ELEMENTARY ITEM'S CLASS AND EDITING.
; IF THE ITEM IS NOT DISPLAY, THE CLASS MUST BE NUMERIC AND THE
; ITEM CAN NOT BE EDITED.
D54.JT: LDB TC, DA.CLA## ;GET THE ITEM'S CLASS.
CAIN TC, %%CL ;DO WE KNOW ITS CLASS?
JRST D54.JX ;NO, THEN DON'T TRY TO CHECK IT.
CAIE TB, %US.D6 ;IF THE USAGE IS DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7, WE DON'T CARE
JRST D54.JX ; WHAT ITS CLASS IS.
CAIN TB, %US.EB ;DON'T CARE ABOUT DISPLAY-9
JRST D54.JX ; EITHER.
LDB TD, DA.EDT## ;GET THE EDIT FLAG.
CAIN TC, %CL.NU ;IF IT'S NOT NUMERIC OR
JUMPE TD, D54.JX ; IF IT'S EDITED
PUSHJ PP, D54E.S ; COMPLAIN.
;CHECK BLANK WHEN ZERO CLAUSE.
; (TA) = ADDRESS OF CURRENT ITEM
; (TB) = USAGE OF CURRENT ITEM.
D54.JX: LDB TC, DA.BWZ## ;IF THERE WAS NO BLANK WHEN ZERO
JUMPE TC, D54.LP ; CLAUSE, SKIP THIS TEST.
LDB TC, DA.CLA## ;GET THE ITEM'S CLASS.
CAIE TC, %CL.NU ;IS IT NUMERIC?
JRST D54.LD ;NO, ERROR.
LDB TC, DA.PWA## ;IS PIC MASK ALLOCATED?
JUMPN TC, D54.JY ;YES
PUSHJ PP, DA35.B ;NO, ALLOCATE IT SO EDIT CAN WORK
HRRZ TA, CURDAT ;PUT TA BACK
LDB TB, DA.USG ;AND TB
D54.JY: CAIE TB, %US.D6 ;IF IT'S DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7,
JRST D54.LP ; IT'S OK.
CAIE TB, %US.EB ;DISPLAY-9 IS OK TOO.
D54.LD: PUSHJ PP, D54E.T ;ANYTHING ELSE IS AN ERROR.
;CHECK JUSTIFIED CLAUSE.
; (TA) = ADDRESS OF CURRENT ITEM.
; (TB) = USAGE OF CURRENT ITEM.
D54.LP: LDB TC, DA.JST## ;IF THERE WAS NO JUSTIFIED
JUMPE TC, D54.LT ; CLAUSE, SKIP THIS TEST.
LDB TC, DA.CLA## ;IF THE ITEM'S CLASS
CAIN TC, %CL.NU ; IS NUMERIC,
PUSHJ PP, D54E.U ; IT' AN ERROR.
;DEFAULT SYNC CLAUSE, IF NECESSARY.
D54.LT: LDB TC, DA.SYL## ;IF THERE ALREADY WAS
LDB TD, DA.SYR## ;A SYNC SPECIFIED
IORI TC, (TD) ; DON'T
JUMPN TC, D54.LX ; DEFAULT IT.
CAIE TB, %US.D6 ;DISPLAY-6 AND
CAIN TB, %US.D7 ; DISPLAY-7 DON'T HAVE
JRST D54.LX ; TO BE SYNCED RIGHT.
CAIE TB, %US.EB ;NEITHER DOES DISPLAY-9
CAIN TB, %US.C3 ; OR COMP-3.
JRST D54.LX
SETO TC, ;EVERYTHING ELSE MUST
DPB TC, DA.SYR## ; BE SYNCED RIGHT.
;CHECK FOR VALUE AT A HIGHER LEVEL.
; (TA) = ADDRESS OF CURRENT ITEM
; (TB) = USAGE OF CURRENT ITEM.
D54.LX: LDB TC, DA.VHL## ;IF THERE IS NO VALUE AT A
JUMPE TC, D54.NH ; HIGHER LEVEL, SKIP THIS TEST.
LDB TC, DA.SYR## ;SYNCS ARE NOT ALLOWED.
JUMPN TC, D54.ND
LDB TC, DA.SYL##
JUMPN TC, D54.ND
LDB TC, DA.JST## ;JUSTIFICATION IS NOT ALLOWED.
JUMPN TC, D54.ND
CAIE TB, %US.D6 ;DISPLAY-6 AND
CAIN TB, %US.D7 ; DISPLAY-7
JRST D54.NH ; ARE OK
CAIE TB, %US.EB ;DISPLAY-9 IS OK TOO.
D54.ND: PUSHJ PP, D54E.V ;EVERYTHING ELSE IS AN ERROR.
D54.NH: PUSHJ PP, D54J.D ;GO SEE IF 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.
IFN ANS74,<
;GET THE SIZE OF THE RECORD IN WORDS
;KEEP TRACK OF THE LARGEST SO THAT IS WE ARE IN DEBUG MODE
;WE CAN ALLOCATE ENOUGH SPACE FOR DEBUG-CONTENTS
HRRZ TA,CURDAT
SKIPN TB,RUSAGE ;GET RECORD USAGE
JRST D54.VD ;IGNORE IF NOT SET?
LDB TC,DA.EXS ;GET SIZE
CAILE TB,%US.EB ;ONLY FOR DISPLAY MODES
JRST D54.VD
IDIV TC,[EXP 6,5,4]-1(TB) ;GET SIZE IN WORDS
SKIPE TB
ADDI TC,1 ;COUNT REMAINDER
CAMLE TC,MAXDBC## ;BIGGEST YET?
MOVEM TC,MAXDBC ;YES
>
D54.VD: HRRZ TA, CURDAT ;RESTORE THE CURRENT ITEM'S
; DATAB ADDRESS.
;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.
IFN MCS!TCS,<
SKIPN COMSEC ;IS THIS IN THE COMMUNICATIONS SECTION?
JRST D54VL1 ;NO, GIVE USUAL ERROR MESSAGE
LDB TC,DA.LVL ;IS THIS A LEVEL 01? (IMPLICIT REDEFINITION).
CAIE TC,LVL.01
JRST D54VL1 ;NO, A REAL ERROR.
IFN ANS74,< ;JUST IGNORE THIS "ERROR"
;SINCE FCTC TESTS GET IT ON OUTPUT CD
;WHICH HAS NON-SUBSCRIPTED DEST TABLE
HRRZI DW,E.642 ;TELL HIM HIS SIZE IS WRONG WITHOUT MENTIONING
; REFERRING TO THE "REDEFINITION".
PUSHJ PP,D54E.8 ;. .
>
JRST D54VL2 ;SKIP OTHER ERROR.
;HERE TO GIVE USUAL REDEFINITION SIZE ERROR MESSAGE
D54VL1:
>
PUSHJ PP, D54E.W ;GO COMPLAIN.
D54VL2: 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.
IFN MCS!TCS,<
SKIPE COMSEC ; ALLOW USER TO SET VALUE IF DEFINING
JRST D54JD0 ; OWN CD AREA
;NOTE: THIS WILL CAUSE TROUBLE UNLESS WE MAKE SURE THAT THERE ARE ONLY
; VALUE CLAUSES FOR ONE OF THE IMPLICITLY REDEFINED 01'S.
; THIS IS CURRENTLY NOT CHECKED FOR, SO USERS ARE ON THEIR OWN.
>
LDB TD, DA.RDF## ;IF THERE IS A REDEFINITION
PJUMPN TD, D54E.M ; AT THIS LEVEL
LDB TD, DA.RDH## ; OR AT A HIGHER LEVEL,
PJUMPN TD, D54E.M ; IT'S AN ERROR.
D54JD0: HRLM TC, CURLIT## ;MAKE THIS THE CURRENT LITERAL.
HRRZI TA, (TC)
PUSHJ PP, LNKSET
HRRM TA, CURLIT##
LDB TC, LI.PUR## ;GET THE NON-SIXBIT CHAR FLAG.
JUMPE TC, D54J.H ;IF EVERYTHING IS SIXBIT, ALL
; IS WELL.
CAIE TB, %US.D7 ;IF THE CURRENT ITEM IS
CAIN TB, %US.EB ; DISPLAY-7 OR DISPLAY-9
JRST D54J.H ; ALL IS WELL.
PJRST D54E.N ;OTHERWISE, GIVE AN ERROR.
D54J.H: LDB TC, LI.NLT## ;IF THE LITERAL IS NOT NUMERIC
JUMPE TC, D54J.L ; ALL IS WELL.
TSWT ELITEM; ;OTHERWISE, IF THE ITEM IS A
PJRST D54E.O ; GROUP ITEM, IT'S AN ERROR.
D54J.L: LDB TD, LI.FGC## ;IF THE LITERAL IS NOT A
JUMPE TD, D54J.T ; FIGURATIVE CONSTANT GO
; CHECK IT OUT.
;THE LITERAL IS A FIGURATIVE CONSTANT.
LDB TC, LI.FCC## ;SEE WHICH ONE IT IS.
HRRZ TA, CURDAT## ;POINT AT THE CURRENT ITEM.
LDB TD, DA.CLA## ;GET ITS CLASS.
CAIN TD, %CL.NU ;IS THE ITEM NUMERIC?
JRST D54J.P ;YES, GO CHECK IT.
CAIE TC, QUOTE. ;IS IT QUOTE
CAIN TC, SPACE. ; OR SPACE?
POPJ PP, ;YES, ALL IS WELL.
D54J.P: CAIE TC, HIVAL. ;IS IT HIGH VALUES
CAIN TC, LOVAL. ; OR LOW VALUES?
POPJ PP, ;YES, ALL IS WELL.
CAIN TC, ZERO. ;IS IT ZERO?
POPJ PP, ;YES, ALL IS WELL.
PJRST D54E.P ;ALL IS NOT WELL, COMPLAIN.
;HERE WE CHECK REGULAR LITERALS.
D54J.T: HRRZ TA, CURDAT## ;POINT AT THE CURRENT ITEM.
LDB TD, DA.CLA## ;GET ITS CLASS
LDB TE,DA.BWZ ;GET "BLANK WHEN ZERO" FLAG
SKIPN TE ;IF ON THEN ITS EDITED BY DEFINITION
LDB TE, DA.EDT## ;OTHERWISE GET ITS EDIT FLAG.
CAIN TD, %%CL ;DO WE KNOW ITS CLASS.
POPJ PP, ;NO, THEN DON'T CHECK ANY MORE.
JUMPE TC, D54J.X ;IF THE LITERAL IS NOT NUMERIC,
; GO MAKE SURE THAT THE ITEM
; ISN'T EITHER.
;THE LITERAL IS NUMERIC.
CAIN TD, %CL.NU ;IF THE ITEM IS NUMERIC
JUMPE TE, 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>!<%US.C2-11>
IFN N,<
PRINTX %D54ZZ. - TABLES ARE MESSED UP.
PASS2
END
>
;TABLE OF BYTES PER WORD.
BYTWRD: EXP 6 ;UNKNOWN
EXP 6 ;DISPLAY-6
EXP 5 ;DISPLAY-7
EXP 4 ;DISPLAY-9
EXP 1 ;ONE WORD COMP
EXP 1 ;TWO WORD COMP
EXP 1 ;COMP-1
EXP 1 ;INDEX
EXP 4 ;COMP-3
EXP 1 ;COMP-2
;TABLE OF BITS PER BYTE.
BITBYT: EXP 6 ;UNKNOWN
EXP 6 ;DISPLAY-6
EXP 7 ;DISPLAY-7
EXP 9 ;DISPLAY-9
EXP 44 ;ONE WORD COMP
EXP 44 ;TWO WORD COMP
EXP 44 ;COMP-1
EXP 44 ;INDEX
EXP 9 ;COMP-3
EXP 44 ;COMP-2
;TABLE OF ROUTINES TO GET THE NUMBER OF BITS PER BYTE AND IF NECESSARY
; CHANGE THE SIZE OF THE ITEM.
BIBYSZ: JRST [OUTSTR [ASCIZ /
?Compiler error - D54.NL - usage wasn't assigned/]
JRST KILL##]
HRRZI TC, 6 ;DISPLAY-6 ==> 6
HRRZI TC, 7 ;DISPLAY-7 ==> 7
HRRZI TC, ^D9 ;DISPLAY-9 ==> 9
JSP TE, D54K.D ;COMP (MAY BE 1 OR 2 WORDS.)
JSP TE, D54K.H ;2 WORD COMP.
JSP TE, D54K.L ;COMP-1.
JSP TE, D54K.L ;INDEX
JSP TE, D54K.P ;COMP-3.
JSP TE, D54K.H ;COMP-2
PUTVLU: JUMPE TA,CPOPJ
HRLZM TA,CURLIT
PUSHJ PP,LNKSET
HRRM TA,CURLIT
PUSHJ PP,ADJUST##
SKIPN TA,CURDAT
POPJ PP,
LDB TB,DA.ERR
JUMPN TB,CPOPJ ;DD ERROR --- IGNORE VALUE
LDB TB,DA.USG
JRST PVDPTB(TB) ;DISPATCH TO THE APPROPRIATE ROUTINE.
PUTC2: SKIPN SIGNED## ;IS IT IN BINARY OR IN THE FUNNY FORMAT.
JRST PUT1WC ;BINARY, GO PRETEND IT'S COMP.
SKIPN SVDADR
JRST PUTC21
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1##
SETZM SVDADR
PUTC21: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000
PUSHJ PP,PUTAS1 ;RELOC TO ITEM
MOVE CH,[XWD 600000+ASCF2,2] ;FLOATING POINT NUMBER HEADER
JRST PUT2W2
PUTC1: SKIPN SIGNED## ;IS IT IN BINARY OR IN THE FUNNY FORMAT.
JRST PUT1WC ;BINARY, GO PRETEND IT'S COMP.
SKIPN SVDADR
JRST PUTC11
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1##
SETZM SVDADR
PUTC11: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000
PUSHJ PP,PUTAS1 ;RELOC TO ITEM
MOVE CH,[XWD 600000+ASCFLT,2] ;FLOATING POINT NUMBER HEADER
JRST PUT2W2
PUT2WC: SKIPN SVDADR
JRST PUT2W1 ;NOTHING SAVED
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1
SETZM SVDADR
PUT2W1: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000 ;RELOC TO ITEM
PUSHJ PP,PUTAS1
MOVE CH,[XWD 600000+ASCD2,2] ;2-WORD COMP HEADER
PUT2W2: PUSHJ PP,PUTAS1 ;PUT OUT HEADER
MOVE CH,VALUE1##
PUSHJ PP,PUTAS1
MOVE CH,VALUE2##
JRST PUTAS1
PUT1WC: SKIPN SVDADR
JRST PUT1W1 ;NOTHING SAVED
MOVE CH,SVDWRD
PUSHJ PP,PUTAS1
SETZM SVDADR
PUT1W1: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000 ;RELOC TO ITEM
PUSHJ PP,PUTAS1
MOVE CH,[XWD 600000+ASCD1,1]
PUSHJ PP,PUTAS1 ;1-WORD COMP HEADER
MOVE CH,VALUE2
JRST PUTAS1
PUTDSP: SKIPN TA,SVDADR ;IF THERE ISN'T ANYTHING LEFT OVER
JRST P6 ; FROM THE LAST LITERAL, GO ON.
HRRZ TB,ITMLOC
CAIE TB,(TA)
JRST P5 ;DIFFERENT LOCATION
MOVE CH,SVDWRD
MOVE TE, CONVR2## ;GET THE CONVERSION INDEX.
MOVE TE, PVPTRS(TE) ;PICK UP THE APPROPRIATE POINTER.
HRRZ TB,ITMRES
CAILE TB,44
HRRZI TB,44
DPB TB,[POINT 6,TE,5] ;RESIDUE
HRRZI TC,44 ;NEXT WORD, IF ANY, WILL START
HRRZM TC,ITMRES ;IN BIT 0
P1: SOSGE NCHITM## ;IF THERE IS NO MORE ROOM IN THE
JRST P4 ; ITEM, GO ON.
PUSHJ PP,GETCHR## ;OTHERWISE, GET A CHAR AND
IDPB TC,TE ;PUT IT IN THE WORD.
LDB TB,[POINT 6,TE,5] ;RESIDUE
LDB TC,[POINT 6,TE,11] ;BYTE SIZE
CAIL TB,(TC)
JRST P1 ;IF THERE IS ROOM FOR MORE IN THIS WORD, LOOP.
;FIRST WORD IS FULL, WRITE IT OUT.
PUSHJ PP,PUTAS1
SETZ CH,
AOS SVDADR
;COME HERE TO START A NEW WORD FOR A NEW ITEM.
P1.5: SKIPG NCHITM ;IF THERE IS MORE ROOM IN THE ITEM GO ON.
JRST P7 ;OTHERWISE, NOTE THAT WE DON'T HAVE TO
; WRITE OUT MORE LATER ON AND RETURN.
HRRZI TC,44
SUB TC,ITMRES ;(TC) = # OF BITS USED IN THIS WORD.
CAIGE TC,0
SETZ TC,
MOVE TB,NCHWRD## ;GET BYTES PER WORD
IDIV TC,PVBPB-4(TB) ;DIVIDE BY BITS PER BYTE
ADD TC,NCHITM ;(TC) = # OF BYTES TO END OF ITEM FROM
; BEGINNING OF THIS WORD.
IDIV TC,NCHWRD ;(TC) = # OF WORDS NEEDED.
JUMPE TB,.+2
HRRZI TC,1(TC) ;THERE WILL BE SOMETHING LEFT OVER
; SO MAKE IT ONE WORD LONGER.
MOVE CH,CONVR2## ;GET THE CONVERSION INDEX.
HRLZ CH,PVASCD(CH) ;GET THE ASSEMBLY CODE.
HRRI CH,(TC)
PUSHJ PP,PUTAS1
MOVE TE, CONVR2## ;GET THE CONVERSION INDEX.
MOVE CH, PVBLKS(TE) ;GET SOME FORM OF BLANKS.
MOVE TE, PVPTRS(TE) ;GET THE APPROPRIATE POINTER.
HRRZ TB,ITMRES
DPB TB,[POINT 6,TE,5]
JRST P3
P2: AOS SVDADR
PUSHJ PP,PUTAS1
MOVE TE, CONVR2## ;GET THE CONVERSION INDEX.
MOVE CH, PVBLKS(TE) ;GET SOME FORM OF BLANKS.
MOVE TE, PVPTRS(TE) ;GET THE APPROPRIATE POINTER.
P3: SOSGE NCHITM
JRST P4
PUSHJ PP,GETCHR
IDPB TC,TE
LDB TB,[POINT 6,TE,5] ;RESIDUE
LDB TC,[POINT 6,TE,11] ;BYTE SIZE
CAIL TB,(TC)
JRST P3 ;ROOM FOR MORE IN THIS WORD
JRST P2 ;WORD IS FULL
P4: LDB TB,[POINT 6,TE,5]
CAIN TB,44
JRST P7
MOVEM CH,SVDWRD
HRLM TB,SVDADR
POPJ PP,
P5: MOVE CH,SVDWRD
PUSHJ PP,PUTAS1
P6: HLRZ CH,CURDAT
ANDI CH,077777
IORI CH,1B20
HRLI CH,710000
PUSHJ PP,PUTAS1
HRRZ TB,ITMLOC##
HRRZM TB,SVDADR
HRRZ TB,ITMRES##
HRLM TB,SVDADR##
JRST P1.5
P7: SETZM SVDADR ;NOTE THAT WE DON'T HAVE TO
POPJ PP, ; WRITE OUT MORE LATER ON AND RETURN.
;MAKE SURE THAT THE TABLE BELOW DOESN'T GET MESSED UP.
N==<%%US>!<%US.D6-1>!<%US.D7-2>!<%US.EB-3>!<%US.1C-4>
N==N!<%US.2C-5>!<%US.C1-6>!<%US.IN-7>!<%US.C3-10>!<%US.C2-11>
IFN N,<
PRINTX %PVDPTB - TABLE IS MESSED UP.
PASS2
END
>
;DISPATCH TABLE - INDEX BY USAGE.
PVDPTB: POPJ PP, ;NOT DEFINED.
JRST PUTDSP ;DISPLAY-6.
JRST PUTDSP ;DISPLAY-7.
JRST PUTDSP ;DISPLAY-9.
JRST PUT1WC ;1-WORD COMP.
JRST PUT2WC ;2-WORD COMP.
JRST PUTC1 ;COMP-1.
JRST PUT1WC ;INDEX.
JRST PUTDSP ;COMP-3 (PRETEND IT'S DISPLAY-9)
JRST PUTC2 ;COMP-2.
;TABLES USED BY PUTDSP - INDEX BY CONVR2.
;BLANKS.
PVBLKS: BYTE (9)100,100,100,100 ;COMP-3.
Z ;SIXBIT.
ASCII / / ;ASCII.
BYTE (9)100,100,100,100 ;EBCDIC.
;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,RPWITX ; [315] NOT A REPORT ITEM EXIT
HRLZM TB,CURRPW ; [315] KEEP IT
MOVE TA,RPWLOC ; [315] CONVERT RPWTAB RELATIVE
ADDI TA,(TB) ; [315] TO REAL ONE
HRRM TA,CURRPW ; [315] KEEP IT
PUSHJ PP,RPWLCH ; [315] CHECK LINE NUMBER IF ANY
PUSHJ PP,RWCLC ;[V10] GO CHECK LINE AND COLUMN CLAUSES.
LDB TB,RW.NLC ; [315] NEXT GROUP ILLEGAL
JUMPE TB,RPWITA ; [315] AT ITEM LEVEL
HRRZ TA,CURDAT ; [315] UNLESS ITEM IS
LDB TB,DA.LVL ; [315] AT 01 LEVEL
SOJN TB,RPWIT4 ; [315] ERROR
HRRZ TA,CURRPW ; [315] GET BACK REPORT ITEM
RPWITA: LDB TB,RW.SCD ; [315] GET "SOURCE" CODE
JUMPE TB,RPWIT2 ; [315] NONE- ERROR
CAIE TB,%RG.VL ; [315] VALUE ?
JRST RPWIT1 ; [315] NO- GO ON
LDB TB,RW.GPI ; [315] DO WE HAVE GROUP INDICATE?
JUMPE TB,RPWIT1 ; [315] IF ZERO- NO
; HERE IF GROUP INDICATE WITH A VALUE CLAUSE MAKE ENTRY INTO
; HLDTAB- IN CLEANC WE WILL CONVERT TO SOURCE ITEM FROM VALUE
MOVE TA,[CD.HLD,,SZ.HLD] ; [315] MAKE A HLDTAB ENTRY
PUSHJ PP,GETENT ; [315] GET THE SPACE
MOVEM TA,CURHLD ; [315] SAVE HLDTAB ADDRESS
HRRZI TD,%HL.GI ; [315] SET G.I. HLDTAB CODE
DPB TD,HL.COD ; [315] STORE IN HLDTAB
HLRZ TB,CURDAT ; [315] GET DATAB RELATIVE ADDRESS
DPB TB,HL.LNK ; [315] STORE INTO HLDTAB
HRRZ TA,CURDAT ; [315] GET REAL DATAB ADDRESS
LDB TB,DA.VAL ; [315] GET DATAB VALUE LINK
LDB TD,DA.LNC ; [315] GET LINE AND CHAR POS
SETZ TC, ; [315] CLEAR
DPB TC,DA.VAL ; [315] THE VALUE LINK IN DATAB
HRRZ TA,CURHLD ; [315] GET BACK HLDTAB ADDRESS
DPB TB,HL.NAM ; [315] STORE VALUE LINK HERE
DPB TD,HL.LNC ; [315] STORE LINE AND CHAR POS
HRRZ TA,CURRPW ; [315] GET REPORT TAB ITEM ADDR
MOVEI TB,%RG.SR ; [315] CHANGE SOURCE CODE FROM
DPB TB,RW.SCD ; [315] VALUE TO SOURCE
; THE NEW SOURCE ITEM TO MADE IN CLEANC
RPWIT1: LDB TB,RW.COL ; [315] GET COLUMN NUMBER
JUMPE TB,RPWITX ; [315] NONE-NO CHECK
SKIPE RWLCS.## ;IF HE HAS GIVEN A LINE CLAUSE
JRST RPWT1D ; ALL IS WELL.
SETOM RWLCS.## ;ONLY COMPLAIN ONCE.
HRRZI DW,E.497
JRST RPWITE
RPWT1D: LDB TC,RW.LCD ; [315] IF IT IS A NEW LINE
SKIPE TC ; [315] THEN START COLUMN NUMBER FROM ZERR
SETZM LASCOL ; [315]
CAMG TB,LASCOL ; [315] MUST BE GREATER THAN LAST COL IN GROUP
JRST RPWIT3 ; [315] IT ISNT-ERROR
MOVEM TB,LASCOL ; [315] OKAY- UPDATE LAST COL
RPWITX: MOVE TA,CURDAT ; [315] RESTORE DATAB ADDRESS
POPJ PP, ; [315] RPWITC EXIT POINT
RPWIT2: HRRZI DW,E.475 ; [315] NO SOURCE/VALUE/SUM ERROR
JRST RPWITE ; [315]
RPWIT3: HRRZI DW,E.474 ; [315] COLUMN NUMBER TOO LOW
JRST RPWITE ; [315]
RPWIT4: HRRZ TA,CURRPW ;[527] GET CORRECT TABLE
SETZ TB, ; [315] CLEAR NEXT GROUP
DPB TB,RW.NLC ; [315]
HRRZI DW,E.480 ; [315] NEXT GROUP ILLEGAL
; JRST RPWITE ; [315] GIVE ERROR MESSAGE AND EXIT
RPWITE: MOVE TA,CURDAT ; [315] GET DATAB ADDRESS
LDB LN,DA.LN ; [315] GET LINE NUMBER
LDB CP,DA.CP ; [315] GET CHARACTER POSITION
JRST FATAL ; [315] FATAL ERROR AND RETURN
; CHECK REPORT GROUP FOR CORRECT PARAMETERS [315]
RPWGPC: SETZM LASCOL ; [315] CLEAR LAST COLUMN AT GROUP LEVEL
SKIPGE RPWERR ; [335] ANY FATAL REPORT GENERATOR
POPJ PP, ; [335]
LDB TB,DA.RPW ; [315] GET DATAB LINK TO REPORT ITEM
JUMPE TB,RPWITX ; [315] NOT A REPORT GROUP EXIT
HRLZM TB,CURRPW ; [315] KEEP IT
MOVE TA,RPWLOC ; [315] CONVERT RPWTAB RELATIVE
ADDI TA,(TB) ; [315] TO REAL ONE
HRRM TA,CURRPW ; [315] KEEP IT
PUSHJ PP,RPWLCH ; [315] CHECK LINE NUMBER IF ANY
LDB TB,RW.SCD ; [315] GET SOURCE CODE
JUMPN TB,RPWGE1 ; [315] ERROR IF AT GROUP LEVEL
RPWGP1: LDB TB,RW.COL ; [315] COLUMN NUMBER
JUMPN TB,RPWGE2 ; [315] IS ILLEGAL
PUSHJ PP,RWCLC ;[V10] GO CHECK LINE AND COLUMN CLAUSES.
RPWGP2: LDB TB,RW.GPI ; [315] GROUP INDICATE
JUMPN TB,RPWGE3 ; [315] IS ILLEGAL
RPWGP3: LDB TB,RW.RSF ; [315] RESET ON FINAL
LDB TC,RW.RSI ; [315] OR RESET ON IDENTIFIER
JUMPN TB,RPWGE4 ; [315] ARE BOTH
JUMPN TC,RPWGE4 ; [315] ILLEGAL
RPWGP4: LDB TB,RW.NLC ; [315] NEXT GROUP ILLEGAL
JUMPE TB,RPWITX ; [315] NONE OKAY
HRRZ TA,CURDAT ; [315] NEXT GROUP OKAY
LDB TB,DA.LVL ; [315] ONLY AT 01 LEVEL
CAIN TB,LVL.01 ; [315]
JRST RPWITX ; [315] 01 OKAY EXIT
HRRZ TA,CURRPW ;[527] GET CORRECT TABLE
SETZ TB, ; [315] CLEAR
DPB TB,RW.NLC ; [315] NEXT GROUP CODE
MOVEI DW,E.480 ; [315] NEXT GROUP ERROR
RPWGEE: MOVE TA,CURDAT ; [315] GET DATAB ADDRESS
LDB LN,DA.LN ; [315] GET LINE NUMBER
LDB CP,DA.CP ; [315] GET CHARACTER POSITION
HRRZ TA,CURRPW ; [315] RESTORE REPORT ITEM FOR MORE CHECKS
JRST FATAL ; [315] FATAL ERROR AND RETURN
RPWGE1: SETZ TB, ; [315] CLEAR
DPB TB,RW.SCD ; [315] SOURCE TYPE
MOVEI DW,E.479 ; [315] SOURCE / SUM / VALUE ERROR
PUSHJ PP,RPWGEE ; [315] GIVE ERROR MESSAGE
JRST RPWGP1 ; [315] DO MORE ERROR CHECKING
RPWGE2: SETZ TB, ; [315] CLEAR
DPB TB,RW.COL ; [315] COLUMN NUMBER
MOVEI DW,E.478 ; [315] COLUMN ERROR NUMBER
PUSHJ PP,RPWGEE ; [315] GIVE ERROR MESSAGE
JRST RPWGP2 ; [315] DO MORE ERROR CHECKING
RPWGE3: SETZ TB, ; [315] CLEAR
DPB TB,RW.GPI ; [315] GROUP INDICATE
MOVEI DW,E.477 ; [315] ERROR NUMBER
PUSHJ PP,RPWGEE ; [315] ERROR MESSGE
JRST RPWGP3 ; [315] MORE ERROR CHECKING
RPWGE4: SETZ TB, ; [315] CLEAR
DPB TB,RW.RSF ; [315] RESET CODES
DPB TB,RW.RSI ; [315]
MOVEI DW,E.476 ; [315] ERROR MESSAGE
PUSHJ PP,RPWGEE ; [315]
JRST RPWGP4 ; [315] MORE ERROR CHECKING
; CHECK LINE PARAMETER TO SEE IF WITHIN BOUNDS
RPWLCH: LDB TD,RW.TYP ; [315] LINE TYPE
JUMPE TD,CPOPJ ; [315] NONE-EXIT
LDB TC,RW.LCD ; [315] GET LINE CODE
CAIE TC,%RG.LN ; [315] DO WE HAVE LINE INTEGER?
POPJ PP, ; [315] NOT LINE INTEGER
LDB TC,RW.LIN ; [315] GET LINE NUMBER
PUSHJ PP,GETRDL ; [315] MAKE PTR TO RD ENTRY
LDB TB,RW.PAG## ; [315] GET PAGE-LIMIT
JUMPE TB,RPWLHX ; [315] NONE-SPECIFIED NO CHECKS THEN
CAIE TD,%RG.RH ; [315] REPORT HEADING
CAIN TD,%RG.RF ; [315] OR REPORT FOOTING?
JRST RPWLH3 ; [315] YES CHECK IT
CAIN TD,%RG.PH ; [315] PAGE-HEADING ?
JRST RPWLH4 ; [315] YES CHECK IT
CAIG TD,%RG.DE ; [315] CONTROL HEADING OR DETAIL LINE?
JRST RPWLH5 ; [315] YES CHECK IT
CAIN TD,%RG.CF ; [315] CONTROL FOOTING?
JRST RPWLH6 ; [315] YES CHECK IT
; [315] THEN IT IS PAGE FOOTING
LDB TB,RW.CFL ; [315] PAGE FOOTING MUST BE
LDB TD,RW.PAG ; [315] FROM FOOTING TO PAGE-LIMIT
MOVEI DW,E.487 ; [315] SET UP ERROR NUMBER
JRST RPWLH7 ; [315] GO CHECK
RPWLH3: LDB TB,RW.PHL ; [315] RH OR RF- MUST BE FROM HEADING
LDB TD,RW.PAG ; [315] TO PAGE-LIMIT
MOVEI DW,E.486 ; [315] SET UP ERROR NUMBER
JRST RPWLH7 ; [315] GO CHECK IT
RPWLH4: LDB TB,RW.PHL ; [315] PH MUST BE FROM HEADING
LDB TD,RW.FDE ; [315] TO FIRST DETAIL
MOVEI DW,E.485 ; [315] GET ERROR NUMBER
JRST RPWLH7 ; [315] GO CHECK IT
RPWLH5: LDB TB,RW.FDE ; [315] CH OR DE MUST BE FROM FIRST DETAIL
LDB TD,RW.LDE ; [315] TO LAST DETAIL
MOVEI DW,E.484 ; [315] GET ERROR NUMBER
JRST RPWLH7 ; [315] CHECK IT
RPWLH6: LDB TB,RW.FDE ; [315] CF MUST BE FROM FIRST DETAIL
LDB TD,RW.CFL ; [315] TO FOOTING
MOVEI DW,E.483 ; [315] GET ERROR NUMBER
RPWLH7: CAML TC,TB ; [315] LINE NUMBER WITHIN RANGE SET UP
CAMLE TC,TD ; [315] UPPER LIMIT
; [315] OKAY- STORE LINE NUMBER
JRST RPWGEE ; [315] NO- GIVE ERROR AND RETURN
RPWLHX: HRRZ TA,CURRPW ;RESTORE PTR TO GROUP ITEM
DPB TC,RW.LIN ;OK, STORE IT
POPJ PP, ; [315] RETURN
RWCLC: HRRZ TA, CURDAT ;[V10] POINT AT DATAB.
LDB TB, DA.LVL## ;[V10] GET THE LEVEL.
SOJN TB, RWCLCH ;[V10] IF IT'S NOT 01, GO ON.
SKIPE RWLCS.## ;[V10] IF WE HAVE SEEN A
SKIPE RWCCS.## ;[V10] LINE CLAUSE BUT NOT A
JRST RWCLCH ;[V10] COLUMN CLAUSE, WARN THE
HRRZI DW, E.586 ;[V10] USER THAT WE'RE GOING
LDB LN, DA.LN## ;[V10] TO SKIP LINES WITHOUT
LDB CP, DA.CP## ;[V10] PRINTING ANYTHING.
PUSHJ PP, WARN##
RWCLCH: HRRZ TA, CURRPW ;[V10] POINT AT THE RPWTAB ENTRY.
POPJ PP, ;[V10] RETURN.
>; [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 ;[243] GET CURRENT DATAB ADDRESS
LDB TB,DA.ERR ;[243] DID WE HAVE AN ERROR (USER)
JUMPE TB,DA56.1 ;[243] NO GO ON
SETZ TC, ;[243] YES DATAB TABLE NOT EXTENED FOR OCCURS
JRST DA56.B ;[243] GO TO CLEAR NO. OF OCCURS AND EXIT
DA56.1: MOVE TC,0(SAVPTR) ;[243] NO OF OCCURS
CAIGE TC,1
EWARNJ E.25
CAIG TC,77777
JRST DA56.A
EWARNW E.593
HRRZI TC,77777
HRRZM TC,0(SAVPTR)
DA56.A: HRRZ TA,CURDAT
LDB TB,DA.NOC
CAIG TC,(TB)
EWARNJ E.272
DA56.B: DPB TC,DA.NOC ;[243] NEW LABEL
POPJ PP,
INTER. DA57.
DA57.: PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.DP ;DEPENDING-FOR-OCCURS CODE
DPB TB,HL.COD
HLRZ TB,CURDAT ;STORE DATAB LINK IN HLDTAB
DPB TB,HL.LNK
HLRZ TA,CURDAT
PUSHJ PP,LNKSET
SETO TB,
DPB TB,DA.DLL## ;MARK THAT AN OCCURS DEPENDING HAS BEEN SEEN
POPJ PP,
;SD SORT-FILE-NAME
INTER. DA58.
DA58.: SKIPN TA,CURFIL
POPJ PP,
SETO TB,
DPB TB,FI.DSD## ;DEFINED IN AN SD
IFN ANS68,<
POPJ PP,
>
IFN ANS74,<
SKIPN FLGSW## ;NEED FIPS FLAGGER?
POPJ PP, ;NO
LDB LN,FI.LN## ;GET LN & CP
LDB CP,FI.CP## ; OF SELECT CLAUSE
MOVEI TA,%LV.HI
PUSHJ PP,FLG.ES## ;AND FLAG IT AT HIGH-INTERMEDIATE
MOVE TA,CURFIL
LDB LN,FI.ALN## ;SEE IF WE HAVE TO FLAG "SAME [RECORD] AREA"
JUMPE LN,CPOPJ ;NO
LDB CP,FI.ACP##
LDB TA,FI.RLC## ;GET [RECORD] FLAG
SKIPN TA
SKIPA TA,[%LV.HI] ;HIGH-INTERMEDIATE IF "SAME AREA"
MOVEI TA,%LV.H ;HIGH IF [RECORD]
JRST FLG.ES
>
;PUT DATA-NAME QUALIFIER IN NEXT WORD OF HLDTAB
INTER. DA60.
DA60.: PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
MOVE TA,CURHLD ;GET # OF QUALIFIERS BEFORE THIS
LDB TB,HL.QAL
AOJ TB,