Trailing-Edge
-
PDP-10 Archives
-
BB-H580E-SB_1985
-
cobolc.mac
There are 20 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 FOR COBOL V12C
SUBTTL DATA DIV. SYNTAX SCAN W.NEELY/CAM/SEB
SEARCH COPYRT
SALL
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
SEARCH P
%%P==:%%P
RPW==:RPW
DBMS==:DBMS
DEBUG==:DEBUG
MCS==:MCS
TCS==:TCS
;EDITS
;NAME DATE COMMENTS
;JEH 07-JUN-84 [1537] Fix edit 1424 - give error if fields are in
; an ASCII record
;JEH 14-FEB-84 [1515] If defining implied indexes for REPORT SECTION,
; check PCHOLD for correct core assignment
;JBB 08-SEP-83 [1475] Fixes edit 1452. Report Writer RESET.
;SMI 23-FEB-83 [1452] Error 370 when RPWTAB gets expanded.
;SMI 03-DEC-82 [1436] 68274 Fix PA1050 ill. inst. when in COMM. SEC.
;JEH 18-NOV-82 [1424] Fatal error on COMP, COMP-1, and INDEX fields
; in ASCII file
;SMI 06-OCT-82 [1413] 68274 Does not handle DBMS correctly.
;RLF 02-AUG-82 [1376] Corrects diagnostic when line before FD too long
;RJD 15-JUL-82 [1373] Corrects page advancing when more than 2 report
; header lines
;JEH 14-JUN-82 [1366] Correct 1335, set up CURHLD properly
;JEH 07-JUN-82 [1362] Make HLDSAV external
;RJD 24-MAY-82 [1356] Allow qualification in DATA RECORDS ARE clause
;JEH 30-MAR-82 [1346] Fatal error if too many ascending/descending keys
;JEH 02-FEB-82 [1335] Declare DATAB entries for all indexes if REPORT
; SECTION is scanned for their use by REPORT WRITER stmts
;
;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
.COPYRIGHT ;Put COPYRIGHT statement in .REL file.
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]
$COPYRIGHT ;Put standard copyright statement in EXE file
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
SETZM BLDIX## ;[1335]
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. DA18A. ;[1356]
DA18A.: PUSHJ PP,TRYNAM ;[1356] IS NAME IN TABLE?
JRST DA18B. ;[1356] NO
HLRZS TA ;[1356] SET UP REL ADDR AND
HRRZI TB,CD.FIL ;[1356] TYPE CODE FOR TABLE SEARCH
PUSHJ PP,FNDLNK ;[1356] SEARCH FILTAB
JRST DA18B. ;[1356] ENTRY NOT FOUND
MOVE TA,CURFIL ;[1356] GET CURRENT FILE ADDR
CAMN TA,TB ;[1356] SAME FILE USED TO QUALIFY?
POPJ PP, ;[1356] YES
DA18B.: EWARNJ E.190 ;[1356] GIVE IMPROPER QUALIFICATION MSG
INTER. DA19.
DA19.: HRRZI TC,%LBL.S ;'STANDARD LABELS' CODE
CHKLBL: MOVE TA,CURFIL
JUMPE TA,CPOPJ
LDB TB,FI.LBL
CAIE TB,%%LBL ;INITIAL STATE?
EWARNJ E.16 ;NO--ERROR
DPB TC,FI.LBL
POPJ PP,
INTER. DA20.
DA20.: HRRZI TC,%LBL.O ;'OMITTED LABELS' CODE
JRST CHKLBL
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.
HRRZM TB, TBLOCK+1 ;[1424] SAVE LINK
DA38.A: PUSHJ PP, FNDPOP## ;FIND THE FATHER.
JRST DA38.L ;NO FATHER.
LDB TC, [POINT 3,TB,20] ;GET FATHER'S TABLE CODE.
CAIE TC, CD.DAT ;IS HE IN DATAB?
JRST DA38.L ;NO.
HRRZM TB, TBLOCK+1 ;SAVE FATHER'S LINK.
HRRZI TA, (TB) ;SET UP FOR LNKSET.
PUSHJ PP, LNKSET## ;GET FATHER'S ADDRESS.
LDB TC, DA.USG## ;GET HIS USAGE.
HRRZ TB, TBLOCK+1 ;RESTORE FATHER'S LINK.
CAIN TC, %%US ;DOES HE HAVE A USAGE?
JRST DA38.A ;NO, GO LOOK AT HIS FATHER.
;FOUND A FATHER FOR WHICH A USAGE CLAUSE WAS GIVEN.
HRRZ TB, TBLOCK ;RESTORE SON'S USAGE.
COMMENT \
NOW WE HAVE TO MAKE SURE THAT THE USAGES ARE VALID.
THE FOLLOWING ARE OK:
USAGE OF FATHER USAGE OF SON
DISPLAY-6 DISPLAY-6
COMP
COMP-1
INDEX
DISPLAY-7 DISPLAY-7
COMP
COMP-1
INDEX
DISPLAY-9(EBCDIC) DISPLAY-9
COMP
COMP-1
COMP-3
INDEX
COMP COMP
COMP-1 COMP-1
COMP-3 COMP-3
INDEX INDEX
\
CAIN TB, (TC) ;FATHER AND SON HAVE SAME USAGES?
JRST DA38.L ;YES, ALL IS WELL.
;SON'S USAGE IS NOT THE SAME AS FATHER'S USAGE.
CAIE TC, %US.D6 ;IS THE FATHER DISPLAY-6
CAIN TC, %US.D7 ; OR DSIPLAY-7?
JRST DA38.F ;YES.
CAIE TC, %US.EB ;HOW ABOUT EBCDIC?
JRST DA38.E ;NO, COMPLAIN SINCE ONLY ITEMS
; WITH SOME FORM OF DISPLAY USAGE
; MAY HAVE SUBORDINATE ITEMS WITH
; DIFFERENT USAGES.
;FATHER IS EBCDIC - DO THE COMP-3 SPECIAL CASE.
CAIN TB, %US.C3 ;IS THE SON COMP-3?
JRST DA38.L ;YES, ALL IS WELL.
;FATHER IS SOME FORM OF DISPLAY AND THE SON'S USAGE IS DIFFERENT.
; MAKE SURE THE SON IS NOT DISPLAY OR COMP-3 SINCE IF IT IS
; DISPLAY IT ISN'T THE SAME FLAVOR AS THE FATHER'S AND IF IT
; IS COMP-3 THE FATHER ISN'T EBCDIC.
DA38.F: CAIE TB, %US.D6 ;IS THE SON DISPLAY-6
CAIN TB, %US.D7 ; OR DISPLAY-7?
JRST DA38.E ;YES, COMPLAIN.
CAIE TB, %US.EB ;IS THE SON EBCDIC
CAIN TB, %US.C3 ; OR COMP-3?
JRST DA38.E ;YES, COMPLAIN.
;THE SON'S USAGE IS ACCEPTABLE.
DA38.L: HRRZ TA, CURDAT ;RESTORE SON'S DATAB ADDRESS
HRRZ TB, TBLOCK ; AND HIS USAGE CODE.
DPB TB, DA.USG## ;PUT THE CODE IN THE DATAB ENTRY.
;[1537] CAN'T TRANSFER COMP DATA FROM ASCII RECORD TO A FILE BUFFER
CAIG TB, %US.DS ;[1424] IF IT'S A DISPLAY MODE,
POPJ PP, ;[1424] EXIT
LDB TB, DA.DFS ;[1424] IF DATA ITEM IS NOT
SKIPN TB ;[1424] IN FILE SECTION,
POPJ PP, ;[1424] EXIT
HRRZ TA, TBLOCK+1 ;[1537] GET LAST TABLE LINK IN TA
D38.L2: PUSHJ PP, LNKSET ;[1537]
LDB TC, DA.LVL ;[1537] ARE WE AT THE RECORD LEVEL?
CAIN TC, 1 ;[1537]
JRST D38.L3 ;[1537] YES
PUSHJ PP, FNDPOP ;[1537] RETURNS TB[ REL ADDR OF POP
POPJ PP, ;[1537] CAN'T FIND ONE
MOVE TA, TB ;[1537] SET UP TA
JRST D38.L2 ;[1537] CHECK AGAIN
D38.L3: LDB TC, DA.USG## ;[1537]
CAIE TC, %US.D7 ;[1537] IS IT ASCII?
POPJ PP, ;[1424] NO, EXIT
HRRZI DW, E.654 ;[1424] GIVE ERROR
HRRZ TA, CURDAT ;[1424] AT DATA FIELD DECLARATION
LDB LN, DA.LN ;[1424]
LDB CP, DA.CP ;[1424]
PUSHJ PP, FATAL## ;[1424]
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, ;INCREMENT COUNT
DPB TB,HL.QAL ;& PUT BACK
ROT TB,-1 ;DIV BY 2
HLRZ TC,CURNAM ;GET NAMTAB LINK
JUMPL TB,DA60.A ;IF BIT0 ON, USE ODD HALF-WORD
ADDI TA,1(TB) ;PTR TO EVEN HALF-WORD
HRRM TC,(TA) ;STORE IN EVEN HALF
POPJ PP,
DA60.A: PUSH PP,CURHLD ;SAVE PTR TO HLDTAB ENTRY
MOVE TA,[XWD CD.HLD,1] ;GET ONE MORE WORD FOR THE ENTRY
PUSHJ PP,GETENT
HLRZ TC,CURNAM ;GET NAMTAB LINK
HRLZM TC,(TA) ;STORE NAMTAB LINK IN ODD HALF
POP PP,CURHLD ;RESTORE HLDTAB PTR
POPJ PP,
;STORE NAMTAB RELATIVE ADDRESS FOR NEW NAME
DA60S.: TLNN W1,GWNOT ;NAME IN NAMTAB?
JRST DA60SA ;YES
PUSHJ PP,BLDNAM ;NO, BUILD NAMTAB ENTRY
MOVEM TA,CURNAM ;SAVE ADDR
HLRZS TA ;LINK TO RIGHT HALF
DPB TA,[POINT 15,W2,15] ;& TO W2 IN CASE ANYBODY WANTS IT
POPJ PP,
DA60SA: LDB TA,[POINT 15,W2,15] ;GET NAMTAB REL ADDR
HRLZM TA,CURNAM ;& SAVE
POPJ PP,
INTER. DA61.
DA61.: FLAGAT NS
MOVEI TA,%HL.VP ;'VALUE OF PROJECT-PROGRAMMER' FLAG
MOVEM TA,PNTS
POPJ PP,
;BUILD REPORT TABLE ENTRY & LINK FILE TO REPORT
IFN RPW,<
INTER. DA62.
DA62.: PUSHJ PP,DA62S.
HLRZ TB,CURFIL ;STORE FILTAB LINK IN RPWTAB
DPB TB,RW.FIL##
HRRZ TA,CURFIL ;GET FILTAB PTR
HLRZ TB,CURRPW ;STORE RPWTAB LINK IN FILTAB
DPB TB,FI.RPG##
SETO TB, ;FORCE ASCII MODE FOR FILE
DPB TB,FI.ADV## ;BY SETTING WRITE-ADVANCING FLAG
POPJ PP,
DA62S.: PUSHJ PP,BLDNAM ;PUT USERN. IN NAMTAB
HLRZ TB,TA ;SAVE NAMTAB LINK
DPB TB,[POINT 15,W2,15]
MOVE TA,[XWD CD.RPW,SZ.RPD] ;GET AN RPWTAB ENTRY
PUSHJ PP,GETENT
MOVEM TA,CURRPW ;SAVE RPWTAB PTR
LDB TB,[POINT 15,W2,15] ;GET BACK NAMTAB LINK
DPB TB,RW.NAM## ;STORE NAMTAB LINK IN RPWTAB
ADD TB,NAMLOC## ;MAKE ABS. NAMTAB PTR
HLRM TA,(TB) ;STORE RPWTAB LINK IN NAMTAB
HLRZ TB,CURRPW ;GET LINK TO CURRENT RPWTAB ENTRY
SKIPN TC,LASTRD ;GET LINK TO PREVIOUS RD
JRST DA62SX ;NO PREVIOUS
HRRZ TA,RPWLOC ;MAKE ABS. PTR TO PREV. ENTRY
ADDI TA,(TC)
DPB TB,RW.BRO## ;LINK OLD ENTRY TO NEW
DA62SX: MOVEM TB,LASTRD ;REMEMBER CURR. ENTRY FOR NEXT TIME
MOVE TA,CURRPW ;RESTORE PTR TO CURRENT
POPJ PP,
INTER. DA62XE
DA62XE: MOVEI DW,E.338 ; [335] BAD TABLE
DA62XF: SETOM RPWERR ; [335] SET REPORT GENERATOR FATAL FLAG
JRST FATALW ; [335] FATAL ERROR
;INIT REPORT SECTION
INTER. DA63.
DA63.: SETZM LNKSEC ;CLR LINKAGE SECTION FLAG
SKIPL TA,PCHOLD ;RESET EAS1PC TO PREVIOUS
MOVEM TA,EAS1PC ; IF CHANGED BY LINKAGE SECTION
SETOM PCHOLD
SKIPN FILSEC ;FILE SECTION SEEN?
JRST DA63E. ;NO
SWOFF FFILSC ;CLR FILE SECTION FLAG
SETOM REPSEC## ;SET REPORT SECTION FLAG
SETZM RPWRDL ;CLR RD RPWTAB LINK STORAGE
POPJ PP,
DA63E.: HRRZI NODE,DD204E## ;NEXT SYNTAX NODE IS DD204E
HRRZM NODE,(NODPTR) ;TO SKIP TO NEXT SECTION
EWARNJ E.339 ;FILE SECTION NOT SEEN MSG
;INIT RD
INTER. DA64.
DA64.: SETZM RPTCID## ; [415] CLEAR CONTROL ID LEVEL
LDB TB,[POINT 15,W2,15] ;GET BACK NAMTAB LINK
ADD TB,NAMLOC ;MAKE ABS NAMTAB PTR
HRRZ TA,(TB) ;GET RPWTAB LINK TO RD ENTRY
HRLI TA,(TA) ;IN BOTH HALVES
TRZE TA,700000 ;TABLE CODE = RPWTAB?
EWARNJ E.359 ;?REPORT-NAME EXPECTED
MOVE TB,RPWLOC## ;MAKE FULL RPWTAB PTR
ADDI TA,(TB)
MOVEM TA,CURRPW ;SAVE PTR TO CURRENT RPWTAB ENTRY
TLO W2,GWDEF ;PUT DEFINING REF. IN CREF TABLE
PUSHJ PP,PUTCRF
MOVE TA,CURRPW ;RESTORE PTR TO NEW ENTRY
HLRZM TA,RPWRDL ;& SAVE LINK FOR GROUP ITEMS
LDB TB,[POINT 20,W2,35] ;STORE LINE POSITION IN RPWTAB
DPB TB,RW.LNC##
MOVSI TB,[SIXBIT /PAGE:COUNTER/]
PUSHJ PP,DA64S. ;MAKE PAGE-COUNTER ENTRY IN DATAB
DPB TB,RW.PC## ;PUT DATAB LINK IN RPWTAB
HRRZ TA,CURDAT ;DEFAULT PAGE-CTR SIZE IS 10
HRRZI TB,^D10
DPB TB,DA.EXS
DPB TB,DA.INS
MOVSI TB,[SIXBIT /LINE:COUNTER/]
PUSHJ PP,DA64S. ;MAKE LINE-COUNTER ENTRY IN DATAB
DPB TB,RW.LC## ;PUT DATAB LINK IN RPWTAB
HRRZ TA,CURDAT ;GET DATAB PTR
HRRZI TB,2 ;LINE-COUNTER IS SIZE 2
DPB TB,DA.EXS
DPB TB,DA.INS
MOVE TA,[CD.LIT,,SZ.LIT+1] ;PUT A -1 IN LITAB
PUSHJ PP,GETENT
MOVEM TA,CURLIT
MOVE TB,[001002,,1] ;SET UP CODE WORD
MOVEM TB,(TA)
MOVSI TB,(ASCII /-1/) ;"-1" TO 2ND WORD OF ENTRY
MOVEM TB,1(TA)
HLRZ TB,CURLIT ;PUT LITAB LINK IN DATAB ENTRY
HRRZ TA,CURDAT
DPB TB,DA.VAL ;AS A VALUE OF -1 TO MEAN NO INITIATE YET
JRST DA8. ;ALLOCATE LINE-COUNTER
;MAKE PAGE/LINE-COUNTER ENTRY IN DATAB
DA64S.: HRRI TB,NAMWRD
BLT TB,NAMWRD+1 ;PUT 'XXXX-COUNTER' IN NAME STORE
SETZM NAMWRD+2 ;CLR REST OF NAMWRD
MOVE TA,[NAMWRD+2,,NAMWRD+3]
BLT TA,NAMWRD+5
PUSHJ PP,DA8. ;ALLOCATE PREVIOUS ITEM
HRRZI TB,LVL.01 ;MAKE COUNTER AN 01 LEVEL ITEM
MOVEM TB,(SAVPTR)
PUSHJ PP,DA26N.
HRRZS REPSEC ;PRETEND ITS AN ORDINARY W-S ITEM
PUSHJ PP,DA27. ;CREATE DATAB ENTRY
SETOM REPSEC ;RESET REPORT SECTION FLAG
HRRZ TA,CURDAT ;PTR TO COUNTER DATAB ENTRY
HRRZI TB,%CL.NU ;SET NUMERIC CLASS IN DATAB
DPB TB,DA.CLA
HRRZI TB,%US.1C ;& 1-WORD COMP USAGE
DPB TB,DA.USG
SETO TB,
DPB TB,DA.PIC ;& PIC SEEN BIT
DPB TB,DA.SGN ;& SIGNED BIT
DPB TB,DA.FAL ;& FATHER BIT
DPB TB,DA.LPC## ;THIS IS A LINE- OR PAGE-COUNTER
HRRZ TB,RPWRDL ;RD ENTRY IS THE FATHER LINK
DPB TB,DA.POP
PUSHJ PP,GETRDL ;GET RPWTAB PTR
HLRZ TB,CURDAT ;PUT PAGE/LINE-CTR DATAB LINK IN RPWTAB ENTRY
POPJ PP,
;GET RPWRDL & CONVERT IT TO AN ABSOLUTE PTR
GETRDL: HRRZ TA,RPWLOC ;TABLE BASE
ADD TA,RPWRDL ;PLUS RELATIVE ADDR
POPJ PP,
;SET UP REPORT NAME FOR RD, WHERE REPORT NAME NOT
;SPECIFIED IN A REPORT CLAUSE OF THE FILE SECTION
INTER. DA64E.
DA64E.: PUSHJ PP,DA62S. ; [335] SET UP REPORT TABLE
SKPNAM ; [335] GO ON
INTER. DA64XE
DA64XE: MOVEI DW,E.342 ; [335] ?NOT NAMED IN FILE SECTION.
JRST DA62XF ; [335] SET REPORT WRITER FATAL FLAG
;GET PAGE LIMIT
INTER. DA66.
DA66.: PUSHJ PP,DA11. ;GET THE INTEGER
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TC,RW.PAG ;PAGE LIMIT CLAUSE SEEN ALREADY?
JUMPN TC,JCE16. ;YES, DUPLICATE CLAUSE
MOVE TC,(SAVPTR) ;GET VALUE OF PAGE LIMIT
JUMPLE TC,DA66E ;MUST BE .GT. 0
CAILE TC,777 ;MUST BE .LT. 512
DA66E: EWARNJ E.344 ;?PAGE-LIMIT MUST BE LESS THAN 512
DPB TC,RW.PAG ;STORE PAGE LIMIT
MOVEI TD,2 ;MAKE LINE-CTR SIZE AGREE WITH PG-LIM
CAIL TC,^D100
MOVEI TD,3
CAIGE TC,^D10
MOVEI TD,1
LDB TC,RW.LC
HRRZI TA,(TC)
PUSH PP,TD
PUSHJ PP,LNKSET
POP PP,TD
DPB TD,DA.EXS
DPB TD,DA.INS
POPJ PP,
;GET PAGE HEADING LINE NUMBER
INTER. DA67.
DA67.: MOVE TB,RW.PHL## ;PTR TO HEADING-LINE FIELD IN RPWTAB ENTRY
DA67X.: MOVEM TB,PNTS ;SAVE FIELD PTR
PUSHJ PP,DA11. ;GET VALUE OF INTEGER
MOVE TC,(SAVPTR)
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TB,RW.PAG ;GET PAGE LIMIT
CAIGE TB,(TC) ;INDICATED LINE .LE. PAGE LIMIT?
EWARNJ E.343 ;NO
DPB TC,PNTS ;YES, STORE NUMBER IN INDICATED FIELD
POPJ PP,
;GET FIRST DETAIL LINE NUMBER
INTER. DA68.
DA68.: MOVE TB,RW.FDE## ;PTR TO FIRST DETAIL FIELD IN RPWTAB ENTRY
JRST DA67X.
;GET LAST DETAIL LINE NUMBER
INTER. DA69.
DA69.: MOVE TB,RW.LDE ;PTR TO LAST DETAIL FEILD
JRST DA67X.
;GET PAGE FOOTING LINE NUMBER
INTER. DA70.
DA70.: MOVE TB,RW.CFL## ;PTR TO FOOTING-LINE FIELD IN RPWTAB
JRST DA67X.
;CONTROL 'FINAL'
INTER. DA71.
DA71.: MOVE TA,[CD.RPW,,SZ.RPC] ;GET A CONTROL ENTRY IN RPWTAB
PUSHJ PP,GETENT
MOVEM TA,CURRPW ;SAVE RPWTAB PTR
HLRZ TC,TA ;PUT LINK TO CONTROL ENTRY INTO RD ENTRY
PUSHJ PP,GETRDL ;GET RPWTAB PTR
LDB TB,RW.NCI ;IS THIS THE FIRST CONTROL?
JUMPE TB,.+2 ;YES
EWARNW E.346 ; [315] NO, FINAL MUST BE FIRST
DPB TC,RW.CID##
HRRZI TC,1 ;INDICATE 1ST CONTROL ENTRY
DA71.X: DPB TC,RW.NCI##
POPJ PP,
;CONTROL <DATA-NAME>
INTER. DA72.
DA72.: PUSHJ PP,DA72N ; [315] READ IDENTIFIER WITH ALL QUALS
CAIN TE,<CD.DAT>B20+1 ; [423] IF DUMMY BECAUSE BAD QUALIFIERS
POPJ PP, ; [423] QUIT NOW TO PREVENT COMPILER CRASH IN D54.NJ
PUSH PP,TE ; [315] SAVE DATAB LINK
MOVEM TE,SAVDAT## ; [315] SAVE DATAB LINK FOR RWPDAT
PUSHJ PP,SAVTHM ; [315] SAV CURRENT SOURCE INPUT
PUSHJ PP,RPWDAT ; [315] GO ENTER A NEW DATA ENTRY INTO DATAB
PUSHJ PP,D54.NJ ; [315] PUT NEW ENTRY INTO ASY FIL
SETOM REPSEC ; [315] SET US BACK TO REPORT SECTION
MOVE TA,[CD.RPW,,SZ.RPC] ;GET A CONTROL ENTRY IN RPWTAB
PUSHJ PP,GETENT
MOVEM TA,CURRPW ;SAVE RPWTAB PTR
POP PP,TE ;STORE DATAB LINK
HRLZM TE,(TA) ;IN CONTROL ENTRY
HLRZ TB,TA ;GET CNTRL ENTRY LINK
HLRZ TD,CURDAT ; [315]GET PREVIOUS DATAB ADR
HRRM TD,(TA) ; [315] STORE IT
PUSHJ PP,GETRDL ; [315] GET RD RPWTAB PTR
PUSHJ PP,RETHM ; [315] GET BACK SOURCE INPUT FOR GETITM REGET
LDB TC,RW.NCI ;# OF CTRL IDENTIFIERS SEEN
SKIPN TC ;THIS THE 1ST CONTROL ID?
DPB TB,RW.CID ;YES, STORE LINK TO 1ST CTRL ID IN RPWTAB
AOJA TC,DA71.X ;INCREMENT CTRL-ID CTR
DA72N: MOVEM W1,HLDSRC## ; [315]SAVE CURRENT SOURCE INPUTS
MOVEM W2,HLDSRC+1 ; [315]
MOVEM CT,HLDSRC+2 ; [315]
PJRST DA96. ; [315] GO GET ANY QUALIFERS AND RETURN
SAVTHM: EXCH W1,HLDSRC ; [315] SAV NEW SOURCE GET BACK ORIGINAL CID
EXCH W2,HLDSRC+1 ; [315]
EXCH CT,HLDSRC+2 ; [315]
MOVE TE,[NAMWRD,,HLDNAM##] ; [315] SAVE SOURCE NAME FOR
BLT TE,HLDNAM+4 ; [315] LATER GETITM REGET
POPJ PP, ; [315] RETURN
RETHM: ; [315] RESTORE LAST SOURCE ITEM
MOVE W1,HLDSRC ; [315]
MOVE W2,HLDSRC+1 ; [315]
MOVE CT,HLDSRC+2 ; [315]
MOVE TE,[HLDNAM,,NAMWRD] ; [315]
BLT TE,NAMWRD+4 ; [315] LAST SOURCE ITEM GOTTEN IN DA96.
MOVEM CT,ITEMCT## ; [315]
POPJ PP, ; [315] IS RESTORED FOR A GETITM REGET.
; THIS ROUTINE PUTS A RPWITM ENTRY INTO DATAB HAVING PARRAMETERS
; SIMULAR TO THE CURRENT DATAB ITEM WHOSE RELATIVE ADDRESS IS IN LOCATION SAVDAT
INTER. RPWDAT
RPWDAT: MOVE TA,['RWITM;'] ; [315] GET FAKE NAME
MOVEM TA,NAMWRD ; [315] STORE IT
PUSHJ PP,SIXDIG ; [315] GET NEXT DIGIT (IN SIXBIT)
MOVEM TA,NAMWRD+1 ; [315] MAKE DATA NAME 'RWITM-NNNNNN'
SETZM NAMWRD+2 ; [315] CLEAR REST OF NAME
MOVE TA,[NAMWRD+2,,NAMWRD+3] ; [315]
BLT TA,NAMWRD+5 ; [315]
MOVEI TB,LVL.01 ; [315] SET LEVEL TO 01
MOVEM TB,(SAVPTR) ; [315]
PUSHJ PP,DA26N. ; [315] SET 01 LEVEL AND USAGE
SETZM REPSEC ; [315] TURN OFF REPORT SECTION MOMENTARILY TO AVOID ANY RPTAB ENTRY
PUSHJ PP,DA27. ; [315] SET UP DATAB ENTRY FOR NEW ENTRY- NEW ITEM ADDRESS RETURN IN CURDAT
SETZM CURFIL ; [315] MAKE SURE NO FILE IS INVOLVED
HRRZ TA,SAVDAT ; [315] GET CURRENT DATAB RELATIVE ADDRESS
PUSHJ PP,LNKSET ; [315] GET ITS REAL ADDRESS
HRRM TA,SAVDAT ; [315] NOW SAVE THE REAL ADDRESS
LDB TB,DA.CLA ; [315] GET CURRENT CLASS
LDB TC,DA.SGN ; [315] GET CURRENT SIGN
LDB TD,DA.BWZ ; [315] GET CURRENT BLANK WHEN ZERO
LDB TE,DA.EDT ; [315] GET CURRENT EDITING PARAMETER
HRRZ TA,CURDAT ; [315] GET NEW ITEM ADDRESS
DPB TB,DA.CLA ; [315] COPY CLASS
DPB TC,DA.SGN ; [315] COPY SIGN
DPB TD,DA.BWZ ; [315] COPY BLANK WHEN ZERO
DPB TE,DA.EDT ; [315] COPY EDIT
JUMPE TE,RPWDT1 ; [315] IF NO EDIT GO ON
MOVE TA,[CD.DAT,,SZ.DOC+SZ.MSK] ; [603] [315] EDIT- NEED TO
PUSHJ PP,GETENT ; [315] INCREASE SIZE OF DATAB TABLE
HRLZ TB,SAVDAT ; [315] GET CURRENT ADDRESS
HRR TB,CURDAT ; [315] GET NEW ADDRESS
ADD TB,[XWD 7,7] ; [315] SET EACH TO 8TH WORD
HRRZ TC,CURDAT ; [315] SET UP LAST NEW ADDRESS
BLT TB,14(TC) ; [315] COPY 8TH - 13 TH WORD OF CURRENT INTO NEW (I.E) EDIT PARAMS
RPWDT1: HRRZ TA,SAVDAT ; [315] GET CURRENT ITEM
LDB TB,DA.JST ; [315] GET JUSTIFICATION
LDB TC,DA.USG ; [315] GET USAGE
LDB TD,DA.DPR ; [315] GET DECIMAL PLACE
HRRZ TA,CURDAT ; [315] GET NEW ITEM
DPB TB,DA.JST ; [315] COPY JUSTIFIED
DPB TC,DA.USG ; [315] COPY USAGE
DPB TD,DA.DPR ; [315] COPY DECIMAL PLACE
HRRZ TA,SAVDAT ; [315] GET CURRENT ADDRESS
LDB TB,DA.NDP ; [315] GET NUMBER OF DECIMAL PLACES
LDB TC,DA.INS ; [315] GET INTERNAL SIZE
LDB TD,DA.EXS ; [315] GET EXTERNAL SIZE
HRRZ TA,CURDAT ; [315] GET NEW ITEM
DPB TB,DA.NDP ; [315] COPY NUMBER OF DECIMAL PLACES
DPB TC,DA.INS ; [315] COPY INTERNAL SIZE
DPB TD,DA.EXS ; [315] COPY EXTERNAL SIZE
SETO TB, ; [315] TURN ON FOLLOWING
DPB TB,DA.FAK ; [315] ITEM IS FAKE
DPB TB,DA.PIC ; [315] PICTURE IS DESCRIBED HERE
POPJ PP, ; [315] RETURN
>; [315] END OF IFN RPW
;CHECK FOR ILLEGAL CLAUSE IN REPORT SECTION
IFN ANS74,<
INTER. DA73.F
DA73.F: HRRZ TA,CURDAT ;POINT TO DATAB
LDB TB,DA.LVL ;GET LEVEL NUMBER
CAIE TB,LVL.01 ;LEVEL 01
CAIN TB,LVL.77 ; AND 77
FLAGAT NS ; ARE NON-STANDARD
SKPNAM
>
INTER. DA73.
DA73.:
IFN RPW,<
SKIPN REPSEC ;IN REPORT SECTION?
POPJ PP, ;NO
EWARNW E.348 ;CLAUSE ILLEGAL IN REPORT SECT.
DA73.X: HRRZI NODE,DD115.## ;CONTINUE AT NODE DD115.
HRRZM NODE,(NODPTR)
>
POPJ PP,
;CHECK FOR ILLEGAL CLAUSE OUTSIDE REPORT SECTION
IFN RPW,<
INTER. DA74.
DA74.: SKIPE REPSEC ;IN REPORT SECTION?
POPJ PP, ;YES, CLAUSE IS OK
DA74.X: EWARNW E.350 ;NO, ILLEGAL CLAUSE
JRST DA73.X ;GO TO SYNTAX NODE DD144.
;IF REPORT ITEM HAS NO NAME,
;PUT NAME 'RWITM.######' ON REPORT GROUP ITEM
FAKNAM: HRRZ TA,CURDAT ;DATAB ADDR
LDB TC,DA.NAM ;HAVE A REAL NAME?
JUMPN TC,CPOPJ ;YES
PUSHJ PP,RPWNAM ;MAKE NAMTAB ENTRY "RWITM.######"
HLRZS TA ;LINK DATAB ENTRY TO NAMTAB
HLL TA,CURDAT
PUSHJ PP,PUTLNK
HRRZ TA,CURDAT ;PUT NAMTAB LINK IN DATAB
HRRZ TB,NAMADR##
HRRZ TC,NAMLOC
SUBI TB,(TC)
DPB TB,DA.NAM
LDB TB,DA.SNL## ;REMOVE ITEM FROM NO-NAME CHAIN
HRRZM TB,(TC)
SETZ TB, ;CLR SAME NAME LINK
DPB 15,DA.SNL
SETO TB, ;SET FAKE NAME BIT
DPB TB,DA.FAK##
POPJ PP,
;MAKE A "RWITM.######" ENTRY IN NAMTAB
RPWNAM::MOVE TA,['RWITM;'] ;FIRST WORD OF SIXBIT NAME
MOVEM TA,NAMWRD
PUSHJ PP,SIXDIG ;SECOND WORD OF NAME
MOVEM TA,NAMWRD+1
SETZM NAMWRD+2 ;CLR REST OF NAMWRD
MOVE TA,[NAMWRD+2,,NAMWRD+3]
BLT TA,NAMWRD+5
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM ;PUT NAME IN NAMTAB
MOVEM TA,NAMADR ;SAVE NAMTAB PTR
POPJ PP,
;GENERATE A 6-DIGIT SIXBIT NUMBER ONE LARGER THAN THE LAST
SIXDIG: MOVE TA,SIXHLD## ;GET LAST NUMBER RETURNED
ADD TA,[464646464647]
MOVE TB,TA
TDZ TB,[171717171717]
MOVE TC,TB
LSH TC,-3
OR TB,TC
SUB TA,TB
ADD TA,[202020202020]
MOVEM TA,SIXHLD ;STORE NEW NUMBER
POPJ PP,
;REPORT LINE IS NEXT PAGE
INTER. DA75.
DA75.: MOVEI TB,%RG.NP ;GET NEXT PAGE CODE
DA75.X: SETOM RWLCS. ;NOTE THAT WE HAVE SEEN A LINE CLAUSE.
HRRZ TA,CURRPW ;PTR TO REPORT GROUP ENTRY
LDB TC,RW.LCD## ;LINE CODE SEEN BEFORE?
JUMPN TC,JCE16. ;YES, DUPLICATE CLAUSE
DPB TB,RW.LCD ;NO, STORE IT
POPJ PP,
;REPORT LINE IS <INTEGER>
INTER. DA76.
DA76.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE POSITIVE
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.LIN## ;LINE # THERE ALREADY?
JUMPN TB,JCE16. ;YES, DUP. CLAUSE
PUSHJ PP,GETRDL ;MAKE PTR TO RD ENTRY
LDB TB,RW.PAG## ; [315] GET PAGE-LIMIT
HRRZ TA,CURRPW ; GET BACK REORT ITEM
JUMPE TB,.+3 ; IF NO PAGE-LIMIT- NO CHECK
CAILE TC,(TB) ; LINE MUST BE L.E. TO PAGE-LIMIT
EWARNJ E.352 ; IT IS NOT
DPB TC,RW.LIN ; OKAY STORE LINE NUMBER
HRRZI TB,%RG.LN ; GET LINE # CODE
JRST DA75.X ; STORE IT AND RETURN
;REPORT LINE IS PLUS <INTEGER>
INTER. DA77.
DA77.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE POS.
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.LIN ;LINE # GIVEN ALREADY?
JUMPN TB,JCE16. ;YES
DPB TC,RW.LIN ;NO, STORE IT
HRRZI TB,%RG.PI ;PLUS INTEGER CODE
JRST DA75.X
;NEXT GROUP IS NEXT PAGE
INTER. DA80.
DA80.: MOVEI TB,%RG.NP ;GET NEXT PAGE CODE
DA80.X: HRRZ TA,CURRPW ;PTR TO REPORT GROUP ENTRY
LDB TC,RW.NLC## ;NEXT GROUP CODE SEEN BEFORE?
JUMPN TC,JCE16. ;YES, CLAUSE DUPLICATED
DPB TB,RW.NLC ;NO, STORE IT
POPJ PP,
;NEXT GROUP IS <INTEGER>
INTER. DA81.
DA81.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE .GT. 0
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.NXT## ;NEXT GROUP CLAUSE SEEN ALREADY?
JUMPN TB,JCE16. ;YES
PUSHJ PP,GETRDL ; [315] GET RD ADDRESS
LDB TB,RW.PAG ;INTEGER MUST BE .LE. PAGE LIMIT
JUMPE TB,.+3
CAILE TC,(TB)
EWARNJ E.352 ;TOO BIG
HRRZ TA,CURRPW ; [315] GET RPWTAB ADDRESS
DPB TC,RW.NXT ;OK, STORE IT
HRRZI TB,%RG.LN ;LINE # CODE
JRST DA80.X
;NEXT GROUP IS PLUS <INTEGER>
INTER. DA82.
DA82.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE .GT. 0
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.NXT ;NEXT GROUP CLAUSE SEEN ALREADY?
JUMPN TB,JCE16. ;YES
DPB TC,RW.NXT ;STORE INTEGER
HRRZI TB,%RG.PI ;GET PLUS INTEGER CODE
JRST DA80.X
;SET GROUP INDICATE BIT
INTER. DA83.
DA83.: SKIPN REPSEC ;IN REPORT SECTION?
JRST DA74.X ;NO, SHOULDN'T BE HERE
HRRZ TA,CURRPW ;REPORT GROUP RPWTAB PTR
LDB TB,RW.TYP ; [315] G.I. LEGAL ONLY FOR
CAIE TB,%RG.DE ; [315] TYPE DETAIL
EWARNJ E.482 ; [315] ILLEGAL
SETO TB, ;SET GROUP INDICATE BIT
DPB TB,RW.GPI##
POPJ PP,
;RESET ON FINAL
INTER. DA84.
DA84.: HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.RSF## ;RESET ON FINAL SEEN BEFORE?
JUMPN TB,JCE16. ;YES
LDB TB,RW.RSI## ;RESET ON IDENTIFIER SEEN?
JUMPN TB,JCE16. ;YES
LDB TB,RW.TYP ;MAKE SURE IT'S CF (OR NOT YET SPECIFIED)
CAIE TB,0
CAIN TB,%RG.CF
JRST .+2 ;OK
EWARNJ E.368 ;?RESET ON ITEM OTHER THAN CF
SETZ TE, ; [315] MAKE SURE WE HAVE A CONTROL
PUSHJ PP,FNDCNT ; [315] FINAL
EWARNJ E.481 ; [315] NO- ERROR
HRRZ TA,CURRPW ; [315] GET BACK PTR TO REPORT ITEM
SETO TB, ;NO, SET RESET ON FINAL BIT
DPB TB,RW.RSF
POPJ PP,
;RESET ON <IDENTIFIER>
INTER. DA85.
DA85.: PUSHJ PP,DA96. ;READ FULL IDENTIFIER
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.RSF ;RESET ON FINAL SEEN BEFORE?
JUMPN TB,JCE16. ;YES
LDB TB,RW.RSI ;RESET ON IDENTIFIER SEEN?
JUMPN TB,JCE16. ;YES
LDB TB,RW.TYP ;MAKE SURE IT'S CF (OR NOT YET SPECIFIED)
JUMPE TB,DA85.X ;NOT YET SPECIFIED, CK IT AT DA94.
CAIE TB,%RG.CF ;CF?
JRST JCE368 ;?RESET ON ITEM OTHER THAN CF
PUSHJ PP,FNDCNT ;LOOK FOR MATCHING CONTROL ENTRY
JRST JCE369 ;?NOT A CONTROL
HRRZ TC,TB ;[1475] [1452]
HRRZ TD,RPWLOC ;[1452]
SUB TC,TD ;[1475] [1452] MAKE ADDRESS OF CONTROL ENTRY RELATIVE
CAML TC,THSCTL ;[1475] [1452] IS RESET CONTROL HIGHER THAN CURRENT ITEMS CONTROL?
JRST JCE370 ;NO
DA85.X: HRRZ TA,CURRPW ;GET BACK PTR TO CURRENT RPW ITEM
SETO TB, ;SET RESET FLAG
DPB TB,RW.RSI
DPB TE,RW.RES## ;STORE DATAB LINK TO RESET IDENTIFIER
POPJ PP,
JCE357: SETZM RPTCID ; [415] CLEAR CID LEVEL NUMBER
HRRZI DW,E.357
JRST FATAL
JCE367: HRRZI DW,E.367
JRST FATAL
JCE368: HRRZI DW,E.368
JRST FATAL
JCE369: HRRZI DW,E.369
JRST FATAL
JCE472: HRRZI DW,E.472 ; [315]
JRST FATAL ; [315]
JCE473: HRRZI DW,E.473 ; [315]
JRST FATAL ; [315]
JCE489: HRRZI DW,E.489 ;[215]
JRST FATAL ;[215]
JCE490: HRRZI DW,E.490 ;[215]
JRST FATAL ;[215]
JCE491: HRRZI DW,E.491 ;[215]
JRST FATAL ;[215]
;LOCATE CONTROL ENTRY FOR DATAB ITEM IN TE
;SKIP RETURNS WITH LINK TO CONTROL ENTRY IN TB IF FOUND
FNDCNT: HRRZ TA,CURRPW ;PTR TO CURRENT GROUP ENTRY
LDB TB,RW.RDL ;MAKE PTR TO RD ENTRY
HRRZ TA,RPWLOC
ADDI TA,(TB)
LDB TC,RW.NCI ;GET NUMBER OF CONTROLS
LDB TB,RW.CID ;GET LINK TO 1ST CONTROL
ADD TB,RPWLOC
HRRZS TB ;CLR LEFT HALF
FNDCN1: HLRZ TD,(TB) ;GET DATAB LINK FROM CONTROL ENTRY
CAIN TD,(TE) ;IS IT THE ONE?
JRST CPOPJ1 ;YES
ADDI TB,3 ;NO, ADVANCE TO NEXT CONTROL
SOJG TC,FNDCN1 ;GO BACK TO TRY NEXT ONE
HRRZ TC,RPWLOC ;REDUCE RPW ADDR TO RPW LINK
SUBI TB,(TC)
POPJ PP, ;NO MORE -- TAKE ERROR RETURN
;GET COLUMN NUMBER
INTER. DA86.
DA86.: PUSHJ PP,DA11. ;GET THE INTEGER
MOVE TC,(SAVPTR)
JUMPLE TC,JCE25. ;MUST BE POSITIVE
HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.COL## ;COLUMN # ALREADY GIVEN?
JUMPN TB,JCE16. ;YES
DPB TC,RW.COL ;YES, STORE IT IN RPWTAB
SETOM RWCCS.## ;NOTE THAT WE HAVE SEEN A COLUMN CLAUSE.
POPJ PP,
;SET REPORT ITEM TYPE
INTER. DA87.
DA87.: PUSHJ PP,GETRDL ;[1373] GET RD POINTER
SETO TC, ;[1373] INDICATE HAVE SEEN A REPORT
DPB TC,RW.RHL## ;[1373] HEADING
MOVEI TC,%RG.RH ;[1373] REPORT HEADING TYPE CODE
DA87.X: HRRZ TA,CURRPW ;PTR TO RPWTAB ENTRY
LDB TB,RW.TYP## ;TYPE STORED ALREADY?
JUMPN TB,JCE16. ;YES
DPB TC,RW.TYP ;NO, STORE IT
MOVEM TC,LASTYP ;REMEMBER LAST TYPE SEEN
POPJ PP,
INTER. DA88.
DA88.: MOVEI TC,%RG.PH ;PAGE HEADING TYPE
JRST DA87.X
INTER. DA89.
DA89.: MOVEI TC,%RG.CH ;CONTROL HEADING TYPE
JRST DA87.X
INTER. DA90.
DA90.: MOVEI TC,%RG.DE ;DETAIL TYPE
JRST DA87.X
INTER. DA91.
DA91.: MOVEI TC,%RG.CF ;CONTROL FOOTING TYPE
JRST DA87.X
INTER. DA92.
DA92.: MOVEI TC,%RG.PF ;PAGE FOOTING
JRST DA87.X
INTER. DA93.
DA93.: MOVEI TC,%RG.RF ;REPORT FOOTING
JRST DA87.X
;CH/CF IDENTIFIER
INTER. DA94.
DA94.: PUSHJ PP,DA96. ;GET FULL IDENTIFIER
DA94.1: PUSHJ PP,FNDCNT ;FIND CORRESPONDING CONTROL ENTRY
JRST JCE357 ;?THIS DATA ITEM IS NOT A CONTROL
MOVEM TC,RPTCID## ; [415] STORE CURRENT LEVEL OF THE CF
HRRZ TC,TB ;[1475] [1452]
HRRZ TD,RPWLOC ;[1452]
SUB TC,TD ;[1475] [1452] MAKE ADDRESS OF CONTROL ENTRY RELATIVE
HRRZM TC,THSCTL ;[1475] [1452]SAVE ADDR OF CORRESP CONTROL ENTRY
MOVE TA,CURRPW ;GET BACK PTR TO RPW ITEM ENTRY
LDB TC,RW.TYP ;CH OR CF?
CAIE TC,%RG.CH
JRST DA94.A ;CF
HLRZ TC,1(TB) ; [315] IF CH GROUP ALREADY THERE
JUMPN TC,JCE472 ; [315] THEN THIS IS DUPLICATE CONTROL HEADING FOR THIS ID
HLLM TA,1(TB) ;STORE RPWTAB LINK TO CH ITEM
POPJ PP,
DA94.A: HRRZ TC,1(TB) ; [315] IF CF GROUP ALREADY THERE
JUMPN TC,JCE473 ; [315] THEN THIS IS DUPLICATE CONTROL FOOTING FOR THIS ID
HLRM TA,1(TB) ;STORE RPWTAB LINK TO CF
LDB TC,RW.RST## ;[651] GET RW.RSF+RW.RSI
JUMPE TC,CPOPJ ;NO RESET FLAGS
MOVEM TE,(SAVPTR) ;SAVE LINK TO CURRENT ITEMS CONTROL
LDB TE,RW.RES ;GET RESET LINK TO DATAB
PUSHJ PP,FNDCNT ;LOCATE CONTROL ENTRY MATCHING RESET
JRST JCE369 ;NO SUCH CONTROL (CHECKED AT DA85.)
HRRZ TC,TB ;[1475] [1452]
HRRZ TD,RPWLOC ;[1452]
SUB TC,TD ;[1475] [1452] MAKE ADDRESS OF CONTROL ENTRY RELATIVE
CAMGE TC,THSCTL ;[1475] [1452] IS RESET CONTROL HIGHER THAN CURRENT CONTROL
POPJ PP, ;YES
JCE370: HRRZI DW,E.370
JRST FATAL
;CH/CF FINAL
INTER. DA95.
DA95.: HRRZ TA,CURRPW ;PTR TO RPWTAB
SETO TB, ;SET FINAL CONTROL FLAG
DPB TB,RW.FNC##
SETZ TE, ;FINAL HAS "DATAB LINK" OF 0
JRST DA94.1
>;END IFN RPW
;READ & FIND A DEFINED DATA-NAME WITH ALL QUALIFIERS
;RETURNS TE=DATAB LINK
INTER. DA96.
DA96.: SETZM TBLOCK## ;CLR TBLOCK
MOVE TA,[TBLOCK,,TBLOCK+1]
BLT TA,TBLOCK+24
MOVEM W2,TBLOCK+4 ;FACTS ABOUT DATA-NAME TO TBLOCK SETUP
MOVEM LN,(SAVPTR) ;SAVE LINE POSITION
MOVEM CP,1(SAVPTR)
DA96.1: PUSHJ PP,GETITM ;READ NEXT SOURCE WORD
CAIN TYPE,LPREN. ; LEFT PAREN [247]
JRST DA96.4 ; YES HANDLE SUBSCRIPTING [247]
CAIE TYPE,OF. ;IS IT "OF" OR "IN"?
JRST DA96.2 ;NO, TIME TO EXIT
PUSHJ PP,GETITM ;YES, QUALIFIER SHOULD FOLLOW
CAILE TYPE,ENDIT. ;IS IT A RESERVED WORD?
JRST DA96.0 ;NO, IT'S OK
SWON FREGWD ;YES, PREPARE TO REGET THAT ITEM
EWARNJ E.101 ;& FLAG THIS AS ILLEGAL QUALIFIER
DA96.0: AOS TA,TBLOCK+1 ;COUNT THE QUALIFIER
LDB TB,[POINT 15,W2,15] ;GET NAMTAB LINK
JUMPL W1,JCE104 ;QUALIFIER MUST BE DEFINED
MOVEM TB,TBLOCK+4(TA) ;STORE NAMTAB LINK OF QUAL IN TBLOCK
JRST DA96.1 ;ANY MORE QUALS?
DA96.2: MOVE LN,(SAVPTR) ;RESTORE LINE POSITION OF ITEM IN CASE ERROR
MOVE CP,1(SAVPTR)
SWON FREGWD ;REGET THIS LAST WORD THAT WASN'T "OF"
PUSHJ PP,FINDAT## ;FIND A DATAB MATCH FOR THE ITEM
JUMPN DW,DA96.3 ;SKIP IF ERROR [247]
PUSH PP,TE ;SAVE LINK POINTER [247]
HRRZI TA,(TE) ;SET UP CALL TO LNKSET [247]
PUSHJ PP,LNKSET ;GET DATAB ADDRESS [247]
POP PP,TE ; GET IT BACK [247]
LDB TB,DA.SUB. ; IS ITEM SUBSCRIPTED [247]
MOVEI DW,E.275 ;GET ERROR FOR SUBSCRIPTING [247]
SKIPE REPSEC ; IN REPORT SECTION [247]
JUMPN TB,DA96.3 ; SUBCRIPTS ARE ILLEGAL [247]
POPJ PP, ;RETURN WITH DATAB LINK IN TE
JCE104: MOVEI DW,E.104 ; UNDEFINED [247]
DA96.3: PUSHJ PP,FATAL ;[247] GIVE MESSAGE
MOVEI TE,<CD.DAT>B20+1 ;AIM AT DUMMY ENTRY
POPJ PP,
DA96.4: SKIPN REPSEC ; IN REPORT SECTION [247]
JRST DA96.2 ; NO GO ON [247]
DA964A: PUSHJ PP,GETITM ; GET NEXT SOURCE ITEM [247]
CAIE TYPE,ENDIT. ; EOF ON SOURCE? [247]
CAIN TYPE,PRIOD. ; PERIOD? [247]
JRST DA964B ; YES
CAIE TYPE,RPREN. ; RIGHT PAREN ? [247]
JRST DA964A ; LOOP TO GET NEXT SOURCE ITEM [247]
SKIPA ; YES DONT REGET IT [247]
DA964B: SWON FREGWD ; SET TO REGET THIS ITEM [247]
MOVE LN,(SAVPTR) ; GET BACK POSITION OF ITEM [247]
MOVE CP,1(SAVPTR) ; AND ITS CHAR POS [247]
MOVEI DW,E.275 ; SUBCRIPTS NOT ALLOWED [247]
PUSHJ PP,DA96.3 ; GIVE ERROR [247]
PUSHJ PP,FINDAT ; LOOK FOR DATAB LINK [247]
JUMPN DW,DA96.3 ; ERROR [247]
POPJ PP, ; [247]
;LINK REPORT ITEM TO SOURCE
; The full identifier, possibly with subscripts, has been parsed.
IFN RPW,<
INTER. DA97.
DA97.: HRRZ W1,CURRPW ;ABS. PTR TO RPWTAB ENTRY
ADDI W1,.RWSRC ; STORE THE ITEM HERE
PUSHJ PP,DA230. ; STORE THE IDENTIFIER
;RESTORE "CURDAT" SO IT GETS A USAGE WHEN TREES POP BACK TO CALL DA8.
HLRZ TA,CURDTT## ;LH OF LINK
HRLM TA,CURDAT
PUSHJ PP,LNKSET ;GET ABS ADDR.
HRRM TA,CURDAT
HRRZ TA,CURRPW ;GET PTR AGAIN (USE TA THIS TIME)
ADDI TA,.RWSRC
HRRZ TE,1(TA)
PUSH PP,TE ;SAVE IT
HRRZI TA,(TE) ;GET PTR TO DATAB ENTRY
PUSHJ PP,LNKSET
POP PP,TE
LDB TB,DA.RPW## ;RPW LINK SHOULD BE 0 (I.E. W-S OR FILE)
JUMPN TB,JCE367 ;?SOURCE ITEM MUST BE IN FILE OR W-S SECTION
SETO TB, ;SET SOURCE FOR DETAIL BIT
DPB TB,DA.RDS
HRRZ TA,CURRPW ;PTR TO RPWTAB ENTRY
LDB TB,RW.SCD## ;SEEN SOURCE, ETC YET?
JUMPN TB,JCE16. ;YES, DUPLICATE ITEM
HRRZI TB,%RG.SR ;SAY IT HAS A SOURCE CLAUSE
DPB TB,RW.SCD
DPB TE,RW.SLK## ;STORE SOURCE LINK TO DATAB
LDB TD,RW.DAT## ;GET LINK TO CORRESP DATAB ENTRY
LDB TB,RW.RDL## ;& LINK TO CORRESP RD ENTRY
HRRZ TA,RPWLOC ;MAKE ABS. PTR TO RD ENTRY
ADDI TA,(TB)
LDB TB,RW.PC ;GET LINK TO THIS REPORT'S PAGE-CTR
CAIE TB,(TE) ;IS THIS SOURCE THE PAGE-CTR?
POPJ PP, ;NO
PUSH PP,TE ;SAVE LINK TO PAGE-CTR
HRRZI TA,(TD) ;MAKE PTR TO DATAB ENTRY
PUSHJ PP,LNKSET
LDB TB,DA.INS ;GET ITS SIZE
POP PP,TE
PUSH PP,TB ;SAVE SIZE OF DATAB ENTRY
HRRZI TA,(TE) ;MAKE ABS PTR TO PAGE-CTR
PUSHJ PP,LNKSET
LDB TC,DA.INS ;GET PAGE-CTR'S SIZE
CAIN TC,^D10 ;1ST TIME THRU?
SETZ TC, ;YES, PAGE-CTR IS 0
POP PP,TB ;GET BACK SIZE OF DATAB ENTRY
CAIG TB,(TC) ;PAGE CTR ALREADY BIGGER?
POPJ PP, ;YES
DPB TB,DA.EXS ;NO, PAGE-CTR MUST GROW
DPB TB,DA.INS
POPJ PP,
>
;ADVANCE TO NEXT ITEM
INTER. DA98.
DA98.: SWOFF FREGWD ;CLR REGET BIT
JRST GETITM ;GET NEXT ITEM
;PROCESS MISSING DATA-NAME FOR ITEM
INTER. DA99.
DA99.:
IFN RPW,<
SKIPE REPSEC ;REPORT SECTION?
JRST DA99.R ;YES
>
EWARNW E.283 ;NO, ?DATA-NAME EXPECTED
HRRZI NODE,DD91P.## ;MAKE DD91. THE NEXT NODE IN TREE
DA99.X: HRRZM NODE,(NODPTR)
JRST DA7. ;SET TO REGET WORD
IFN RPW,<
DA99.R: SETZB TA,NAMWRD ;INDICATE REPORT ITME HAS NO NAME
DPB TA,[POINT 15,W2,15]
HRRZI NODE,DD89P.## ;CONTINUE AT NODE DD89.
JRST DA99.X
>
INTER. DA99A.
DA99A.:
IFN RPW,<
SKIPE REPSEC ;IN REPORT SECTION?
JRST DA99.Q ;YES
>
EWARNW E.17 ;NO, ?DATA-NAME EXPECTED
HRRZI NODE,DD98P.## ;NEXT NODE IS DD98.
JRST DA99.X
IFN RPW,<
DA99.Q: SETZB TA,NAMWRD ;INDICATE ITEM HAS NO NAME
DPB TA,[POINT 15,W2,15]
HRRZI NODE,DD95P.## ;CONTINUE AT NODE DD95.
JRST DA99.X
>
;CHECK REDEFINES CLAUSE FOR REPORT SECTION ITEM
INTER. DA100.
DA100.:
IFN RPW,<
SKIPE REPSEC ;IN REPORT SECTION?
EWARNJ E.348 ;YES, ILLEGAL
>
POPJ PP,
;PROCESS SUM IDENTIFIER
IFN RPW,<
INTER. DA101.
DA101.: HRRZ TA,CURRPW ;GET RPWTAB PTR
LDB TB,RW.NSI## ;GET NUMBER OF SUM IDENTIFIERS SEEN
ADDI TB,1 ;INCREMENT
DPB TB,RW.NSI ;& REPLACE
ROT TB,-1 ;MOVE BIT 35 TO BIT 0
MOVEM TB,CTR ;SAVE LEFT/RIGHT FLAG
JUMPGE TB,DA101A ;IF EVEN, USE RT HF OF CURRENT ENTRY
MOVE TA,[XWD CD.RPW,1] ;IF ODD, GET ANOTHER RPWTAB WORD
PUSHJ PP,GETENT
HLRZM TA,(SAVPTR) ;SAVE RPWTAB LINK
DA101A: PUSHJ PP,DA60S. ;SAVE NAMTAB ENTRY ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZ TB,(SAVPTR) ;STORE RPWTAB LINK IN HLDTAB
DPB TB,HL.LNK
HRRZI TB,%HL.SL ;GET SUM ID (LH) FLAG
SKIPL CTR ;LEFT OR RIGHT HALF STORE?
HRRZI TB,%HL.SR ;RT., GET SUM ID (RH) FLAG
DPB TB,HL.COD ;STORE HLDTAB CODE
POPJ PP,
;SUM UPON CLAUSE
INTER. DA102.
DA102.: PUSHJ PP,DA60S. ;SAVE NAMTAB ENTRY ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZI TB,%HL.UP ;SET 'SUM UPON' CODE
DPB TB,HL.COD
HLRZ TB,CURRPW ;STORE RPWTAB LINK IN HLDTAB
DPB TB,HL.LNK
POPJ PP,
;SET UP FOR SUM CLAUSE
INTER. DA103.
DA103.: HRRZ TA,CURRPW ;PTR TO RPWTAB
LDB TB,RW.SCD ;SEEN SUM, ETC YET?
JUMPN TB,JCE16. ;YES, DUP. CLAUSE
LDB TC,RW.TYP ; [315] SUM CLAUSE ALLOWED
CAIE TC,%RG.CF ; [315] ONLY FOR CF
EWARNJ E.363 ; [315]- ERROR
HRRZI TB,%RG.SM ;NO, INDICATE ITEM HAS A SUM CLAUSE
DPB TB,RW.SCD
LDB TE,RW.DAT ;GET LINK TO CORRESP. DATAB ITEM
PUSH PP,TE ;SAVE
MOVE TA,[CD.HLD,,SZ.HLD] ;GET A HLDTAB ENTRY
PUSHJ PP,GETENT
HRRZI TB,%HL.SC ;SET "BUILD-SUM-CTR" CODE
DPB TB,HL.COD
POP PP,TE
DPB TE,HL.LNK ;& PUT IN LINK TO DATAB ITEM
HRRZ TC,RPTCID ; [415] GET LEVEL NUMBER
DPB TC,HL.CID## ; [415] STORE INTO HLDTAB
HRRZ TC,RPWRDL ; [415] GET RD LINK
DPB TC,HL.RD## ; [415] STORE INTO HLDTAB
POPJ PP,
;SET DEFAULTS FOR PAGE LIMIT CLAUSE
INTER. DA104.
DA104.: PUSHJ PP,GETRDL ;GET PTR TO RPWTAB GROUP ENTRY
LDB TB,RW.PHL ;GET PAGE HEADING LINE #
JUMPN TB,.+3 ;SET?
MOVEI TB,1 ;NO, MAKE IT 1
DPB TB,RW.PHL
LDB TC,RW.FDE ;GET FIRST DETAIL LINE #
JUMPN TC,.+3 ;SET?
MOVEI TC,(TB) ;NO, DEFAULT = PHL
DPB TC,RW.FDE
CAMLE TB,TC ;[215] HEADING .LE. FIRST DETAIL?
JRST JCE489 ;[215] NO IS AN ERROR
LDB TB,RW.PAG ;PAGE LIMIT
LDB TC,RW.LDE## ;LAST DETAIL
LDB TD,RW.CFL ;FOOTING
JUMPN TC,DA104A ;LDE SET?
JUMPN TD,.+2 ;NO, CFL SET?
MOVEI TD,(TB) ;NO, NEITHER SET. MAKE BOTH = PAGE LIMIT
MOVEI TC,(TD) ;MAKE LDE = CFL
JRST .+3
DA104A: JUMPN TD,DA104B ;LDE SET. IS CFL SET?
MOVEI TD,(TC) ;NO, MAKE CFL = LDE
DPB TC,RW.LDE ;STORE VALUES
DPB TD,RW.CFL
DA104B: CAMLE TC,TD ;[215] LDE .LE. CFL?
JRST JCE491 ;[215] NO - SO ERROR
LDB TB,RW.FDE ;[215]
CAMLE TB,TC ;[215] FDE .LE. LDE?
JRST JCE490 ;[215] NO - SO ERROR
POPJ PP,
>
;CK FOR MISSING PERIOD ON DATA ITEM
INTER. DA105.
DA105.: CAIE TYPE,INTGR.
CAIN TYPE,2000+INTGR.
JRST DA105B
CAIN TYPE,2000+FD. ;[1376] IS IT FD ?
JRST DA105A ;[1376] REGET WORD?
CAIE TYPE,2000+PROC.
CAIN TYPE,2000+WORKI.
JRST DA105A
CAIE TYPE,2000+REPOR.
CAIN TYPE,2000+LINKG.
DA105A: SWONS FREGWD;
EWARNJ E.18 ;IMPROPER CLAUSE
PUSHJ PP,CE125. ;PERIOD ASSUMED
JRST DA107. ;POP UP A LEVEL IN TREE
DA105B: HLRZ TB,W1 ;GET THE INTEGER
ANDI TB,177
MOVEM TB,CTR
HRRZI TA,LITVAL
PUSHJ PP,GETVAL##
CAIN TC,^D77
JRST DA105A
CAIL TC,1
CAILE TC,^D49
EWARNJ E.18 ;IMPROPER CLAUSE
;THIS TEST IS HERE BECAUSE ANS-68 COPY AT 01 LEVEL
;DIFFERS FROM ANS-74 IN THAT PERIOD IS ASSUMED
;IS THIS IS THE CASE THEN JUST IGNORE "PERIOD ASSUMED" ERROR
IFN ANS68,<
MOVE TC,LEVEL ;GET LEVEL OF PREVIOUS
CAIN TC,LVL.01 ;IF NOT 01
TSWT FRLIB ;AND CURRENTLY READING FROM LIBRARY
>
JRST DA105A ;THEN PERIOD ASSUMED ERROR
IFN ANS68,<
SWON FREGWD
JRST DA107. ;POP UP A LEVEL AND CONTINUE
>
;STORE CODE LINK
IFN RPW,<
INTER. DA106.
DA106.: LDB TA,[POINT 15,W2,15] ;NAMTAB LINK
HRRZI TB,CD.MNE
PUSHJ PP,FNDLNK
JFCL
PUSHJ PP,GETRDL ;GET PTR TO RD ENTRY
HLRZS TB
DPB TB,RW.COD##
POPJ PP,
>
;END OF DATA ITEM
;IF IN REPORT SECTION AND ITEM HAS NO NAME, GIVE IT ONE
INTER. DA107.
DA107.:
IFN RPW,<
SKIPE REPSEC ;IN REPORT SECTION?
PUSHJ PP,FAKNAM ;YES
>
JRST DA0. ;NOW POP UP A LEVEL IN TREE
SUBTTL TABLE HANDLING SYNTAX
;ASCENDING KEY FOR OCCURS
INTER. DA108.
DA108.: HRRZI TB,%HL.KY ;ASC. KEY CODE
DA108X: FLAGAT HI
MOVEM TB,TBLOCK ;SAVE CODE UNTIL NAME SEEN
POPJ PP,
;DESCENDING KEY FOR OCCURS
INTER. DA109.
DA109.: HRRZI TB,%HL.DY ;DESC. KEY CODE
JRST DA108X
;ASCENDING/DESCENDING KEY FOR OCCURS
INTER. DA110.
DA110.: PUSHJ PP,DA60S. ;SAVE NAMTAB ADDR
PUSHJ PP,DA25S. ;SET UP HLDTAB ENTRY
HRRZ TB,TBLOCK ;STORE KEY CODE
DPB TB,HL.COD
HRRZ TA,CURDAT## ;PTR TO DATAB ENTRY
LDB TB,DA.PWA ;PIC WORDS ALLOCATED?
JUMPN TB,DA110A ;YES
MOVE TA,[CD.DAT,,SZ.MSK] ;NO, DO IT
PUSHJ PP,GETENT
HRRZ TA,CURDAT
SETO TB, ;& SAY SO
DPB TB,DA.PWA
DA110A: LDB TB,DA.KEY## ;INCREMENT KEY CTR
ADDI TB,1
IFN ANS74,<
CAIG TB,377 ;[1346] UP TO 255 KEYS ALLOWED
JRST DA110C ;[1346]
MOVEI DW,E.745 ;[1346] ELSE QUANTITY GETS TRUNCATED
PUSHJ PP,FATALW ;[1346]
DA110C: ;[1346]
>;[1346]
DPB TB,DA.KEY
SOJE TB,DA110B ;[220] IS THIS THE MAJOR KEY?
LDB TB,[POINT 15,(TA),17] ;[220] NO, GET THE GROUP'S NAMTAB REL ADR.
HLRZ TC,CURNAM ;[220] GET THE CURRENT ITEM'S NAMTAB REL ADR.
CAIE TB,(TC) ;[220] ARE THEY THE SAME ITEM?
JRST DA110B ;[220] NO, NO PROBLEMS.
;[220] WE GET HERE IF WE HAVE A MINOR KEY WHICH IS ALSO THE SUBJECT OF THE OCCURS.
;[220] ERROR MESSAGE: FATAL - A GROUP ITEM MAY NOT BE A MINOR KEY
MOVEI DW,E.151 ;[220] SET UP ERROR NUMBER.
PUSHJ PP,FATALW ;[220] GO PUT IT IN THE ERROR FILE.
DA110B: ;[220]
MOVE TA,[CD.DAT,,1] ;GET A WORD ON DATAB ENTRY FOR KEY
PUSHJ PP,GETENT
HLRZ TB,TA ;SAVE DATAB ADDR
HLRZ TC,CURHLD
HRRZ TA,HLDLOC## ;MAKE ABS. PTR TO HLDTAB ENTRY
ADDI TA,(TC)
DPB TB,HL.LNK ;STORE DATAB PTR IN HLDTAB
POPJ PP,
;INITIALIZE LINKAGE SECTION
INTER. DA112.
DA112.: SETOM LNKSEC## ;SET LINKAGE SECTION FLAG
SETOM SUBPRG## ;THIS IS A SUBPROGRAM
MOVE TB,EAS1PC ;SAVE DATA PC WHILE DOING
MOVEM TB,PCHOLD ; LINKAGE SECTION
JRST DA3.0 ;REST IS LIKE WORKING-STORAGE
SUBTTL DBMS SYNTAX
;ACTIONS FOR INVOKE VERB
IFN DBMS,<
INTER. DA113.
DA113.: SKIPE SCHSEC## ;SCHEMA SECTION SEEN BEFORE
EWARNW E.408 ;YES, GIVE ERROR
FLAGAT DB
PUSHJ PP,DA119B ;[476] SEE IF ANY OTHER SECTIONS SEEN
SETOM SCHSEC
SETZM INVSEE## ;[%316]
SETZM ACCSEE## ;[%316]
SETZM DBCNTC## ;CLEAR COUNT OF "INVOKE"/ACCESS'S
POPJ PP, ;[%316] DELAY FUDGED SECTION SETTING TILL INVOKE OR ACCESS SEEN
INTER. DA114A
DA114A: MOVEM LN,INVLN## ;SAVE LN AND CP FOR INVOKE
MOVEM CP,INVCP##
SKIPE DBCNTC## ;[%316] ERROR IF NON-0, DELAY MSG
POPJ PP, ;[%316]
SETOM INVSEE##
PUSHJ PP,DA10. ;[%316] DOWN FROM DA113--PRETEND THAT IT'S A W-S SECTION
JRST DA3. ;[%316] DITTO
INTER. DA114B
;[%316] DA114B NEW--FOR ACCESS. NOTE 114. MADE 114A FOR SYMMET.
DA114B: MOVEM LN,INVLN## ;SAVE LN AND CP FOR INVOKE
MOVEM CP,INVCP##
SKIPE DBCNTC## ;[%316] ERROR IF NON-0, DELAY MSG
POPJ PP, ;[%316]
SETOM ACCSEE##
PUSHJ PP,DA10. ;[%316] PRETEND THAT IT'S A LINKAGE SECTION
JRST DA112. ;[%316] DITTO
INTER. DA115.
DA115.: MOVE TA,[NAMWRD,,S.SCH##] ;[%316] MAKE IT HANDLE 30-CHARACTER SUBSCHEMAS
BLT TA,S.SCH##+4 ;[%316]30 SIXBIT CHARS IN 5 WORDS
POPJ PP, ;[%316]PASS THRU FOR COMPAT WITH PREPRO
INTER. DA116.
DA116.: MOVE TA,NAMWRD
MOVEM TA,SCHEMA##
POPJ PP, ;[%316]PASS THRU FOR COMPAT WITH PREPRO
INTER. DA116A
DA116A: PUSHJ PP,FIXPPN ;GET 1ST PART OF PPN
HRLM TA,DB.PPN## ;STORE IN LH OF PPN WORD
POPJ PP,
INTER. DA116B
DA116B: PUSHJ PP,FIXPPN ;GET PROGRAMMER NUMBER
HRRM TA,DB.PPN ;STORE IN RH OF PPN WORD
POPJ PP,
;THIS SUBROUTINE CONVERTS THE SIXBIT PPN INTEGER IN LITVAL
;INTO A BINARY NUMBER IN THE RH OF TA.
FIXPPN: HLRZ TB,W1 ;GET LENGTH
ANDI TB,777 ;ISOLATE IT
TLNE W1,GWNLIT ;NUMERIC LITERAL?
TLNE W1,GWDP ;DECIMAL POINT?
EWARNJ E.336
CAILE TB,6 ;6 DIGITS?
EWARNJ E.336
SETZ TA, ;CLEAR TOTAL
MOVE TD,[POINT 7,LITVAL]
FIXLUP: SOJL TB,CPOPJ ;EXIT IF COUNT EXHAUTED
ILDB TC,TD ;GET DIGIT
CAIL TC,"0"
CAILE TC,"7"
EWARNJ E.336 ;NOT OCTAL DIGIT
SUBI TC,"0"
LSH TA,3 ;MOVE TOTAL LEFT
ADD TA,TC ;ADD DIGIT TO TOTAL
JRST FIXLUP
INTER. DA117.
DA117.: MOVE TA,NAMWRD
MOVEM TA,PKEY##
POPJ PP, ;[%316]PASS THRU FOR COMPAT WITH PREPRO
;THIS ACTION SETS UP THE WORLD FOR GETITM TO CONTINUE READING
;FROM THE NEW ###DBC.TMP FILE.
INTER. DA119.
DA119.: AOS TA,DBCNTC ;BUMP COUNT OF "INVOKE"'S
CAILE TA,1 ;[%316]NEW RULE IS AT MOST ONE INV. PER P-U
JRST E.MXIN
PUSHJ PP,DDL.## ;CREATE DDL FILES
CALLI TC,$PJOB ;GET JOB NUMBR
MOVEI TD,3
IDIVI TC,^D10
ADDI TB,"0"-40
LSHC TB,-6
SOJG TD,.-3 ;LH OF TA HAS # IN DECIMAL
HRRI TA,'DBC' ;GET REST OF FILENAME
MOVEM TA,DBBLCK##
HRLZI TA,'TMP' ;GET EXTENSION
MOVEM TA,DBBLCK+1
SETZM DBBLCK+2
SETZM DBBLCK+3
SETZM DBOPBK## ;SET MODE TO ASCII
MOVSI TA,'DSK'
MOVEM TA,DBOPBK+1 ;PUT DEVICE NAME IN
HRRZI TA,DBBUFH##
MOVEM TA,DBOPBK+2 ;PUT BUFFER HEADER ADDR IN
MOVE TA,[POINT 7,DBUFF1+3]
MOVEM TA,DBBUFH+1
MOVE TA,[XWD 201,DBUFF1+1]
MOVEM TA,DBUFF1+1
OPEN DBCHAN,DBOPBK ;TRY AN OPEN
JRST OPNERR
MOVE TA,[XWD 400000,DBUFF1##+1]
MOVEM TA,DBBUFH
LOOKUP DBCHAN,DBBLCK ;IS FILE THERE?
JRST NOTFND
IN DBCHAN, ;GET A BUFFER
TRNA ;OK
JRST INPERR
IFN FT68274,< ;[1413]
PUSHJ PP,CVTOAL## ;[1413] WRITE OUT PREVIOUS BUFFER
PUSHJ PP,CVTDPL## ;[1413] AND CURRENT BUFFER
SETZM CVTPLF## ;[1413] PREVIOUS LINE IS NO LONGER NEEDED
> ;[1413]
SETOM FINVOK## ;SET INVOKE FLAG
SETOM FINVD## ;TELL COBOLD TO READ FILE.
TSWFZ FSEQ ;[453] IS /S SWITCH ON--IF YES TURN IT OFF
SETOM DBONLY## ;[453] IT WAS ON, REMEMBER IT
POPJ PP,
E.MXIN: OUTSTR [ASCIZ /?CBLTMI--too many "INVOKES" specified
/]
JRST ALLERR
OPNERR: OUTSTR [ASCIZ /?FATAL--OPEN/]
ALLERR: OUTSTR [ASCIZ / error on file /]
SETZ TA,
MOVEI TE,3
MOVE TD,[POINT 7,TA]
MOVE TC,[POINT 6,DBBLCK]
ALL2: ILDB TB,TC
ADDI TB,40
IDPB TB,TD
SOJG TE,ALL2
OUTSTR TA
OUTSTR [ASCIZ /DBC.TMP
?Cannot continue
/]
CALLI $EXIT
NOTFND: OUTSTR [ASCIZ "?FATAL--LOOKUP"]
JRST ALLERR
INPERR: MOVE TA,PKEY ;[513] GET PRIVACY KEY
AOJE TA,[EWARNJ E.429] ;[513] PRIV KEY OF -1 = BAD KEY
OUTSTR [ASCIZ /?FATAL--INPUT/]
JRST ALLERR
DA119A: SKIPE SCHSEC## ;[476] SCHEMA SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
DA119B:
IFN MCS!TCS,<
SKIPN CSSEEN## ;[476] COMM. SECTION SEEN?
>
DA119C: SKIPE WRKSEC## ;[476] WORKING-STORAGE SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
SKIPGE LNKSSN## ;[763] [476] LINKAGE SECTION SEEN ?
SKIPGE ACCSEE## ;[476] ACCESS VERB USED?
SKIPE REPSSN## ;[763] [476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
POPJ PP, ;[476] OK, RETURN
>
SUBTTL MCS/TCS SYNTAX
IFN MCS!TCS,<
INTER. DA120.
DA120.: SKIPE CSSEEN## ;COMM SEC SEEN?
EWARNJ E.432
SETOM CSSEEN
FLAGAT HI
IFN ANS68,<
IFN DBMS,< ;[507]
PUSHJ PP,DA119C ;[476] CHECK FOR PROPER SEQUENCE
>> ;[507]
IFN ANS74,< ;THE ORDERING IS DIFFERENT IN -74
IFN RPW,<
SKIPE REPSSN ;COMM SECTION IS LAST EXCEPT FOR REPORT SECTION
EWARNJ E.470
>>
SETOM LSTW77## ;[476] CLEAR IN CASE WORKING-STORAGE SEEN
SWOFF FFILSC
IFN RPW,<SETZM REPSEC>
SETZM LNKSEC
IFN DBMS,< ;[503]
SKIPE INVSEE## ;[412] IF INVOKE SEEN,W-S SEC STUFF DONE
POPJ PP, ;[412] DON'T DO IT AGAIN
> ;[503]
SKIPL TA,PCHOLD
MOVEM TA,EAS1PC
SETOM PCHOLD
SKIPE WRKSEC ;HAVE WE SEEN WORK-SEC?
POPJ PP, ;YES, DON'T DO ANYTHING
PUSHJ PP,DA10. ;NO, PRETEND THIS IS IT
JRST DA3.
INTER. DA121.
DA121.: TLO W2,GWDEF
PUSHJ PP,PUTCRF ;PUT OUT CREF LISTING
PUSHJ PP,TRYNAM ;CD-NAME IN NAMTAB?
PUSHJ PP,BLDNAM ;PUT IT IN
MOVEM TA,CURNAM
HLRZS TA
DPB TA,[POINT 15,W2,15] ;SET UP W2
MOVE TA,[XWD CD.CD,SZ.CD] ;GET CDTAB CODE AND SIZE
PUSHJ PP,GETENT
MOVEM TA,CURCD##
LDB TB,[POINT 15,W2,15]
CLEARM (TA) ;CLEAR 1ST WORD
DPB TB,CD.NAM## ;PUT IN NMTAB LINK
LDB TB,[POINT 20,W2,35] ;GET LN,CP
MOVEM TB,1(TA)
HLR TA,CURNAM
PJRST PUTLNK ;SET SAME-NAME CHAIN
INTER. DA122.
DA122.: MOVE TA,CURCD
SKIPE FINITL## ;HAVE WE SEEN INITIAL BEFORE?
EWARNJ E.446 ;YES, BOOBOO
MOVEM TA,FINITL ;SAVE ADDR OF INITIAL ENTRY
MOVEI TB,1
DPB TB,CD.INT## ;THIS ALSO CLEARS INPUT BIT
POPJ PP,
INTER. DA123.
DA123.: MOVEI TA,CDBLK##
HRLI TA,^D-11 ;SET UP TO CLEAR CDBLK
CLEARM (TA)
AOBJN TA,.-1
CLEARM CDINDX## ;CLEAR INDEX TOO
POPJ PP,
INTER. DA124B ;[1436]
DA124B: ;[1436]
IFN FT68274,<
MOVEI TA,[ASCIZ /DEPTH/]
MOVEI TB,[ASCIZ /COUNT/]
PUSHJ PP,CVTRCW## ;REPLACE DEPTH BY COUNT
SKPNAM ;[1436]
>
INTER. DA124. ;[1436]
DA124.: HRRZI TA,^D10 ;[1436]
SAVIDX: MOVEM TA,CDINDX ;SAVE CDBLK INDEX
POPJ PP,
IFN FT68274,<
INTER. DA124A
DA124A: MOVEI TA,[ASCIZ /QUEUE/]
MOVEI TB,[ASCIZ /MESSAGE/]
JRST CVTRCW ;REPLACE QUEUE BY MESSAGE
>
INTER. DA125.
DA125.: CLEARM CDINDX
JRST DA7. ;REGET WORD
INTER. DA126.
DA126.: CLEARM CDINDX
POPJ PP,
INTER. DA127.
DA127.: HRRZI TA,1
JRST SAVIDX
INTER. DA128.
DA128.: HRRZI TA,2
JRST SAVIDX
INTER. DA129.
DA129.: HRRZI TA,3
JRST SAVIDX
INTER. DA130.
DA130.: HRRZI TA,6
JRST SAVIDX
INTER. DA131.
DA131.: HRRZI TA,4
JRST SAVIDX
INTER. DA132.
DA132.: HRRZI TA,5
JRST SAVIDX
INTER. DA133.
DA133.: HRRZI TA,7
JRST SAVIDX
INTER. DA134.
DA134.: HRRZI TA,^D8
JRST SAVIDX
INTER. DA135.
DA135.: HRRZI TA,^D9
JRST SAVIDX
INTER. DA136.
DA136.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
MOVEI TB,CDBLK##
ADD TB,CDINDX
HLRZ TA,TA ;GET REL. ADDR
SKIPE (TB) ;ENTRY ALREADY GIVEN?
EWARNW E.447 ;YES
DPB TA,[POINT 15,W2,15]
MOVEM W2,(TB) ;PUT INTO CDBLK
POPJ PP,
INTER. DA137.
DA137.: MOVE TA,CDINDX
CAIL TA,^D12 ;12 DATA-NAMES?
EWARNJ E.434 ;YES
PUSHJ PP,DA136.
AOS CDINDX ;BUMP INDEX
POPJ PP,
INTER. DA138.
DA138.: HRRZ TA,CURCD
MOVEI TB,1
DPB TB,CD.OUT##
MOVEI TA,CDBLK
HRLI TA,^D-11 ;SET UP TO CLEAR CDBLK
CLEARM (TA)
AOBJN TA,.-1
POPJ PP,
;MACRO TO DISTINGUISH BETWEEN INPUT OR OUTPUT CD:
DEFINE IFINP(.A)
<HRRZ TC,CURCD
SKIPL 1(TC)
JRST .A>
INTER. DA139.
DA139.: MOVEI TA,1 ;DA26.
MOVEM TA,DATLVL
MOVEM TA,LEVEL
SETZM RUSAGE ;---
IFN ANS74,<
PUSH PP,FLGSW ;SAVE FIPS FLAGGING BITS
SETZM FLGSW ;IGNORE POSSIBLE FLAGGER ERRORS
>
MOVE TA,[SIXBIT /FILLER/]
MOVEM TA,NAMWRD
CLEARM NAMWRD+1
TLO W2,GWDEF ;MAKE IT DEFINED
MOVEI CT,FILLE. ;MAKE IT "FILLER"
PUSHJ PP,DA27A ;DA27A
MOVE TA,CURDAT
HLRZ TD,CURCD
DPB TD,DA.POP## ;SET FATHER LINK
SETO TD,
DPB TD,DA.FAL ;SET FATHER BIT
CLEAR TD,
DPB TD,DA.CLA## ;CLASS
MOVE TA,CURDAT ;REPLACE TA
MOVEI TD,2
DPB TD,DA.USG ;USAGE
PUSHJ PP,DA30N. ;DA30N
MOVEI TE,CDBLK ;TE==CDBLK PTR
HRRZ TB,CURCD
ADDI TB,2 ;TB==CDTAB + 2
LDB TD,[POINT 7,-1(TB),35] ;SET UP LN,CP
DPB TD,DA.CP
LDB TD,[POINT 13,-1(TB),28]
DPB TD,DA.LN
TLO TB,442200 ;MAKE IT A XWD BYTE PTR
HLRZ TD,CURDAT
IDPB TD,TB ;PUT IN CD LINK
IFINP DA139A
ADDI TB,2 ;BUMP CDTAB PTR BY 5 XWD'S
IBP TB
ADDI TE,3 ;BUMP CDBLK PTR BY 3
DA139A: IFINP D139AA
CAIE TE,CDBLK+8 ;IF THIS IS ENTRY 8 OR 9...
CAIN TE,CDBLK+9
SKIPA TD,[3] ;...THEN MAKE IT LEVEL 3
D139AA: MOVEI TD,2 ;DA11.
MOVEM TD,(SAVPTR)
PUSHJ PP,PUSHEM
PUSHJ PP,DA28. ;DA28.
PUSHJ PP,POPEM
IFINP D139AB
CAIN TE,CDBLK+6 ;IF ENTRY 6, GO BUILD SPECIAL ENTRY
JRST D139OC
D139AB: MOVEI CT,USERN.
SKIPE W2,(TE) ;GET CDBLK ENTRY
JRST DA139B ;OK, WE HAVE ONE
MOVE TD,[SIXBIT /FILLER/]
MOVEM TD,NAMWRD
CLEARM NAMWRD+1
MOVEI CT,FILLE. ;MARK TYPE AS FILLER SO WE DON'T CREF IT
PUSHJ PP,PUSHEM
PUSHJ PP,TRYNAM ;IN NAMTAB? (IT SHOULD BE)
PUSHJ PP,BLDNAM
PUSHJ PP,POPEM
HLRZS TA ;GET REL. ADDR
HRRZ TD,CURCD
LDB TD,[POINT 20,1(TD),35] ;GET LN,CP
DPB TD,[POINT 20,(TE),35] ;PUT INTO CDBLK
DPB TA,[POINT 15,W2,15] ;SET NAMTAB LINK
DA139B: HLRZ W1,CURCD
PUSHJ PP,PUSHEM
PUSHJ PP,DA29. ;DA29.
MOVE TE,0(PP) ;RECOVER TE
IFINP DA139C
CAIN TE,CDBLK+3 ;IF ENTRY 3, SET DEFAULT VALUE
SKIPE CDBLK+6 ;IF DESTINATION TABLE IS ZERO
JRST DA139C
MOVE TA,[CD.LIT,,SZ.LIT]
PUSHJ PP,GETENT ;GET SPACE FOR DEFAULT VALUE
MOVSI TB,1201
MOVEM TB,0(TA) ;STORE BITS
MOVSI TB,(ASCII/1/)
MOVEM TB,1(TA) ;STORE VALUE
HLRZ TB,TA ;GET REL LOCATION
HRRZ TA,CURDAT
DPB TB,DA.VAL ;STORE VALTAB LINK
DA139C: PUSHJ PP,DA30N. ;DA30N
PUSHJ PP,POPEM
HLRZ TA,CURDAT ;GET REL ADDR
IDPB TA,TB ;PUT INTO CDTAB
HRR TA,CURDAT ;GET ABS ADDR
IFINP .+3
MOVEI TD,OUTPIC-3(TE) ;SET UP WITH OUTPUT PIC TABLE
SKIPA
MOVEI TD,INPIC(TE)
SUBI TD,CDBLK ;THIS GIVES ADDRESS IN INPIC
MOVE TD,(TD) ;GET INPIC ENTRY
DPB TD,DA.EXS ;EXTERNAL SIZE
DPB TD,DA.INS ;INTERNAL SIZE
SKIPL TD ;NUMERIC?
TDZA TC,TC ;NO, ALPHANUMERIC
MOVEI TC,2
DPB TC,DA.CLA ;SET CLASS
MOVEI TC,2 ;DISPLAY-7
DPB TC,DA.USG
LSH TC,-1 ;MAKE IT A "1"
DPB TC,DA.PIC ;PIC SEEN
LDB TC,[POINT 13,(TE),28] ;LN
DPB TC,DA.LN
LDB TC,[POINT 6,(TE),35] ;CP
DPB TC,DA.CP
AOS TE ;BUMP CDBLK PTR
CAIGE TE,CDBLK+^D11 ;THRU CDBLK?
JRST DA139A ;NO
IFN ANS74,<
POP PP,FLGSW ;TURN ON FLAGGER AGAIN
>
JRST DA8. ;********EXIT*********
D139OC: MOVE TA,[SIXBIT /FILLER/]
MOVEM TA,NAMWRD
CLEARM NAMWRD+1
PUSHJ PP,PUSHEM
PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZS TA ;GET REL ADDR.
DPB TA,[POINT 15,W2,15]
MOVEI CT,FILLE.
HLRZ W1,CURCD ;AND TABLE LINK
PUSHJ PP,DA29.
PUSHJ PP,DA30N. ;BUILD FILLER
PUSHJ PP,POPEM
HRRZ TA,HLDSAV## ;GET SAVED HLDTAB ENTRY
JUMPE TA,D13902
HLRZ TD,CURDAT ;GET CURRENT DATAB PTR
HLRZ TC,CDBLK+7 ;GET COUNTER
DPB TD,HL.LNK ;PUT DATAB LINK IN HLDTAB
ADDI TA,2
SOJG TC,.-2
SETZM HLDSAV ;CLEAR IT
D13902: HRRZ TC,CURCD
LDB TD,[POINT 13,1(TC),28]
HRR TA,CURDAT
DPB TD,DA.LN ;FIX LN,CP
LDB TD,[POINT 6,1(TC),35]
DPB TD,DA.CP
MOVE TC,(TE) ;GET # OF OCCURANCES
ADDI TE,2 ;BUMP CDBLK PTR TO WORD 8
JUMPE TC,DA139A ;IF NO OCCUR.,DON'T DO ANY MORE
MOVEM TC,(SAVPTR)
PUSHJ PP,PUSHEM
PUSHJ PP,D33MCS ;FIX DATAB ENTRY
PUSHJ PP,POPEM
MOVE TA,CURDAT ;GET LEVEL 2 DATAB LINK
HRRZ TC,CDBLK+7 ;GET INDEX POINTER
SKIPE TC ;NO INDEXED BY PHRASE
DPB TC,DA.XBY## ;PUT "INDXD BY" IN DATAB
JRST DA139A
INTER. DA140.
DA140.: PUSHJ PP,DA11. ;GET INTEGER VALUE
JUMPLE TC,JCE25. ;VALUE MUST BE BETWEEN 1 AND 50
CAILE TC,^D50
; CAIE TC,1 ;ONLY 1 ALLOWED
EWARNW E.445
MOVEM TC,CDBLK+6
POPJ PP,
INTER. DA141.
DA141.: SETOM COMSEC## ;SET COMM. SECTION ACTIVE
PUSHJ PP,DA34.
CLEARM COMSEC ;THIS IS ONLY PLACE WE NEED IT
HLRZ TA,CDBLK+7 ;GET INDEX COUNT
AOS TA ;BUMP IT
HRLM TA,CDBLK+7
CAIE TA,1 ;IS THIS THE FIRST ONE?
POPJ PP,
HLRZ TA,CURHLD ;YES, SAVE HLDTAB LINK
HRRM TA,CDBLK+7
MOVE TB,CURHLD
MOVEM TB,HLDSAV## ;SAVE 1ST HLDTAB ENTRY PTR
POPJ PP,
INTER. DA142.
DA142.: SWON FREGWD
JRST DA135.
INTER. DA143.
DA143.: SETOM COMSEC ;SET COMM.SECTION ACTIVE
JRST DA7.
INTER. DA144.
DA144.: CLEARM COMSEC ;CLEAR COMM. SECTION ACTIVE
POPJ PP,
PUSHEM: POP PP,TD
PUSH PP,TB
PUSH PP,TE
JRST (TD)
POPEM: POP PP,TD
POP PP,TE
POP PP,TB
JRST (TD)
;THIS IS A TABLE INDICATING THE DATA TYPE AND LENGTH OF EACH
;ENTRY IN THE CDBLK. THE RIGHT HALF IS THE LENGTH AND BIT 0
;IS THE CLASS----0=ALPHANUMERIC
; 1=NUMERIC
NUMERIC==400000
INPIC: XWD 0,^D12
XWD 0,^D12
XWD 0,^D12
XWD 0,^D12
XWD NUMERIC,6
XWD NUMERIC,^D8
XWD 0,^D12
XWD NUMERIC,4
XWD 0,1
XWD 0,2
XWD NUMERIC,6
;SAME TABLE FOR OUTPUT PICS (1ST 3 ENTRIES OF CDBLK DON'T HAVE ENTRIES
;IN THIS TABLE.
OUTPIC: XWD NUMERIC,4
XWD NUMERIC,4
XWD 0,2
Z ;DUMMY ENTRY
Z
XWD 0,1
XWD 0,^D12
IFE TOPS20,<
XWD 0,^D8 ;MCS-10 EXTENSION
>
IFN TOPS20,<
XWD 0,^D12 ;TCS-20 EXTENSION
>
>;END IFN MCS!TCS
SUBTTL RECORDING MODE CLAUSE.
; ASCII
INTER. DA145.
DA145.: HRRZI TB, %RM.7B
JRST DA150D
; STANDARD-ASCII
INTER. DA146.
DA146.: HRRZI TB, %RM.SA
JRST DA150D
; SIXBIT
INTER. DA147.
DA147.: HRRZI TB, %RM.6B
JRST DA150D
; BINARY
INTER. DA148.
DA148.: HRRZI TB, %RM.BN
JRST DA150D
; F, V OR ERROR.
INTER. DA149.
DA149.: HLRZ TC, NAMWRD## ;SEE WHAT WE GOT.
CAIE TC, (SIXBIT /F/) ;WAS IT F OR
CAIN TC, (SIXBIT /V/) ; V?
SWOFFS FREGWD; ;YES, DON'T REGET IT.
EWARNJ E.578 ;NO, GO COMPLAIN.
HRRZ TA, CURFIL## ;GET THE FILE TABLE ADDRESS.
LDB TB, FI.RM2## ;DO WE ALREADY HAVE A RM?
JUMPN TB, JCE16. ;IF WE DO, GO COMPLAIN.
SETOI TB, ;GET SOME ONES.
CAIN TC, (SIXBIT /V/) ;VARIABLE LENGTH?
DPB TB, FI.VLR## ;YES, TURN ON THE VLR FLAG.
HRRZI TB, %RM.EB ;MAKE IT EBCDIC.
;SET THE RECORDING MODE.
DA150D: HRRZ TA, CURFIL## ;GET THE FILE TABLE'S ADDRESS.
LDB TC, FI.RM2## ;IF WE ALREADY HAVE A RM
JUMPN TC, DA150C ; MAKE SURE ITS THE SAME OR ELSECOMPLAIN.
DPB TB, FI.ERM## ;SET IT.
SETO TB, ;NOTE THAT WE HAVE ONE.
DPB TB, FI.RM2##
POPJ PP, ;RETURN.
DA150C: LDB TC,FI.ERM ;GET CURRENT RECORDING MODE
CAME TC,TB ;SAME AS WHAT WE WANT?
JCE16.: EWARNJ E.16 ;NO, DUPLICATE CLAUSE
POPJ PP, ;YES, ALLOW IT
;SET THE BYTE MODE.
INTER. DA150B
DA150B: HRRZ TA,CURFIL## ;GET THE FILE TABLE'S ADDRESS.
SETO TB,
DPB TB,FI.BM## ;SET BYTE MODE
POPJ PP, ;RETURN.
SUBTTL COBOL-74 SYNTAX
IFN ANS74,<
;SET LINAGE SEEN IN FILE TABLE
INTER. DA200.
DA200.: FLAGAT HI
HRRZ TA,CURFIL
SETO TB,
DPB TB,FI.LCP## ;SET LINAGE COUNTER REQUIRED
POPJ PP,
DA200V: TLNN W1,GWNLIT ;IS ITEM NUMERIC LITERAL?
JRST DA200Z ;NO
TLNE W1,GWDP ;IS IT INTEGER?
JRST DA200Z ;NO
HLRZ TB,W1
ANDI TB,177 ;NO. OF CHARACTERS
MOVEM TB,CTR##
HRRZI TA,LITVAL##
PJRST GETVAL
DA200Z: EWARNW E.25
SETZ TC,
POPJ PP,
;STORE LINES PER PAGE
INTER. DA201.
DA201.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA202A
INTER. DA202.
DA202.: PUSHJ PP,DA200V ;GET VALUE
DA202A: HRRZ TA,CURFIL
DPB TC,FI.LPP## ;STORE NO. OF LINES PER PAGE
POPJ PP,
;STORE FOOTING AT
INTER. DA203.
DA203.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA204A
INTER. DA204.
DA204.: PUSHJ PP,DA200V ;GET VALUE
DA204A: HRRZ TA,CURFIL
DPB TC,FI.WFA## ;STORE WITH FOOTING AT LINE NUMBER
POPJ PP,
;STORE LINES AT TOP
INTER. DA205.
DA205.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA206A
INTER. DA206.
DA206.: PUSHJ PP,DA200V ;GET VALUE
DA206A: HRRZ TA,CURFIL
DPB TC,FI.LAT## ;STORE NO. OF LINES AT TOP
POPJ PP,
;STORE LINES AT BOTTOM
INTER. DA207.
DA207.: PUSHJ PP,TRYNAM
PUSHJ PP,BLDNAM
HLRZ TC,TA ;GET POINTER
TRO TC,(1B0) ;SIGNAL NAME NOT VALUE
JRST DA208A
INTER. DA208.
DA208.: PUSHJ PP,DA200V ;GET VALUE
DA208A: HRRZ TA,CURFIL
DPB TC,FI.LAB## ;STORE NO. OF LINES AT BOTTOM
POPJ PP,
;DEBUG-ITEM
DA210.: MOVE TB,[SIXBIT /DEBUG:/]
MOVEM TB,NAMWRD
MOVE TB,[SIXBIT /ITEM/]
MOVEM TB,NAMWRD+1
SETZM NAMWRD+2
MOVE TA,[NAMWRD+2,,NAMWRD+3]
BLT TA,NAMWRD+5 ;CLEAR REST OF NAMWRD
PUSHJ PP,TRYNAM ;SEE IF NAME ALREADY EXISTS
TRNA ;NO
EWARNJ E.731 ;YES, ERROR
PUSH PP,EAS1PC ;SAVE CURRENT LOCATION FOR DEBUG-CONTENTS-INDEX
AOS EAS1PC ;ALLOW 1 WORD FOR IT
PUSHJ PP,DA211. ;PUT ENTRY IN DATAB
HLRZM TA,DEBSW ;SAVE LINK TO DEBUG-ITEM
PUSH PP,DEBSW ;SAVE TABLE LINK
MOVE TB,[44,,^D90]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
LDB TB,DA.BRO
DPB TB,DA.SON ;MAKE THE BROTHER BE THE SON
SETZ TB,
DPB TB,DA.BRO
DPB TB,DA.SLL ;SET SINC AT LOWER LEVEL FOR DEBUG-CONTENTS
MOVEI TB,%CL.AN ;ALPHANUMERIC
DPB TB,DA.CLA
MOVE TB,[SIXBIT /LINE/]
PUSHJ PP,DA212. ;PUT DEBUG-LINE IN SYMBOL TABLE
MOVE TB,[44,,6]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
PUSHJ PP,DA214. ;SET ALPHANUMERIC CLASS AND PIC SEEN.
AOS EAS1PC
MOVE TB,[SIXBIT /NAME/]
PUSHJ PP,DA212. ;PUT DEBUG-NAME IN SYMBOL TABLE
PUSHJ PP,DA214. ;SET ALPHANUMERIC CLASS AND PIC SEEN.
MOVE TB,[36,,^D30]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
MOVEI TB,5
ADDM TB,EAS1PC
MOVE TB,[SIXBIT /SUB:1/]
PUSHJ PP,DA212. ;PUT DEBUG-SUB-1 IN SYMBOL TABLE
PUSHJ PP,DA213. ;SET SIZE AND VARIOUS FLAGS
AOS EAS1PC
MOVE TB,[SIXBIT /SUB:2/]
PUSHJ PP,DA212. ;PUT DEBUG-SUB-2 IN SYMBOL TABLE
PUSHJ PP,DA213. ;SET SIZE AND VARIOUS FLAGS
AOS EAS1PC
MOVE TB,[SIXBIT /SUB:3/]
PUSHJ PP,DA212. ;PUT DEBUG-SUB-3 IN SYMBOL TABLE
PUSHJ PP,DA213. ;SET SIZE AND VARIOUS FLAGS
AOS EAS1PC
AOS EAS1PC ;SYNCHRONIZE LEFT (I.E. WASTE 5 BYTES)
MOVSI TB,'TS '
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /CONTEN/]
PUSHJ PP,DA212. ;PUT DEBUG-CONTENTS IN SYMBOL TABLE
MOVE TB,[44,,^D30]
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
PUSHJ PP,DA214. ;SET ALPHANUMERIC CLASS AND PIC SEEN.
PUSHJ PP,DA216A ;SET VARIOUS BITS
;NOW DEFINE THE VARIOUS REDEFINITIONS OF DEBUG-CONTENTS
MOVE TB,[SIXBIT /TS:DIS/]
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /PLAY:6/]
MOVEM TB,NAMWRD+3
PUSHJ PP,DA211.
MOVE TB,[44,,^D30]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
PUSHJ PP,DA216A ;SET VARIOUS BITS
AOS NAMWRD+3 ;DEBUG-CONTENTS-DISPLAY-7
PUSHJ PP,DA211.
MOVE TB,[44,,^D25]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.D7
PUSHJ PP,DA216. ;SET VARIOUS BITS
MOVEI TB,2 ;DEBUG-CONTENTS-DISPLAY-9
ADDM TB,NAMWRD+3
PUSHJ PP,DA211.
MOVE TB,[44,,^D20]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.EB
PUSHJ PP,DA216. ;SET VARIOUS BITS
MOVE TB,[SIXBIT /TS:1:W/]
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /ORD:CO/]
MOVEM TB,NAMWRD+3
MOVSI TB,'MP '
MOVEM TB,NAMWRD+4
PUSHJ PP,DA211. ;DEBUG-CONTENTS-1-WORD-COMP
MOVE TB,[44,,^D10]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.1C
PUSHJ PP,DA217. ;SET VARIOUS BITS
MOVEI TB,'2:W'
HRRM TB,NAMWRD+2 ;DEBUG-CONTENTS-2-WORD-COMP
PUSHJ PP,DA211.
MOVE TB,[44,,^D18]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.2C
PUSHJ PP,DA217. ;SET VARIOUS BITS
MOVEI TB,'COM'
HRRM TB,NAMWRD+2
MOVSI TB,'P:3'
MOVEM TB,NAMWRD+3 ;DEBUG-CONTENTS-COMP-3
PUSHJ PP,DA211.
MOVE TB,[44,,^D18]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
MOVEI TB,%US.C3
PUSHJ PP,DA217. ;SET VARIOUS BITS
;NOW GENERATE DEBUG-CONTENTS-INDEX
;NOTE THIS IS NOT PART OF DEBUG-ITEM
;AND IS AT DEBUG-ITEM MINUS 1
;FIRST ACCOUNT FOR LARGEST FILE DATA RECORD WE HAVE SEEN
MOVE TB,MAXDBC ;GET MAX RECORD
SUBI TB,^D30/6 ;SIZE WE WOULD LIKE TO USE
SKIPLE TB ;IGNORE IF WE HAVE ENOUGH
ADDM TB,EAS1PC ;OTHERWISE USE EXTRA
MOVEI TB,^D10 ;ACCOUNT FOR INITIAL SIZE OF DEBUG-CONTENTS
ADDB TB,EAS1PC
EXCH TB,-1(PP) ;SWAP WITH ORIGINAL EAS1PC
MOVEM TB,EAS1PC ;FROM BEFORE DEBUG-ITEM
MOVE TB,[SIXBIT /TS:IND/]
MOVEM TB,NAMWRD+2
MOVSI TB,'EX '
MOVEM TB,NAMWRD+3 ;DEBUG-CONTENTS-INDEX
SETZM NAMWRD+4
PUSHJ PP,DA211.
MOVE TB,[44,,5]
PUSHJ PP,DA215.
PUSHJ PP,DA214.
POP PP,TB ;GET FATHER LINK
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.SYR ;SET SYNCHRONIZED RIGHT
MOVEI TB,%US.IN
DPB TB,DA.USG ;RESET USAGE
POP PP,EAS1PC ;RESTORE LOCATION COUNTER
POPJ PP,
DA212.: MOVEM TB,NAMWRD+1 ;FINISH OFF NAME
DA211.: MOVEI TB,LVL.01 ;PRETEND ITS LEVEL 01
MOVEM TB,(SAVPTR)
SETZB W1,W2 ;CLEAR THE FLAGS
MOVEI TYPE,USERN. ;ITEM IS A USER-NAME
PUSHJ PP,DA26N.
PUSHJ PP,DA27. ;CREATE DATAB ENTRY
MOVE TA,CURDAT ;POINT TO DATAB
HLRZ TB,TA ;GET TABLE ENTRY
ADDI TB,7 ;ADVANCE TO NEXT ITEM
DPB TB,DA.BRO ;SINCE IT WILL BE BROTHER EVENTUALLY
POPJ PP,
DA213.: MOVE TB,[30,,5] ;BYTE OFFSET ,, SIZE
PUSHJ PP,DA215. ;SET SIZE, BYTE RESIDUE AND BASE ADDRESS
MOVEI TB,%CL.NU ;NUMERIC
DPB TB,DA.CLA
SETO TB,
DPB TB,DA.SGN ;SIGNED
DPB TB,DA.SSC ;SEPARATE SIGN CHAR.
DPB TB,DA.LSC ;LEADING SIGN CHAR.
JRST DA214A
DA214.: MOVEI TB,%CL.AN ;ALPHANUMERIC
DPB TB,DA.CLA
DA214A: SETO TB,
DPB TB,DA.PIC ;INDICATE PICTURE SEEN
MOVEI TB,02
DPB TB,DA.LVL ;RESET THE LEVEL TO 02
POPJ PP,
DA215.: DPB TB,DA.EXS ;EXTERNAL
DPB TB,DA.INS ;INTERNAL
HLRZ TB,TB
DPB TB,DA.RES ;BYTE RESIDUE
MOVE TB,EAS1PC ;GET BASE
DPB TB,DA.LOC ;STORE IT
MOVEI TB,%US.D6 ;DISPLAY-6
DPB TB,DA.USG
POPJ PP,
DA216.: DPB TB,DA.USG ;RESET USAGE
DA216A: MOVE TB,-1(PP) ;GET FATHER LINK
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.SYL ;SET SYNCH LEFT
POPJ PP,
DA217.: DPB TB,DA.USG ;RESET USAGE
MOVEI TB,%CL.NU
DPB TB,DA.CLA ;SET NUMERIC
MOVE TB,-1(PP) ;GET FATHER LINK
DPB TB,DA.POP
SETO TB,
DPB TB,DA.FAL
DPB TB,DA.SYR ;SET SYNCH RIGHT
DPB TB,DA.SGN ;SET SIGNED
POPJ PP,
>
SUBTTL ROUTINES TO PARSE A DATANAME ALLOWING QUALIFIERS, SUBSCRIPTS
; These are essentially the same as some of the Phase D routines
;This is the PA2. routine
INTER. DA220. ;DATANAME OR INTEGER PARSED
DA220.: TLNE W1,GNLIT ;IS ITEM AN INTEGER?
JRST D220L ;YES
;Item must be in NAMTAB.
D220S: TLZ W1,4000 ;'ROUNDED BIT'
MOVEM W1,ARG1## ;SAVE ITEM
MOVEM W2,ARG1+1
POPJ PP,
D220L: HLRZ TB,W1
ANDI TB,177 ;NO. OF CHARACTERS
MOVE TC,[POINT 7,LITVAL]
MOVEM TC,TBLOCK+1 ;STORE POINTER TO LITERAL
MOVEM TB,TBLOCK## ;# CHARACTERS
HRRZI TB,5(TB)
IDIVI TB,5 ;NO. OF WORDS REQUIRED
HRRZI TA,(TB)
HRLI TA,CD.VAL ;VALTAB CODE
PUSHJ PP,GETENT## ;GET VALTAB ENTRY
HLR W1,TA ;UPDATE ITEM
MOVE TB,TBLOCK+1 ;'GET' POINTER
MOVE TC,[POINT 7,(TA),6] ;'PUT' POINTER
HRRZ TD,TBLOCK ;COUNTER
DPB TD,TC
D220LQ: SOJL TD,D220S ;JUMP TO STORE ITEM IN ARG1 WHEN ALL CHARS MOVED
ILDB TE,TB ;GET CHARACTER
IDPB TE,TC ;SAVE
JRST D220LQ
;This is the PA171. routine
INTER. DA221.
DA221.: HRRZ TC,NQUAL##
LSH TC,1
CAIL TC,144 ;SIZE OF TABLE
EWARNJ E.190 ;?TOO MANY QUALIFIERS
MOVE TA,ARG1
MOVEM TA,QUALT(TC)
MOVE TA,ARG1+1
MOVEM TA,QUALT+1(TC)
SETZM ARG1
SETZM ARG1+1
AOS NQUAL
POPJ PP,
;This is the PA170. routine
INTER. DA222.
DA222.: SETZM GOTQUA##
SKIPN TA,NQUAL
JRST D222.1
CAIE TA,1
JRST D222.5
MOVE TA,QUALT##
TLNN TA,GWFIGC
JRST D222.5
LDB TB,[POINT 9,TA,17]
IFN ANS68,<
CAIN TB,TALLY
JRST D222O
>
D222.5: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB POINTER
HRRZI TB,CD.DAT
PUSHJ PP,FNDLNK
JRST D222.0 ;MAY BE CONDITION-NAME
D222A: HLRM TB,QUALT
PUSHJ PP,DOQUAL
JRST D222B
SKIPE GOTQUA
JRST D222.2 ;INSUFFICIENT QUALIFICATION
HRRZM TA,GOTQUA ;TA CONTAINS QUALT ON RETURN
D222B: PUSHJ PP,LNKSET
PUSHJ PP,FNDNXT## ;FIND THE NEXT ITEM WITH THE SAME
; NAME IN THE CURRENT TABLE.
SKIPA TB,SAVE1## ;NO MORE IN THIS TABLE.
JRST D222A ;GO SEE IF THIS NAME WORKS.
CAIE TB,CD.CON ;IF IT WAS CONTAB, WE'RE THROUGH.
JRST D222.0 ;GO LOOK AT CONTAB.
D222C: SKIPN TA,GOTQUA ;ANY FOUND?
JRST D222.1 ;NO
D222O: HLL TA,QUALT
MOVEM TA,ARG1
MOVE TA,QUALT+1
MOVEM TA,ARG1+1
SETZM NQUAL
POPJ PP,
D222.0: LDB TA,[POINT 15,QUALT+1,15] ;ITEM'S NAMTAB PTR.
HRRZI TB,CD.CON
PUSHJ PP,FNDLNK
JRST D222C ;NO CONTAB LINK
JRST D222A
D222.1: HRRZI DW,E.104 ;NOT DEFINED
JRST D222E
D222.2: HRRZI DW,E.60
D222E: LDB LN,[POINT 13,QUALT+1,28]
LDB CP,[POINT 7,QUALT+1,35]
IFN DEBUG,<
PUSHJ PP,WARN
>
IFE DEBUG,<
PUSHJ PP,FATAL
>
MOVEI TA,<CD.DAT>B20+1 ;ASSUME DUMMY DATAB ENTRY
MOVEM TA,QUALT
JRST D222O
;THE following code copied (temporarily) from COBOLD.MAC:
DOQUAL: HRRZI TA,1
HRRZM TA,CURQUA## ;CURRENT ENTRY NUMBER-1
HRRZ TA,QUALT
JUMPE TA,NOPOP
HRLZM TA,CURDAT##
PUSHJ PP,LNKSET
HRRM TA,CURDAT
HRRZ TC,CURQUA
DQULUP: CAML TC,NQUAL
JRST DOOUT
NXTPOP: PUSHJ PP,GETPOP ;FIND FATHER OF CURDAT ITEM
JRST NOPOP ;FOUND NONE
MOVEM TA,CURDAT ;SAVE FATHER LINK
LDB TB,DA.NAM## ;FATHER'S NAMTAB LINK
HRRZ TC,CURQUA
LSH TC,1
LDB TD,[POINT 15,QUALT+1(TC),15] ;NAMTAB LINK OF ITEM SOUGHT
CAME TB,TD ;ARE THEY THE SAME?
JRST NXTPOP ;NO --- TRY HIGHER
HLRM TA,QUALT(TC) ;PUT LINK IN QUALT ENTRY
AOS TC,CURQUA
JRST DQULUP ;CHECK FOR MORE QUALIFIERS
DOOUT: MOVE TA,QUALT
POP PP,TE
JRST 1(TE)
NOPOP: MOVE TA,QUALT
POPJ PP, ;FAILURE EXIT
GETPOP: SKIPN TA,CURDAT
POPJ PP,
LDB TB,[POINT 3,CURDAT,2]
CAIN TB,CD.DAT
JRST NXTTRY ;DATAB ITEM
CAIE TB,CD.CON
POPJ PP,
LDB TA,CO.DAT## ;CONTAB ITEM FATHER LINK
JUMPN TA,GOTFA ;NOT NULL
POPJ PP,
NXTTRY: LDB TB,DA.FAL## ;FATHER/BROTHER FLAG
JUMPN TB,ISFAL ;FATHER
LDB TA,DA.BRO## ;GET BROTHER LINK
JUMPE TA,CPOPJ ;NULL
PUSHJ PP,LNKSET
JRST NXTTRY
ISFAL: LDB TA,DA.POP## ;GET FATHER LINK
JUMPE TA,CPOPJ ;NULL
GOTFA: HRRZM TA,TBLOCK
LDB TB,LNKCOD## ;COULD BE AN RPW LINK
JUMPE TB,GOTRPW ;MAYBE
GOTFA1: PUSHJ PP,LNKSET
GOTFA2: HRL TA,TBLOCK
POP PP,TE
JRST 1(TE)
GOTRPW: HRRZI TC,(TA)
HRRZ TA,CURDAT ;SEE IF LINE- OR PAGE-COUNTER BIT ON
LDB TB,DA.LPC##
JUMPE TB,GOTRP1 ;NO, MUST BE A FILTAB LINK
HRRZ TA,RPWLOC ;YES, GET RPWTAB ADDRESS
ADDI TA,(TC)
JRST GOTFA2
GOTRP1: HRRZI TA,(TC) ;RESTORE TA
JRST GOTFA1
;** END OF CODE COPIED FROM COBOLD **
; This is the PA205. routine
INTER. DA223. ;LEFT PAREN TO START SUBSCRIPTS
DA223.: SETZM NSBSC1##
MOVE TA,[XWD NSBSC1,SBSCR1##]
MOVEI TB,MAXSUB*4-1
BLT TA,SBSCR1(TB)
PUSHJ PP,DA222.
MOVE TA,[XWD ARG1,ARG3##]
BLT TA,ARG3+1
POPJ PP,
;This is the PA263. routine
INTER. DA224. ; Improper subscript error
DA224.: MOVEI W1,<CD.DAT>B20+1 ;USE DUMMY DATA ITEM FOR SUBSCRIPT
TLZ W2,777770
MOVEM W1,ARG1 ;NO NEED TO GIVE DIAGNOSTIC MESSAGE
MOVEM W2,ARG1+1 ; PHASE E DOES IT ALREADY
SWOFF FREGWD ;GO ON TO NEXT SOURCE ITEM
HRRZI TA,(W1) ; SET UP DUMMY RELATIVE ADDRESS
PUSHJ PP,LNKSET ; GET DATAB ADR FOR DUMMY
HRRM TA,CURDAT ; STORE IT
HRLM W1,CURDAT ; PUT BACK DATAB RELATIVE ADDR
POPJ PP,
;This is the PA206. routine
INTER. DA225. ;Count another subscript
DA225.: AOS TA,NSBSC1
CAILE TA,MAXSUB
JRST [MOVEI TA,MAXSUB ;RESTORE TO MAXIMUM
MOVEM TA,NSBSC1 ;LIMIT
EWARNJ E.277] ;TOO MANY SUBSCRIPTS
ASH TA,2
HRRZI TA,SBSCR1-4(TA)
HRRZI TB,1(TA)
HRLI TA,ARG1
BLT TA,(TB)
POPJ PP,
;This is the PA206A routine
INTER. DA225A
DA225A:
IFN ANS68,<
HLRZ TA,ARG1 ;GET SUBSCRIPT
CAIN TA,GWRESV!GWFIGC!TALLY ;IS IT TALLY?
JRST DA225. ;YES, GO ON
>
HRRZ TA,ARG1 ;GET SUBSCRIPT RELATIVE DATAB ADDRESS
PUSHJ PP,LNKSET ;GET REAL ADDRESS
MOVEM TA,CURDAT ;NOW STORE IT
LDB TB,DA.SUB## ;IS SUBSCRIPT SUBSCRIPTED?
SKIPE TB ;ERROR IF SO
EWARNW E.495 ;ERROR MESSAGE
JRST DA225. ;OK GO ON
;This is the PA220. routine
INTER. DA226.
DA226.: MOVE TA,[XWD ARG3,ARG1]
BLT TA,ARG1+1
POPJ PP,
;This is the PA234. routine
INTER. DA227. ;PLUS follows subscript
DA227.: MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVSI TB,400000 ;CLR BIT 0 OF 1ST WORD IN ENTRY
ANDCAM TB,SBSCR1-4(TA) ; TO INDICATE PLUS
POPJ PP,
;This is the PA235. routine
INTER. DA228. ;MINUS follows subscript
DA228.: MOVE TA,NSBSC1
ASH TA,2
MOVSI TB,400000 ;SET BIT 0 OF 1ST WORD OF ENTRY
IORM TB,SBSCR1-4(TA) ; TO INDICATE MINUS
POPJ PP,
;This is the PA236. routine
INTER. DA229. ;INTEGER TO BE ADDED TO SUBSCRIPT
DA229.: PUSHJ PP,DA220. ;PROCESS LITERAL
MOVE TA,NSBSC1 ;MAKE INDEX TO SUBSCRIPT TABLE
ASH TA,2
MOVE TB,ARG1 ;STORE WORDS FOR ADDITIVE
MOVEM TB,SBSCR1-2(TA)
MOVE TB,ARG1+1
MOVEM TB,SBSCR1-1(TA)
POPJ PP,
;PA21.-type routine, Call: w1/ addr where item and subscripts
; should be written
DA230.: SETZM TBLOCK+7 ;FLAG SAYS THIS IS NOT A SUBSCRIPT
D230.0: HRRZ TB,ARG1 ;R.H. OF GETSRC W1
MOVE TA,ARG1+1 ;GETSRC W2
MOVE TE,TA ;W2
MOVE TD,ARG1 ;W1
AND TA,[XWD 3,777777] ;LN,CP
TLO TA,400000 ;SET OPERAND BIT
TLNN TD,GWLIT ;IS ITEM A LITERAL?
JRST D230.A ;NO
SETZM NSBSC1
TLO TA,GNLIT ;YES--SET LITERAL BIT
TLNE TD,GWASCI ;IS ITEM 'PURE' ASCII?
TLO TA,020000 ;YES -- SET BIT
TLNE TD,GWNLIT ;IS ITEM A NUMERIC LITERAL?
TLO TA,GNNUM ;YES--SET NUMERIC LITERAL BIT
JUMPE TB,D230.E
D230.B: TLNE TD,GWALL ;'ALL' ITEM?
TLO TA,GNALL ;YES--SET ALL BIT
SETZM ARG1
SETZM ARG1+1
IFN ANS74,<
JRST DA231. ;OUTPUT ARG1
>
IFN ANS68,<
CAIN TC,TALLY ;TALLY?
SKIPN TBLOCK+7 ;TALLY- IS IT A SUBSCRIPT?
JRST DA231. ;NO, PUT LITERAL IN OUTPUT AREA
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2 ;4 WORDS EACH
SKIPN SBSCR1+2(TD) ;DOES TALLY HAVE AN ADDITIVE?
JRST DA231. ;NO, PUT INTO OUTPUT AREA
MOVEI TC,1 ;ASSUME +
SKIPGE SBSCR1(TD) ;UNLESS IT WAS -
MOVEI TC,2
DPB TC,[POINT 2,TB,11] ;STORE ADDITIVE OPERATOR
JRST DA231.
>
D230.A: TLNN TD,GWFIGC ;IS ITEM A FIG. CONSTANT?
JRST D230.C ;NO
SETZM NSBSC1
TLO TA,GNLIT!GNFIGC ;YES---SET FIGURATIVE CONSTANT BIT
HLRZ TC,TD
ANDI TC,777 ;YES--GET VALUE
SETZ TE,
CAIN TC,HIVAL.
HRLZI TE,GNFCHV ;HIGH-VALUE(S)
CAIN TC,LOVAL.
HRLZI TE,GNFCLV ;LOW-VALUE(S)
CAIN TC,QUOTE.
HRLZI TE,GNFCQ ;QUOTE(S)
CAIN TC,ZERO.
HRLZI TE,GNFCZ ;ZERO((E)S)
CAIN TC,SPACE.
HRLZI TE,GNFCS ;SPACE(S)
IFN ANS68,<
CAIN TC,TALLY
HRLZI TE,GNTALY ;TALLY
>
CAIN TC,TODAY
HRLZI TE,GNTODY ;TODAY
IOR TA,TE ;SET APPROPRIATE BITS
JRST D230.B
D230.C: TLNN TE,400000 ;FLOTAB ENTRY?
JRST D230.D ;NO
SETZM NSBSC1
TLO TB,100000 ;YES--SET BIT IN OPERAND WORD
JRST PUTFT
D230.D: HRRZI TC,(TD) ;TABLE LINK
JUMPE TC,D230.E ;NULL
LSH TC,-17 ;TABLE TYPE CODE
CAIN TC,CD.CON ;CONTAB?
JRST PUTFT ;YES, DON'T CLR NSBSC1
CAIN TC,CD.DAT ;DATAB?
JRST .+3
SETZM NSBSC1
JRST PUTFT ;NO--OUTPUT AS IS
MOVEM TA,TBLOCK
MOVEM TB,TBLOCK+1
MOVEM TD,TBLOCK+2
MOVEM TE,TBLOCK+3
HRRZ TA,TB ;LINK
PUSHJ PP,LNKSET ;ABS. ADDR. OF DATAB ENTRY
MOVE TC,TA ;ENTRY ADDRESS
MOVE TA,TBLOCK
MOVE TB,TBLOCK+1
MOVE TD,4(TC) ;WORD 5 OF DATAB ENTRY
TRNE TD,100 ;LINKAGE SECTION
TLO TA,(LKSFLG) ;YES
TLNE TD,100000 ;SYNC LEFT?
TLO TA,10000 ;YES
TLNE TD,40000 ;SYNC RIGHT?
TLO TA,4000 ;YES
TLNE TD,10 ;JUST RIGHT?
TLO TA,1000 ;YES
TLO TA,2000 ;SET NUMERIC BIT
TLNE TD,400000 ;NOT NUMERIC
TLNE TD,200000 ;SKIP IF NUMERIC
TLZ TA,2000 ;TURN OFF NUMERIC BIT
TRNE TD,400000 ;DD ERROR?
TLO TB,400000 ;YES
EXCH TA,TC ;PUT DATAB OFFSET IN TA & SAVE TC.
LDB TD,DA.USG## ;PICK UP THE ITEM'S USAGE.
EXCH TA,TC ;PUT THINGS BACK THE WAY THEY WERE.
DPB TD,[POINT 4,TA,13] ;PUT THE USAGE IN THE FIRST GENFIL WORD.
PUTFT: SKIPN TBLOCK+7 ;DOING A SUBSCRIPT?
JRST PUTFT0 ;NO
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2 ;4 WORDS EACH
SKIPN SBSCR1+2(TD) ;DOES IT HAVE AN ADDITIVE?
JRST PUTFT0 ;NO
MOVEI TC,1 ;ASSUME +
SKIPGE SBSCR1(TD)
MOVEI TC,2 ;NO, -
DPB TC,[POINT 2,TB,11] ;STORE ADDITIVE OPERATOR
PUTFT0: SETZM ARG1
SETZM ARG1+1
HRRZI TC,(TB)
JUMPE TC,D230.E
SKIPN TD,NSBSC1 ;NUMBER OF SUBSCRIPTS
JRST DA231. ;NONE, WRITE OUT INFO
HRRZM TD,TBLOCK+6
MOVNI TC,MAXSUB ;ALSO COUNT ADDITIONS TO SUBSCRIPTS
MOVSI TC,(TC)
PUTFT3: SKIPE SBSCR1+2(TC) ;THIS SUBSCRIPT HAVE AN ADDITIVE?
AOJ TD, ;YES
ADDI TC,3 ;AIM AT NEXT SUBSCRIPT
AOBJN TC,PUTFT3
DPB TD,[POINT 6,TB,17]
PUSHJ PP,DA231.
PUTFT1: SOSGE TD,TBLOCK+6
JRST PUTFT2
ASH TD,2
HRLZI TC,SBSCR1(TD)
HRRI TC,ARG1
BLT TC,ARG1+1
SETZM NSBSC1
AOS TBLOCK+7 ;TELL DA230. WE ARE DOING A SUBSCRIPT
PUSHJ PP,D230.0
MOVE TD,TBLOCK+6 ;GET INDEX TO SUBSCRIPT TABLE
ASH TD,2
SKIPN TA,SBSCR1+2(TD) ;IS THERE AN ADDITIVE?
JRST PUTFT1 ;NO
MOVE TB,SBSCR1+3(TD) ;YES, GET 2ND WORD OF ADDITIVE
MOVEM TA,ARG1
MOVEM TB,ARG1+1
PUSHJ PP,DA230.
JRST PUTFT1
PUTFT2: MOVE TA,[XWD NSBSC1,SBSCR1]
MOVEI TB,MAXSUB*4-1
BLT TA,SBSCR1(TB)
POPJ PP,
D230.E: OUTSTR [ASCIZ/?DA230.: null table link
/]
EWARNJ E.263
;This is the equivalent of PUTGEN for phase C.
;Input: TA/ FIRST WORD , TB/ 2ND WORD, W1/ INDEX WHERE TO PUT IT
DA231.: MOVEM TA,(W1) ;STORE FIRST WORD
MOVEM TB,1(W1) ;STORE 2ND WORD
ADDI W1,2 ;BUMP W1 FOR NEXT TIME
POPJ PP, ;RETURN
SUBTTL COMMON ROUTINES
INTER. DCA1.
DCA1.:
IFN DBMS,< ;[507]
PUSHJ PP,DA119A ;[476] CHECK PROPER SEQUENCE
> ;[507]
PUSHJ PP,DA10.
JRST DA2.
INTER. DCA2.
DCA2.: SKIPE WRKSEC ;WORKING-STORAGE SECTION ALREADY SEEN?
EWARNJ E.402 ;YES, CAN'T DUPLICATE
SETOM WRKSEC ;[710] NOW SET FLAG TO SHOW WE'VE SEEN IT
IFN FT68274,<
MOVEI TE,CVT.WS ;SIGNAL WORKING STORAGE JUST SEEN
MOVEM TE,CVTXLC## ;SO WE CAN GENERATE TALLY
>
SKIPE REPSSN## ;[763] [476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
IFN DBMS,<
SKIPE INVSEE## ;SCHEMA SECTION SEEN?
POPJ PP, ;YES, DON'T SET UP
>
IFN MCS!TCS,<
SKIPE CSSEEN ;COMMUNICATION SECTION SEEN?
POPJ PP, ;YES, DON'T SET UP
>
PUSHJ PP,DA10.
JRST DA3.
INTER. DCA3.
DCA3.: PUSHJ PP,DA5.
JRST DA0.
INTER. DCA4.
DCA4.: PUSHJ PP,DA7.
JRST DA0.
INTER. DCA5.
DCA5.: PUSHJ PP,DA11.
JRST DA28.
IFN RPW,<
INTER. DCA6.
DCA6.: SKIPE REPSSN## ;[763] REPORT SECTION ALREADY SEEN?
EWARNJ E.171 ;[763] YES, CAN'T DUPLICATE
SETOM REPSSN ;[763] NOW SET FLAG TO SHOW WE'VE SEEN IT
SETOM BLDIX ;[1335] TURN ON BUILD INDEXES FLAG
SKIPL TA,PCHOLD ;[1515] If linkage section preceded,
MOVEM TA,EAS1PC ;[1515] then next core offset is in
SETOM PCHOLD ;[1515] PCHOLD
MOVE TA,CURHLD ;[1335] SAVE CURHLD
MOVEM TA,HLDSAV## ;[1362] [1335] MAKE EXTERNAL
HRRZ TA,HLDLOC ;[1335] FIND START OF HLDTAB
AOJ TA, ;[1335]
MOVEM TA,CURHLD ;[1366] [1335] STORE IN CURHLD
PUSHJ PP,CLNHLD## ;[1335] BUILD DATAB ENTRIES FOR INDEXES
MOVE TA,HLDSAV ;[1335] RESTORE CURHLD
MOVEM TA,CURHLD ;[1335]
SETZM BLDIX ;[1335] SHUT OFF FLAG
IFN ANS74, PUSHJ PP,DA10R.
IFN ANS68, PUSHJ PP,DA10.
JRST DA63.
>
INTER. DCA7.
DCA7.: SKIPE LNKSSN## ;[763] LINKAGE SECTION ALREADY SEEN?
EWARNJ E.171 ;[763] YES, CAN'T DUPLICATE
SETOM LNKSSN ;[763] NOW SET FLAG TO SHOW WE'VE SEEN IT
FLAGAT LI
IFN DBMS,< ;[%316]FOR ACCESS
SKIPE ACCSEE## ;[%316]
JRST [SETZM ACCSEE## ;[476] CLEAR ACCESS FLAG
SETOM LNKSEC## ;[476]
SETOM SUBPRG ;[476] THIS IS A SUBPROGRAM FLAG
MOVE TB,EAS1PC ;[476] SAVE DATA PC
MOVEM TB,PCHOLD ;[476] WHILE DOING LINKAGE SECTION
POPJ PP,] ;[476]
> ;[%316]
SKIPE REPSSN## ;[763] [476] REPORT SECTION SEEN?
EWARNJ E.470 ;[476] YES, ERROR
PUSHJ PP,DA10.
JRST DA112.
INTER. DCA10.
DCA10.: PUSHJ PP,DA9.
JRST DA58.
;This is the PCA42. routine
INTER. DCA11.
DCA11.: PUSHJ PP,DA220. ;PA2. routine
JRST DA221. ;PA171. routine
;Here to save CURDAT of the RD GROUP item in CURDTT,
; then call action routine
INTER. DCA12.
DCA12.: MOVE TE,CURDAT##
MOVEM TE,CURDTT##
SETZM NSBSC1## ;CLEAR SUBSCRIPT COUNT
JRST DA220. ;PA2. routine
SUBTTL ERROR ROUTINES FOR DD SYNTAX SCAN
INTER. CE111.
CE111.: TLNE W1,GWRESV
EWARNJ E.103
EWARNJ E.104
INTER. CE125.
CE125.: MOVE CP,BLNKCP##
MOVE LN,BLNKLN##
HRRZI DW,E.125
JRST WARN
END COBOLC