Google
 

Trailing-Edge - PDP-10 Archives - ap-c800d-sb - cleand.mac
There are 7 other files named cleand.mac in the archive. Click here to see a list.
; UPD ID= 1900 on 5/15/79 at 5:32 PM by N:<NIXON>
TITLE	CLEAND	FOR COBOL V12
SUBTTL	CLEANUP AFTER PHASE D		W.NEELY/CAM



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1974, 1979 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	P
	%%P==:%%P
	DBMS==:DBMS
	DEBUG==:DEBUG

;EDITS
;NAME	DATE		COMMENTS

;V12*****************
;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.

TWOSEG
RELOC	400000

	SALL

ENTRY	CLEAND,CLENTA,PRFSUB
SUBTTL	CLEAND:; 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
	PUSHJ	PP,CLE1.	;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.
	PUSHJ	PP,	CLE18.		;IF EITHER IS ON, TURN
CC1.D:	DPB	TC,	FI.ADV##	; ON ADVANCING.
CC1.H:	IORI	TC,	(TD)		;GET ADV FLAG FOR LATER.
	LDB	TD,	FI.ERM##	;GET EXTERNAL RECORDING MODE.
	CAIE	TD,%RM.7B		; [407] IF IT IS ASCII
	CAIN	TD,%RM.SA		; [407] STANDARD 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
	PUSHJ	PP,CLE13.		;YES, GIVE ERROR
;IF LABELS ARE NON STANDARD ON EBCDIC TAPES GIVE AN ERROR.

CC2.:	LDB	TB,	FI.ERM##	;GET THE EXTERNAL RECORDING MODE.
	CAIE	TB,	%RM.EB		;IF IT'S NOT EBCDIC
	JRST		CC3.		; ALL IS WELL.
	LDB	TB,	FI.LBL##	;GET THE FILE'S LABEL TYPE.
	CAIE	TB,	%LBL.N		;IF IT'S NOT NON-STANDARD
	JRST		CC3.		; ALL IS WELL.
	PUSHJ	PP,	CLE28.		;OTHERWISE COMPLAIN.
	HRRZ	TA,	CURFIL		;RESTORE THE FILE TABLE'S ADDRESS.

CC3.:	LDB	TB,FI.DRL##	;DATA RECORD LINK
	JUMPN	TB,.+3
	PUSHJ	PP,CLE2.	;NO DATA RECORDS
	HRRZ	TA,CURFIL
	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.		;OMITTED [157]
	JRST	CC4.		;STANDARD
	JRST	CC5.		;NON-STANDARD [157]
	HRRZI	TB,%LBL.S	;NOT SPECIFIED

	DPB	TB,FI.LBL	;ASSUME STANDARD
	JRST	CC4.

CC4.:	JUMPN	TC,CC5.		;VALUE-OF-ID REQUIRED
	PUSHJ	PP,CLE4.
	HRRZ	TA,CURFIL
CC5.:	LDB	TB,FI.POS	;MULTIPLE FILE TAPE FLAG
	JUMPE	TB,CC6.
	LDB	TB,FI.NDV
	CAIG	TB,1		;ONLY ONE DEVICE ALLOWED
	JRST	CC5.2
	PUSHJ	PP,CLE6.
	HRRZ	TA,CURFIL
	HRRZI	TB,1
	DPB	TB,FI.NDV
CC5.2:
IFN ANS68,<
	LDB	TB,FI.MLT##	;MULTIPLE REEL/UNIT
	JUMPE	TB,CC6.		;NOT ALLOWED
	PUSHJ	PP,CLE7.
	HRRZ	TA,CURFIL
>
;CHECK BLOCKING FACTOR

CC6.:	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
	PUSHJ	PP,CLE30.	;TOO BAD
	JRST	CC7.

CC6B.:	LDB	TC,FI.ACC
IFN ANS68,<
	CAIN	TC,%ACC.R
	PUSHJ	PP,CLE11.	;MUST NOT BE RANDOM ACCESS
>
IFN ANS74,<
	CAIE	TC,%ACC.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 FEE 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,%ACC.I	;IS IT INDEX?
	JRST	CC6I.		;YES, SET DEFAULT
>
	HRRZ	TA,CURFIL
	LDB	TB,FI.IOO##
	JUMPE	TB,CC7.
IFN ANS68,<
	PUSHJ	PP,CLE15.
	HRRZ	TA,CURFIL
>
IFN ANS74,<
CC6I.:	MOVEI	TB,1		;USE DEFAULT OF 1
	DPB	TB,FI.BLF
>
CC7.:	LDB	TB,FI.ACC	;ACCESS MODE
	CAIE	TB,%%ACC
	JRST	CC8.		;SPECIFIED
	HRRZI	TB,%ACC.S	;ASSUME SEQUENTIAL
	DPB	TB,FI.ACC
