Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/cleand.mac
There are 7 other files named cleand.mac in the archive. Click here to see a list.
; UPD ID= 1330 on 7/18/83 at 1:55 PM by HOFFMAN
TITLE CLEAND FOR COBOL V13
SUBTTL CLEANUP AFTER PHASE D W.NEELY/CAM
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
SEARCH FTDEFS ;GET FILE TABLE DEFINITIONS
IFN TOPS20,<SEARCH MACSYM> ;GET TX AND MOVX DEFINITIONS
IFE TOPS20,<SEARCH MACTEN>
%%P==:%%P
DBMS==:DBMS
DEBUG==:DEBUG
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
ENTRY CLEAND,CLENTA,PRFSUB
;The data put into the file tables must match the definitions in FTDEFS
DEFINE .WORD. (ARG),<ZZ==^D<ARG>>
DEFINE .CHECK. (ARG),<IF1,<IFN ZZ-1-ARG,<PRINTX CLEAND/FTDEFS mis-match for ARG>>>
;EDITS
;NAME DATE COMMENTS
;JEH 02-MAY-83 [1466] Give error 365 in COBOLD under WRITE stmt,
;DAW 14-Nov-80 [1074] "?Catastrophe in PHASE D" if "DYNAMIC"
; in ACCESS MODE clause is misspelled.
;JEH 27-JUN-80 [1032] STORE EBCDIC MODE IN KEY DESCRIPTOR
;JEH 03-APR-80 [1006] PULL OUT CODE TESTING ON USE PROCEDURE CONFLICTS
;DMN 24-OCT-79 [747] COBOL-74 BAD TABLE LINK IF MISSING ISAM RECORD KEY
;CLRH 14-SEP-79 [735] GIVE ERROR IF RECORD KEY NOT DEFINED IN RIGHT FD
;V12A SHIPPED
;DAW 23-APR-79 [677] FIX PROBLEM WITH TABLES EXPANDING THAT
; CAN MESS UP DBMS USE PROCEDURES
;EHM 17-SEP-78 [552] GIVE ERROR IF DECLARITIVES AND NO END DECL.
;V10*****************
; 10-AUG-76 [435] FIX UP USE PROCEDURE TABLE FOR DBMS
; 18-FEB-76 [407] FIX WRITING BEFORE/AFTER FOR STD ASCII
;DPL 01/29/76 [401] SET DBONLY OFF(=0) IF ONLY USE PROC IS DBMS
;ACK 14-JAN-74 GENERATE POINTERS IN THE FILE TABLE FOR FILE
; STATUS STUFF AND SIMULTANEOUS ACCESS STUFF.
;DBT 1/22/74 CHANGE THE PERF. UUO GENERATION TO GENERATE
; A PUSHJ 17,PERF.
;********************
;[236] /ACK COBOLC.MAC, CLEAND.MAC
; RESERVE SPACE FOR LABEL RECORD IF LARGER THAN FD
; BUT DONT CHANGE FILE TABLE MAX-REC-SIZE
; EDIT 171 MAKES ENTER COBOL EQUIVELENT TO CALL.
; EDIT 137 GIVE ERROR MESSAGE IF SUBSCRIPT IS IN LINKAGE
; SECTION OF IF SUBSCRIPTED IS SUBSCRIPTED.
; EDIT 165 FIXES COMPILER LOOP IF RIGHT PAREN
; MISSING FOR SUBSCRIPTED DATA-NAME.
; EDIT 155 FIXES "ADDRESS CHECK" WHEN SORT FILE SHARES SAME BUFFER AREA.
; EDIT 151 FIXES UNBALL PAREN PROBLEM IN COMPUTE STATEMENT.
; EDIT 111 FIXES COMPILER LOOP FOR SEARCH ALL... AT END STOP RUN.
; EDIT 110 OPEN STATEMENT DOES NOT GIVE PERIOD ASSUMED MESSAGE
; IF A PERIOD IS MISSING AND STATEMENT IS LAST ONE IN A PARA.
SUBTTL GENERATE OBJECT FILE TABLES
CLEAND: TSWTZ INDECL ;[552] STILL IN DECLARITIVES?
JRST CLND0 ;[552] NO, OK
LDB LN,[POINT 13,DECLR.##,28] ;[552] GET LINE NUMBER
LDB CP,[POINT 7,DECLR.,35] ;[552] AND CHAR. POS.
MOVEI DW,E.608 ;[552] GET ERROR MESSAGE CODE
PUSHJ PP,FATAL ;[552] WARN USER
CLND0: MOVE TA,EAS1PC##
MOVEM TA,FILTBL##
SETZM EAS1PC
MOVE TA,FILLOC##
CAMN TA,FILNXT##
JRST ECLND ;NO FILTAB ENTRIES
HRRZI TA,SZ.DEV
ADDM TA,FILTBL
HRRZI TA,CD.FIL*1B20+1
CLND: HRLZM TA,CURFIL##
PUSHJ PP,LNKSET##
HRRM TA,CURFIL
SETZM TBLOCK+20
LDB TB,FI.FDD##
JUMPN TB,CC0.
SETOM TBLOCK+20
PUSHJ PP,CLE12. ;NO FD
HRRZ TA,CURFIL
CC0.: LDB TB,FI.NDV## ;NUMBER OF DEVICES
JUMPG TB,CC0.1
HRRZI DW,E.202 ;NO DEVICES
PUSHJ PP,CLER2. ;SHOULD BE AT LEAST ONE
CC0.1: HRRZ TA,CURFIL
LDB TB,FI.IRM## ;INTERNAL RECORDING MODE
CAIE TB,%%RM
JRST CC1. ;SPECIFIED
HRRZI TB,%RM.6B
DPB TB,FI.IRM ;ASSUME SIXBIT
CC1.: LDB TC,FI.PSN## ;GET POSITIONING
LDB TD,FI.ADV## ; AND ADVANCING FLAGS.
JUMPE TD,CC1.D ;IF THEY ARE BOTH ON,
JUMPE TC,CC1.H ; COMPLAIN.
HRRZI DW,E.579 ;ADVANCING AND POSITIONING FOR THE SAME FILE.
PUSHJ PP,CLER2.
CC1.D: DPB TC,FI.ADV## ;IF EITHER IS ON, TURN ON ADVANCING.
CC1.H: IORI TC,(TD) ;GET ADV FLAG FOR LATER.
LDB TD,FI.ERM## ;GET EXTERNAL RECORDING MODE.
CAIN TD,%RM.7B ;[1466] [407] IF IT IS ASCII
JRST CC2. ; [407] GO ON
TRNN TC,1 ;IS ADVANCING ON?
JRST CC2. ;NO, USE WHAT'S SPECIFIED OR DEFAULT TO SIXBIT
MOVEI TD,%RM.7B ;YES, MAKE IT ASCII.
DPB TD,FI.ERM## ;SET THE EXTERNAL RECORDING MODE.
; LDB TB,FI.RM2 ;WAS IT SPECIFIED?
; JUMPE TB,CC2. ;NO, OK
;[1466] HRRZI DW,E.365 ;FILE MUST BE ASCII IF WRITE ADV BIT ON
;[1466] PUSHJ PP,CLER2.
CC2.: LDB TB,FI.DRL## ;DATA RECORD LINK
JUMPN TB,CC3.
HRRZI DW,E.201 ;NO DATA RECORDS
PUSHJ PP,CLER.
HRRZ TA,CURFIL
CC3.: LDB TB,FI.DSD##
JUMPN TB,CFGEN ;SORT-FILE
LDB TB,FI.LBL## ;TYPE OF LABELS
LDB TC,FI.VID## ;VALUE-OF-ID
LDB TD,FI.VDW## ;VALUE-OF-DATE-WRITTEN
JRST .+1(TB)
JRST CC5. ;[157] OMITTED
JRST CC4. ;STANDARD
JRST .+1 ;CANNOT HAPPEN, BUT JUST IN CASE
HRRZI TB,%LBL.S ;NOT SPECIFIED
DPB TB,FI.LBL ;ASSUME STANDARD
CC4.: JUMPN TC,CC5. ;VALUE-OF-ID REQUIRED
HRRZI DW,E.199 ;VAL-ID AND VAL-DW REQUIRED
PUSHJ PP,CLER.
HRRZ TA,CURFIL
CC5.: LDB TB,FI.POS ;MULTIPLE FILE TAPE FLAG
JUMPE TB,CC5.2
LDB TB,FI.NDV
SOJE TB,CC5.2 ;ONLY ONE DEVICE ALLOWED
HRRZI DW,E.197 ;ONLY ONE DEVICE ALLOWED
PUSHJ PP,CLER2.
HRRZ TA,CURFIL
HRRZI TB,1
DPB TB,FI.NDV
;CHECK DEPENDING VARIABLE FOR "SIZE IS VARYING DEPENDING ON ...
CC5.2: LDB TB,FI.DEP## ;GET DEPENDING VARIABLE
JUMPE TB,CC6. ;NONE
ADD TB,NAMLOC ;POINT TO NAME
MOVE TB,(TB) ;GET FIRST WORD
TLNE TB,-1 ;DATAB WOULD HAVE LHS ALL ZERO
JRST CC5.2Z ;ERROR
LDB TC,[POINT 3,TB,20]
CAIE TC,CD.DAT ;MAKE SURE ITS A DATAB
JRST CC5.2Z ;NO, ERROR
DPB TB,FI.DEP ;OK, STORE BACK DATAB POINTER
MOVE TA,TB
PUSHJ PP,LNKSET ;POINT TO DATAB NOW
LDB TB,DA.SON## ;SEE IF ELEMENTARY ITEM
JUMPN TB,CC5.2Y ;NO
LDB TB,DA.CLA ;GET CLASS
CAIE TB,%CL.NU ;MUST BE NUMERIC
JRST CC5.2Y
LDB TE,DA.SGN ;SEE IF SIGNED
JUMPN TE,CC5.2Y
LDB TE,DA.NDP ;OR NOT INTEGER
JUMPN TE,CC5.2Y
MOVE TA,CURFIL ;OK
JRST CC6.
CC5.2Y: HRRZI DW,E.723
LDB LN,DA.LN## ;SET UP FOR ERROR.
LDB CP,DA.CP##
PUSHJ PP,WARN
MOVE TA,CURFIL
JRST CC6.
CC5.2Z: SETZ TB,
DPB TB,FI.DEP ;CLEAR OUT POINTER
;CHECK BLOCKING FACTOR
CC6.: LDB TB,FI.RMS ;IS THIS AN RMS FILE?
JUMPN TB,CC7. ;YES, IGNORE BLOCKING FACTOR
LDB TB,FI.BLF## ;BLOCKING FACTOR
JUMPN TB,CC7.
LDB TC,FI.FBS## ;GIVEN BUFFER SIZE INSTEAD?
JUMPE TC,CC6B. ;NO
LDB TB,FI.MRS## ;YES, GET RECORD SIZE
IDIVI TC,(TB) ;SEE HOW MANY FIT
DPB TC,FI.BLF ;THIS IS BLOCKING FACTOR
JUMPN TC,CC7. ;BETTER NOT BE ZERO
HRRZI DW,E.623 ;BLOCKING FACTOR TOO SMALL
PUSHJ PP,CLER2.
JRST CC7.
CC6B.: LDB TC,FI.ORG
CAIE TC,%ORG.R
JRST CC6A. ;NOT RELATIVE
LDB TB,FI.ERM## ;EXTERNAL RECORDING MODE
MOVE TB,[EXP 6,1,5,4,4](TB) ;BYTES PER WORD
LSH TB,7 ;ASSUME 200 WORD BUFFER
MOVE TC,[200000,,1] ;SEED EXCESS,,BLOCKING FACTOR
MOVSI CH,-4 ;NO. OF PHYSICAL BUFFERS IN LOGICAL BUFFER
CC6L.: MOVE TE,TB ;CHARS. IN 1 BUFFERS
IMULI TE,1(CH) ;NO. IN LOGICAL BUFFER
LDB TD,FI.MRS## ;RECORD SIZE
CAIN TB,5*200 ;ASCII?
ADDI TD,2 ;ALLOW FOR CR-LF
CAIN TB,4*200 ;EBCDIC?
JRST [PUSH PP,TD+1 ;YES, GET FREE AC
LDB TD+1,FI.VLR## ;IS IT VARIABLE LENGTH?
JUMPE TD+1,CC6M. ;NO
ADDI TD,4 ;YES, ACCOUNT FOR 4 BYTE HEADER
JRST CC6M.]
CAIE TB,6*200 ;SIXBIT?
JRST CC6N. ;NO
PUSH PP,TD+1 ;SAVE TD+1
ADDI TD,6+5 ;ROUNDING + CONTROL WORD
IDIVI TD,6 ;NO. WHOLE WORDS
IMULI TD,6 ;NO. OF CHARACTERS OCCUPIED BY RECORD
CC6M.: POP PP,TD+1
CC6N.: IDIVI TE,(TD) ;TE=NUMBER OF RECORDS, TD=REMAINDER
HRL TE,TD ;EXCESS,,BLOCKING FACTOR
IMULI TD,5 ;TRY TO GET 80% FULL
CAIG TD,(TB) ;
JRST CC6K. ;WASTAGE LESS THAN 20% OF 1 BUFFER
CAMGE TE,TC ;BETTER THAN PREVIOUS?
MOVE TC,TE ;YES, SAVE IT
AOBJN CH,CC6L. ;TRY AGAIN
MOVE TE,TC ;GET BLOCKING FACTOR
CC6K.: DPB TE,FI.BLF ;STORE BLOCKING FACTOR
JRST CC7.
CC6A.: CAIN TC,%ORG.I ;IS IT INDEX?
JRST CC6I. ;YES, SET DEFAULT
HRRZ TA,CURFIL
LDB TB,FI.IOO##
JUMPE TB,CC7.
CC6I.: MOVEI TB,1 ;USE DEFAULT OF 1
DPB TB,FI.BLF
MOVEI DW,E.733 ;"BLOCK CONTAINS 1 RECORD assumed."
LDB LN,FI.FLN ;POINT TO THE FD
LDB CP,FI.FCP
PUSHJ PP,WARN##
HRRZ TA,CURFIL ;POINT TO FILE AGAIN
CC7.: LDB TB,FI.ORG ;ORGANIZATION
CAIE TB,%%ORG
JRST CC8. ;SPECIFIED
HRRZI TB,%ORG.S ;ASSUME SEQUENTIAL
DPB TB,FI.ORG
CC8.: JRST .+1(TB)
JRST CFGEN ;SEQUENTIAL
JRST CC12. ;RELATIVE
JRST CFGEN ;INDEXED
CC12.: LDB TB,FI.LBL ;LABELS MUST BE
CAIN TB,%LBL.S ;STANDARD
JRST CFGEN
HRRZI DW,E.198 ;LABELS MUST BE STANDARD
PUSHJ PP,CLER.
; JRST CFGEN ;FALL THRU
;OUTPUT THE DEVICE TABLE - MOSTLY ZEROS
;BUT OTS EXPECTS CERTAIN FLAGS IN D.F1 AND D.RFLG TO BE SET
CFGEN: HRRZ TA,CURFIL
;WORDS -SZ.DEV THROUGH D.FI-1
HRRZI TC,SZ.DEV+D.F1 ;D.F1 IS NEGATIVE
PUSHJ PP,PUTWZ ;OUTPUT OCTAL 0'S
;WORD D.F1
MOVE CH,[XWD AS.OCT,1]
PUSHJ PP,PUTAS1
LDB TC,FI.ERM ;RECORDING MODE
LDB TB,FI.VLR## ;VARIABLE LENGTH FLAG
SKIPE TB ;IS IT VARIABLE LENGTH?
CAIE TC,%RM.EB ; AND EBCDIC?
TDZA CH,CH ;NO
MOVX CH,B%VLER ;YES
LDB TB,FI.OPT## ;FILE OPTIONAL?
SKIPE TB
TXO CH,B%OPTF ;YES
LDB TB,FI.LBL ;LABELS
CAIN TB,%%LBL ;WERE THEY OMITTED (ON A SORT FILE)?
MOVEI TB,%LBL.S ;YES, MAKE THEM STANDARD.
DPB TB,FI.LBL
CAIN TB,%LBL.S ;STANDARD?
TXO CH,B%STL ;YES
PUSHJ PP,PUTAS1 ;OUTPUT D.F1
;WORDS D.F1+1 THROUGH D.RFLG-1
MOVEI TC,D.RFLG-D.F1-1 ;BOTH NEGATIVE
PUSHJ PP,PUTWZ
;WORD D.RFLG
MOVE CH,[XWD AS.OCT,1]
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB TB,FI.ERM ;RECORDING MODE
CAIE TB,%RM.SA ;STANDARD ASCII?
TDZA CH,CH ;NO
MOVX CH,B%SASC ;YES, SET FLAG
PUSHJ PP,PUTAS1 ;OUTPUT D.RFLG
;REST OF DEVICE TABLE
MOVEI TC,-D.RFLG-1
PUSHJ PP,PUTWZ ;FINISH OFF DEVICE TABLE
MOVE TC,EAS1PC
HRRZ TA,CURFIL
DPB TC,FI.OFT##
ADDI TC,SZ.DEV
MOVEM TC,EAS1PC
LDB TA,FI.LCP## ;SEE IF LINAGE-COUNTER
JUMPE TA,B0.1 ;NO
PUSHJ PP,LNKSET
HRREI TC,D.LCV ;GET RUN-TIME FILE TABLE OFFSET (NEGATIVE)
ADD TC,FILTBL ;PLUS BASE OF FILE TABLE
SUBI TC,SZ.DEV ;DON'T COUNT SZ.DEV TWICE
ADD TC,EAS1PC ;DEPTH IN FILTBL
DPB TC,DA.LOC## ;STORE INCORE LOCATION
HRRZ TA,CURFIL
LDB TC,FI.LPP##
TRNE TC,700000
JRST B0.0
LDB TC,FI.WFA##
TRNE TC,700000
JRST B0.0
LDB TC,FI.LAT##
TRNE TC,700000
JRST B0.0
LDB TC,FI.LAB##
TRNN TC,700000
JRST B0.1
B0.0: PUSHJ PP,GETTAG ;GET NEXT TAG
HRRZ TA,CURFIL
DPB CH,FI.LCI## ;STORE IT
B0.1: HRRZ TA,CURFIL
MOVE TC,[TBLOCK,,TBLOCK+1]
SETZM TBLOCK##
BLT TC,TBLOCK+4
LDB TB,FI.NAM## ;NAMTAB LINK
ADD TB,NAMLOC##
MOVNI TC,5
MOVEM TC,CTR##
B1: ADDI TB,1
MOVE TD,(TB) ;SIX CHARACTERS OF NAME
TLNN TD,600000
JRST W1.0 ;NEXT ENTRY
MOVEM TD,TBLOCK+5(TC)
AOJL TC,B1
;WORDS 1-5 - PROGRAM NAME IN SIXBIT
.WORD. 1
.CHECK. F.WFNM
W1.0: HRLZI CH,AS.SIX##
HRRI CH,5 ;5-WORD SIXBIT LITERAL
PUSHJ PP,PUTAS1
MOVE TA,[POINT 6,TBLOCK]
HRRZI TD,5
W1.1: HRRZI TC,6
MOVE TB,[POINT 6,CH]
SETZ CH,
W1.2: ILDB TE,TA
JUMPE TE,W1.3
CAIN TE,":"-40
HRRZI TE,"-"-40
CAIN TE,";"-40
HRRZI TE,"."-40
W1.3: IDPB TE,TB
SOJG TC,W1.2
PUSHJ PP,PUTAS1
SOJG TD,W1.1
.WORD. 6
.CHECK. F.WCVR ;Bits 0-5 Compiler version number
.CHECK. F.WBLC ;Bit 6 Buffer location assigned
.CHECK. F.WSDF ;Bit 7 SORT file
.CHECK. F.WDRM ;Bit 8 Default recording mode
.CHECK. F.WNOD ;Bits 12-17 Number of devices assigned to file
.CHECK. F.WDNM ;Bits 18-35 Address of first device table
HRLZI CH,AS.XWD## ;XWD
HRRI CH,5 ;WORDS 6-10
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.NDV
DPB CH,[F%CNOD] ;RHS GETS CLEARED LATER
LDB TB,FI.DSD
SKIPE TB
TXO CH,B%SDF ;THIS IS A SORT FILE
LDB TB,FI.RM2##
SKIPN TB ;IF RECORDING MODE WAS NOT SET
TXO CH,B%DRM ;SET FLAG FOR OTS
LDB TB,[POINT 6,.JBVER##,11] ;GET COBOL VERSION #
DPB TB,[F%CCVR]
HRRI CH,AS.CNB##
PUSHJ PP,PUTAS1 ;LEFT HALF OF WORD 6
HRRZ TA,CURFIL
LDB CH,FI.VAL##
JUMPE CH,W6.1 ;NULL LINK
HRRZ TA,CH
PUSHJ PP,REFTAG## ;REFERENCE IF TAG
TRNA
W6.1: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
.WORD. 7
;Bits 0-2 Not used
.CHECK. F.WFAM ;Bits 3-4 File access mode
.CHECK. F.WLAB ;Bits 5-8 Tape label format bits
;Bits 9-11 System label type
.CHECK. F.WPMT ;Bits 12-17 File position on mag-tape
.CHECK. F.RNFT ;Bits 18-35 Link to next file table
HRRZI CH,AS.CNB
HRRZ TA,CURFIL
LDB TB,FI.POS##
DPB TB,[F%CPMT] ;POSITION
LDB TB,FI.FAM ;FILE ACCESS MODE
SKIPE TB ;LEAVE DEFAULT AS SEQENTIAL
SUBI TB,1 ;OTS USES 0,1,2 FOR MODES
DPB TB,[F%CFAM] ;FILE ACCESS MODE
LDB TB,FI.POS ;IS THIS A MULTI-FILE REEL?
JUMPE TB,W7.4 ;NO
LDB TB,FI.DSD ;YES, BUT IS IT A SORT FILE?
JUMPN TB,[MOVEI DW,E.195 ;YES, ITS AN ERROR
PUSHJ PP,CLE12A
JRST W7.4] ;IGNORE REST FOR NOW
LDB TB,FI.LBL ;GET LABEL TYPE
LDB TA,FI.SDL ;GET NEXT FILE ON REEL
JUMPE TA,W7.4 ;ERROR, GIVE UP
PUSH PP,TB ;SAVE LABEL TYPE
W7.1: PUSHJ PP,LNKSET
HRRZ TB,CURFIL
CAIN TB,(TA) ;ARE WE ROUND THE LOOP?
JRST W7.3 ;YES
LDB TB,FI.DSD ;IS THIS A SORT FILE?
JUMPN TB,W7.2 ;YES, ERROR ALREADY GIVEN
LDB TB,FI.LBL ;GET ITS LABEL TYPE
CAME TB,(PP) ;SAME?
PUSHJ PP,CLE14. ;NO, GIVE ERROR
W7.2: LDB TA,FI.SDL ;GET NEXT
JUMPN TA,W7.1 ;IF THERE IS ONE
W7.3: POP PP,TB ;CLEAR STACK
W7.4: PUSHJ PP,PUTAS1
LDB CH,FI.NXT## ;POINTER TO NEXT
JUMPE CH,W7.5 ;FILE TABLE ENTRY
IFN CD.FIL-4,<
ANDI CH,077777
IORI CH,AS.FIL
>
TRNA
W7.5: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
.WORD. 8
.CHECK. F.WNAB ;Bits 0-6 Number of buffers
.CHECK. F.WLCR ;Bit 7 LINAGE-COUNTER wanted
.CHECK. F.RRRC ;Bits 18-35 Number of records between rerun dumps
HRRZ TA,CURFIL
SETZ CH,
LDB TB,FI.NBF## ;NUMBER OF BUFFERS
DPB TB,[F%CNAB]
LDB TB,FI.LCP ;LINAGE-COUNTER WANTED
SKIPE TB
SETO TB, ;YES
DPB TB,[F%CLCR]
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.RCT## ;RE-RUN COUNT
MOVSS CH
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
.WORD. 9
.CHECK. F.WFLG ;Flags
;Bits 0-3 External recording mode
;Bit 4 File is OPEN for INPUT
;Bit 5 File is OPEN for OUTPUT
;Bit 6 File is an INPUT/OUTPUT file
;Bit 7 An EOF was seen
;Bit 8 Device and core data modes differ
;Bit 9 Optional file not present
;Bit 10 RERUN dump at END-OF-REEL
;Bit 11 RERUN dump via RECORD-COUNT
;Bits 12-14 Core data mode
;Bits 15-17 File organization
.CHECK. F.RREC ;Bits 18-35 Address of record area
HRRZ TA,CURFIL
SETZ CH, ;
LDB TB,FI.ERM ;RECORDING MODE
CAIE TB,%RM.SA ;STANDARD ASCII?
JRST W9.1 ;NO, GO ON.
LDB TC,FI.RD## ;GET DENSITY.
CAIE TC,%RD.2 ;ONLY 800, 1600 AND DEFAULT
CAIN TC,%RD.5 ; DENSITY ARE ALLOWED.
PUSHJ PP,[HRRZI DW,E.585 ;ONLY DENSITIES OF 800 AND 1600 BPI
PJRST CLER2.] ; ARE ALLOWED ON STANDARD ASCII FILES.
W9.1: LDB TC,FI.ORG ;ORGANIZATION
CAIE TC,%ORG.I ;INDEXED?
JRST W9.2 ;NO
CAIN TB,%RM.BN ;YES, MAY NOT BE BINARY.
PUSHJ PP,[HRRZI DW,E.378 ;INDEXED FILE MUST BE 6BIT OR ASCII
JRST CLER2.]
W9.2: IOR CH,[B%DDMS ;SIXBIT
B%DDMB ;BINARY
B%DDMA ;ASCII
B%DDME ;EBCDIC
B%DDMA](TB) ;STANDARD-ASCII
IOR CH,[B%ORGS ;SEQUENTIAL
B%ORGR ;RELATIVE
B%ORGI](TC) ;INDEXED
LDB TB,FI.RER## ;RE-RUN END OF REEL
DPB TB,[F%CRER]
LDB TB,FI.RRC## ;RE-RUN ON COUNT
DPB TB,[F%CRRC]
LDB TB,FI.IRM ;INTERNAL MODE
IOR CH,[B%CDMS ;SIXBIT
0 ;BINARY
B%CDMA ;ASCII
B%CDME](TB) ;EBCDIC
HRRI CH,AS.CNB
LDB TB,FI.IOO
JUMPE TB,.+2
TXO CH,B%IOF
PUSHJ PP,PUTAS1
SETZ CH, ;WORD 9, RIGHT HALF
HRRZ TA,CURFIL
LDB CH,FI.DRL ;DATA RECORD LINK
JUMPE CH,W9.3
LDB TB,[POINT 3,CH,20] ;TYPE CODE
CAIE TB,CD.DAT
JRST W9.3
IFN CD.DAT-1,<
ANDI CH,LMASKB
IORI CH,AS.DAT
>
TRNA
W9.3: HRRZI CH,AS.CNB ;NULL
PUSHJ PP,PUTAS1
.WORD. 10
;LH Not used
.CHECK. F.RFSD ;RH Link to file table that shares device
HRRZ TA,CURFIL
HRRZI CH,AS.CNB ;ZERO
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.SDL##
JUMPE CH,W10.1 ;NULL
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.FIL
JRST W10.1 ;NOT A FILE
IFN CD.FIL-4,<
IFN CD.FIL,<
ANDI CH,LMASKS
>
IORI CH,AS.FIL##
>
TRNA
W10.1: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
.WORD. 11
.CHECK. F.WBKF ;LH Blocking factor
.CHECK. F.RACK ;RH Address of RELATIVE KEY
MOVE CH,[XWD AS.XWD,1]
PUSHJ PP,PUTAS1 ;WORD 11
HRRZI CH,AS.CNB ;LEFT HALF
LDB TB,FI.BLF
DPB TB,[F%CBKF] ;BLOCKING FACTOR
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.ACK## ;ACTUAL KEY
JUMPE CH,W11.1
LDB TB,[POINT 3,CH,20] ;GET CODE
CAIE TB,AC.MSC## ;SPECIAL?
JRST W11.3 ;NO, OUTPUT KEY
HRLZ CH,CH ;PUT INCREMENT IN LHS
TLZ CH,AS.MSC##
TLO CH,AS.PAR## ;RELATIVE TO %PARAM
HRRI CH,AS.MSC## ;SIGNAL MISC.
JRST W11.3 ;OUTPUT IT
W11.1: LDB TB,FI.ORG##
CAIE TB,%ORG.R ;RELATIVE FILE?
JRST W11.2 ;NO, PUT OUT A ZERO
LDB TB,FI.FAM## ;GET ACCESS MODE
CAIG TB,%FAM.S ;SEQUENTIAL DOESN'T NEED KEY
JRST W11.2 ;SO PUT OUT A ZERO
HRRZI DW,E.727 ;?RELATIVE KEY MUST BE SUPPLIED
HRRZ TA,CURFIL
LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
PUSHJ PP,FATAL
W11.2: HRRZI CH,AS.CNB
W11.3: PUSHJ PP,PUTAS1
.WORD. 12
.CHECK. F.WVID ;Byte pointer to VALUE OF ID
LDB CH,FI.VID ;VALUE OF ID
HRRZ TA,CH
SKIPE TA
PUSHJ PP,REFTAG## ;REFERENCE IF A TAG
HRRZ TA,CURFIL
IFE TOPS20,<
PUSHJ PP,PUTBYT ;WORD 12
>
IFN TOPS20,<
PUSHJ PP,PUTBYA ;WORD 12
>
.WORD. 13
.CHECK. F.WVDW ;Byte pointer to VALUE OF DATE-WRITTEN
HRRZ TA,CURFIL
LDB CH,FI.VDW
PUSHJ PP,PUTBYT ;WORD 13
.WORD. 14
.CHECK. F.LSBA ;LH Link to file table that shares buffer area
.CHECK. F.REUP ;RH Address of error use procedure
HRLZI CH,AS.XWD
HRRI CH,5
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL
LDB CH,FI.SBA## ;SAME BUFFER AREA LINK
JUMPE CH,W14.1 ;NULL
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.FIL
JRST W14.1
IFN CD.FIL-4,<
IFN CD.FIL,<
ANDI CH,077777>
IORI CH,AS.FIL
>
TRNA
W14.1: HRRZI CH,AS.CNB
PUSHJ PP,PUTAS1
SETZ TD,
HRRZ TA,CURFIL
LDB CH,FI.ERR## ;'USE' POINTER
JUMPE CH,W14.2 ;NULL
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.PRO
JRST W14.2 ;NOT PROTAB
MOVE TA,CH
PUSHJ PP,PUTPRF
HRRZ TA,CH
PUSHJ PP,REFTAG## ;GETS THE FILE USE-PROCEDURE TAGS
JRST W14.3
W14.2: HRRZI CH,AS.CNB
W14.3: PUSHJ PP,PUTAS1
.WORD. 15
.CHECK. F.WMRS ;LH Maximum record size in characters
.CHECK. F.WLRS ;RH Minimum record size in characters
HRRZ TA,CURFIL
LDB TB,FI.MRS## ;MAXIMUM RECORD SIZE
HRLZ CH,TB
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
LDB TB,FI.LRS## ;MINIMUM SIZE
HRLZ CH,TB
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
;WORDS 16-18
MOVEI TB,6
MOVEM TB,CTR
MOVE TA,FI.LCP## ;NOT ACTUALLY USED
MOVEM TA,PNTR## ;BUT START OF LINAGE STUFF
.WORD. 16
.CHECK. F.LPP ;LH Lines per page
.CHECK. F.WFA ;RH WITH FOOTING AT count
.WORD. 17
.CHECK. F.AKS ;WD Approx. key size for START
.CHECK. F.LAT ;LH Lines at top
.CHECK. F.LAB ;RH Lines at bottom
.WORD. 18
.CHECK. F.DEB ;LH DEBUGGING USE procedure
.CHECK. F.LCI ;RH LINAGE counter initialization routine
W18.0: HRRZ TA,CURFIL
ILDB CH,PNTR
TRNN CH,(1B2)
TRZN CH,(1B0) ;IS IT USER NAME
JRST W18.1 ;NO
ADD CH,NAMLOC ;GET POINTER TO NAME
HRRZ CH,(CH) ;GET DATAB PTR.
DPB CH,PNTR ;STORE BACK
SETOM RELKEY## ;SIGNAL PHASE E TO JUMP ROUND DECLARATIVES
W18.1: TRNE CH,700000 ;TYPE SET?
JRST W18.2 ;YES
MOVS CH,CH ;PUT VALUE IN LHS AND
HRRI CH,AS.CNB ;OUTPUT AS CONST.
W18.2: PUSHJ PP,PUTAS1
SOSLE CTR
JRST W18.0 ;LOOP FOR ALL LINAGE STUFF
.WORD. 19
.CHECK. F.WDNS ;Bits 0-2 Mag-tape density
;Bit 4 Mag-tape parity
.CHECK. F.WDIO ;Bit 5 Deferred ISAM flag
.CHECK. F.WOUP ;Bit 6 OPEN use procedure when ENTER fails
.CHECK. F.RMS ;Bit 7 RMS flag
.CHECK. F.WBM ;Bit 8 BYTE mode flag
.CHECK. F.CKP ;Bit 9 Checkpoint flag
.CHECK. F.CRC ;Bits 10-17 Checkpoint record count
.CHECK. F.RPPN ;Bits 18-35 Address of PPN
MOVE CH,[AS.XWD,,1] ;WORD 19
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL ;LEFT HALF
HRRZI CH,AS.CNB
LDB TB,FI.RD## ;RECORD DENSITY
DPB TB,[F%CDNS]
LDB TB,FI.RP## ;RECORD PARITY
LSH TB,-1 ;CONVERT 1 TO 0, 2 TO 1 FOR REAL FILE TABLE
DPB TB,[F%CPAR]
LDB TB,FI.DFR## ;GET DEFERRED OUTPUT ISAM BIT
DPB TB,[F%CDIO] ;SET ACCORDINGLY
LDB TB,FI.ENT## ;GET ERROR-PROC-ON-OPEN BIT
DPB TB,[F%COUP] ;SET RUN-TIME ACCORDINGLY
LDB TB,FI.RMS## ;GET RMS BIT
DPB TB,[F%CRMS]
LDB TB,FI.BM## ;GET BYTE MODE BIT
LDB TC,FI.ERM ;GET RECORDING MODE
CAIN TC,%RM.BN ;CANNOT BE BINARY
JUMPN TB,CLE29. ;AND BYTE MODE
DPB TB,[F%CBM]
W19.1: LDB TB,FI.CKP## ;GET CHECKPOINT BIT
DPB TB,[F%CCKP]
LDB TB,FI.CRC## ;GET CHECKPOINT RECORD COUNT
DPB TB,[F%CCRC]
PUSHJ PP,PUTAS1
HRRZ TA,CURFIL ;RIGHT HALF
LDB CH,FI.VPP## ;PPN LINK
PUSHJ PP,PUTAS1
.WORD. 20
PUSHJ PP,PBYT0 ;ZERO FOR NOW
.WORD. 21
.CHECK. F.WBRK ;Byte pointer to RECORD KEY
HRRZ TA,CURFIL
LDB TC,FI.ORG ;ISAM FILE?
CAIE TC,%ORG.I
JRST W22.3 ;NO, OUTPUT OCTAL 0'S IN WORDS 21-22
REPEAT 1,<
LDB TB,FI.RKY ;MAKE SYMBOLIC KEY = RECORD KEY
DPB TB,FI.SKY## ;AS EASIEST WAY TO FAKE OUT ISAM
>
LDB TC,FI.RKY## ;RECORD KEY
JUMPN TC,W21.1 ;OK
HRRZI DW,E.394 ;RECORD KEY REQUIRED
PUSHJ PP,CLER2.
MOVEI TC,100001 ;DUMMY DATAB ENTRY
MOVEI TB,100001 ;[747] DUMMY DATAB ENTRY
W21.1: MOVE TD,[TBLOCK+1,,TBLOCK+2] ;CLR STORAGE
MOVEM TB,TBLOCK ;SAVE KEYS
SETZM TBLOCK+1
BLT TD,TBLOCK+4
MOVEM TC,TBLOCK+5
CAIN TC,100001 ;[1074] IF DUMMY ENTRY (ERRORS EARLIER ON),
JRST W21.5 ;[1074] SKIP THIS
HRRZI TA,(TB) ;MAKE PTR TO SYMBOLIC KEY
PUSHJ PP,LNKSET
LDB TB,DA.CLA## ;CLASS
MOVEM TB,TBLOCK+1
LDB TB,DA.USG## ;USAGE
MOVEM TB,TBLOCK+2
LDB TB,DA.INS## ;SIZE
MOVEM TB,TBLOCK+3
LDB TB,DA.NDP## ;# OF DECIMAL PLACES
MOVEM TB,TBLOCK+4
LDB TB,DA.DFS## ;RECORD KEY IN RECORD?
JUMPE TB,W21.4 ;NO
W21.2: LDB TB,DA.POP## ;[735] FIND FILENAME
LDB TE,[POINT 3,TB,20] ;[735] GET TYPE
CAIN TE,CD.FIL ;[735] FILENAME?
JRST W21.3 ;[735] YES - SEE IF ITS THE ONE
MOVE TA,TB ;[735] NOT AT TOP YET
PUSHJ PP,LNKSET ;[735] UP TO NEXT LEVEL...
JRST W21.2 ;[735] LOOP UNTIL WE GET TO FILE
W21.3: HLRZ TA,CURFIL ;[735] GET CURRENT FILE
CAMN TA,TB ;[735] SAME FILE?
JRST W21.5 ;YES
W21.4: HRRZI DW,E.379 ;RECORD KEY NOT IN RECORD
HRRZ TA,CURFIL
LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
PUSHJ PP,FATAL##
W21.5: MOVE CH,TBLOCK ;OUTPUT RECORD KEY BYTE PTR (WD 21)
PUSHJ PP,PUTBYT
REPEAT 0,<
HRLZI CH,AS.BYT## ;OUTPUT RECORD KEY BYTE PTR (WD 21)
HRRI CH,AS.CNB
PUSHJ PP,PUTAS1
HRRZ TA,TBLOCK+5
PUSHJ PP,LNKSET
LDB CH,DA.LOC## ;REL. LOC OF KEY IN RECORD
PUSHJ PP,PUTBX
>
.WORD. 22
.CHECK. F.WIKD ;ISAM key description word
HRLZI CH,AS.XWD ;WORD 22
HRRI CH,1
PUSHJ PP,PUTAS1
MOVE TA,TBLOCK+1 ;GET CLASS OF KEY
CAIE TA,%CL.NU ;NUMERIC
SETZM TBLOCK+1 ;NON-NUMERIC -- SET TYPE = 0
HRRZ TA,TBLOCK+5 ;GET PTR TO RECORD KEY
PUSHJ PP,LNKSET
HRRZM TA,TBLOCK+5
LDB TB,DA.EDT## ;EDITING BIT ON?
SKIPE TB
SETZM TBLOCK+1 ;IF NUMERIC EDITED SET TYPE = 0
SKIPN TBLOCK+1 ;IF TYPE = 0, SKIP NUMERIC STUFF
JRST W22.2
MOVE TA,TBLOCK+2 ;USAGE
CAIE TA,%US.C1 ;FLOATING?
CAIN TA,%US.C2
JRST [HRRZI TA,5 ;YES, SET TYPE = 5
JRST W22.1]
CAIN TA,%US.C3 ;COMP-3?
JRST [HRRZI TA,7 ;YES, SET TYPE = 7
JRST W22.1] ;NOTE: IF SIZE >10, TYPE IS SET TO 10
CAIL TA,%US.1C ;FIXED PT?
JRST [HRRZI TA,3 ;YES, SET TYPE = 3
JRST W22.1]
HRRZI TA,1 ;MUST BE DISPLY
W22.1: MOVEM TA,TBLOCK+1 ;STORE TYPE
MOVE TA,TBLOCK+3 ;GET SIZE
CAILE TA,^D10 ;MORE THAN 10 DIGITS?
AOS TBLOCK+1 ;YES, ADD 1 TO TYPE
HRRZ TA,TBLOCK+5 ;PTR TO REC. KEY
LDB TB,DA.SGN## ;GET SIGN FLAG
SETCA TB, ;COMPLEMENT IT
DPB TB,[POINT 1,TBLOCK+3,20]
W22.2: HRRZ TA,CURFIL ;GET MODE
LDB TB,FI.ERM
SETZ TC, ;ASSUME SIXBIT
CAIN TB,%RM.7B
MOVEI TC,2 ;[1032] ASCII
CAIN TB,%RM.EB ;[1032] TEST FOR EBCDIC
MOVEI TC,1 ;[1032]
DPB TC,[POINT 2,TBLOCK+3,19] ;[1032]
HRRZI CH,AS.CNB ;OUTPUT LEFT HALF OF WD 22
HRL CH,TBLOCK+1 ;TYPE CODE
PUSHJ PP,PUTAS1
HRRZI CH,AS.CNB ;RT. HALF
HRL CH,TBLOCK+3 ;OTHER CODES
PUSHJ PP,PUTAS1
JRST W23.0
W22.3: MOVEI TC,2 ;OCTAL 0'S TO WORDS 21-22
PUSHJ PP,PUTWZ
.WORD. 23
.CHECK. F.WSMU
repeat 0,<
; BITS 0-8 OWNER ACCESS.
; BITS 9-17 OTHER ACCESS.
; BITS 18-35 COUNT OF RECORDS RETAINED.
>
; F.WSMU - definitions of names below are in LSU.MAC
; Bits 0-3 Owner access
; Bits 9-12 Other access
; Bit 13 Retained NEXT has shared access to file.
; Bit 14 Retained NEXT needs exclusive access to the file.
; Bit 15 LFENQ. OPEN flag
; Bits 16-17 Retained Index Share Flag
; Bits 18-35 Contains pointer to address of currently Retained Key.
W23.0: HRRZ TA, CURFIL ;POINT AT THE CURRENT FILE TABLE.
MOVE CH, [AS.XWD,,1] ;A SINGLE XWD SHOULD SUFFICE.
PUSHJ PP, PUTAS1
LDB TB, FI.OWA## ;OWNER ACCESS.
DPB TB, [F%COWN]
LDB TB, FI.OTA## ;OTHER ACCESS.
DPB TB, [F%COTH]
HRRI CH, AS.CNB
PUSHJ PP, PUTAS1
LDB CH, FI.RTC## ;COUNT OF RECORDS RETAINED.
MOVSS CH, CH
HRRI CH, AS.CNB
PUSHJ PP, PUTAS1
;WORDS 24 THROUGH 31 ARE THE FILE STATUS WORDS.
MOVE TD, FI.SPT## ;POINTER TO THEM IN THE FILE TABLE.
.WORD. 24
.CHECK. F.WPFS ;Byte pointer to FILE-STATUS data-item
;BITS 0-5 BYTE RESIDUE.
;BITS 6-11 BYTE SIZE.
;BITS 12-17 FIELD SIZE.
;BITS 18-35 ADDRESS.
HRREI TE, -10
PUSHJ PP, PPTR
.WORD. 25
.CHECK. F.WPEN ;Byte pointer to ERROR-NUMBER data-item
;BITS 0-5 BYTE RESIDUE.
;BITS 6-11 BYTE SIZE.
;BITS 12-17 FIELD SIZE.
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PPTR
.WORD. 26
.CHECK. F.WPAC ;Byte pointer to ACTION-CODE data-item
;BITS 0-17 0
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PIDX
.WORD. 27
.CHECK. F.WPID ;Byte pointer to VALUE-OF-ID data-item
;BITS 0-5 BYTE RESIDUE.
;BITS 6-11 BYTE SIZE.
;BITS 12-17 FIELD SIZE.
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PPTR
.WORD. 28
.CHECK. F.WPBN ;Byte pointer to BLOCK-NUMBER data-item
;BITS 0-17 0
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PIDX
.WORD. 29
.CHECK. F.WPRN ;Byte pointer to RECORD-NUMBER data-item
;BITS 0-17 0
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PIDX
.WORD. 30
.CHECK. F.WPFN ;Byte pointer to FILE-NAME data-item
;BITS 0-5 BYTE RESIDUE.
;BITS 6-11 BYTE SIZE.
;BITS 12-17 FIELD SIZE.
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PPTR
.WORD. 31
.CHECK. F.WPFT ;Byte pointer to FILE-TABLE data-item
;BITS 0-17 0
;BITS 18-35 ADDRESS.
AOJGE TE, W32.0
PUSHJ PP, PIDX
.WORD. 32
.CHECK. F.PROT ;LH Link to protection code
;Bits 18-27 Not used
.CHECK. F.SZID ;Bits 28-35 Size of VALUE-OF-ID
W32.0: HRRZ TA,CURFIL
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTAS1
LDB CH,FI.PRT## ;GET PROTECTION CODE POINTER
PUSHJ PP,PUTAS1
LDB CH,FI.SID## ;SIZE OF VALUE-OF-ID
PUSHJ PP,PUTAS1
.WORD. 33
.CHECK. F.PADD ;Bits 0-35 Byte pointer to padding character
;or
;Bits 28-35 Padding character
LDB CH,FI.PAD## ;GET PADDING CHARACTER
SKIPE CH ;LITERAL IS 1 THROUGH 377
CAILE CH,377 ;IS IT A LITERAL OR DATA-NAME
JRST [PUSHJ PP,PUTBYT
JRST W34.0]
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTAS1
SETZ CH,
PUSHJ PP,PUTAS1
LDB CH,FI.PAD
PUSHJ PP,PUTAS1
.WORD. 34
.CHECK. F.RMKL ;LH - Address of Block of RMS Key Descriptors in constant area under START.
.CHECK. F.APBL ;RH Bit fields which can apply to RMS files
;Bits 18-21 SMU Lock bits for Self. Set at Run Time.
;Bits 22-25 SMU Lock bits for Other. Set at Run Time.
;Bit 35 Apply Basic-Locking to this file.
;Bit 34 Write / no-Write switch for <CR> for ASCII STM files
W34.0: HRRZ TA,CURFIL
MOVE CH,[AS.XWD,,1]
PUSHJ PP,PUTAS1
LDB CH,FI.RKL## ;GET ADDR OF RMS FILE KEY LIST
PUSHJ PP,PUTAS1
LDB CH,FI.ABL## ;GET APPLY BASIC-LOCKING BIT
MOVSS CH,CH ; PUT IN LEFT SIDE OF CH
HRRI CH,AS.CNB ; AND "LARGE" CONST FLAG ON RIGHT
PUSHJ PP,PUTAS1
;WORD 35 through SZ.OFT
REPEAT SZ.OFT+1-^D35,<
PUSHJ PP,PBYT0
>
;ADD NEXT WORDS HERE
MOVEI TB,SZ.OFT
ADDM TB,EAS1PC ;ADD IN THE FIXED PART OF THE FILE TABLE
B5: HRRZ TA,CURFIL
MOVEI TD,^D80 ;[236] 80. CHARS IF STANDARD LABELS
LDB TE,FI.MRS
CAMGE TE,TD ;[236]
MOVE TE,TD ;[236] USE THE LARGER
LDB TD,FI.IRM
CAIN TD,%RM.6B
JRST B5.1
CAIE TD,%RM.7B
SKIPA TD,[EXP 4]
MOVEI TD,5
TRNA
B5.1: MOVEI TD,6
IDIVI TE,(TD)
CAIE TD,0
HRRZI TE,1(TE)
HRRZM TE,TBLOCK ;RECORD AREA IN WORDS
B5.2: LDB TB,FI.SRA##
JUMPE TB,B5.3 ;NO SAME RECORD AREA
HLRZ TC,CURFIL
CAIN TC,(TB)
JRST B5.3
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,FI.ADR##
JUMPN TB,B5.5 ;RECORD AREA DEFINED
LDB TE,FI.MRS
LDB TD,FI.LBL ;GET LABEL TYPE
SKIPE TD
MOVEI TD,^D80 ;SIZE IS 80 FOR STANDARD LABELS
CAIGE TE,(TD)
HRRZI TE,(TD)
LDB TD,FI.IRM
CAIN TD,%RM.6B
JRST .+5
CAIE TD,%RM.7B
SKIPA TD,[EXP 4]
MOVEI TD,5
TRNA
MOVEI TD,6
IDIVI TE,(TD)
CAIE TD,0
HRRZI TE,1(TE)
CAMLE TE,TBLOCK
HRRZM TE,TBLOCK
JRST B5.2
B5.3: MOVE TA,CURFIL
B5.4: LDB TB,FI.SAL##
JUMPE TB,B5.6 ;NO SAME AREA LINK
HLRZ TC,CURFIL
CAIN TB,(TC)
JRST B5.6 ;NO MORE
HRRZI TA,(TB)
PUSHJ PP,LNKSET
LDB TB,FI.ADR
JUMPN TB,B5.5 ;RECORD AREA DEFINED
LDB TE,FI.MRS
LDB TD,FI.LBL ;GET LABEL TYPE
SKIPE TD
MOVEI TD,^D80 ;SIZE IS 80 FOR STANDARD LABELS
CAIGE TE,(TD)
HRRZI TE,(TD)
LDB TD,FI.IRM
CAIN TD,%RM.6B
JRST .+5
CAIE TD,%RM.7B
SKIPA TD,[EXP 4]
MOVEI TD,5
TRNA
MOVEI TD,6
IDIVI TE,(TD)
CAIE TD,0
HRRZI TE,1(TE)
CAMLE TE,TBLOCK
HRRZM TE,TBLOCK
JRST B5.4
B5.5: LDB TB,FI.LOC## ;LOCATION OF RECORD AREA
B5.51: HRRZ TA,CURFIL
DPB TB,FI.LOC
SETO TC,
DPB TC,FI.ADR
JRST B6
;PUT OUT 'RELOC .+<SIZE OF RECORD>
B5.6: MOVEI CH,AS.MSC##
HRLI CH,1+AS.REL##
PUSHJ PP,PUTAS1
HRRZ CH,TBLOCK
ANDI CH,077777
HRRZ TA,CURFIL
LDB TB,FI.LBL
CAIE TB,%LBL.S
JRST B5.61
CAIGE CH,^D21
HRRZI CH,^D21
HRRZM CH,TBLOCK
B5.61: IORI CH,AS.DOT##
PUSHJ PP,PUTAS1
HRRZ TB,EAS1PC
HRRZ TC,TBLOCK
ADDM TC,EAS1PC
ADD TB,FILTBL
HRRZI TB,-SZ.DEV(TB)
JRST B5.51
B6: HRRZ TA,CURFIL
LDB TA,FI.NXT ;NEXT FILTAB ENTRY
JUMPN TA,CLND
;ALL DONE WITH FILE TABLES - FALL THROUGH
;SEE IF WE HAVE TO ADJUST THE SIZE OF DEBUG-CONTENTS
MOVE TA,MAXDBC## ;GET MAX. RECORD SIZE
SUBI TA,^D30/6 ;MINUS WHAT WE HAVE
JUMPLE TA,ECLND ;NOTHING TO DO
MOVEM TA,MAXDBC ;SAVE DIFFERENCE
PUSH PP,FLGSW## ;SAVE CURRENT SETTING
SETZM FLGSW ;TURN IT OFF TO AVOID SPURIOUS DEBUG-ITEM ERRORS
MOVE TB,[SIXBIT /DEBUG:/]
MOVEM TB,NAMWRD##
MOVE TB,[SIXBIT /ITEM/]
MOVEM TB,NAMWRD+1
SETZM NAMWRD+2
MOVE TB,[NAMWRD+2,,NAMWRD+3]
BLT TB,NAMWRD+5
PUSHJ PP,TRYNAM## ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,6
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
MOVE TB,[SIXBIT /CONTEN/]
MOVEM TB,NAMWRD+1
MOVSI TB,'TS '
MOVEM TB,NAMWRD+2
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,6
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
MOVE TB,[SIXBIT /TS:DIS/]
MOVEM TB,NAMWRD+2
MOVE TB,[SIXBIT /PLAY:6/]
MOVEM TB,NAMWRD+3
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,6
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
AOS NAMWRD+3 ;DEBUG-CONTENTS-DISPLAY-7
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,5
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
MOVEI TB,2
ADDM TB,NAMWRD+3
PUSHJ PP,TRYNAM ;NAME BETTER EXIST
JRST ECLND1 ;NO, GIVE UP
HRRZ TA,0(TA) ;GET DATAB LINK
PUSHJ PP,LNKSET
MOVE TB,MAXDBC ;GET SIZE IN WORDS
IMULI TB,4
HRL TB,TB
ADDM TB,5(TA) ;MAKE IT BIGGER
ECLND1: POP PP,FLGSW ;RESTORE FIPS FLAGGER
;SET 'USEBAS' AND PREPARE TO PUT OUT 'USE' TABLE
ECLND: SKIPE TA,EAS1PC
SUBI TA,SZ.DEV ;FILTBL POINTS AROUND
; FIRST DEVICE TABLE
MOVEM TA,USEBAS##
SETZM EAS1PC
SKIPE RELKEY## ;NEED %PARAM+0 FOR CONVERSION?
AOS IMPPAR ;YES, RESERVE IT
IFN DBMS,<
SETZM DBONLY## ;[401] START IN OFF POSITION
SETZM TBLOCK+7 ;CLR CTR OF ERROR-STATUS DECL. PROCS.
>
PUSHJ PP,CUSETB ;SET UP PERFORMS FOR EACH E-S PROCEDURE
MOVEI TC,0 ;TC IS # OF WORDS PUT OUT
MOVE TA,[XWD -USES.L##,USES##] ;IF NO
SKIPN (TA) ;ENTRIES
AOBJN TA,.-1 ;IN USE TABLE,
JUMPGE TA,EC1.B ;DON'T PUT OUT ANYTHING
IFN DBMS,<SETOM DBONLY##> ;[401] TURN ON SINCE AT LEAST ONE USE IS NON-DBMS
MOVE CH,[XWD AS.XWD,SZ.OUS] ;PREPARE TO WRITE THE USES TABLE
PUSHJ PP,PUTAS1 ;WRITE HEADER WORD
;EACH HALFWORD WILL BE WRITTEN OUT IN THE SAME ORDER THAT IT APPEARS
; IN USES, FOR EACH OF THE 20 WORDS.
SETZB TA,CTR
EC1: HLRZ TA,USES(TA) ;GET LH
PUSHJ PP,CHKUSE ;DO IT
MOVE TA,CTR
HRRZ TA,USES(TA) ;GET RH
PUSHJ PP,CHKUSE ;WRITE IT
AOS TA,CTR ;COUNT WORDS WRITTEN
CAIGE TA,SZ.OUS ;EXIT WHEN WROTE THEM ALL
JRST EC1 ;ELSE LOOP
;COPY USE PROCEDURE ADDRESSES FOR PHASE E
MOVEI TC,0 ;PTR TO USP.XXXX
MOVE TA,USES ;INPUT
PUSHJ PP,PUTPTE ;PUT TAG FOR PHASE E
MOVE TA,USES+5 ;OUTPUT
PUSHJ PP,PUTPTE
MOVE TA,USES+^D10 ;I-O
PUSHJ PP,PUTPTE
MOVE TA,USES+^D15 ;EXTEND
PUSHJ PP,PUTPTE
HRRZI TC,SZ.OUS ;# WORDS WRITTEN
EC1.B:
IFN DBMS,<ADD TC,TBLOCK+7> ;ADD IN COUNT OF ERROR-STATUS PROCEDURES
EXCH TC,IMPPAR##
MOVEM TC,EAS1PC
MOVE CH,[AS.REL+1,,AS.MSC]
PUSHJ PP,PUTAS1
HRRZI CH,AS.DAT##
PUSHJ PP,PUTAS1
JUMPLE TC,CPOPJ##
HRRZ CH,TC ;NUMBER OF EXIT WORDS USED
HRLI CH,AS.XWD
PUSHJ PP,PUTAS1
HRRZI CH,AS.CNB
EC1.L: PUSHJ PP,PUTAS1
PUSHJ PP,PUTAS1
SOJG TC,EC1.L
POPJ PP,
;CHECK TO SEE IF USE PROCEDURE IN TA HAS A TAG, IF NOT,
; CREATE A PERFORM AND OUTPUT A TAG REFERENCE.
CHKUSE: HRRZI CH,AS.CNB
JUMPE TA,PUTAS1 ;NO USE PROCEDURE, OUTPUT 0
LDB TC,LNKCOD##
CAIN TC,CD.PRO
PUSHJ PP,PUTPRF
PUSH PP,TA ;NEED TO SAVE TA
HRRZ TA,CH
PUSHJ PP,REFTAG## ;REFERENCE IF IT'S A TAG
POP PP,TA
JRST PUTAS1
;SCAN USETAB FOR DEBUG AND ERROR-STATUS ENTRIES --
; FOR EACH ONE SET UP A PERFORM OF THAT PROCEDURE, AND
; REMEMBER TAG OF THE PERFORM
CUSETB: SETZM TBLOCK+5 ;[677] INIT DYNAMIC USETAB PTR AT TOP
HRRZ TB,USELOC## ;[677] GET PTR TO START OF TABLE
HRRZ TA,USENXT## ;GET PTR TO END OF USETAB
SUB TA,TB ;[677] GET RELATIVE ADDRESS
MOVEM TA,TBLOCK+6 ;[677] SAVE PTR TO END OF TABLE
CUSET1: AOS TA,TBLOCK+5 ;BUMP USETAB PTR TO NEXT ENTRY
CAMLE TA,TBLOCK+6 ;PAST END?
POPJ PP, ;YES, RETURN
ADD TA,USELOC## ;[677] MAKE ABSOLUTE ADDR.
LDB TB,US.TYP## ;GET TYPE CODE
CAIN TB,%UT.DB ;DEBUGGING?
JRST CUSET6 ;YES
IFN DBMS,<
CAIE TB,%UT.ES ;THIS AN ERROR-STATUS ENTRY?
>
JRST CUSET4 ;NO
IFN DBMS,<
LDB TB,US.XTR## ;ANY EXTRA WORDS ALLOCATED?
JUMPE TB,CUSET1 ;NO, MUST HAVE BEEN A BAD ENTRY
AOS TBLOCK+7 ;BUMP ERROR-STATUS PROC COUNTER
>
CUSET6: HRRZ TB,USELOC## ;[677] GET ABS. START OF TABLE
HRRZ TC,TA ;[677] TC:= ABS. PLACE IN TABLE
SUB TC,TB ;[677] GET RELATIVE PLACE
PUSH PP,TC ;[677] AND SAVE IT
LDB TA,US.PRO## ;GET PROTAB LINK OF E-S SECTION
PUSHJ PP,PUTPR2 ;ENTER PUTPRF ROUTINE
POP PP,TA ;RESTORE USETAB PTR
ADD TA,USELOC ;[677] MAKE ABS. POINTER
DPB CH,US.PRO ;SAVE TAG ADDR OF PERFORM OF THAT SECTION
LDB TB,US.TYP
CAIE TB,%UT.DB ;IF DEBUG WE MAY NOT BE FINISHED
JRST CUSET3
SKIPN TB,DBPARM## ;HAVE WE ALLOCATED %PARAM+N YET?
JRST [AOS TB,IMPPAR ;NO, ALLOCATE IT
SOJA TB,.+1] ;BUT USE PREVIOUS
MOVEM TB,DBPARM
LDB TB,US.XTR## ;ANY EXTRA WORDS?
JUMPE TB,CUSET1 ;NO, WE ARE DONE
LDB TC,US.CNT## ;YES, GET THE COUNT
MOVNI TC,-1(TC) ;BUT NOT THE FIRST EXTRA WORD
HRLZ TC,TC
HRRI TC,2(TA) ;AOBJN POINTER TO USETAB
CUSET5: HLRZ TA,(TC) ;GET FLOTAB POINTER
ADD TA,FLOLOC##
LDB TA,FL.PRO## ;GET PROTAB LINK
ANDI TA,077777
ADD TA,PROLOC##
MOVE TB,TBLOCK+5 ;GET USETAB LINK
DPB TB,PR.DEB## ;SAVE IT IN PROTAB
HRRZ TA,(TC) ;GET FLOTAB POINTER
JUMPE TA,CUSET7 ;ALL DONE
ADD TA,FLOLOC##
LDB TA,FL.PRO## ;GET PROTAB LINK
ANDI TA,077777
ADD TA,PROLOC##
MOVE TB,TBLOCK+5 ;GET USETAB LINK
DPB TB,PR.DEB## ;SAVE IT IN PROTAB
CUSET7: AOBJN TC,CUSET5 ;LOOP
MOVE TA,TBLOCK+5
ADD TA,USELOC
LDB TC,US.CNT ;GET EXTRA WORDS
ADDM TC,TBLOCK+5
JRST CUSET1
CUSET4: LDB TC,US.XTR## ;ANY EXTRA WORDS?
JUMPE TC,CUSET1 ;NO
CUSET3: LDB TC,US.CNT## ;GET COUNT OF EXTRA WORDS IN USETAB ENTRY
;[435] THE USE TABLE LOOKS LIKE
;[435] CNT OF ERROR-STATUS,,ERROR-STATUS-1
;[435] ERROR-STATUS-2,,ERROR-STATUS-3 ETC
LSH TC,-1 ;[435] DIVIDE # OF ERROR-STATUS VALUES BY 2
AOS TC ;[435] ROUND UP TO GET NUMBER OF WORDS NEEDED
ADDM TC,TBLOCK+5 ;[435] ADD TO DYNAMIC USETAB PTR
JRST CUSET1 ;TRY NEXT ENTRY
CLE12.: HRRZI DW,E.97 ;NO FD
HRRZ TA,CURFIL
CLE12A: LDB LN,FI.LN## ;POINT TO THE "SELECT"
LDB CP,FI.CP##
JRST FATAL##
CLE14.: MOVEI DW,E.196 ;MUST HAVE SAME KIND OF LABELS
JRST CLE12A ;TA IS ALREADY SET UP
CLE29.: HRRZI DW,E.596 ;CAN NOT BE BYTE MODE AND BINARY
PUSHJ PP,CLER2.
JRST W19.1 ;SO IGNORE BYTE MODE
CLER.: SKIPE TBLOCK+20
POPJ PP,
CLER2.: HRRZ TA,CURFIL
LDB LN,FI.FLN## ;POINT TO THE FD
LDB CP,FI.FCP##
JRST FATAL##
;ROUTINE TO PUT OUT A FILE STATUS POINTER FOR DISPLAY ITEMS.
PPTR: JSP TB, PINT ;SET UP.
LDB TB, DA.RES## ;RESIDUE.
DPB TB, [POINT 6,CH,5]
LDB TB, DA.USG## ;USAGE.
CAIN TB, %US.D6 ;SIXBIT.
MOVEI TC, 6
CAIN TB, %US.D7 ;ASCII.
MOVEI TC, 7
CAIN TB, %US.EB ;EBCDIC.
MOVEI TC, 11
DPB TC, [POINT 6,CH,11]
LDB TB, DA.EXS## ;SIZE.
DPB TB, [POINT 6,CH,17]
HRRI CH, AS.CNB
PPTR1: PUSHJ PP, PUTAS1
HRRZ TA, CURFIL ;POINT AT THE CURRENT FILE TABLE AGAIN.
LDB CH, TD ;LOCATION.
JRST PUTAS1 ;WRITE IT AND RETURN.
;ROUTINE TO PUT OUT A FILE STATUS POINTER FOR INDEX ITEMS.
PIDX: JSP TB, PINT ;SET UP.
HRRZI CH, AS.CNB ;NOTHING IN THE LEFT HALF.
JRST PPTR1
;INITIALIZATION ROUTINE.
PINT: HRRZ TA, CURFIL
ILDB TA, TD ;NEXT LINK.
JUMPN TA, PINT2 ;JUMP IF THER IS ONE.
PINT1: MOVE CH, [AS.OCT,,1] ;NONE, WRITE OUT ZEROES.
PUSHJ PP, PUTAS1
SETZ CH,
PUSHJ PP, PUTAS1
AOJL TE, PINT1
POPJ PP,
PINT2: LDB TC, LNKCOD## ;GET ITS CODE.
CAIE TC, CD.DAT ;DATAB?
JRST PINT1 ;NO, MUST HAVE BEEN AN ERROR IN
; CLEANC.
ANDI TA, 077777 ;GET THE OFFSET.
ADD TA, DATLOC## ;MAKE IT ABSOLUTE.
MOVE CH, [AS.XWD,,1] ;ONE XWD.
PUSHJ PP, PUTAS1
JRST (TB) ;RETURN.
PUTBYT: JUMPE CH,PBYT0
LDB TB,[POINT 3,CH,20]
PUTBY1: CAIE TB,CD.DAT
JRST VALBYT
HRRZM CH,CURDAT##
ANDI CH,077777
IORI CH,AS.DAT
HRLI CH,AS.BYT##
PUSHJ PP,PUTAS1
SETZ CH,
HRRZ TA,CURDAT
PUSHJ PP,LNKSET
PUTBX: LDB TB,DA.RES##
DPB TB,[POINT 6,CH,5]
;** Note: 3-APR-80 /DAW:
; Keys that are not DISPLAY get a 9-bit byte pointer
; by the nature of the code below. Code in CBLIO will not check
; the left half of the byte pointer when the compare against
; the file parameter is done for COMP keys.
HRRZI TC,6
LDB TB,DA.USG
CAIN TB,%US.D6 ;IS IT DISPLAY-6?
JRST .+4 ;YES, GO ON.
CAIN TB,%US.D7 ;HOW ABOUT DISPLAY-7?
AOJA TC,.+2 ;YES, MAKE IT SEVEN BITS.
HRRZI TC,^D9 ;MUST BE EBCDIC THEN.
DPB TC,[POINT 6,CH,11]
JRST PUTAS1
VALBYT: CAIE TB,CD.TAG
JRST PBYT0
HRLI CH,AS.BYT ;BYTE POINTER
PUSHJ PP,PUTAS1
HRLZI CH,440600
JRST PUTAS1
IFN TOPS20,<
PUTBYA: JUMPE CH,PBYT0 ;SAME AS PUTBYT BUT FOR ASCIZ
LDB TB,[POINT 3,CH,20]
CAIE TB,CD.TAG
JRST PUTBY1
HRLI CH,AS.BYT ;BYTE POINTER
PUSHJ PP,PUTAS1
HRLZI CH,440700
JRST PUTAS1
>
;ROUTINE TO OUTPUT OCTAL ZEROS
;ENTER WITH REPEAT COUNT IN TC
PUTWZ: PUSHJ PP,PBYT0
SOJG TC,PUTWZ
POPJ PP,
PBYT0: MOVE CH,[AS.OCT##,,1]
PUSHJ PP,PUTAS1## ;PUT
SETZ CH, ; OUT
JRST PUTAS1 ; 'OCT 0'
; FOR EACH DECLARATIVE PROCEDURE, STORE THE TAG FOR PHASE E
;CALLED WITH TC= INDEX INTO USP.I BLOCK
; TA= PARAGRAPH
;EXIT WITH TAG STORED IN USP.I BLOCK, TC INCREMENTED
PUTPTE: JUMPE TA,PUTPT2 ;JUMP IF NONE THERE
PUSHJ PP,PUTPRF ;GET THE TAG
HRRZM CH,USP.I##(TC) ;STORE THE INFO
AOJA TC,CPOPJ ;INCREMENT TC AND RETURN
PUTPT2: SETZM USP.I(TC) ;CLEAR LOCATION
AOJA TC,CPOPJ ;INCREMENT TC AND RETURN
;FOR EACH DECLARATIVE PROCEDURE, GENERATE THE FOLLOWING CODE:
; %TAG: PERF. %PARAM-LOC
; JRST DECL-PROC
; POPJ PP,
PUTPRF: MOVEM TC,TBLOCK+10
JUMPE TA,PFZOUT
LDB TB,LNKCOD
CAIE TB,CD.PRO
JRST PFZOUT
;ENTER HERE FOR DEBUGGING AND ERROR-STATUS PROCEDURES
PUTPR2: HRLZM TA,CURPRO##
PUSHJ PP,LNKSET
HRRM TA,CURPRO
LDB CH,PR.PRF##
JUMPN CH,PRFOUT
LDB CH,PR.SFI ;DID WE PREVIOUSLY ALLOCATE A TAG#?
SKIPN CH ;YES, JUST USE IT
PUSHJ PP,GETTAG##
HRRZ TA,CURPRO
DPB CH,PR.PRF
DPB CH,PR.SFI## ;SO ERROR USE CAN FIND LABEL
PUSHJ PP,PRFSUB
PRFOUT: HRRZ TA,CURPRO
LDB CH,PR.PRF
MOVE TC,TBLOCK+10
POPJ PP,
PFZOUT: HRRZI CH,AS.CNB
MOVE TC,TBLOCK+10
POPJ PP,
PRFSUB: HRRZ TA,CURPRO
LDB TB,PR.XTW##
JUMPN TB,PRFXTW
HRRZ TB,IMPPAR
ANDI TB,077777
IORI TB,AS.PAR##
DPB TB,PR.XTW
AOS IMPPAR
PRFXTW: SETO TB,
DPB TB,PR.EXR## ;TURN ON EXIT REQUIRED FLAG
HRLI CH,AS.%X##
PUSHJ PP,PUTAS2##
HRRZ TB,EAS2PC##
ANDI CH,077777
HRRZ TD,CH
ADD TD,TAGLOC##
HRRM TB,(TD)
MOVE CH,[XWD 201700,AS.MSC] ;MOVEI 16,%PARAM-LOC
PUSHJ PP,PUTAS2
LDB CH,PR.XTW
PUSHJ PP,PUTAS2
MOVE CH,[XWD 113740,PERF%##] ;PUSHJ 17,PERF.
PUSHJ PP,PUTAS2
HLRZ CH,CURPRO
ANDI CH,077777
IORI CH,AS.PRO##
HRLI CH,076000 ;JRST
PUSHJ PP,PUTAS2
HRLZI CH,137740 ;POPJ 17,
PUSHJ PP,PUTAS2
MOVEI TB,4
ADDM TB,EAS2PC
POPJ PP,
SUBTTL CLEAN UP TABLES AND WRITE NAMTAB
CLENTA:
IFN ANS82,<
MOVE TA,['FILLER'] ;WE NEED TO KNOW WHERE FILLER IS
MOVEM TA,NAMWRD ; FOR INITIALIZE VERB
SETZM NAMWRD+1
SETZM NAMWRD+2
SETZM NAMWRD+3
SETZM NAMWRD+4
PUSHJ PP,TRYNAM ;SEE IF ITS BEEN DEFINED
SETZ TA, ;NO, STORE ZERO
HLRZM TA,FLRADD## ;STORE DATAB ADDRESS OF FILLER
>
PUSHJ PP,CLEANT## ;CLEAN UP TABLES
IFN DEBUG,<
MOVE TA,CORESW## ;CK SWITCHES
TLNE TA,%KILL
POPJ PP, ;DON'T DUMP NAMTAB IF /K ON
>
MOVE TE,NAMNXT## ;COMPUTE SIZE OF NAMTAB
SUB TE,NAMLOC
MOVEI TE,1(TE)
ADD TE,NM12SZ## ;ADD SIZE OF NAMTAB
IFE TOPS20,<
MOVNS TE
HRL TE,NM2LOC## ;FORM THE NAMTAB I/O LIST
MOVSM TE,NAMIOL##
SOS NAMIOL
SETZM NAMIOL+1
OUT NAM,NAMIOL
JRST CLENTB ;NO ERRORS
OUTSTR [ASCIZ "%Couldn't write NAMTAB, compilation continuing without maps or object listing
"]
SWOFF FMAP!FOBJEC
CLENTB: CLOSE NAM,
>
IFN TOPS20,<
MOVNM TE,NAMIOL+1 ;-<SIZE>
HRRZ TE,NM2LOC## ;FORM THE NAMTAB PTR
HRLI TE,(POINT ^D36,)
MOVEM TE,NAMIOL##
PUSHJ PP,RITNAM##
>
HRRZ TE,FREESP## ;REDUCE SIZE OF IMPURE AREA
IORI TE,1777
IFE TOPS20,<
CORE TE,
JRST CLENTE ;IGNORE ERRORS
>
IFN TOPS20,<
MOVEM TE,.JBREL## ;RESET SIZE
>
IFN DEBUG,<EXTERN LSTMES,PUTLST,LCRLF
MOVE TE,[POINT 7,[ASCIZ "Reduced memory to "]]
PUSHJ PP,LSTMES
HRRZ TE,.JBREL
ADDI TE,1
LSH TE,-^D9
PUSHJ PP,CLENTD
MOVEI CH,"P"
PUSHJ PP,PUTLST
PUSHJ PP,LCRLF
>
CLENTE: MOVE TE,.JBREL##
ADDI TE,1
HRRZM TE,TOPLOC##
SUB TE,FREESP
HRLM TE,FREESP
POPJ PP,
IFN DEBUG,<
CLENTD: IDIVI TE,^D10
HRLM TD,(PP)
SKIPE TE
PUSHJ PP,CLENTD
HLRZ CH,(PP)
ADDI CH,"0"
JRST PUTLST
>
END