CC8.:	JRST	.+1(TB)
	JRST	CFGEN		;SEQUENTIAL
	JRST	CC12.		;RANDOM
	JRST	CFGEN		;INDEXED

CC12.:
IFN ANS68,<
	LDB	TB,FI.NFL##	;NUMBER OF FILE-LIMITS
	JUMPG	TB,CC14.	;MUST BE SOME
	PUSHJ	PP,CLE10.
	HRRZ	TA,CURFIL
CC14.:>
	LDB	TB,FI.LBL	;LABELS MUST BE
	CAIN	TB,%LBL.S	;STANDARD
	JRST	CFGEN
	PUSHJ	PP,CLE5.
	HRRZ	TA,CURFIL
;	JRST	CFGEN		;FALL THRU
CFGEN:	HRRZI	TC,SZ.DEV
BAK.0:	MOVEI	CH,1
	HRLI	CH,AS.OCT##	;PUT
	PUSHJ	PP,PUTAS1##	;  OUT
	SETZ	CH,		;  'OCT 0'
	PUSHJ	PP,PUTAS1
	SOJG	TC,BAK.0
	MOVE	TC,EAS1PC
	HRRZ	TA,CURFIL
	DPB	TC,FI.OFT##
	ADDI	TC,SZ.DEV
	MOVEM	TC,EAS1PC
IFN ANS74,<
	LDB	TA,FI.LCP##	;SEE IF LINAGE-COUNTER
	JUMPE	TA,B0.1		;NO
	PUSHJ	PP,LNKSET
	HRRZ	TC,FI.LCP	;GET COMPILE TIME OFFSET
	ADD	TC,FILTBL	;PLUS BASE OF FILE TABLE
	SUBI	TC,SZ.DEV-4	;RUN TIME OFFSET, 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	B2		;NEXT ENTRY
	MOVEM	TD,TBLOCK+5(TC)
	AOJL	TC,B1

B2:	HRLZI	CH,AS.SIX##
	HRRI	CH,5		;5-WORD SIXBIT LITERAL
	PUSHJ	PP,PUTAS1
	MOVE	TA,[POINT	6,TBLOCK]
	HRRZI	TD,5
B3:	HRRZI	TC,6
	MOVE	TB,[POINT	6,CH]
	SETZ	CH,
B3.1:	ILDB	TE,TA
	JUMPE	TE,B3.2
	CAIN	TE,":"-40
	HRRZI	TE,"-"-40
	CAIN	TE,";"-40
	HRRZI	TE,"."-40
B3.2:	IDPB	TE,TB
	SOJG	TC,B3.1
	PUSHJ	PP,PUTAS1
	SOJG	TD,B3

	HRLZI	CH,AS.XWD##	;XWD
	HRRI	CH,5		;WORDS 6-10
	PUSHJ	PP,PUTAS1
	HRRZ	TA,CURFIL
	LDB	CH,FI.NDV
	LDB	TB,FI.DSD
	JUMPE	TB,.+2
	TRO	CH,002000	;THIS IS A SORT FILE
	MOVSS	CH		;NUMBER OF DEVICES IN LEFT HALF
	MOVSI	TB,(POINT 6,0,11)	;GET COBOL VERSION #
	HRRI	TB,.JBVER##
	LDB	TC,TB
	DPB	TC,[POINT 6,CH,5]
	HRRI	CH,AS.CNB##
	PUSHJ	PP,PUTAS1	;LEFT HALF OF WORD 6
	HRRZ	TA,CURFIL
	LDB	CH,FI.VAL##
	JUMPE	CH,B4.1		;NULL LINK
	HRRZ	TA,CH
	PUSHJ	PP,REFTAG##	;REFERENCE IF TAG
	PUSHJ	PP,PUTAS1
	JRST	B4.2
B4.1:	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
B4.2:	HRRZI	CH,AS.CNB
	HRRZ	TA,CURFIL
	LDB	TB,FI.POS##
	DPB	TB,[POINT 6,CH,17]	;POSITION
IFN ANS68,<
	LDB	TB,FI.NFL
	DPB	TB,[POINT 5,CH,4]	;NUMBER OF FILE-LIMITS
>
IFN ANS74,<
	LDB	TB,FI.FAM
	SKIPE	TB		;LEAVE DEFAULT AS SEQENTIAL
	SUBI	TB,1		;LIBOL USES 0,1,2 FOR MODES
	DPB	TB,[POINT 2,CH,4]	;FILE ACCESS MODE
>
	PUSHJ	PP,PUTAS1
	LDB	CH,FI.NXT##	;POINTER TO NEXT
	JUMPE	CH,B4.3		;FILE TABLE ENTRY
	IFN	CD.FIL-4,<
	ANDI	CH,077777
	IORI	CH,AS.FIL
>
	PUSHJ	PP,PUTAS1
	JRST	B4.4
B4.3:	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
B4.4:	MOVE	TA,CURFIL
	SETZ	CH,		;WORD 8
	LDB	TB,FI.NBF##	;NUMBER OF BUFFERS
	DPB	TB,[POINT 6,CH,5]
	LDB	TB,FI.MRS##	;MAXIMUM RECORD SIZE
	DPB	TB,[POINT 12,CH,17]
	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
	HRRZ	TA,CURFIL	;WORD 9
	SETZ	CH,
	LDB	TB,FI.ERM	;RECORDING MODE
	CAIE	TB,	%RM.SA		;STANDARD ASCII?
	JRST		B4.4D		;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,	CLE19.		;COMPLAIN.
B4.4D:	LDB	TC,FI.ACC	;ACCESS MODE
	CAIN	TC,%%ACC	;DO WE HAVE AN ACCESS MODE?
	MOVEI	TC,%ACC.S	;NO, MAKE IT SEQUENTIAL.
	DPB	TC,FI.ACC##
	CAIE	TC,%ACC.I	;INDEXED?
	JRST	.+3		;NO
	CAIN	TB,%RM.BN	;YES, MAY NOT BE BINARY.
	PUSHJ	PP,CLE24	;BAD NEWS
	DPB	TB,[POINT 3,CH,9]
	DPB	TC,[POINT 2,CH,17]
	LDB	TB,FI.VLR##	;VARIABLE LENGTH.
	DPB	TB,[POINT 1,CH,0]
	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
	DPB	TB,[POINT 2,CH,3]
	LDB	TB,FI.RER##	;RE-RUN END OF REEL
	DPB	TB,[POINT 1,CH,10]
	LDB	TB,FI.RRC##	;RE-RUN ON COUNT
	DPB	TB,[POINT 1,CH,11]
	LDB	TB,FI.OPT##
	DPB	TB,[POINT 1,CH,13]
	LDB	TB,FI.IRM	;INTERNAL MODE
	DPB	TB,[POINT 2,CH,15]
	HRRI	CH,AS.CNB
	LDB	TB,FI.IOO
	JUMPE	TB,.+2
	TLO	CH,4000
	PUSHJ	PP,PUTAS1
	SETZ	CH,		;WORD 9, RIGHT HALF
	HRRZ	TA,CURFIL
	LDB	CH,FI.DRL	;DATA RECORD LINK
	JUMPN	CH,B4.6
B4.5:	HRRZI	CH,AS.CNB	;NULL
	PUSHJ	PP,PUTAS1
	JRST	B4.7
B4.6:	LDB	TB,[POINT 3,CH,20]	;TYPE CODE
	CAIE	TB,CD.DAT
	JRST	B4.5
	IFN	CD.DAT-1,<
	ANDI	CH,LMASKB
	IORI	CH,AS.DAT
>
	PUSHJ	PP,PUTAS1
B4.7:	SETZ	CH,		;WORD 10
	HRRZ	TA,CURFIL
	LDB	CH,FI.LRS##	;MAXIMUM LABEL RECORD SIZE
	MOVSS	CH
	HRRI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
	HRRZ	TA,CURFIL
	LDB	CH,FI.SDL##
	JUMPE	CH,B4.8		;NULL
	LDB	TB,[POINT 3,CH,20]
	CAIE	TB,CD.FIL
	JRST	B4.8		;NOT A FILE
	IFN	CD.FIL-4,<
	IFN	CD.FIL,<
	ANDI	CH,LMASKS
>
	IORI	CH,AS.FIL##
>
	PUSHJ	PP,PUTAS1
	JRST	B4.13
B4.8:	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
B4.13:	MOVE	CH,[XWD	AS.XWD,1]
	PUSHJ	PP,PUTAS1		;WORD 11
	HRRZI	CH,AS.CNB		;LEFT HALF
	LDB	TB,FI.BLF
	DPB	TB,[POINT 12,CH,17]	;BLOCKING FACTOR
	PUSHJ	PP,PUTAS1
	HRRZ	TA,CURFIL
	LDB	CH,FI.ACK##	;ACTUAL KEY
IFN ANS68,<
	JUMPN	CH,B4.13B
>
IFN ANS74,<
	JUMPE	CH,B4.13Z
	LDB	TB,[POINT 3,CH,20]	;GET CODE
	CAIE	TB,AC.MSC##	;SPECIAL?
	JRST	B4.13B		;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	B4.13B		;OUTPUT IT
B4.13Z:>
	LDB	TB,FI.ACC##
	CAIE	TB,%ACC.R	;RANDOM FILE?
	JRST	B4.13A		;NO, PUT OUT A ZERO
IFN ANS74,<
	LDB	TB,FI.FAM##	;GET ACCESS MODE
	CAIG	TB,%FAM.S	;SEQUENTIAL DOESN'T NEED KEY
	JRST	B4.13A		;SO PUT OUT A ZERO
	HRRZI	DW,E.727	;?RELATIVE KEY MUST BE SUPPLIED
>
IFN ANS68,<
	HRRZI	DW,E.240 >	;?NO ACTUAL KEY
	HRRZ	TA,CURFIL
	LDB	LN,FI.LN##
	LDB	CP,FI.CP##
	PUSHJ	PP,FATAL
B4.13A:	HRRZI	CH,AS.CNB
B4.13B:	PUSHJ	PP,PUTAS1
	LDB	CH,FI.VID	;VALUE OF ID
	HRRZ	TA,CH
	SKIPE	TA
	PUSHJ	PP,REFTAG##	;REFERENCE IF A TAG
	HRRZ	TA,CURFIL
	PUSHJ	PP,PUTBYT	;WORD 12
	HRRZ	TA,CURFIL
	LDB	CH,FI.VDW
	PUSHJ	PP,PUTBYT	;WORD 13
	HRLZI	CH,AS.XWD
	HRRI	CH,5
	PUSHJ	PP,PUTAS1
	MOVE	TA,FI.SBA##
	MOVEM	TA,PNTR##
	HRRZ	TA,CURFIL
	LDB	CH,PNTR		;SAME BUFFER AREA LINK
	JUMPE	CH,B4.14Z	;NULL
	LDB	TB,[POINT	3,CH,20]
	CAIE	TB,CD.FIL
	JRST	B4.14Z
	IFN	CD.FIL-4,<
	IFN	CD.FIL,<
	ANDI	CH,077777>
	IORI	CH,AS.FIL
>
	PUSHJ	PP,PUTAS1
	JRST	B4.15
B4.14Z:	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1

B4.15:	SETZB	TD,CTR
B4.15L:	HRRZ	TA,CURFIL
	ILDB	CH,PNTR		;'USE' POINTER
	JUMPE	CH,B4.15Z	;NULL
	LDB	TB,[POINT	3,CH,20]
	CAIE	TB,CD.PRO
	JRST	B4.15Z		;NOT PROTAB
IFN ANS68,<
	HRRZ	TD,CTR
	IMULI	TD,3
	SETZ	TE,
	SKIPE	TC,USES##(TD)
	PUSHJ	PP,CLE14.
	SKIPE	TC,USES+1(TD)
	PUSHJ	PP,CLE14.
	SKIPE	TC,USES+2(TD)
	PUSHJ	PP,CLE14.
	JUMPN	TE,B4.15Z
>
	MOVE	TA,CH
	PUSHJ	PP,PUTPRF
	HRRZ	TA,CH
	PUSHJ	PP,REFTAG##	;GETS THE FILE USE-PROCEDURE TAGS
	JRST	B4.15A
B4.15Z:	HRRZI	CH,AS.CNB
B4.15A:	PUSHJ	PP,PUTAS1
	AOS	TC,CTR
IFN ANS68,<
	CAIGE	TC,11
	JRST	B4.15L
>
IFN ANS74,<
B4.16:	HRRZ	TA,CURFIL
	ILDB	CH,PNTR	
	TRNN	CH,(1B2)
	TRZN	CH,(1B0)	;IS IT USER NAME
	JRST	B4.16A		;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
B4.16A:	TRNE	CH,700000	;TYPE SET?
	JRST	B4.16B		;YES
	MOVS	CH,CH		;PUT VALUE IN LHS AND
	HRRI	CH,AS.CNB	;OUTPUT AS CONST.
B4.16B:	PUSHJ	PP,PUTAS1
	AOS	TC,CTR
	CAIGE	TC,11
	JRST	B4.16		;LOOP FOR ALL LINAGE STUFF
>
	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,[POINT 3,CH,2]
	LDB	TB,FI.RP##	;RECORD PARITY
	LSH	TB,-1		;CONVERT 1 TO 0, 2 TO 1 FOR REAL FILE TABLE
	DPB	TB,[POINT 1,CH,3]
	LDB	TB,FI.DFR##	;GET DEFERRED OUTPUT ISAM BIT
	DPB	TB,[POINT 1,CH,5]	;SET ACCORDINGLY
	LDB	TB,FI.ENT##	;GET ERROR-PROC-ON-OPEN BIT
	DPB	TB,[POINT 1,CH,6]	;SET RUN-TIME ACCORDINGLY
	LDB	TB,FI.RMS##	;GET RMS BIT
	DPB	TB,[POINT 1,CH,7]
	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,[POINT 1,CH,8]
B4.16D:	LDB	TB,FI.CKP##	;GET ISAM CHECKPOINT BIT
	DPB	TB,[POINT 1,CH,9]
	PUSHJ	PP,PUTAS1
	HRRZ	TA,CURFIL	;RIGHT HALF
	LDB	CH,FI.VPP##	;PPN LINK
	PUSHJ	PP,PUTAS1
	HRRZ	TA,CURFIL	;WORDS 20-21
	LDB	TC,FI.ACC	;ISAM FILE?
	CAIE	TC,%ACC.I
	JRST	B4.P		;NO, OUTPUT OCTAL 0'S IN WORDS 20-22
IFN ANS74,<
	LDB	TB,FI.RKY	;MAKE SYMBOLIC KEY = RECORD KEY
	DPB	TB,FI.SKY##	;AS EASIEST WAY TO FAKE OUT ISAM
>
IFN ANS68,<
	LDB	TB,FI.SKY##	;SYMBOLIC KEY
	JUMPE	TB,CLE26.	;NO SYMBOLIC KEY
B4.IX1:
>
	LDB	TC,FI.RKY##	;RECORD KEY
	JUMPE	TC,CLE27.	;NO RECORD KEY
B4.IX2:	MOVE	TD,[TBLOCK,,TBLOCK+1]	;CLR STORAGE
	SETZM	TBLOCK
	BLT	TD,TBLOCK+4
	MOVEM	TB,TBLOCK	;SAVE KEYS
	MOVEM	TC,TBLOCK+5
	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

IFN ANS68,<			;IF -74 WE KNOW THEY ARE THE SAME
	HRRZ	TA,TBLOCK+5	;COMPARE RECORD KEY INFO
	PUSHJ	PP,LNKSET
	LDB	TB,DA.CLA
	CAME	TB,TBLOCK+1
	JRST	CLE20		;CLASS NOT SAME AS SYMBOLIC KEY
B4.SK1:	LDB	TB,DA.USG
	CAME	TB,TBLOCK+2
	JRST	CLE21		;USAGE NOT SAME
B4.SK2:	LDB	TB,DA.INS
	CAME	TB,TBLOCK+3
	JRST	CLE22		;SIZE NOT SAME
B4.SK3:	LDB	TB,DA.NDP
	CAME	TB,TBLOCK+4
	JRST	CLE23		;# DEC. PLACES NOT SAME
B4.SK4:
>;END IFN ANS68
	LDB	TB,DA.DFS##	;RECORD KEY IN RECORD?
	JUMPE	TB,CLE25	;NO
B4.SK5:	MOVE	CH,TBLOCK	;OUTPUT SYMBOLIC KEY BYTE PTR (WD 20)
	PUSHJ	PP,PUTBYT
	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
	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	B4.C2
	MOVE	TA,TBLOCK+2	;USAGE
	CAIE	TA,%US.C1	;FLOATING?
	JRST	.+3		;NO
	HRRZI	TA,5		;YES, SET TYPE = 5
	JRST	B4.C1
	CAIGE	TA,%US.1C	;FIXED PT?
	JRST	.+3		;NO
	HRRZI	TA,3		;YES, SET TYPE = 3
	JRST	B4.C1
	HRRZI	TA,1		;MUST BE DISPLY
B4.C1:	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]
B4.C2:	HRRZ	TA,CURFIL	;GET MODE
	LDB	TB,FI.ERM
	SETZ	TC,
	CAIN	TB,%RM.7B	;IF NOT ASCII, ASSUME SIXBIT
	SETO	TC,		;ASCII
	DPB	TC,[POINT 1,TBLOCK+3,18]
	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	B4.Q
B4.P:	MOVEI	TA,3		;OCTAL 0'S TO WDS 20-22
	MOVEM	TA,CTR
B4.S:	MOVE	CH,[AS.OCT,,1]
	PUSHJ	PP,PUTAS1
	SETZ	CH,
	PUSHJ	PP,PUTAS1
	SOSLE	CTR
	JRST	B4.S

B4.Q:

;WORD 23 LOOKS LIKE:
;	BITS	0-8	OWNER ACCESS.
;	BITS	9-17	OTHER ACCESS.
;	BITS	18-35	COUNT OF RECORDS RETAINED.

	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,	[POINT 9,CH,8]
	LDB	TB,	FI.OTA##	;OTHER ACCESS.
	DPB	TB,	[POINT 9,CH,17]
	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 - FILE STATUS.
;	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 - ERROR NUMBER.
;	BITS	0-5	BYTE RESIDUE.
;	BITS	6-11	BYTE SIZE.
;	BITS	12-17	FIELD SIZE.
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PPTR

;WORD 26 - ACTION CODE.
;	BITS	0-17	0
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PIDX

;WORD 27 - VALUE OF ID.
;	BITS	0-5	BYTE RESIDUE.
;	BITS	6-11	BYTE SIZE.
;	BITS	12-17	FIELD SIZE.
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PPTR
;WORD 28 - BLOCK NUMBER.
;	BITS	0-17	0
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PIDX

;WORD 29 - RECORD NUMBER.
;	BITS	0-17	0
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PIDX

;WORD 30 - FILE NAME.
;	BITS	0-5	BYTE RESIDUE.
;	BITS	6-11	BYTE SIZE.
;	BITS	12-17	FIELD SIZE.
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PPTR

;WORD 31 - FILE TABLE ADDRESS.
;	BITS	0-17	0
;	BITS	18-35	ADDRESS.

	AOJGE	TE,	FSDN
	PUSHJ	PP,	PIDX
	JRST		FSDN
;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.
FSDN:	MOVE	TB,EAS1PC
	ADDI	TB,SZ.OFT
	MOVEM	TB,EAS1PC
IFN ANS68,<
	HRRZ	TA,CURFIL
	LDB	TB,FI.NFL	;NUMBER OF FILE-LIMITS
	JUMPE	TB,B5
	ADDI	TA,SZ.FIL
	HRLI	TA,442200
	MOVEM	TA,PNTR		;BYTE POINTER
	HRLZI	CH,AS.XWD
	HRRZI	TE,(TB)		;NO. FILE LIMIT CLAUSES
	IMULI	TE,3		;NO. WORDS NEEDED
	HRRI	CH,(TE)
	ASH	TB,1		;NO. HALFWORDS FOR LIMITS
	MOVEM	TB,CFLM##
	ADDM	TE,EAS1PC
	PUSHJ	PP,PUTAS1
B4.16:	ILDB	CH,PNTR		;NEXT FILE-LIMIT
	JUMPE	CH,B4.18
	LDB	TB,[POINT 3,CH,20]	;TYPE CODE
	CAIE	TB,CD.DAT
	JRST	B4.17
	IFN	CD.DAT-1,<
	ANDI	CH,077777
	IORI	CH,AS.DAT
	>
	PUSHJ	PP,PUTAS1
	JRST	B4.19
B4.17:	CAIE	TB,CD.TAG
	JRST	B4.18
	PUSHJ	PP,PUTAS1
	JRST	B4.19
B4.18:	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
B4.19:	MOVE	TB,PNTR
	TLNE	TB,770000
	JRST	B4.20		;NEED ANOTHER LIMIT
	HRRZI	TB,4
	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
	SOJG	TB,.-2		;4 HALFWORDS
B4.20:	SOSLE	CFLM
	JRST	B4.16
>
B5:	HRRZ	TA,CURFIL
	LDB	TD,FI.LRS	;[236] GET LABEL RECORD SIZE
	SKIPN	TD		;[236]
	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.LRS
	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.LRS
	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

;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
IFN DBMS,<
;**;[401],ECLND+3.5,DPL,29-JAN-76
	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
	>
IFN ANS74,<
	MOVE	TC,[USES,,USP.I##]	;COPY INPUT, OUTPUT, I-O, EXTEND
	BLT	TC,USP.X##	;TO SAFE PLACE FOR PHASE "E"
>
	MOVEI	TC,0
	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

;**;[401],EC1-3.5,DPL,29-JAN-76
IFN DBMS,<SETOM DBONLY##>	;[401] TURN ON SINCE AT LEAST ONE USE IS NON-DBMS
	MOVE	CH,[XWD AS.XWD,SZ.OUS]
	PUSHJ	PP,PUTAS1

	SETZB	TA,CTR
EC1:	SETZM	TBLOCK
	HRRZI	CH,AS.CNB
	PUSHJ	PP,PUTAS1
	HRRZ	TA,USES(TA)
EC1.A:	PUSHJ	PP,CHKUSE
IFN ANS74,<
	JUMPE	TA,EC1.D	;NOT USE PROCEDURE
	MOVE	TB,CTR
	CAILE	TB,2		;ONLY CARE ABOUT FIRST 3
	JRST	EC1.D
	XOR	TA,CURPRO	;BETTER MAKE SURE
	TRNE	TA,-1
	JRST	EC1.D		;STILL NOT PROCEDURE
	HRRZ	TA,CURPRO
	LDB	TA,PR.SFI	;GET TAG
	MOVEM	TA,USP.I##(TB)	;STORE IT
EC1.D:>
	AOS	TB,TBLOCK
	CAILE	TB,^D8
	JRST	EC1.C
	HRRZ	TA,USEPTR-1(TB)
	ADD	TA,CTR
	HRRZ	TA,(TA)
	JRST	EC1.A

EC1.C:	AOS	TA,CTR
	CAIG	TA,2
	JRST	EC1

	HRRZI	TC,SZ.OUS
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,

CHKUSE:	HRRZI	CH,AS.CNB
	JUMPE	TA,PUTAS1
	LDB	TC,[POINT 3,TA,20]
	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
IFN DBMS,<

;SCAN USETAB FOR 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##	;THIS AN ERROR-STATUS ENTRY?
	CAIE	TB,%UT.ES
	JRST	CUSET4		;NO

	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

	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
	JRST	CUSET3

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

	>
;ADDRESS OF USE ENTRIES IN "USES"

USEPTR:	XWD 0,USES+^D3	;BEFORE BEGINNING REEL
	XWD 0,USES+^D6	;BEFORE BEGINNING FILE
	XWD 0,USES+^D9	;AFTER BEGINNING REEL
	XWD 0,USES+^D12	;AFTER BEGINNING FILE
	XWD 0,USES+^D15	;BEFORE ENDING REEL
	XWD 0,USES+^D18	;BEFORE ENDING FILE
	XWD 0,USES+^D21	;AFTER ENDING REEL
	XWD 0,USES+^D24	;AFTER ENDING FILE

CLE1.:	HRRZI	DW,E.202		;NO DEVICES
	JRST	CLER2.
CLE2.:	HRRZI	DW,E.201		;NO DATA RECORDS
	JRST	CLER.
CLE4.:	HRRZI	DW,E.199		;VAL-ID AND VAL-DW REQUIRED
	JRST	CLER.
CLE5.:	HRRZI	DW,E.198		;LABELS MUST BE STANDARD
	JRST	CLER.
CLE6.:	HRRZI	DW,E.197		;ONLY ONE DEVICE ALLOWED
	JRST	CLER2.
IFN ANS68,<
CLE7.:	HRRZI	DW,E.196		;MULTIPLE REEL/UNIT NOT ALLOWED
	JRST	CLER.
CLE10.:	HRRZI	DW,E.193		;FILE-LIMITS REQUIRED
	JRST	CLER2.
CLE11.:	HRRZI	DW,E.192		;'BLOCK CONTAINS N RECORDS' MUST BE SPECIFIED
	JRST	CLER.
>
CLE12.:	HRRZI	DW,E.97			;NO FD
	JRST	CLER2.
CLE13.:	HRRZI	DW,E.365		;FILE MUST BE ASCII IF WRITE ADV BIT ON
	JRST	CLER2.

IFN ANS68,<
CLE14.:	LDB	TB,[POINT	3,TC,20]
	CAIE	TB,CD.PRO
	JRST	CLE14A
	MOVEM	CH,TBLOCK+11
	MOVEM	TC,TBLOCK+12
	MOVEM	TD,TBLOCK+13
	MOVEM	TE,TBLOCK+14
	HRRZ	TA,CH
	PUSHJ	PP,LNKSET
	LDB	TA,PR.FLO##
	ADD	TA,FLOLOC
	LDB	LN,FL.LN##
	LDB	CP,FL.CP##
	HRRZI	DW,E.505	;CONFLICTING USES
	PUSHJ	PP,FATAL##
	MOVE	DW,TBLOCK+12
	PUSHJ	PP,PUTERA##
	MOVE	CH,TBLOCK+11
	MOVE	TC,TBLOCK+12
	MOVE	TD,TBLOCK+13
	SKIPA	TE,TBLOCK+14
CLE14A:	SETZM	USES(TD)
	POPJ	PP,

CLE15.:	HRRZI	DW,E.301
	JRST	CLER2.		;BLOCKING FACTOR MUST BE GT. 0 FOR I-O USE
>
CLE18.:	HRRZI	DW,E.579	;ADVANCING AND POSITIONING FOR THE SAME FILE.
	PJRST	CLER2.
CLE19.:	HRRZI	DW,E.585	;ONLY DENSITIES OF 800 AND 1600 BPI
	PJRST	CLER2.		; ARE ALLOWED ON STANDARD ASCII FILES.
IFN ANS68,<
CLE20:	HRRZI	DW,E.374	;SYMBOLIC KEY & REC KEY NOT SAME CLASS
	PUSHJ	PP,CLER2.
	JRST	B4.SK1
CLE21:	HRRZI	DW,E.375	;SYMBOLIC KEY & REC KEY NOT SAME USAGE
	PUSHJ	PP,CLER2.
	JRST	B4.SK2
CLE22:	HRRZI	DW,E.376	;SYMBOLIC KEY & REC KEY NOT SAME SIZE
	PUSHJ	PP,CLER2.
	JRST	B4.SK3
CLE23:	HRRZI	DW,E.377	;SYMBOLIC KEY & REC KEY NOT SAME # DEC PLACES
	PUSHJ	PP,CLER2.
	JRST	B4.SK4
>
CLE24:	HRRZI	DW,E.378	;INDEXED FILE MUST BE 6BIT OR ASCII
	JRST	CLER2.
CLE25:	HRRZI	DW,E.379	;RECORD KEY NOT IN RECORD
	PUSHJ	PP,CLER2.
	JRST	B4.SK5
IFN ANS68,<
CLE26.:	HRRZI	DW,E.393	;SYMBOLIC KEY REQUIRED
	PUSHJ	PP,CLER2.
	MOVEI	TB,100001	;DUMMY DATAB ENTRY
	JRST	B4.IX1
>
CLE27.:	HRRZI	DW,E.394	;RECORD KEY REQUIRED
	PUSHJ	PP,CLER2.
	MOVEI	TC,100001	;DUMMY DATAB ENTRY
	JRST	B4.IX2
CLE28.:	HRRZI	DW,E.566	;EBCDIC FILES MAY NOT
	PJRST	CLER2.		;HAVE NON-STANDARD LABELS.
CLE29.:	HRRZI	DW,E.596	;CAN NOT BE BYTE MODE AND BINARY
	PUSHJ	PP,CLER2.
	JRST	B4.16D		;SO IGNORE BYTE MODE
CLE30.:	HRRZI	DW,E.623	;BLOCKING FACTOR TOO SMALL
	PJRST	CLER2.

CLER.:	SKIPE	TBLOCK+20
	POPJ	PP,
CLER2.:	HRRZ	TA,CURFIL
	LDB	LN,FI.LN
	LDB	CP,FI.CP
	JRST	FATAL##
PUTBYT:	JUMPE	CH,PBYT0
	LDB	TB,[POINT	3,CH,20]
	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]
	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
PBYT0:	MOVE	CH,[XWD	AS.OCT,1]
	PUSHJ	PP,PUTAS1
	SETZ	CH,
	JRST	PUTAS1
;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,[POINT 3,TA,20]
	CAIE	TB,CD.PRO
	JRST	PFZOUT

IFN DBMS,<PUTPR2:	>	;ENTER HERE FOR ERROR-STATUS PROCEDURES
	HRLZM	TA,CURPRO##
	PUSHJ	PP,LNKSET
	HRRM	TA,CURPRO
	LDB	CH,PR.PRF##
	JUMPN	CH,PRFOUT
	PUSHJ	PP,GETTAG##
	HRRZ	TA,CURPRO
	DPB	CH,PR.PRF
IFN ANS74,<
	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
IFN ANS74,<
	SKIPE	RELKEY##	;NEED %PARAM+0 FOR CONVERSION?
	ADDI	TB,1		;YES
>
	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

DEFINE	TABSET	(A,B,C,D,E,F)<

IFDIF <A><NAM><EXTERNAL A'LOC
	XWD	A'LOC,E
	>>

CLENTT:	TABLES
CLENTX:	XWD	CLENTT-.,CLENTT

INTERN	CLENTX

CLENTA:	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
	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

	TTCALL	3,[ASCIZ "%COULDN'T WRITE NAMTAB
%COMPILATION CONTINUING WITHOUT MAPS OR OBJECT LISTING
"]
	SWOFF	FMAP!FOBJEC

CLENTB:	CLOSE	NAM,
	HRRZ	TE,FREESP##	;REDUCE SIZE OF IMPURE AREA
	IORI	TE,1777
	CALLI	TE,$CORE
	JRST	CLENTE		;IGNORE ERRORS

IFN DEBUG,<EXTERN LSTMES,PUTLST,LCRLF

	MOVE	TE,[POINT 7,[ASCIZ "REDUCED CORE TO "]]
	PUSHJ	PP,LSTMES
	HRRZ	TE,.JBREL
	ADDI	TE,1
	LSH	TE,-^D10
	PUSHJ	PP,CLENTD
	MOVEI	CH,"K"
	PUSHJ	PP,PUTLST
	PUSHJ	PP,LCRLF
	JRST	CLENTE

CLENTD:	IDIVI	TE,^D10
	HRLM	TD,(PP)
	SKIPE	TE
	PUSHJ	PP,CLENTD
	HLRZ	CH,(PP)
	ADDI	CH,"0"
	JRST	PUTLST
	>

CLENTE:	MOVE	TE,.JBREL##
	ADDI	TE,1
	HRRZM	TE,TOPLOC##

	SUB	TE,FREESP
	HRLM	TE,FREESP
	POPJ	PP,


	END