; UPD ID= 3507 on 5/4/81 at 10:53 AM by NIXON                           
TITLE	COBOLB	FOR COBOL V12B
SUBTTL	ID AND ED CONTROL PROGRAM	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, 1981 BY DIGITAL EQUIPMENT CORPORATION


	SEARCH	P
	%%P==:%%P
	DEBUG==:DEBUG
	RPW==:RPW
	ISAM==:ISAM
	BIS==:BIS

;EDITS
;V12*****************
;NAME	DATE		COMMENTS

;DMN	16-MAY-80	[1021] FIX ERROR CAUSE BY LOWER CASE LITERAL IN PROGRAM-ID.
;DMN	26-SEP-79	[740] FIX SOURCE-COMPUTER. WITH NO COMMENT ENTRY
;DMN	30-APR-79	[702] LIST COMMENTS IN DATE-COMPILED PARAGRAPH.
;EHM	17-SEP-78	[553] GIVE WARNING IF RECORDS/RERUN TO LARGE

;V10*****************
;NAME	DATE		COMMENTS
;	27-JUL-77	[505] ADD CHECKS SO "KEY" TYPE MATCHES ACCESS MODE
;EHM	3-JUN-77	[501] ENFORCE NO PRINTER CHANNEL GREATER THAN 8
;	6-APR-76	[422] FIX LOSS OF FIRST CHAR IN DATE=COMPILED OR SOURCE-COMPUTER STATEMENTS
;ACK	12-JAN-75	ADDED ROUTINES FOR:
;			1.  RECORDING MODE IS STANDARD-ASCII/F/V.
;			2.  RECORDING DENSITY IS 1600.
;			3.  I/O ERROR RECOVERY.
;********************

; EDIT 355 ALLOW FOR 1 BUFFER, ALSO CHECK FOR MAX OF 62 ALTERNATE AREAS.
; EDIT 277 FIX CODE FOR OBJECT AND SOURCE COMPUTER STATEMENTS TO HANDLE LC LETTERS.
; EDIT 175 FIXES ERROR RECOVERY FOR SELECT STATEMENTS ERRORS
; EDIT 153 FIXES NUMERIC DATA IN DATE-WRITTEN SKIPPING NEXT PARA.


TWOSEG
RELOC	400000

	SALL
ENTRY	COBOLB

EXTERN	BTREE
EXTERN	FNDLNK,KILL,LITVAL
EXTERN	SAVETA,SAMSRT
EXTERN	CTR,GETVAL
EXTERN	PNTR
EXTERN	TRYNAM,CPYBHO
EXTERN	CFLM,FI.SDL
EXTERN	LNKSET
EXTERN	PROGID
EXTERN	NAMWRD,NAMADR,BLDNAM,GETENT,PUTLNK,OBJSIZ
EXTERN	DOLLR.,STDATE,PUTCPY,GETITM
EXTERN	FILLOC,TBLOCK,ESIZE,VALADR,CURNAM
EXTERN	LSIZE,MNETYP,SKPSRC
EXTERN	CURVAL
EXTERN	FI.LNC,FI.ERM,FI.LBL,FI.ACC
EXTERN	FI.RCT,FI.MLT
EXTERN	FI.IRM,FI.NXT,FI.OPT,FI.NDV,FI.VAL,FI.NBF
EXTERN	FI.SRA,FI.RRC,FI.RER,FI.SAL,FI.POS
EXTERN	FI.RM2,FI.RD,FI.RP
IFN ANS74,<
EXTERN	FI.RMS
EXTERN	CURAKT,AK.DUP,AK.FLK
>
EXTERN	ISVPTR,INDPTR,CURFIL,LSTFIL
EXTERN	SQURL.,SEGLIM
EXTERN	KILL
EXTERN	CURHLD,HL.NAM,HL.COD,HL.LNC,HL.QAL,HL.LNK
EXTERN	HLDLOC
IFN DEBUG,<
EXTERN	CORESW,TRACEI,TRACEE
	>
COBOLB:	SETFAZ	B;		;INIT PHASE B
	MOVE	SAVPTR,ISVPTR	;INITIALIZE SAVE LIST POINTER
	MOVE	NODPTR,INDPTR	;INITIALIZE NODE POINTER
IFN DEBUG,<
	MOVE	TE,CORESW
	SWOFF	FNDTRC		;CLR TRACE REQUEST
	TRNE	TE,TRACEI	;TRACE ID NODES?
	SWON	FNDTRC		;YES, TURN ON TRACER
	>
	HRRZI	TA,62		;50 DECIMAL IS SEGLIM INITIAL VALUE
	MOVEM	TA,SEGLIM
	HRRZI	TA,ID0.##	;AIM AT FIRST ID NODE
	PUSH	NODPTR,TA
	SETZM	CURFIL		;INIT FILE TABLE PTRS
	SETZB	W2,LSTFIL
	PUSHJ	PP,SQURL.	;START SCAN
	OUTSTR	[ASCIZ "COBOLB--lost; too many POPJ's
"]
	JRST	KILL

SUBTTL	ACTIONS FOR ID AND ED SYNTAX PROCESSING

;CHECK FOR PERIOD, THEN SKIP TO END OF PARAGRAPH
;MUST ALSO WATCH FOR THERE BEING NOTHING TO SKIP

IFN FT68274,<
	INTER.	IA0B.
IA0B.:	SETOM	CVTCCF##	;TURN THIS LINE INTO A COMMENT
	SETOM	CVTCAL##	;AND ALL FOLLOWING ONES
	PUSHJ	PP,IA0A.	;READ REST OF PARAGRAPH
	SETZM	CVTCCF		;TURN OF COMMENT FOR THIS LINE
	SETZM	CVTCAL		;AND FOR REST OF LINES
	POPJ	PP,
>

	INTER.	IA0A.
IA0A.:
IFN ANS74!FT68274,<
	SETOM	NOIDHY##	;SET HYPHEN CONTINUATION NOT ALLOWED
>
;HACK TO PREVENT FIRST WORD OF PARAGRAPH FROM GOING TO THE CREF LISTING.
	PUSH	PP,CREFSW##	;SAVE THE STATE OF THE CREF SWITCH.
	SETZM	CREFSW##	;DON'T CREF WHILE CHEKING FOR PERIOD.
	PUSHJ	PP,CKPERI	;CHECK FOR PERIOD.
	POP	PP,CREFSW##	;RESTORE THE CREF SWITCH TO IT'S ORIGINAL STATE.
IA0.S:
IFN ANS74!FT68274,<
	TRNN	TYPE,AMRGN.	;A-MARGIN?
	PUSHJ	PP,IA0.		;NO, SKIP TO END OF PARAGRAPH
	SETZM	NOIDHY		;TURN IT BACK ON
IFN ANS74,<
	SETZM	DCCFLG		;OUT OF DATE-COMPILED NOW
>
	POPJ	PP,
>
IFN ANS68,<
	TRNE	TYPE,AMRGN.	;A-MARGIN?
	POPJ	PP,		;YES, NEW PARAGRAPH.
	SKPNAM
>

;SKIP TO END OF PARAGRAPH, PASSING DATA TO LISTING FILE

	INTER.	IA0.
IA0.:	SWOFF	FNOCPY		;TURN OFF 'NO LISTING' FLAG
	TRZ	FGTPER		;[153] DON'T GET PERIOD FROM GETITM
	PUSHJ	PP,SKPPGF##	;SKIP TO END OF PARAGRAPH
IA0.N:	PUSHJ	PP,GETITM	;GET A SOURCE ITEM
	SKPNAM

;SET TO REGET LAST ITEM SEEN

	INTER.	IA0.R
IA0.R:	SWON	FREGWD		;SET REGET WORD BIT
	POPJ	PP,

;TURN OFF REGET WORD FLAG

	INTER.	IA0.A
IA0.A:	SWOFF	FREGWD;
	POPJ	PP,

;ADVANCE TO NEXT WORD

	INTER.	IA0.G
IA0.G:	SWOFF	FREGWD		;CLR REGET WORD FLAG
	PJRST	GETITM		;GET NEXT ITEM
;FLAG MISSING IDENTIFICATION DIVISION, THEN TRY ITEM AGAIN

	INTER.	IA0E1.
IA0E1.:	EWARNW	E.1		;NO IDENTIFICATION DIV.
	JRST	IA0.R		;SET TO REGET WORD

;IF /S NOT SEEN, SET /S AND TRY AGAIN, GIVE WARNING

	INTER.	IA0S1.
IA0S1.:	TSWFS	FSEQ		;WAS /S SEEN
	EWARNJ	E.1		;YES, GIVE OLD MESSAGE
	EWARNJ	E.601		;NO, GIVE NEW MESSAGE

IFN ANS74,<
	INTER.	IA0.ID
IA0.ID:	MOVSI	TE,'ID '	;ID IS NOT ANSI STANDARD
	CAMN	TE,NAMWRD	;SO IF THATS WHAT WE SAW
	FLAGAT	NS		;FLAG IT
	POPJ	PP,
>

;FLAG ILLEGAL PARAGRAPH, THEN SKIP TO NEXT PARAGRAPH

	INTER.	IA0E7.
IA0E7.:	EWARNW	E.7		;'ILLEGAL PARAGRAPH NAME'
	JRST	IA0.

;FLAG ILLEGAL SECTION, THEN SKIP TO NEXT PARAGRAPH

	INTER.	IA0E43
IA0E43:	EWARNW	E.43		;'ILLEGAL SECTION NAME'
	JRST	IA0.
;OBJECT COMPUTER WASN'T 'DECSYSTEM-10' SEE IF IT'S 'DECSYSTEM-10NN'.

	INTER.	IA0E5.
IA0E5.:	MOVE	TA,	[SIXBIT	/DECSYS/]	;CHECK THE FIRST PART.
	MOVE	TB,	[SIXBIT /TEM:10/]
	CAMN	TA,	NAMWRD##
	CAME	TB,	NAMWRD##+1
	JRST		IA0E5E		;[740] IT'S NOT 'DECSYSTEM-10', COMPLAIN.

	MOVE	TA,	NAMWRD##+2	;GET THE NN PART.
	SETZI	TC,
IA0E5D:	SETZI	TB,
	IMULI	TC,	^D10
	LSHC	TB,	6
	CAIL	TB,	'0'
	CAILE	TB,	'9'
	JRST		IA0E5H		;IT'S NOT A NUMBER, COMPLAIN.
	ADDI	TC,	-20(TB)
	JUMPN	TA,	IA0E5D

	JRST		IA0.A		;CLEAR REGET WORD BIT.

IA0E5E:	CAIG	TYPE,ENDIT.+AMRGN.	;[740] SEE IF RESERVED WORD
	TRNN	TYPE,AMRGN.	;[740] IN THE "A" MARGIN
	JRST	IA0E5H		;[740] NO
	MOVEI	NODE,ED269.##	;[740] YES, SET RETURN ADDRESS
	MOVEM	NODE,0(NODPTR)	;[740] SO WE CAN RECOVER CORRECTLY
	SWONS	FREGWD		;[740] MAKE SURE WE REGET THIS WORD
				;[740] AND WARN THE USER

IA0E5H:	SWOFF	FREGWD;		;CLR REGET WORD BIT.
	EWARNJ	E.5		;'DECSYSTEM-10/20 ASSUMED'.

;STOP SOURCE FROM GOING TO LISTING FOR DATE-COMPILED

	INTER.	IA1.
IA1.:	FLAGAT	HI
	SWON	FNOCPY		;SET NO LISTING BIT
	POPJ	PP,

	INTER.	IA1.N
IA1.N:	SWON	FNOCPY		;SET NO LISTING BIT
	PUSHJ	PP,SKPNW.	;SKIP BLANKS ETC.
	JRST	IA0.G		;GET NEXT ITEM

;START SOURCE GOING TO LISTING AGAIN

	INTER.	IA1.L
IA1.L:	SWOFF	FNOCPY		;CLEAR NO LISTING BIT
	POPJ	PP,
;GET NEXT ITEM & VERIFY THAT IT IS A PERIOD
;IF NOT A PERIOD, FLAG IT

CKPERI:	PUSHJ	PP,GETITM	;READ FOR PERIOD
	LDB	TA,[POINT 10,TYPE,35]	;GET TYPE OF ITEM
	CAIN	TA,PRIOD.	;IS IT A PERIOD?
	JRST	IA0.N		;IF PERIOD THERE GET NEXT ITEM FOR CONSISTENCY
	SKPNAM			;NO, GIVE PERIOD ASSUMED MSG

	INTER.	BE125.
BE125.:	MOVE	LN,BLNKLN##
	MOVE	CP,BLNKCP##
	HRRZI	DW,E.125	;DIAGNOSTIC 125
	SWON	FREGWD		;READ THAT AGAIN LATER
	JRST	WARN##		;WARNING ONLY


;SKIP TO START OF NEXT WORD
;THE TRICK IS TO FIND A CHARACTER IN THE A-FIELD OR B-FIELD THAT IS NOT
;EITHER A SPACE, TAB, OR HYPHEN
;(ASTERISKS ARE FILTERED OUT AT A MUCH EARLIER STAGE)

SKPNW.:	PUSHJ	PP,SKPSRC	;GET NEXT SOURCE CHAR.
	CAIN	CP,7		;ALREADY AT COLUMN 7?
	JRST	SKPNW2		;YES, WHAT KIND OF CHAR.?
	JRST	SKPNW4		;MUST BE IN A-FIELD OR B-FIELD
SKPNW1:	PUSHJ	PP,SKPSRC	;GET CHARACTER
SKPNW2:	TSWF	FEOF		;END-OF-FILE?
	JRST	END2##		;EOF FOUND
	CAIN	CP,7		;COLUMN 7?
	CAIE	CH," "		;YES, SPACE?
	JRST	SKPNW1		;NO, MUST BE A HYPHEN OR NOT COL. 7
SKPNW3:	PUSHJ	PP,SKPSRC	;GET CHARACTER
	TSWF	FEOF		;END-OF-FILE?
	JRST	END2		;YES
SKPNW4:	CAIN	CH," "		;IS IT A SPACE?
	JRST	SKPNW3		;YES
	CAIL	CH,"a"		;ABOVE LOWER CASE A?
	MOVEI	CH,-40(CH)	;YES MOVE IT INTO THE UPPER CASE SET.
	CAIL	CH,"A"		;IS IT ALPHABETIC?
	CAILE	CH,"Z"
	JRST	SKPNW2		;NOT A LETTER
	JRST	END2		;REGET LAST CHARACTER
;GET PROGRAM TITLE
;IF NO NAME GIVEN, GIVE IT THE NAME 'MAIN'

	INTER.	IA2.
IA2.:	SKIPE	PROGID		;'PROGRAM-ID' SEEN ALREADY?
	EWARNJ	E.3		;YES, DUPLICATE PARAGRAPH
	PUSHJ	PP,CKPERI	;GET THE PERIOD
	TRNN	TYPE,AMRGN.	;AT THE A-MARGIN?
	JRST	IA2.0		;NO
IA2.2:	MOVE	TD,[SIXBIT /MAIN/]	;YES, NO ID THERE
	MOVEM	TD,NAMWRD	;SO GIVE IT A DUMMY NAME
	TSWF	FDSKC		;CCL?
	OUTSTR	[ASCIZ /MAIN/]
IA2SUB:	MOVEM	TD,PROGID	;STORE RESULT
	TSWT	FDSKC		;CCL OR CMD FILE?
	JRST	IA2SU3		;NO
	OUTSTR	[ASCIZ /  [/]	;PRINT "[FILNAM.EXT]"
	MOVEI	TA,'.'		;PUT A DOT WHERE THERE IS A SPACE
	DPB	TA,[POINT 6,SRCFIL+1,5]
	MOVE	TA,[POINT 6,SRCFIL##]
	MOVEI	TB,^D10
IA2SU2:	ILDB	TC,TA
	ADDI	TC,40		;CONVERT TO ASCII
	CAIE	TC,40		;SPACE?
	OUTCHR	TC		;NO, PRINT IT
	SOJG	TB,IA2SU2
	SETZ	TA,		;CLR '.' AGAIN
	DPB	TA,[POINT 6,SRCFIL+1,5]
	OUTSTR	[ASCIZ /]
/]
IA2SU3:	SETZM	NAMWRD+1
	MOVE	TA,[NAMWRD+1,,NAMWRD+2]
	BLT	TA,NAMWRD+5
	PUSHJ	PP,TRYNAM	;PROGRAM-ID A RESERVED WORD?
	  JRST	.+3		;NO
	EWARNW	E.315		;YES
	JRST	IA2.2		;TRY IT WITH "MAIN"

	PUSHJ	PP,BLDNAM	;MAKE NAMTAB ENTRY
	HLRS	TA
	DPB	TA,[POINT 15,W2,15]	;SAVE NAMTAB LINK
	MOVE	TA,[CD.EXT,,SZ.EXT]	;PUT PROGRAM-ID IN EXTAB
	PUSHJ	PP,GETENT
	HLRM	TA,PIDLNK##	;SAVE EXTAB LINK
	LDB	TB,[POINT 15,W2,15]
	IORI	TB,<CD.EXT>B20	;EXT FLAG + NAMTAB LINK
	MOVSM	TB,(TA)		;TO 1ST WORD OF ENTRY
	SETO	TC,		;SET PROG-ID FLAG
	DPB	TC,EX.PID##
	DPB	TC,EX.ENT##	;ALSO SET ENTRY FLAG
	HRRI	TA,(TB)		;LINK NAMTAB TO EXTAB
	PJRST	PUTLNK
IA2.0:	PUSHJ	PP,GETITM	;REGET SOURCE ITEM AFTER THE PERIOD
	SKIPE	NAMWRD		;IS IT A USER-NAME?
	JRST	IA2.12		;YES
	SKIPE	LITVAL		;IS IT A LITERAL?
	JRST	.+3		;YES
	EWARNW	E.4		;NEITHER A WORD NOR A LITERAL
	JRST	IA2.2		;USE "MAIN"
	MOVE	TD,[POINT 6,NAMWRD]	;SET PTRS TO MOVE THE
	MOVE	TE,[POINT 7,LITVAL]	;LITERAL INTO THE NAMWRD TABLE
	LDB	TB,GWVAL##	;GET # OF CHARS
	CAILE	TB,6		;IF LESS THAN OR = SIX, USE IT
	MOVEI	TB,6		;SET CTR FOR 1ST 6 CHARS
IA2.11:	ILDB	TA,TE		;GET LITERAL CHARACTER
	JUMPE	TA,IA2.12	;END OF LITERAL
	CAIL	TA,"a"		;[1021] CHECK FOR LOWER CASE
	CAILE	TA,"z"		;[1021]
	TRNA			;[1021]
	SUBI	TA,40		;[1021] AND CONVERT TO UPPER CASE
	CAIL	TA,"0"		;LETTER OR DIGIT?
	CAILE	TA,"Z"
	JRST	IA2110		;NO
	CAILE	TA,"9"
	CAIL	TA,"A"
	TRNA			;YES
IA2110:	HRRZI	TA,":"		;CHANGE NON-LETTER/DIGIT TO POINT (:)
	HRRZI	TA,-40(TA)	;CONVERT TO SIXBIT
	IDPB	TA,TD		;PUT IN NAMWRD
	SOJG	TB,IA2.11	;CONT. IN LOOP UNTIL 6 CHARS MOVED
IA2.12:	SETZ	TD,		;INIT AC FOR RESULT
	MOVEI	TB,6		;CTR FOR 6 CHARS
	MOVE	TA,[POINT 6,NAMWRD]
IA2.N2:	ILDB	TC,TA		;GET 6BIT CHAR
	CAIN	TC,32		;IS IT A COLON (WHICH AROSE FROM A HYPHEN, ETC)?
	MOVEI	TC,16		;YES, CHANGE IT TO A DOT
	LSH	TD,6		;SHIFT PREVIOUS RESULT LEFT 6
	OR	TD,TC		;MERGE IN NEW CHAR
	TSWT	FDSKC		;CCL OR COMMAND FILE?
	JRST	IA2.N3		;NO, DONT PRINT NAME
	ADDI	TC,40		;CONVERT 6BIT TO ASCII
	OUTCHR	TC		;PRINT CHAR
IA2.N3:	SOJG	TB,IA2.N2	;CONT. THRU 6 CHARS.
	PUSHJ	PP,IA2SUB
	JRST	IA0.
;REPLACE DATE-COMPILED COMMENTS WITH TODAY'S DATE

	INTER.	IA4.
IA4.:
IFN ANS74!FT68274,<
	SETOM	NOIDHY##	;SET HYPHEN CONTINUATION NOT ALLOWED
>
	PUSHJ	PP,IA5SUB	;PUT SPACE AFTER 'DATE-COMPILED.'
	MOVE	TA,[POINT 7,STDATE]
	MOVEM	TA,PNTR		;POINTER FOR DATE
	MOVEI	TB,11		;9 CHARACTERS
	MOVEM	TB,CTR
IA4.G:	ILDB	CH,PNTR		;GET CHARACTER
	PUSHJ	PP,PUTCPY	;PUT ON LISTING
	SOSLE	CTR
	JRST	IA4.G
	HRRZI	CH,"."		;PUT A PERIOD AFTER DATE
	PUSHJ	PP,PUTCPY

	SWON	FNOCPY		;[702] TURN ON NO LISTING FLAG
	PUSHJ	PP,GETSRC##	;[702] READ NEXT CHARACTERS
	CAIE	CH,12		;[702] <CR-LF>
	JRST	.-2		;[702] NO, LOOK FOR END OF LINE
	SWOFF	FNOCPY		;[702] RE-ENABLE LISTING
	SWON	FREGCH		;[702] GET EOL AGAIN
IFN ANS74,<
	SETOM	DCCFLG##	;SIGNAL IN DATE-COMPILED COMMENT ENTRY.
>
IFE FT68274,<
	JRST	IA0.S		;AND SKIP REST OF PARAGRAPH
>
IFN FT68274,<
	TRNE	TYPE,AMRGN.	;A-MARGIN (SHOULDN'T BE)?
	POPJ	PP,		;YES, NEW PARAGRAPH.
	SETOM	CVTCAL		;NO, MAKE THE REST IN THIS PARAGRAPH A COMMENT
	PUSHJ	PP,IA0.S	;SKIP THE PARAGRAPH
	SETZM	CVTCCF		;THIS LINE IS NO LONGER A COMMENT
	SETZM	CVTCAL
	POPJ	PP,
>
;REENABLE LISTING, SEE IF LAST CHAR OUTPUT TO IT WAS "."
;IF SO, PUT A SPACE AFTER THE "."
;IF NOT, REPLACE WHATEVER IT WAS BY SPACE

IA5SUB:	SWOFF	FNOCPY		;ENABLE OUTPUT TO LISTING
	HRRZI	CH," "		;GET A SPACE
	LDB	TA,CPYBHO+1	;GET LAST CHAR PUT ON LISTING
	CAIN	TA,"."		;WAS IT A "."
	JRST	PUTCPY		;YES, PUT SPACE AFTER "."
	DPB	CH,CPYBHO+1	;NO, REPLACE IT BY SPACE
	POPJ	PP,


IFN CSTATS,<
;"WITH METER--ING" SPECIFIED
	INTER.	IA6.
IA6.:	FLAGAT	NS
	SETOM	METRSW##
	JRST	IA0.G		;GET NEXT
>;END IFN CSTATS

IFN ANS74,<
	INTER.	IA7.
IA7.:	FLAGAT	LI
	SETOM	DEBSW##		;SET DEBUG MODULE WANTED
	POPJ	PP,
>
;PUT SAVED INTEGER INTO OBJECT-COMPUTER MEMORY SIZE WORD

	INTER.	IA8.
IA8.:	POP	SAVPTR,TB	;GET INTEGER FROM SAVE LIST
IA8.1:	CAMN	TB,OBJSIZ	;IF INTEGER=OBJSIZ, IGNORE IT
	POPJ	PP,
	SKIPE	OBJSIZ		;OBJSIZ=0?
	EWARNJ	E.6		;NO, 'MORE THAN 1 OBJ-COMPUTR PARA'
	MOVEM	TB,OBJSIZ	;PUT INTEGER IN OBJSIZ
	POPJ	PP,

;CONVERT #MODULES TO #WORDS & PUT INTO OBJSIZ

	INTER.	IA9.
IA9.:	POP	SAVPTR,TB	;GET SAVED INTEGER
	IMULI	TB,^D1024	;#MODULES * 1K WORDS EACH
	JRST	IA8.1

;CONVERT #CHARACTERS (SIXBIT) TO #WORDS & PUT INTO OBJSIZ

	INTER.	IA10.
IA10.:	POP	SAVPTR,TB	;GET SAVED INTEGER
	ADDI	TB,5		;FORCE ROUNDING UPWARD
	IDIVI	TB,6		;N CHARS = N+5/6 WORDS
	JRST	IA8.1

;TURN OFF 'FILE OPTIONAL' FLAG

	INTER.	IA12.
IA12.:	SWOFF	FOPT		;OFF
IFN ANS74,<
	SETZM	RSLNCP##	;CLEAR ANY PREVIOUS SAVED LN & CP
	SETZM	ASLNCP##	;...
>
	POPJ	PP,

;TURN ON 'FILE OPTIONAL' FLAG

	INTER.	IA13.
IA13.:	FLAGAT	HI
	SWON	FOPT		;ON
	POPJ	PP,
;PUT SELECTED FILE-NAME IN FILE TABLE

	INTER.	IA14.
IA14.:	TLO	W2,GWDEF	;PUT DEFINING REFERENCE ON CREF FILE
	PUSHJ	PP,PUTCRF##
	TLNE	W1,GWNOT	;IS NAME IN NAMTAB?
	JRST	IA14.B		;NO--PUT IN
	HLRZ	TA,W2		;YES, GET NAMTAB RELATIVE ADDR.
	LSH	TA,-2
	HRLZM	TA,NAMADR	;SAVE IT
	JRST	IA14.C		;NOT FOUND--CREATE
IA14.B:	PUSHJ	PP,BLDNAM	;ENTER NAME IN NAMTAB
	MOVEM	TA,NAMADR	;SAVE ADDRESS
IA14.C:	MOVE	TA,CURFIL	;CURRENT FILE ENTRY ADDRESS
	MOVEM	TA,LSTFIL	;SAVE IT
	MOVE	TA,[XWD CD.FIL,SZ.FIL]	;GET 15-WORD FILTAB ENTRY
	PUSHJ	PP,GETENT
	MOVEM	TA,CURFIL	;SAVE ADDRESS OF CURRENT FILTAB ENTRY
	HLLZ	TB,NAMADR	;NAMTAB ENTRY REL.ADDR.
	MOVEM	TB,(TA)		;TO WORD 1 OF FILTAB ENTRY
	DPB	W2,FI.LNC	;LINE NUMBER, CHARACTER POSITION
	HRRZI	TB,%%RM		;INITIALIZE OPTIONS AS NOT YET DECLARED
	DPB	TB,FI.ERM	;EXT. RECORDING MODE
	DPB	TB,FI.IRM	;AND INT. RECORDING MODE
	MOVEI	TB,%%ACC	;MORE DEFAULTS
	DPB	TB,FI.LBL	;LABELS
	DPB	TB,FI.ACC	;ACCESS MODE
	TSWF	FOPT		;TEST WHETHER OPTIONAL FILE
	DPB	TB,FI.OPT	;SET FLAG IF IT IS
	AOS	TB,NFILES##	;GET # OF THIS FILE; BUMP COUNTER
	DPB	TB,FI.NUM##	;STORE FIELD IN COMPILER'S FILE-TABLE
	HLRZ	TA,LSTFIL	;REL.ADDR.OF LAST FILTAB ENTRY
	JUMPE	TA,IA14.D	;NULL PREVIOUS ENTRY
	HRRZ	TB,FILLOC	;STARTING ADDRESS OF FILTAB
	ADD	TA,TB		;ABS.ADDR. OF LAST FILTAB ENTRY
	HLRZ	TB,CURFIL	;REL. ADDR. OF CURRENT FILTAB ENTRY
	DPB	TB,FI.NXT	;'NEXT ENTRY' LINK
IA14.D:	HLLZ	TA,CURFIL	;ENTRY REL. ADDR.
	HLR	TA,NAMADR	;NAMTAB ENTRY REL. ADDR.
	JRST	PUTLNK		;LINK FILTAB & NAMTAB

;GET VALUE OF INTEGER & PUT ON SAVLST

	INTER.	IA16.
IA16.:	PUSHJ	PP,IA16S.	;GET VALUE OF INTEGER
	  HRRZI	TC,1		;ERROR -- ASSUME VALUE OF 1
IA16.A:	MOVE	LN,WORDLN##	;[553] GET LINE & CHAR POS. OF THE
	MOVE	CP,WORDCP##	;[553] INTEGER - SO WE CAN POINT TO
	MOVEM	LN,SAVPLN##	;[553] IT IF IT IS OUT OF
	MOVEM	CP,SAVPCP##	;[553] RANGE
	PUSH	SAVPTR,TC	;SAVE INTEGER VALUE ON SAVLST
	POPJ	PP,

;GET VALUE OF NUMERIC LITERAL
;CALL:	PUSHJ	PP,IA16S.
;	ERROR RETURN (MESSAGE BE25. GIVEN)
;	NORMAL RETURN (VALUE IN TC)

IA16S.:	HLRZ	TB,W1		;L.H. OF FIRST GETWRD PARAMETER
	TRNE	TB,GWNLIT	;IS THIS A NUMERIC LITERAL?
	TRNE	TB,GWDP		;YES, IS IT AN INTEGER?
	EWARNJ	E.25		;NO, 'POSITIVE INTEGER REQUIRED' -- EXIT
	HRRZI	TA,LITVAL	;ADDRESS OF INTEGER (ASCII STRING FORM)
	ANDI	TB,000777	;LENGTH OF STRING
	MOVEM	TB,CTR
	AOS	(PP)		;SKIP RETURN
	PJRST	GETVAL		;GET VALUE OF INTEGER

	INTER.	IA16C.
IA16C.:	PUSHJ	PP,IA16.	;[501] GET THE VALUE
	CAIL	TC,11		;[501] IF GREATER THAN 8
	EWARNW	E.99		;[501] TROUBLE
	POPJ	PP,

IFN ANS74,<
	INTER.	IA17.
IA17.:	SKIPN	FLGSW##		;NEED FIPS FLAGGER?
	POPJ	PP,		;NO
	SKIPE	TB,RSLNCP	;SEEN ORGANIZATION TYPE ALREADY?
	JRST	@[TST.HI		;SEQUENTIAL
		TST.HI			;RELATIVE
		TST.H]-1(TB)		;INDEXED
	HRLZM	LN,RSLNCP	;NO, SAVE FOR LATER
	HRRM	CP,RSLNCP
	POPJ	PP,

	INTER.	IA17A.
IA17A.:	SKIPN	FLGSW		;NEED FIPS FLAGGER?
	POPJ	PP,		;NO
	SKIPE	TB,ASLNCP	;SEEN ORGANIZATION TYPE ALREADY?
	JRST	@[TST.L		;SEQUENTIAL
		TST.LI			;RELATIVE
		TST.H]-1(TB)		;INDEXED
	HRLZM	LN,ASLNCP	;NO, SAVE FOR LATER
	HRRM	CP,ASLNCP
	POPJ	PP,
>
;GET DEVICE NAME

	INTER.	IA18.
IA18.:	TLNE	W1,GWLIT	;LITERAL?
	JRST	IA18.A		;YES
	TLNE	W1,GWHYF	;HYPHEN IN DEV-NAME?
	EWARNW	E.83		;YES, 'IMPROPER DEVICE NAME'
	SETZM	NAMWRD+1	;DELETE ALL BUT 6 CHARS
	MOVE	TA,[POINT 6,NAMWRD]	;PTR TO SIXBIT NAME
	MOVE	TB,[POINT 7,TBLOCK,6]	;PTR TO ASCII NAME STORE
	MOVNI	TD,6		;6 CHAR CTR
IA18.L:	ILDB	TC,TA		;GET CHARACTER OF NAME
	JUMPE	TC,IA18.M	;END OF NAME
	ADDI	TC,40		;CONVERT SIxBIT TO ASCII
	IDPB	TC,TB		;SAVE CHARACTER
	AOJL	TD,IA18.L	;CONTINUE UNTIL 6 CHARS
IA18.M:	ADDI	TD,6		;GET # OF CHARS IN NAME
IA18.N:	DPB	TD,[POINT 7,TBLOCK,6]
	IDIVI	TD,5		;GET LENGTH OF VALTAB ENTRY (INCL CHAR CNT)
	ADDI	TD,1		;AT LEAST 1 WORD
	MOVEM	TD,ESIZE	;SAVE ENTRY SIZE
	HRLI	TD,CD.VAL	;VALTAB CODE
	MOVE	TA,TD
	PUSHJ	PP,GETENT	;FIND VALTAB ENTRY
	MOVEM	TA,VALADR	;SAVE ADDRESS
	MOVE	TD,TBLOCK	;MOVE WORD OF NAME
	MOVEM	TD,(TA)		;TO VALTAB
	MOVE	TD,TBLOCK+1	;POSSIBLE 2ND WORD OF NAME
	SOSLE	ESIZE		;1 OR 2 WORDS NEEDED?
	MOVEM	TD,1(TA)	;2, STORE 2ND WORD
	HRRZ	TA,CURFIL	;ABS. ADDR. OF FILTAB ENTRY
	LDB	TB,FI.NDV	;DEVICE COUNT FOR CURRENT FILE
	ADDI	TB,1		;SET DEV COUNT UP BY 1
	DPB	TB,FI.NDV	;DEPOSIT NEW DEVICE COUNT
	LDB	TB,FI.VAL	;VALTAB LINK TO UNIT NAME
	JUMPN	TB,CPOPJ	;EXIT IF ALREADY SET
	HLRZ	TB,VALADR	;VALTAB POINTER
	DPB	TB,FI.VAL	;PUT LINK IN ENTRY
	POPJ	PP,
IA18.A:	MOVE	TA,[POINT 7,LITVAL]	;PTR TO LITERAL NAME
	MOVE	TB,[POINT 7,TBLOCK,6]	;PTR TO ASCII NAME STORE
	LDB	TD,GWVAL	;GET SIZE
	CAILE	TD,6		;6 CHAR AT MOST
	MOVEI	TD,6
	PUSH	PP,TD		;SAVE COUNT FOR LATER
IA18.B:	ILDB	TC,TA		;GET CHARACTER OF NAME
	CAIN	TC,":"		;TEST FOR END OF DEVICE
	JRST	IA18.C		;YES IT IS
	CAIL	TC,"0"		;LETTER OR DIGIT?
	CAILE	TC,"Z"
	JRST	IA18.E		;NO, 'IMPROPER DEVICE NAME'
	CAILE	TC,"9"
	CAIL	TC,"A"
	TRNA			;YES
	JRST	IA18.E		;NO, 'IMPROPER DEVICE NAME'
	IDPB	TC,TB		;SAVE CHARACTER
	SOJG	TD,IA18.B	;CONTINUE UNTIL 6 CHARS
	POP	PP,TD		;GET EXACT COUNT BACK
	JRST	IA18.N

IA18.E:	EWARNW	E.83		;NO, 'IMPROPER DEVICE NAME'
IA18.C:	MOVN	TD,TD		;GET MINUS WHATS LEFT
	POP	PP,TC		;CLEAN UP STACK
	JRST	IA18.M
;GET NUMBER OF ALTERNATE BUFFERS
;IN COBOL-74, THIS IS THE "NUMBER OF AREAS TO RESERVE" (I.E.
; ABSOLUTE NUMBER OF BUFFERS TO ALLOCATE).

	INTER.	IA19.
IA19.:	PUSHJ	PP,IA16S.	;GET VALUE OF INTEGER IN TC
	  POPJ	PP,		;NOT AN INTEGER
REPEAT 1,<			;Delete when LIBOL doesn't have
				; to be compatible with 12A.
				;Then change OPEN code in LIBOL.
IFN ANS74,<
	JUMPLE	TC,[EWARNJ E.643]	;MUST BE POSITIVE INTEGER
	SUBI	TC,2		; Remove the default size
	CAMN	TC,[-1]		;Did he say 1?
	 JRST	IA19A		;Yes, OK
>
>;END REPEAT 1
IFN FT68274,<
	ADDI	TC,2		;INCREASE SIZE BY 2 FOR -74
>
IFN ANS74!FT68274,<
;	JUMPLE	TC,[EWARNJ E.643]	;MUST BE POSITIVE INTEGER
>
	JUMPGE	TC,.+2		; [355] IF NEGATIVE SET TO
	SETOI	TC,		; [355] MAX-LIBOL WILL INTERPRET AS ONE BUFFER
	CAIG	TC,^D62		; [355] IF LESS THAN OR EQUAL TO 62
	JRST	IA19A		; [355]  OK, GO ON.
	EWARNW	E.587		; [355] OTHERWISE WARN USER.
	MOVEI	TC,^D62		; [355] SET TO MAX.
IA19A:
REPEAT 0,<			;Turn this code on when the REPEAT 1 above
				; is turned off.
IFN ANS74,<
	JUMPN	TC,IA19A1	;JUMP IF NOT ZERO SPECIFIED
	EWARNW	E.734		;"RESERVE 2 AREAS ASSUMED".
	MOVEI	TC,2		;GET DEFAULT VALUE.
IA19A1:
>;END IFN ANS74
>;end REPEAT 0
IFN FT68274,<
	MOVE	TB,TC		;GET THE NO. OF BUFFERS
	IDIVI	TB,^D10		;GET BOTH DIGITS
	MOVE	TD,CVTSCP##	;GET POINTER TO START OF INTEGER
	ADDI	TA,"0"		;MAKE UNITS ASCII
	JUMPE	TB,[DPB	TA,TD		;ONLY ONE DIGIT
		JRST	IA19A2]
	ADDI	TB,"0"		;MAKE TENS ASCII
	DPB	TB,TD
	IDPB	TA,TD
IA19A2:	IBP	TD		;ADVANCE TO THE NEXT CHAR
	CAME	TD,CVTBFP##	;DID WE EAT UP THE SPACE?
	JRST	IA19A3		;NO, MAKE SURE NO JUNK LEFT
	LDB	TA,CVTBFP	;YES, INSERT SPACE
	MOVEI	TB," "
	DPB	TB,CVTBFP
	IDPB	TA,CVTBFP
	JRST	IA19A4

IA19A3:	MOVEI	TA," "		;GET SPACE
	DPB	TA,TD		;WE ALREADY ADVANCED THIS CHAR
	TRNA		
	IDPB	TA,TD		;STORE SPACE
	CAME	TD,CVTBFP	;ARE WE THERE YET?
	JRST	.-2		;NO
IA19A4:>
	HRRZ	TA,CURFIL	;FILTAB ENTRY ABSOLUTE ADDRESS
	LDB	TB,FI.NBF	;GET NUMBER OF BUFFERS FIELD
	JUMPE	TB,IA19.P	;RESERVE CLAUSE SEEN ALREADY?
	CAIE	TB,(TC)		;YES, IS THIS THE SAME VALUE?
JBE16.:	EWARNJ	E.16		;NO, 'DUPLICATE CLAUSE' MSG
	POPJ	PP,

;INDICATE NO ALTERNATE BUFFERS
IFN ANS68,<
	INTER.	IA20.
IA20.:
IFN FT68274,<
	MOVEI	TA,[ASCIZ /NO/]
	MOVEI	TB,[ASCIZ / 1/]
	PUSHJ	PP,CVTRCW	;REPLACE NO BY 1
>
	HRRZ	TA,CURFIL	;FILTAB ENTRY ABS. ADDR.
	LDB	TB,FI.NBF	;GET NUMBER OF BUFFERS FIELD
	CAILE	TB,1		;0 OR 1?
	EWARNJ	E.16		;NO, GIVE 'DUPLICATE CLAUSE' MSG
	HRRZI	TC,1		;SET TO 1 BUFR (NO ALTERNATES)
>
IA19.P:	DPB	TC,FI.NBF	;INSERT NO. OF EXTRA BUFFERS IN FILTAB ENTRY
	POPJ	PP,
;CHECK FOR MORE THAN 1 ORGANIZATION MODE SETTING PER FILE

	INTER.	IA21.
IA21.:
IFN ANS74,<
	PUSHJ	PP,IA21F.	;TEST FIPS FLAGGER
>
IFN FT68274,<
	MOVEI	TA,[ASCIZ /ACCESS/]
	MOVEI	TB,[ASCIZ /ORGANIZATION/]
	PUSHJ	PP,CVTRCW	;REPLACE ACCESS BY ORGANIZATION
>
	HRRZ	TA,CURFIL	;AIM AT CURRENT FILTAB ENTRY
	LDB	TB,FI.ACC	;GET CURRENT SETTING OF ACCESS MODE BITS
	CAIN	TB,3		;IS IT AT INITIAL VALUE?
	POPJ	PP,		;YES
	HRRZI	TA,ED12.##	;AFTER DOING BE16., GO TO SYNTAX NODE ED12.
	MOVEM	TA,(NODPTR)
	EWARNJ	E.16		;'DUPLICATE CLAUSE'

IFN ANS74,<
IA21F.:	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)
>
;SAVE SYMBOLIC KEY CODE FOR HLDTAB
IFN ANS68,<
	INTER.	IA22.
IA22.:
IFN ISAM,<
IFN FT68274,<
	PUSHJ	PP,CVTCTC##	;TURN SYMBOLIC KEY CLAUSE INTO A COMMENT
	PUSHJ	PP,CVTDPL##	;DUMP THE PREVIOUS LINE
	SETZM	CVTCPF##	;NOT A COMMENT
	SETZM	CVTPXC##	;NO EXTRA CHARACTERS
	SETOM	CVTPLF##	;BUT REAL DATA
	MOVE	TD,[POINT 7,IA22X.]	;COPY MESSAGE
	PUSHJ	PP,CVTTPL##	;TO PREVIOUS LINE BUFFER
>
	HRRZ	TA,CURFIL	;[505] ABS. ADDR. OF FILTAB ENTRY
	LDB	TB,FI.ACC	;[505] GET ACCESS MODE
	CAIE	TB,%%ACC	;[505] IS IT THE "DEFAULT"?
	CAIN	TB,%ACC.I	;[505] NO, INDEXED?
	JRST	IA22A.		;[505] YES, OK
	MOVEI	DW,E.595	;[505] NO, ERROR - WRONG TYPE KEY
	PUSHJ	PP,FATALW##	;[505] FLAG IT
	HRRZI	TB,%HL.AK	;[505] GET PROPER CODE
	SKIPA			;[505]
IA22A.:	HRRZI	TB,%HL.SY	;[505] GET CODE
	JRST	IA24X.
	>
IFE ISAM,<EWARNJ E.91>		;?NOT IMPLEMENTED
>

IFN FT68274,<
IA22X.:	ASCIZ	/	ACCESS MODE IS DYNAMIC
/
>

;SAVE RECORD KEY CODE FOR HLDTAB

	INTER.	IA22R.
IA22R.:
IFN ISAM,<
	FLAGAT	H
	HRRZI	TB,%HL.RC	;GET CODE
	JRST	IA24X.
	>
IFE ISAM,<EWARNJ E.91>		;?NOT IMPLEMENTED


IFN ANS74,<

;HERE WHEN PARSED "ALTERNATE.." AND EXPECTING "RECORD KEY IS.."

	INTER.	IA22K.
IA22K.:
 IFN ISAM,<
	FLAGAT	H
	MOVE	TA,CURFIL
	LDB	TB,FI.ACC	;GET FILE ORGANIZATION
	CAIE	TB,%ACC.I	;MAKE SURE THIS IS AN INDEXED FILE
	CAIN	TB,%%ACC	;OR NOT SPECIFIED YET
	 CAIA			;ALL OK
	  JRST	IA22K2		;NO, ERROR
	SETO	TB,		;MAKE SURE RMS BIT IS SET
	DPB	TB,FI.RMS##
	DPB	TB,FI.AKS##	;SET "ALTERNATE KEYS SPECIFIED" FOR THIS FILE
	SETOM	RMSFLS##	;SET "RMS FILES" FLAG
	POPJ	PP,		;RETURN OK

IA22K2:	EWARNJ	E.624		;"ALTERNATE KEY ONLY ALLOWED WITH INDEXED FILES"
 >;END IFN ISAM
 IFE ISAM,<EWARNJ E.91>		;?NOT IMPLEMENTED
>;END IFN ANS74
;INITIALIZE FILE-LIMIT CLAUSE

IFN ANS68,<
	INTER.	IA23.
IA23.:	PUSHJ	PP,IA62.	;RE-INIT SAVLST
IFN FT68274,<
	PUSHJ	PP,CVTCTC##	;TURN THIS CLAUSE INTO A COMMENT
>
	HRRZ	TA,CURFIL	;FILTAB ENTRY ABS. ADDR.
	LDB	TB,FI.NFL##	;GET NO. OF FILE-LIMIT CLAUSES
	JUMPN	TB,JBE16.	;ERROR IF NOT 0 (DUP. CLAUSE)
	POPJ	PP,
>

;SAVE ACTUAL/RELATIVE KEY CODE FOR HLDTAB

	INTER.	IA24.
IA24.:	FLAGAT	LI
IFN FT68274,<
	MOVEI	TA,[ASCIZ /ACTUAL/]
	MOVEI	TB,[ASCIZ /RELATIVE/]
	PUSHJ	PP,CVTRCW##	;REPLACE ACTUAL BY RELATIVE
>
	HRRZ	TA,CURFIL	;[505] ABS. ADDR. OF FILTAB ENTRY
	LDB	TB,FI.ACC	;[505] GET ACCESS MODE
	CAIE	TB,%%ACC	;[505] IS IT "DEFAULT"?
	CAIN	TB,%ACC.R	;[505] NO, IS IT RANDOM?
	JRST	IA24A.		;[505] YES, OK
	MOVEI	DW,E.595	;[505] NO, ERROR - WRONG TYPE KEY
	PUSHJ	PP,FATALW##	;[505] FLAG IT
	HRRZI	TB,%HL.SY	;[505]
	SKIPA			;[505]
IA24A.:	HRRZI	TB,%HL.AK	;[505] GET CODE
IA24X.:	MOVEM	TB,CTR		;STORE CODE IN HLDTAB
	POPJ	PP,
;SET SEQUENTIAL ORGANIZATION/ACCESS FLAG

	INTER.	IA25.
IA25.:	HRRZI	TB,%ACC.S	;ACCESS MODE SEQUENTIAL CODE
	JRST	IA27.X		;INSERT IN FILTAB ENTRY

;SET INDEXED-SEQUENTIAL ORGANIZATION/ACCESS MODE

	INTER.	IA26.
IA26.:
IFN ISAM,<
	FLAGAT	H
ifn ft68274,<
;add " access mode is dynamic"
>
	HRRZI	TB,%ACC.I	;ACCESS MODE IS ISAM CODE
	JRST	IA27.X		;INSERT IN FILTAB ENTRY
	>
IFE ISAM,<EWARNJ E.91>		;?NOT IMPLEMENTED

;SET RMS BIT
IFN ANS74,<
	INTER.	IA26W.
IA26W.:	EWARNW	E.777		;WE CHANGED THE SYNTAX ON THE USERS
	SKPNAM			;BUT THE OLD SYNTAX STILL WORKS

	INTER.	IA26R.
IA26R.:
IFE ISAM,< POPJ	PP,>		;ALREADY GOT ERROR MESSAGE
IFN ISAM,<
	FLAGAT	NS
	HRRZ	TA,CURFIL	;ABS. ADDR OF FILTAB ENTRY
	SETO	TB,		;GET A BIT "ON"
	DPB	TB,FI.RMS	;SET RMS BIT
	SETOM	RMSFLS##	;SET FLAG "RMS FILES USED"
	POPJ	PP,		;DONE, RETURN
>>;END IFN ANS74

;SET RANDOM ORGANIZATION/ACCESS FLAG

	INTER.	IA27.
IA27.:	FLAGAT	LI
IFN FT68274,<
	MOVEI	TA,[ASCIZ /RANDOM/]
	MOVEI	TB,[ASCIZ /RELATIVE ACCESS MODE IS DYNAMIC/]
	PUSHJ	PP,CVTRCW
>
	HRRZI	TB,%ACC.R	;ACCESS MODE RANDOM CODE
IA27.X:	HRRZ	TA,CURFIL	;ABS. ADDR. OF FILTAB ENTRY
IFN ANS74,<
	LDB	TC,FI.AKS	;WERE ALTERATE KEYS SPECIFIED?
	JUMPN	TC,IA27X1	;JUMP IF YES
IA27X0:>
	DPB	TB,FI.ACC	;DEPOSIT IN FILTAB ENTRY
IFN ANS68,<
	POPJ	PP,
>
IFN ANS74,<
	SKIPN	FLGSW		;NEED FIPS FLAGGER?
	POPJ	PP,		;NO
	LDB	LN,FI.LN##	;GET LN & CP OF FD
	LDB	CP,FI.CP##
	MOVE	TA,[%LV.L		;SEQUENTIAL
		%LV.LI			;RELATIVE
		%LV.H](TB)		;INDEXED
	PUSHJ	PP,FLG.ES	;FLAG FD IF REQUIRED
	ADDI	TB,1		;CONVERT 0 TO 1 ETC.
	SKIPN	RSLNCP		;HAVE WE SEEN [RESERVE N AREAS] YET?
	JRST	[MOVEM TB,RSLNCP	;NO, SAVE ORGANIZATION +1
		JRST	IX27X1]		;IN CASE WE SEE IT LATER
	HLRZ	LN,RSLNCP	;YES, SET LN
	HRRZ	CP,RSLNCP	; & CP
	MOVE	TA,[%LV.HI		;SEQUENTIAL
		%LV.HI			;RELATIVE
		%LV.H]-1(TB)		;INDEXED
	PUSHJ	PP,FLG.ES##	;TEST FIPS LEVEL
IX27X1:	SKIPN	ASLNCP		;HAVE WE SEEN ASSIGN CLAUSE YET?
	JRST	[MOVEM TB,ASLNCP	;NO, SAVE ORGANIZATION +1
		POPJ	PP,]		;IN CASE WE SEE IT LATER
	HLRZ	LN,ASLNCP	;YES, SET LN
	HRRZ	CP,ASLNCP	; & CP
	MOVE	TA,[%LV.L		;SEQUENTIAL
		%LV.LI			;RELATIVE
		%LV.H]-1(TB)		;INDEXED
	PJRST	FLG.ES##	;TEST FIPS LEVEL
>

IFN ANS74,<
IA27X1:	CAIN	TB,%ACC.I	;SETTING ORGANIZATION TO INDEXED IS OK
	 JRST	IA27X0
	EWARNW	E.624		;"ONLY INDEXED FILES MAY HAVE ALTERNATE KEYS"
	HRRZ	TA,CURFIL	;POINT AT CURRENT FILE AGAIN
	MOVEI	TB,%ACC.I	;PRETEND HE SAID "INDEXED"
	JRST	IA27X0		;GO SET IT

;CHECK FOR MORE THAN 1 ACCESS MODE SETTING PER FILE

	INTER.	IA25X.
IA25X.:	HRRZ	TA,CURFIL	;AIM AT CURRENT FILTAB ENTRY
	LDB	TB,FI.FAM	;GET CURRENT SETTING OF ACCESS MODE BITS
	JUMPN	TB,JBE16.	;'DUPLICATE CLAUSE'
	POPJ	PP,		;AT INITIAL SETTING

;SET SEQUENTIAL ACCESS MODE

	INTER.	IA25S.
IA25S.:	MOVEI	TB,%FAM.S
	SKIPN	FLGSW##		;NEED FIPS FLAGGER?
	JRST	IA25.X		;NO
	PUSHJ	PP,IA25.X	;SETS UP TA = CURFIL
	LDB	TB,FI.ORG##	;GET FILE ORGANIZATION
	JRST	@[CPOPJ			;SEQUENTIAL
		TST.LI			;RELATIVE
		TST.H			;INDEXED
		CPOPJ](TB)

IA25.X:	HRRZ	TA,CURFIL
	DPB	TB,FI.FAM##	;STORE IN FILTAB
	POPJ	PP,

;SET RANDOM ACCESSS MODE

	INTER.	IA25R.
IA25R.:	MOVEI	TB,%FAM.R
	SKIPN	FLGSW##		;NEED FIPS FLAGGER?
	JRST	IA25.X		;NO
	PUSHJ	PP,IA25.X	;SETS UP TA = CURFIL
	LDB	TB,FI.ORG##	;GET FILE ORGANIZATION
	JRST	@[CPOPJ			;SEQUENTIAL
		TST.LI			;RELATIVE
		TST.H			;INDEXED
		CPOPJ](TB)

;SET DYNAMIC ACCESS MODE

	INTER.	IA25D.
IA25D.:	MOVEI	TB,%FAM.D
	SKIPN	FLGSW##		;NEED FIPS FLAGGER?
	JRST	IA25.X		;NO
	PUSHJ	PP,IA25.X	;SETS UP TA = CURFIL
	LDB	TB,FI.ORG##	;GET FILE ORGANIZATION
	JRST	@[CPOPJ			;SEQUENTIAL
		TST.HI			;RELATIVE
		TST.H			;INDEXED
		CPOPJ](TB)
>;END IFN ANS74
;PUT KEY DATA-NAME IN HLDTAB

	INTER.	IA28.
IA28.:	PUSHJ	PP,IA59S.	;SAVE NAMTAB ADDR
	PUSHJ	PP,IA28S.	;SET UP HLDTAB ENTRY
	HRRZ	TB,CTR		;GET KEY CODE
	DPB	TB,HL.COD	;& PUT IT IN HLDTAB
	HLRZ	TB,CURFIL	;STORE FILTAB LINK IN HLDTAB
	DPB	TB,HL.LNK
	POPJ	PP,

;SET UP HLDTAB ENTRY

IA28S.:	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,

IFN ANS74,<
;STORE ALTERNATE RECORD KEY DATA-NAME
	INTER.	IA28A.
IA28A.:	PUSHJ	PP,IA59S.	;SAVE NAMTAB ADDR
	PUSHJ	PP,IA28SK	;SETUP ALTERNATE KEY ENTRY
	PUSHJ	PP,IA28S.	;SET UP HLDTAB ENTRY
	HRRZI	TB,%HL.KA	;GET KEY CODE
	DPB	TB,HL.COD	;& PUT IN HLDTAB
	HLRZ	TB,CURAKT	;GET CURRENT ALTERNATE KEY
	DPB	TB,HL.LNK	;STORE AKTTAB LINK IN HLDTAB
	POPJ	PP,		;RETURN

;SET UP AKTTAB ENTRY
IA28SK:	MOVE	TA,[XWD CD.AKT,SZ.AKT] ;GET AN AKTTAB ENTRY
	PUSHJ	PP,GETENT
	MOVEM	TA,CURAKT	;SAVE ADDR
	HLRZ	TB,CURFIL	;PUT FILTAB ADDR IN AKTTAB
	DPB	TB,AK.FLK
	POPJ	PP,		;RETURN

;SET "DUPLICATES" BIT
	INTER.	IA28D.
IA28D.:	HRRZ	TA,CURAKT	;GET CURRENT ACTUAL KEY TABLE ADDR
	SETO	TB,		;TURN ON "DUPLICATES" BIT
	DPB	TB,AK.DUP
	POPJ	PP,		;RETURN
>;END IFN ANS74
;LITERAL FILE-LIMIT
IFN ANS68,<
	INTER.	IA29.
IA29.:	HLRZ	TB,W1		;GET SIZE OF LITERAL
	ANDI	TB,000777
	TLNE	W1,GWNLIT	;IS IT A NUMERIC LITERAL?
	TLNE	W1,GWDP		;DOES IT HAVE A DECIMAL POINT?
	EWARNJ	E.264		;NOT AN INTEGER
	MOVE	TC,[POINT 7,LITVAL]	;GET PTR TO LITERAL
	ILDB	TD,TC		;AND PICK UP FIRST CHARACTER
	CAIN	TD,"-"		;IS IT -?
	EWARNW	E.25		;YES, GIVE ERROR MESSAGE
	HRRZI	TB,1(TB)	;1 MORE FOR NUMBER OF CHARACTERS
	MOVEM	TB,LSIZE	;SAVE
	HRRZI	TB,4(TB)	;ROUND UPWARDS
	IDIVI	TB,5		;NO. OF WORDS REQUIRED
	HRRZI	TA,(TB)		;GET A VALTAB ENTRY OF THIS SIZE
	HRLI	TA,CD.VAL
	PUSHJ	PP,GETENT
	MOVEM	TA,CURVAL	;SAVE ADDRESS
	MOVE	TB,[POINT 7,(TA)]	;PTR TO VALTAB STORE
	MOVE	TC,[POINT 7,LITVAL]	;PTR TO LITERAL
	MOVE	TE,LSIZE	;CHAR COUNT FOR THE MOVE
	MOVEI	TD,-1(TE)	;1ST STORE THE TRUE CHAR COUNT
	JRST	IA29.L+1
IA29.L:	ILDB	TD,TC		;GET CHARACTER
	IDPB	TD,TB		;STASH IT
	SOJG	TE,IA29.L
	HLRZ	TA,CURVAL	;SAVE VALTAB PTR
	JRST	IA30.X

;PUT FILE-LIMIT DATA-NAME IN HLDTAB

	INTER.	IA30.
IA30.:	PUSHJ	PP,IA59S.	;SAVE NAMTAB ADDR
	PUSHJ	PP,IA28S.	;SET UP HLDTAB ENTRY
	HLRZ	TA,CURHLD	;PUT HLDTAB PTR ON SAVE LIST
IA30.X:	PUSH	SAVPTR,TA
	POPJ	PP,

;ERROR OF TYPE: "FILE-LIMITS 1 THRU 200, FOO."
;(OBJECT IS TO KEEP HLDTAB FROM GETTING MIXED UP)

	INTER.	IA30E
IA30E:	PUSHJ	PP,IA32.	;SET UP DUMMY LOW LIMIT
	PUSHJ	PP,IA34.	;MAKE FOO THE HIGH LIMIT
	EWARNJ	E.303		;?'THRU' EXPECTED
;ITEM BEFORE 'THRU' BECOMES LOW FILE-LIMIT

	INTER.	IA31.
IA31.:	HRRZ	TA,CURFIL	;GET PTR TO CURRENT FILTAB ENTRY
	LDB	TC,FI.NFL	;INCREMENT NO. OF FILE-LIMITS CLAUSES
	ADDI	TC,1
	DPB	TC,FI.NFL	;PUT NEW VALUE IN FILTAB FIELD
	MOVE	TA,[XWD CD.FIL,1]	;GET 1 WORD IN FILTAB FOR FILE-LIMITS
	PUSHJ	PP,GETENT
	MOVEM	TA,CFLM		;SAVE ADDRESS
	POP	SAVPTR,TD	;GET POINTER FROM SAVE LIST
	CAIL	TD,<CD.VAL>B20	;SAVING LOW-LIM ON VALTAB OR HLDTAB?
	HRLZM	TD,(TA)		;VALTAB, PUT PTR TO LOW-LIMIT IN FILTAB
	HRRZI	TB,%HL.LL	;SET LOW-LIMIT FLAG IN HLDTAB
IA31.X:	TRNE	TD,600000	;VALTAB OR HLDTAB ADDR?
	POPJ	PP,		;VALTAB
	HRRZ	TA,HLDLOC	;GET HLDTAB START ADDR.
	ADDI	TA,(TD)		;PLUS REL ADDR. OF CURRENT WORD
	DPB	TB,HL.COD
	HLRZ	TB,CFLM		;PUT FILTAB LINK IN HLDTAB
	DPB	TB,HL.LNK
	POPJ	PP,

;SINGLE-ITEM FILE-LIMIT SEEN -- ASSUME 1 AS LOW LIMIT

	INTER.	IA32.
IA32.:	MOVE	TA,[XWD CD.VAL,1]	;GET 1-WORD VALTAB ENTRY
	PUSHJ	PP,GETENT
	MOVSI	TB,5420		;PUT '1' IN VALTAB
	MOVEM	TB,(TA)
	HLRZ	TB,TA		;PUT VALTAB POINTER ON SAVE LIST
	PUSH	SAVPTR,TB
	JRST	IA31.		;PUT LOW LIMIT OF 1 IN FILTAB

;STORE HIGH LIMIT IN FILTAB FILE-LIMIT WORD

	INTER.	IA34.
IA34.:	HLRZ	TA,CFLM		;REL ADDR OF FILE-LIMIT WORD
	HRRZ	TB,FILLOC	;FILTAB ENTRY ADDR
	ADD	TA,TB		;ABS. ADDR. OF CURRENT FILE-LIMIT
	POP	SAVPTR,TD	;GET POINTER TO LAST ITEM
	CAIL	TD,<CD.VAL>B20	;SAVING HI-LIM ON VALTAB OR HLDTAB?
	JRST	IA34.X		;VALTAB, CHECK AGAINST LOW LIMIT
	HRRZI	TB,%HL.HL	;SET HI-LIM FLAG IN HLDTAB
	JRST	IA31.X
IA34.X:	HLRZ	TB,(TA)		;PICK UP LOW LIMIT POINTER FROM FILTAB
	CAIGE	TB,<CD.VAL>B20	;IS IT VALTAB?
	JRST	IA34.Y		;NO, CAN'T CHECK LIMITS
	PUSH	PP,TA		;SAVE POINTER TO FILE LIMITS WORD
	PUSH	PP,TD		;SAVE POINTER TO HI-LIMIT
	MOVE	TA,TB		;MOVE RELATIVE POINTER FOR LOW LIMIT
	HRRZ	TC,VALLOC##	;GET POINTER TO VALTAB
	ADD	TA,TC		;MAKE LOW-LIMIT PTR ABSOLUTE
	TRZ	TA,600000	;GET RID OF FLAGS
	MOVE	TD,[POINT 7,(TA)]	;BYTE POINTER TO LOW LIMIT
	ILDB	TB,TD		;PICK UP FIRST BYTE
	MOVEM	TB,CTR##	;AND USE IT AS CHAR COUNT
	PUSHJ	PP,GETV2##	;GO GET VALUE FOR LOW LIMIT
	POP	PP,TA		;NOW SET UP FOR HIGH LIMIT
	PUSH	PP,TC		;SAVE LOW LIMIT VALUE
	HRRZ	TC,VALLOC	;CONVERT RELATIVE HI-LIMIT
	ADD	TA,TC		;POINTER TO ABSOLUTE
	TRZ	TA,600000	;AND GET RID OF FLAGS
	MOVE	TD,[POINT 7,(TA)]	;GET ITS FIRST BYTE
	ILDB	TB,TD		;INTO TB
	MOVEM	TB,CTR##	;AND USE AS COUNT
	PUSHJ	PP,GETV2	;NOW GET HI-LIMIT VALUE INT TC
	POP	PP,TD		;RESTORE LOW LIMIT VALUE TO TD
	CAMG	TC,TD		;IS HI-LIM GREATER?
	JRST	IA34.Z		;NO, FIX STACK AND GIVE ERROR
	TRO	TA,600000	;YES, RESTORE FLAGS
	HRRZ	TB,VALLOC##	;AND MAKE POINTER RELATIVE
	SUB	TA,TB		;TO VALTAB
	MOVE	TD,TA		;RETURN IT TO ITS USUAL PLACE
	POP	PP,TA		;AND RESTORE POINTER TO FILE LIMITS WORD
IA34.Y:	HRRM	TD,(TA)		;HERE IF ALL OK, STORE HI-LIM
	HRRZI	TB,%HL.HL	;AND SET HI-LIM FLAG IN HLDTAB
	JRST	IA31.X
IA34.Z:	POP	PP,TA		;HERE ON ERROR, CLEAR THE STACK
	EWARNJ	E.272		;GO GIVE ERROR

>;END IFN ANS68
;GET VALUE OF INTEGER & PUT INTO SEGMENT LIMIT WORD

	INTER.	IA35.
IA35.:	PUSHJ	PP,IA16S.	;GET VALUE OF INTEGER
	  POPJ	PP,		;ITEM NOT AN INTEGER
	JUMPLE	TC,JBE19.	;<=0 IS ILLEGAL
	CAILE	TC,^D49		;>=50 IS ILLEGAL
JBE19.:	EWARNJ	E.19		;'IMPROPER SEGMENT LIMIT' -- EXIT
	MOVE	TA,SEGLIM	;GET PREVIOUS LIMIT
	CAIN	TA,^D50		;50 IS INITIAL VALUE
	JRST	IA35.A		;HAS NOT YET BEEN RESET
	CAMN	TC,TA		;RESETTING TO SAME VALUE?
	POPJ	PP,		;YES, IGNORE IT
	EWARNJ	E.16		;NO, 'CLAUSE DUPLICATED'
IA35.A:	MOVEM	TC,SEGLIM	;STORE NEW SEGMENT LIMIT
	POPJ	PP,
;SAME RECORD AREA (ONLY) FOR FILES IN LIST

	INTER.	IA36.
IA36.:	SWON	FSAME		;SET FLAG
IFN ANS74,<
	MOVEM	W2,SRALNC##	;SAVE LN & CP OF "SAME RECORD"
>
	POPJ	PP,

;SAME AREA (REC. AREA & BUFRS) FOR FILES IN LIST

	INTER.	IA37.
IA37.:	SWOFF	FSAME		;CLR SAME-REC-AREA FLAG
	POPJ	PP,

;SAVE PTR TO FIRST FILE IN SAME-AREA CLAUSE

	INTER.	IA38.
IA38.:	SKIPE	SAMSRT		;IF 'SAME SORT' CLAUSE, DON'T DO ANYTHING
	POPJ	PP,
	PUSHJ	PP,IA38S.	;GET PTR TO FILTAB ENTRY FOR THIS FILE
IFN ANS74,<
	SKIPE	FLGSW		;NEED FIPS FLAGGER
	PUSHJ	PP,IA38.F	;YES
>
	HLRZ	TC,TB		;GET FILTAB ENTRY REL. ADDR.
	PUSH	SAVPTR,TC	;PUT ON SAVLST
	PUSH	SAVPTR,TC	;TWICE
	HRRZ	TA,TB		;GET FILTAB ENTRY ABS. ADDR.
	LDB	TB,FI.SAL	;EXAMINE SAME-AREA LINK
	TSWF	FSAME		;IS THIS A SAME-AREA OR A SAME-REC-AREA CLAUSE?
	LDB	TB,FI.SRA	;THE LATTER -- EXAMINE SAME-REC-AREA LINK
	JUMPE	TB,CPOPJ##	;IF NOT ON, RETURN
	TSWF	FSAME		;'SAME REC. AREA'?
	EWARNW	E.173		;YES, 'FILE ALREADY IN SAME RECORD AREA CLAUSE'
	TSWT	FSAME		;'SAME AREA'?
	EWARNW	E.174		;YES, 'FILE ALREADY IN SAME AREA CLAUSE'
	HRRZI	NODE,ED135.##	;NEXT SYNTAX NODE WILL BE ED135.
	MOVEM	NODE,0(NODPTR)
	JRST	IA62.		;RESET SAVE LIST POINTER

;GET PTR TO FILTAB ENTRY

IA38S.:	HLRZ	TA,W2		;GET NAMTAB REL. ADDR
	LSH	TA,-2
	HRRZI	TB,CD.FIL	;FIND FILTAB ENTRY FOR THIS NAME
	PUSHJ	PP,FNDLNK
	  JRST	IA38.E		;NONE FOUND
	POPJ	PP,

IA38.E:	OUTSTR	[ASCIZ /IA38S.: TYPE=file-name but no FILTAB link found.
/]
	JRST	KILL

IFN ANS74,<
IA38.F:	HRRZ	TA,TB		;GET CURFIL
	TSWF	FSAME		;IF SAME RECORD
	SKIPA	TC,SRALNC	;GET LN & CP OF "SAME RECORD"
	MOVE	TC,SAMLNC	;GET LN & CP OF "SAME"
	DPB	TC,FI.ALC##	;STORE THEM INCASE ITS A SORT FILE
	SETO	TC,
	TSWF	FSAME		;IF [RECORD]
	DPB	TC,FI.RLC##	;SET FLAG
	LDB	TA,FI.ORG	;GET ORGANIZATION
	CAIN	TA,%%ACC	;IGNORE THE DEFAULT
	SETZ	TA,
	CAMLE	TA,CURORG##	;BIGGER THAN ONE WE LAST SAW?
	MOVEM	TA,CURORG	;NO, STORE NEW ONE
	POPJ	PP,
>
;LINK THIS FILE TO PREVIOUS FILE IN SAME AREA CLAUSE
;AND SAVE PTR TO THIS FILE IN CASE THERE ARE MORE

	INTER.	IA38A.
IA38A.:	SKIPE	SAMSRT		;IF 'SAME SORT' CLAUSE, DONT DO ANYTHING
	POPJ	PP,
	PUSHJ	PP,IA38S.	;GET PTR TO FILTAB ENTRY FOR THIS FILE
IFN ANS74,<
	SKIPE	FLGSW		;NEED FIPS FLAGGER
	PUSHJ	PP,IA38.F	;YES
>
	MOVE	TD,(SAVPTR)	;GET PTR TO PREVIOUS FILE
	HRRZ	TA,FILLOC
	ADD	TA,TD		;ABS. ADDR. OF THAT FILTAB ENTRY
	HLRS	TB		;GET LINK TO THIS FILE
	TSWT	FSAME		;SAME-AREA OR SAME-REC-AREA?
	JRST	IA38AA		;SAME-AREA
	LDB	TE,FI.SRA	;GET SAME-REC-AREA LINK
	JUMPN	TE,JBE173	;IF NOT 0, 'FILE ALREADY IN SAME-REC-AREA CLAUSE'
	DPB	TB,FI.SRA	;STORE LINK TO THIS FILE IN THAT FILE'S ENTRY
	JRST	IA38AB
IA38AA:	LDB	TE,FI.SAL	;GET SAME-AREA LINK
	JUMPN	TE,JBE174	;IF NOT 0, 'FILE ALREADY IN SAME-AREA CLAUSE'
	DPB	TB,FI.SAL	;STORE LINK TO THIS FILE IN THAT FILE'S ENTRY
IA38AB:	MOVEM	TB,(SAVPTR)	;SAVE POINTER TO THIS FILE
	POPJ	PP,

JBE173:	EWARNJ	E.173
JBE174:	EWARNJ	E.174

;LINK LAST FILE IN SAME-AREA CLAUSE TO THE FIRST

	INTER.	IA39.
IA39.:	SKIPE	SAMSRT		;IF 'SAME SORT' CLAUSE, DONT DO ANYTHING
	POPJ	PP,
	HRRZ	TA,0(SAVPTR)	;REL. ADDR. OF LAST FILE IN GROUP
	PUSHJ	PP,LNKSET	;GET ABS. ADDR.
	HRRZ	TB,-1(SAVPTR)	;REL. ADDR. OF FIRST FILE IN GROUP
	TSWF	FSAME		;SAME-REC AREA?
	DPB	TB,FI.SRA	;YES, STORE LINK
	TSWT	FSAME		;SAME-AREA?
	DPB	TB,FI.SAL	;YES, STORE LINK
IFN ANS74,<
	SKIPN	FLGSW		;NEED FIPS FLAGGER?
	JRST	IA62.		;NO, RESET SAVE LIST POINTER
	LDB	LN,[POINT 13,SAMLNC,28]	;GET LN & CP
	LDB	CP,[POINT 7,SAMLNC,35]	;OF SAME
	MOVE	TA,CURORG	;GET ORGANIZATION OF "HIGHEST" FILE
	MOVE	TA,[%LV.L		;SEQUENTIAL
		%LV.LI			;RELATIVE
		%LV.H](TA)		;INDEX
	PUSHJ	PP,FLG.ES	;FLAG IF REQUIRED
	TSWT	FSAME		;WAS [RECORD] SEEN?
	JRST	IA62.		;NO
	LDB	LN,[POINT 13,SRALNC,28]	;GET LN & CP
	LDB	CP,[POINT 7,SRALNC,35]	;OF RECORD
	MOVE	TA,CURORG	;GET ORGANIZATION OF "HIGHEST" FILE
	MOVE	TA,[%LV.HI		;SEQUENTIAL
		%LV.HI			;RELATIVE
		%LV.H](TA)		;INDEX
	PUSHJ	PP,FLG.ES	;FLAG IF REQUIRED
>
	JRST	IA62.		;RESET SAVE LIST POINTER
;SAVE PTR TO FILE FOR SAME-DEVICE LINKAGE

	INTER.	IA40.
IA40.:	PUSHJ	PP,IA38S.	;GET PTR TO FILTAB ENTRY FOR THIS FILE
	HRRZI	TA,1		;SAVE POSITION 1 (DEFAULT POS.)
	PUSH	SAVPTR,TA
	PUSH	SAVPTR,TB	;SAVE FILTAB ENTRY ADDR
	MOVE	TA,TB		;GET NO. OF DEVICES FOR THIS FILE
	LDB	TB,FI.NDV
	CAIE	TB,1		;MUST BE 1
	EWARNJ	E.197		;'ONLY ONE DEVICE ALLOWED'
	LDB	TC,FI.SDL	;GET SAME-DEVICE LINK
	JUMPN	TC,CPOPJ	;IF ON, LEAVE IT ALONE
	HLRZ	TB,TA		;GET REL ADDR OF FILTAB ENTRY
	DPB	TB,FI.SDL	;MAKE FILE POINT TO ITSELF IF NOWHERE ELSE
	POPJ	PP,

;GET POSITION OF FILE ON TAPE & STORE IN FILTAB ENTRY

	INTER.	IA41.
IA41.:	PUSHJ	PP,IA16S.	;GET VALUE OF INTEGER
	  POPJ	PP,		;NOT AN INTEGER
IA41.A:	MOVEM	TC,TBLOCK	;SAVE POSITION
	HLRZ	TA,(SAVPTR)	;GET FILTAB ENTRY REL. ADDR.
	PUSHJ	PP,LNKSET	;GET ABS. ADDR
	MOVE	TC,TBLOCK	;GET POSITION ON TAPE
	LDB	TB,FI.POS	;EXAMINE TAPE POSITION FIELD
	JUMPE	TB,IA41.P	;ON?
	CAIE	TB,(TC)		;YES, SAME AS NEW ONE?
	EWARNJ	E.16		;NO, 'DUPLICATE CLAUSE'
	MOVEM	TC,-1(SAVPTR)	;YES, PUT ON SAVE LIST AS POSITION
	POPJ	PP,

IA41.P:	DPB	TC,FI.POS	;PUT INTEGER IN POSITION FIELD
	MOVEM	TC,-1(SAVPTR)	;AND ON SAVE LIST
	POPJ	PP,

;NO POSITION CLAUSE
;GET POSITION FROM SAVLST & STORE IN FILTAB ENTRY

	INTER.	IA42.
IA42.:	MOVE	TC,-1(SAVPTR)	;GET SAVED INTEGER
	JRST	IA41.A
;CHAIN SAME-DEVICE LINKS
;AND CHECK NEW FILE FOR SAME DEVICE AS PREVIOUS

	INTER.	IA43.
IA43.:	PUSHJ	PP,IA38S.	;GET PTR TO FILTAB ENTRY FOR THIS FILE
	MOVE	TA,TB		;FILTAB ENTRY ADDR.
	LDB	TB,FI.NDV	;NO. OF DEVICES FOR THIS FILE
	CAIE	TB,1		;MUST BE 1
	EWARNJ	E.197		;'ONLY ONE DEVICE ALLOWED'
	MOVEM	TA,TBLOCK	;SAVE POINTER TO CURRENT FILTAB ENTRY
	LDB	TA,FI.VAL	;VALTAB LINK
	PUSHJ	PP,LNKSET	;GET ABS. ADDR.
	MOVEM	TA,SAVETA	;AND SAVE ADDR OF DEVICE NAME
	HRRZ	TA,(SAVPTR)	;GET SAVED FILE FILTAB ADDR
	LDB	TA,FI.VAL	;VALTAB LINK
	PUSHJ	PP,LNKSET	;GET ABS. ADDR. OF DEVICE NAME OF PREV. FILE
	HLRZ	TC,(TA)
	LSH	TC,-13		;LENGTH OF ENTRY IN CHARACTERS
	IDIVI	TC,5
	ADDI	TC,1		;AND IN WORDS, ROUNDED UP
	MOVE	TB,SAVETA	;CURRENT FILE VALTAB ADDRESS
IA43.L:	MOVE	TD,(TA)		;COMPARE WORD OF DEVICE NAMES
	CAME	TD,(TB)
	JRST	IA43.E		;DIFFERENT DEVICES
	ADDI	TA,1		;GO TO NEXT WORD
	ADDI	TB,1
	SOJG	TC,IA43.L	;ALL WORDS DONE?
	AOS	-1(SAVPTR)	;YES, DEFAULT TAPE POS. IS NEXT ON TAPE
	HRRZ	TA,(SAVPTR)	;FILTAB ADDR OF LAST FILE IN LIST
	LDB	TC,FI.SDL	;GET REL ADDR OF 1ST FILE IN LIST
	HRRZ	TA,TBLOCK	;STORE LINK TO 1ST FILE IN NEW FILE ENTRY
	DPB	TC,FI.SDL
	HLRZ	TC,TBLOCK	;REL. FILTAB ADDR OF NEW FILE
	HRRZ	TA,(SAVPTR)	;STORE LINK TO NEW FILE IN OLD FILE ENTRY
	DPB	TC,FI.SDL
	MOVE	TA,TBLOCK	;SAVE ADDR OF NEW FILE
	MOVEM	TA,(SAVPTR)
	POPJ	PP,

IA43.E:	HRRZI	TA,ED158.##	;AFTER ERROR MSG, GO TO SYNTAX NODE ED158.
	MOVEM	TA,(NODPTR)
	EWARNJ	E.23		;'NOT SAME DEV. AS PREV. FILE'
;GET MNEMONIC-NAME FOR CONSOLE

	INTER.	IA44.
IA44.:	HRLZI	TA,040000	;GET CONSOLE TYPE FLAG

;ENTER HERE TO STORE NAME IN MNETAB
;TA SHOULD CONTAIN APPROPRIATE TYPE FLAG

IA44.D:	MOVEM	TA,MNETYP	;STORE TYPE FLAG
	JUMPGE	W1,IA44.A	;IS THIS NAME IN NAMTAB?
	TLNE	W1,30000	;IS IT A LITERAL OR RESERVED WORD?
	EWARNJ	E.24		;YES, 'ILLEGAL MNEMONIC-NAME'
	TLO	W2,GWDEF	;PUT DEFINING REFERENCE ON CREF FILE
	PUSHJ	PP,PUTCRF
	PUSHJ	PP,BLDNAM	;PUT IN NAMTAB
IA44.C:	MOVEM	TA,CURNAM	;SAVE NAMTAB PTR
IA44.B:	MOVE	TA,[XWD CD.MNE,SZ.MNE]	;GET MNETAB ENTRY
	PUSHJ	PP,GETENT
IFN ANS74,<
	HLRZM	TA,CURMNE##	;SAVE POINTER TO IT
>
	HLRZ	TC,CURNAM	;GET NAMTAB POINTER
	ORI	TC,700000	;SET MNETAB FLAG
	MOVSM	TC,(TA)		;PUT NAMTAB LINK IN MNETAB
	MOVE	TC,MNETYP	;GET TYPE FLAG
	TLNE	TC,730000	;SKIP IF NOT SWITCH, CHANNEL, CODE, OR STATUS
	HRR	TC,(SAVPTR)	;GET SWITCH OR CHANNEL NUMBER
	MOVEM	TC,1(TA)	;TO WORD 2 OF ENTRY
	HLR	TA,CURNAM	;NAMTAB REL. ADDR.
	PJRST	PUTLNK		;LINK NAMTAB TO MNETAB

IA44.A:
IFN ANS74,<
	TLNE	TA,(1B6)	;ALPHABET-NAME?
	JRST	IA44.E		;YES
>
	HLRZ	TA,W2		;GET NAMTAB PTR
	LSH	TA,-2
	HRRZI	TB,CD.MNE	;MNETAB FLAG
	HRLZM	TA,CURNAM	;SAVE NAMTAB REL. ADDR.
	PUSHJ	PP,FNDLNK	;FIND MNETAB LINK
	JRST	IA44.B		;NOT FOUND
	EWARNJ	E.28		;'MNEMONIC-NAME ALREADY IN USE'

IFN ANS74,<
IA44.E:	TLO	W2,GWDEF	;PUT DEFINING REFERENCE ON CREF FILE
	PUSHJ	PP,PUTCRF
	PUSHJ	PP,TRYNAM	;GET NAME
	  PUSHJ	PP,BLDNAM	;BUT WE REALLY KNOW IT IS
	JRST	IA44.C		;SAVE POINTER AND CONTINUE
>
;GET MNEMONIC-NAME FOR LPT CHANNEL

	INTER.	IA46.
IA46.:	HRLZI	TA,020000	;GET CHANNEL TYPE FLAG
	JRST	IA44.D

;GET MNEMONIC-NAME FOR HARDWARE SWITCH

	INTER.	IA47.
IA47.:	HRLZI	TA,400000	;GET SWITCH TYPE FLAG
	JRST	IA44.D

;SET SWITCH-ON STATUS FLAG

	INTER.	IA48.
IA48.:	SWON	FSTAT		;ON
	POPJ	PP,

;SET SWITCH-OFF STATUS FLAG

	INTER.	IA49.
IA49.:	SWOFF	FSTAT		;OFF
	POPJ	PP,

;GET MNEMONIC-NAME FOR SWITCH STATUS

	INTER.	IA50.
IA50.:	TSWT	FSTAT;
	HRLZI	TA,100000	;'OFF STATUS'
	TSWF	FSTAT;	
	HRLZI	TA,200000	;'ON STATUS'
	JRST	IA44.D
;GET CHARACTER FOR CURRENCY SIGN

	INTER.	IA51.
IA51.:	TLNE	W1,200000	;IS ITEM A LITERAL?
	TLNE	W1,174000	;SIMPLE ALPHANUMERIC?
	EWARNJ	E.27		;NO, 'MUST BE A 1 CHAR NON-NUMERIC LITERAL'
	TLNE	W1,000776	;IS ITS LENGTH 1?
	EWARNJ	E.27		;NO
	LDB	TA,[POINT 7,LITVAL,6]	;YES, GET THAT CHARACTER
	SKIPN	DOLLR.		;CURR. SIGN ALREADY GIVEN?
	JRST	IA51.P		;NO
	CAMN	TA,DOLLR.	;YES, IS NEW ONE THE SAME?
	POPJ	PP,		;YES
	EWARNJ	E.16		;NO, 'DUPLICATE CLAUSE'
IA51.P:	MOVEI	TB,-40(TA)	;CONVERT TO SIXBIT
	CAIL	TB,1		;IN SIXBIT RANGE & NOT SPACE?
	CAIL	TB,100
	EWARNJ	E.175		;NO, INVALID CHARACTER
	MOVE	TD,[POINT 6,CSL]	;AIM AT LIST OF ILLEGAL CHARS
IA51.R:	ILDB	TC,TD		;GET A CHAR FROM LIST
	JUMPE	TC,IA51.Q	;END OF LIST -- ALL IS WELL
	CAIN	TB,(TC)		;IS THIS A MATCH?
	EWARNJ	E.175		;YES, INVALID CHARACTER
	JRST	IA51.R		;NO, TRY NEXT
IA51.Q:
IFN FT68274,<
	MOVE	TD,[POINT 6,CSL74]	;AIM AT LIST OF ILLEGAL CHARS
IA51.S:	ILDB	TC,TD		;GET A CHAR FROM LIST
	JUMPE	TC,IA51.T	;END OF LIST -- ALL IS WELL
	CAIE	TB,(TC)		;IS THIS A MATCH?
	JRST	IA51.S		;NO, TRY NEXT
	EWARNW	E.772		;YES, INVALID CHARACTER
IA51.T:
>
	MOVEM	TA,DOLLR.	;STASH NEW CURRENCY SIGN
	POPJ	PP,

;ITEMS ILLEGAL AS CURRENCY SIGN
;(SPACE MARKS END OF LIST)

CSL:
IFN ANS68,<
	SIXBIT	/0123456789*+-,.;()"ABCDPRSVXZ /
>
IFN ANS74,<
	SIXBIT	'0123456789*+-,.;()"=/ABCDLPRSVXZ '
>
IFN FT68274,<
CSL74:	SIXBIT	'=/L'
>
;SWITCH FUNCTIONS OF COMMA AND DECIMAL POINT

	INTER.	IA52.
IA52.:	MOVEI	TA,"."		;COMMA = .
	MOVEM	TA,COMA.##
	MOVEI	TA,","		;DEC.PT. = ,
	MOVEM	TA,DCPNT.##
	POPJ	PP,

;MISSING INTEGER -- WARN AND ASSUME 0

	INTER.	IA54E.
IA54E.:	EWARNW	E.25		;'POSITIVE INTEGER REQUIRED'
	SKPNAM

;PUT A ZERO VALUE ON THE SAVLST

	INTER.	IA54.
IA54.:	SETZ	TC,		;PUT 0 ON SAVE LIST
	JRST	IA16.A

;SET RERUN FLAG & COUNT FOR FILE

	INTER.	IA55.
IA55.:	PUSHJ	PP,IA38S.	;GET PTR TO FILTAB ENTRY FOR THIS FILE
IFN ANS74,<
	SKIPN	FLGSW		;NEED FIPS FLAGGER?
	JRST	IA55.F		;NO
	HLRZ	LN,CURLNC	;RESTORE LN
	HRRZ	CP,CURLNC	; & CP
	HRRZ	TA,TB		;GET CURFIL
	LDB	TA,FI.ORG##	;GET FILE ORGANIZATION
	MOVE	TA,[%LV.L		;SEQUENTIAL
		%LV.LI			;RELATIVE
		%LV.H](TA)		;INDEXED
	PUSHJ	PP,FLG.ES	;FLAG FD IF REQUIRED
IA55.F:>
	HRRZ	TA,TB		;FILTAB ENTRY ABS. ADDR.
	POP	SAVPTR,TC	;GET SAVED INTEGER
	JUMPE	TC,IA55.A	;RERUN END-OF-REEL
	CAIG	TC,177777	;[553] TOO BIG TO FIT?
	JRST	IA55.0		;[553] NO, STASH IT
	MOVE	LN,SAVPLN##	;[553] YES - RESTORE THE LINE NO. &
	MOVE	CP,SAVPCP##	;[553] CHARACTER POS. OF INTEGER
	MOVEI	DW,E.609	;[553] GET CORRECT ERROR NUMBER
	PUSHJ	PP,WARN		;[553] GIVE USER WARNING
	MOVEI	TC,177777	;[553] ASSUME THE MAXIMUM
IA55.0:	DPB	TC,FI.RCT	;[553] RERUN COUNT
	HRRZI	TC,1
	DPB	TC,FI.RRC	;SET RERUN ON COUNT FLAG
	POPJ	PP,

IA55.A:	HRRZI	TC,1
	DPB	TC,FI.RER	;SET RERUN END-OF-REEL FLAG
	POPJ	PP,

;SET SPECIAL-NAMES PARAGRAPH FLAG

	INTER.	IA56.
IA56.:	TSWFS	FSPNAM		;ALREADY SEEN A SPECIAL-NAMES PARA?
	EWARNJ	E.30		;YES, 'DUPLICATE PARAGRAPH'
	POPJ	PP,		;NO, BUT NOW WE HAVE

;WIPE LAST ENTRY OFF SAVLST

	INTER.	IA57.
IA57.:	POP	SAVPTR,TA	;LOSE SAVE LIST ENTRY
	POPJ	PP,
;PUT DATA-NAME QUALIFIER IN NEXT WORD OF HLDTAB

	INTER.	IA59.
IA59.:	PUSHJ	PP,IA59S.	;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,IA59.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,

IA59.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

IA59S.:	TLNN	W1,GWNOT	;NAME IN NAMTAB?
	JRST	IA59SA		;YES
	PUSHJ	PP,BLDNAM	;NO, BUILD NAMTAB ENTRY
	MOVEM	TA,CURNAM	;SAVE ADDR
	HLRZS	TA		;LEAVE LINK IN RIGHT HALF
	DPB	TA,[POINT 15,W2,15]	;& IN W2
	POPJ	PP,

IA59SA:	LDB	TA,[POINT 15,W2,15]	;GET NAMTAB REL ADDR
	HRLZM	TA,CURNAM	;& SAVE
	POPJ	PP,

;ILLEGAL DATA-NAME IN FILE-LIMIT CLAUSE

	INTER.	IA61.
IA61.:	HLRZ	TA,CFLM		;GET CURRENT FILE LIMIT POINTER
	PUSHJ	PP,LNKSET	;GET ABS. ADDR.
	HLRS	(TA)		;MAKE HIGH-LIMIT=LOW-LIMIT
	EWARNJ	E.17		;'ILLEGAL DATA NAME'

IFN FT68274,<

;FLAG SWITCH (N) AS DIFFERENT

	INTER.	IA62A.
IA62A.:	EWARNW	E.776
	SKPNAM

>

IFN ANS74,<

;RERUN - SAVE POINTER TO IT

	INTER.	IA62F.
IA62F.:	HRLZM	LN,CURLNC##	;SAVE LN & CP
	HRRM	CP,CURLNC	;IN  CASE WE SEE A FILE NAME
	JRST	IA62.

;MULTIPLE FILE TAPE

	INTER.	IA62M.
IA62M.:	FLAGAT	HI
	SKPNAM
>

;REFRESH SAVLST
;(SAVLST IS USED FOR TEMPORARY STORAGE)

	INTER.	IA62.
IA62.:	MOVE	SAVPTR,ISVPTR	;RESET SAVE LIST
	POPJ	PP,
;FLAG MISSING DATA DIVISION, THEN GO TO COBOLC

	INTER.	IA63F.
IA63F.:	EWARNW	E.31		;'NO DATA DIVISION'
	SKPNAM

;INIT MISSING ENVIRONMENT DIVISION, THEN GO TO COBOLC

	INTER.	IA63E.
IA63E.:	PUSHJ	PP,IA67.	;DO ENV. DIV. INITS
	SKPNAM

;CLEAN-UP AT END OF PHASE B, AND THEN CALL IN COBOLC

	INTER.	IA63.
IA63.:	SWON	FREGWD		;REGET 'DATA' OR WHATEVER
				;INIT MISSING ENVIRONMENT ITEMS
	SKIPN	OBJSIZ		;MEMORY SIZE = 0?
	SETOM	OBJSIZ		;IF SO, SET TO -1
	MOVEI	TA,"$"		;DEFAULT DOLLAR SIGN IS "$"
	SKIPN	DOLLR.		;HAS HE SET ONE?
	MOVEM	TA,DOLLR.	;NO
	SKIPN	PROGID		;DID HE SET PROGRAM-ID?
	PUSHJ	PP,IA2.2	;NO, NAME IT "COBOL."
	SKIPN	DEFDSP		;DEFAULT DISPLAY MODE GIVEN?
	AOS	DEFDSP		;NO, SO MAKE IS DISPLAY-6
IFN ANS74,<
	PUSHJ	PP,IA210.	;CLEANUP ALPHABET-NAMES
>
	ENDFAZ	B;		;CLOSE OUT PHASE B & GO TO COBOLC

;INITIALIZE ENVIRONMENT DIVISION

	INTER.	IA67.
IA67.:
IFN DEBUG,<
	MOVE	TE,CORESW
	SWOFF	FNDTRC		;CLR OLD TRACE REQUEST
	TRNE	TE,TRACEE	;TRACE ED NODES?
	SWON	FNDTRC		;YES, TURN ON TRACER
	>
	MOVE	TA,[XWD CD.DAT,SZ.DAT]	;MAKE A DUMMY DATAB ENTRY
	PUSHJ	PP,GETENT	;FOR DATA-DIV. BREAK
	HRRZI	TB,CD.DAT
	DPB	TB,[POINT 3,(TA),2]	;ENTER DATTAB CODE
	POPJ	PP,

;SET MULTIPLE REEL FLAG FOR FILE

IFN ANS68,<	INTER.	IA68.
IA68.:	HRRZ	TA,CURFIL	;FILTAB ENTRY ADDR
	LDB	TB,FI.MLT	;GET MULTIPLE REEL BIT
	JUMPN	TB,JBE16.	;IF ON, GIVE 'DUPLICATE CLAUSE' MSG
	SETO	TB,		;OK, SET MULTIPLE REEL BIT
	DPB	TB,FI.MLT
	POPJ	PP,
>
;RECORDING MODE CLAUSE

;ASCII

	INTER.	IA69.
IA69.:	HRRZI	TB,%RM.7B	;ASCII RECORDING MODE BITS
IA69.X:	HRRZ	TA,CURFIL	;AIM AT FILE ENTRY
	LDB	TC,FI.RM2	;ENTERED ALREADY?
	JUMPN	TC,JBE16.	;YES, ERROR
	DPB	TB,FI.ERM	;NO, ENTER IT
	SETO	TB,		;SAY IT IS ENTERED
	DPB	TB,FI.RM2
	POPJ	PP,

;STANDARD ASCII

	INTER.	IA69A.
IA69A.:	HRRZI	TB,%RM.SA
	JRST	IA69.X

;BYTE MODE

	INTER.	IA69B.
IA69B.:	HRRZ	TA,CURFIL	;AIM AT FILE ENTRY
	SETO	TB,
	DPB	TB,FI.BM##	;SET BYTE MODE FLAG
	POPJ	PP,

;SIXBIT

	INTER.	IA70.
IA70.:	HRRZI	TB,%RM.6B	;SIXBIT RECORDING MODE BITS
	JRST	IA69.X

;BINARY

	INTER.	IA71.
IA71.:	HRRZI	TB,%RM.BN	;BINARY
	JRST	IA69.X
;SEE IF IT IS F OR V.

	INTER.	IA72.
IA72.:	HLRZ	TC,	NAMWRD		;SEE WHAT WE GOT.
	CAIE	TC,	(SIXBIT /F/)	;WAS IT F OR
	CAIN	TC,	(SIXBIT /V/)	; V?
	JRST		IA72FV		;YES.

	HRRZI	TB,	ED271.##	;FAKE SQUIRL OUT BY MAKING IT
	MOVEM	TB,	(NODPTR)	; LOOK LIKE WE WERE ALWAYS AT
	JRST		IA0.R		; ED271. AND REGETTING THE ITEM.

IA72FV:	SWOFF		FREGWD		;DON'T REGET THE ITEM.
	HRRZ	TA,	CURFIL		;GET THE FILE TABLE ADR.
	LDB	TB,	FI.RM2		;DID WE ALREADY GET A RECORDING MODE?
	JUMPN	TB,	JBE16.		;YES, ERROR.
	SETO	TB,			;GET SOME ONES.
	CAIN	TC,	(SIXBIT /V/)	;WAS IT V?
	DPB	TB,	FI.VLR##	;YES, TURN ON THE VLR FLAG.
	HRRZI	TB,%RM.EB		;SET EBCDIC MODE
	JRST	IA69.X
;RECORDING MODE CLAUSE

;DENSITY

	INTER.	IA73.
IA73.:	PUSHJ	PP,IA16S.	;GET THE INTEGER
	  POPJ	PP,		;NOT AN INTEGER
	HRRZ	TA,	CURFIL		;GET THE FILE TABLE'S ADR.
	LDB	TB,	FI.RD		;GET THE RECORDING DENSITY.
	JUMPN	TB,	JBE16.		;ALREADY SAW ONE - DUP CLAUSE.
	CAIN	TC,	^D200		;200 BPI?
	HRRZI	TB,	%RD.2
	CAIN	TC,	^D556		;556 BPI?
	HRRZI	TB,	%RD.5
	CAIN	TC,	^D800		;800 BPI?
	HRRZI	TB,	%RD.8
	CAIN	TC,	^D1600		;1600 BPI?
	HRRZI	TB,	%RD.16
	CAIN	TC,	^D6250		;6250 BPI?
	HRRZI	TB,	%RD.62
	DPB	TB,	FI.RD		;PUT IT IN THE FILE TABLE.
	JUMPN	TB,	CPOPJ		;RETURN IF IT WAS VALID.
	EWARNJ		E.327		;OTHERWISE GIVE AN ERROR MSG.

;ODD PARITY

	INTER.	IA74.
IA74.:	HRRZI	TB,%RP.OD	;ODD PARITY BITS
IA74.X:	HRRZ	TA,CURFIL	;AIM AT FILE ENTRY
	LDB	TC,FI.RP	;DECLARED ALREADY?
	JUMPN	TC,JBE16.	;YES, ERROR
	DPB	TB,FI.RP	;NO, ENTER IT
	POPJ	PP,

;EVEN PARITY

	INTER.	IA75.
IA75.:	HRRZI	TB,%RP.EV	;EVEN PARITY BITS
	JRST	IA74.X
;SET SAME SORT AREA CLAUSE FLAG

	INTER.	IA76.
IA76.:	FLAGAT	H
	SETOM	SAMSRT
	POPJ	PP,

;INIT SAME <RECORD, SORT> AREA CLAUSE

	INTER.	IA77.
IA77.:	SETZM	SAMSRT		;CLEAR SAME SORT AREA FLAG
IFN ANS74,<
	MOVEM	W2,SAMLNC##	;SAVE LN & CP OF "SAME"
	SETZM	CURORG		;NO FILES SEEN YET
>
	JRST	IA62.		;CLR SAVLST
IFN RPW,<

;STASH LITERAL FOR CODE UNTIL MNEMONIC SEEN

	INTER.	IA78.
IA78.:	FLAGAT	RP
	HLRZ	TC,W1		;PUT SIZE IN THE SPECIAL PLACE
	ANDI	TC,177
	MOVEM	TC,(SAVPTR)
	IDIVI	TC,5		;CONVERT TO WORDS
	JUMPE	TB,.+2
	ADDI	TC,1
	MOVEM	TC,1(SAVPTR)
	MOVE	TA,[LITVAL,,TBLOCK]	;STORE LITERAL
	MOVEI	TB,TBLOCK-1(TC)
	BLT	TA,(TB)
	POPJ	PP,

;GET LITERAL FOR REPORT CODE

	INTER.	IA79.
IA79.:	HRLZI	TA,010000	;"CODE" FLAG
	PUSHJ	PP,IA44.D	;MAKE A CODE MNETAB ENTRY
	HRRZ	TA,1(SAVPTR)	;# WORDS IN LITERAL
	HRLI	TA,CD.MNE	;GET THAT MUCH SPACE IN MNETAB
	PUSHJ	PP,GETENT
	HRLI	TA,TBLOCK	;MOVE LITERAL TO MNETAB
	HRRZI	TB,-1(TA)
	ADD	TB,1(SAVPTR)
	BLT	TA,(TB)
	POPJ	PP,

>

;DEFERRED OUTPUT ISAM

	INTER.	IA80.
IA80.:	FLAGAT	NS
IFN ISAM,<
	HRRZ	TA,CURFIL	;AIM AT FILTAB ENTRY
	MOVEI	TB,1		;SET DEFERRED BIT
	DPB	TB,FI.DFR##
>
	POPJ	PP,

IFN ANS74,<

;RMS I/O

	INTER.	IA81.
IA81.:	FLAGAT	NS
	HRRZ	TA,CURFIL	;AIM AT FILTAB ENTRY
	MOVEI	TB,1		;SET RMS BIT
	DPB	TB,FI.RMS##
	SETOM	RMSFLS##	;SET "RMS USED"
	POPJ	PP,
>
;CHECKPOINT OUTPUT FILE EVERY N RECORDS

	INTER.	IA82.
IA82.:	FLAGAT	NS
	HRRZ	TA,CURFIL	;AIM AT FILTAB ENTRY
	MOVEI	TB,1		;SET CHECKPOINT BIT
	DPB	TB,FI.CKP##
	POPJ	PP,

	INTER.	IA83.
IA83.:	PUSHJ	PP,IA16S.	;GET VALUE OF INTEGER
	  SETZ	TC,		;ERROR, USE 0
	HRRZ	TA,CURFIL	;AIM AT FILTAB ENTRY
	CAILE	TC,377		;CHECK SIZE
	EWARNJ	E.634		;TOO BIG
	DPB	TC,FI.CRC##	;SET CHECKPOINT RECORD COUNT
	JUMPE	TC,CPOPJ	;ZERO MEANS PHYSICAL BLOCK
	SETZ	TB,		;OTHERWISE 
	DPB	TB,FI.CKP	;CLEAR PHYSICAL CHECKPOINT BIT
	POPJ	PP,
;SAW "FILE-STATUS"

	INTER.	IA100.
IA100.:
IFN ANS74,<
	PUSHJ	PP,IA21F.	;TEST FIPS FLAGGER
>
	HRRZ	TA,	CURFIL		;GET FILTAB ABS ADR.
	LDB	TB,	FI.PFS##	;GET FIRST STATUS WORD LINK.
	JUMPN	TB,	IA100A		;IF WE ALREADY HAVE ONE - DUP CLAUSE.
	MOVE	TB,	FI.SPT##	;GET BYTE POINTER TO ENTRIES.
	MOVEM	TB,	SAVLST##	;SAVE IT.
	HRREI	TB,	-11		;-MAXIMUM NUMBER OF NAMES ALLOWED.
	MOVEM	TB,	SAVLST+1	;SAVE IT.
	POPJ	PP,			;GO LOOK FOR NAMES.

;DUPLICATE CLAUSE - SKIP TO NEXT NON USER-NAME

IA100A:	MOVEI	TB,	1
	MOVEM	TB,	SAVLST+1	;FORCE SKIPPING.
	JRST		JBE16.		;GO GIVE ERROR MSG.


;SAW THE NAME OF A FILE STATUS ITEM.

	INTER.	IA101.
IA101.:	AOSGE	TA,	SAVLST+1	;DO WE HAVE AN ERROR CONDITION.
	JRST		IA101A		;NO.
	JUMPN	TA,	CPOPJ##		;FIRST TIME?
	EWARNJ		E.227		;YES, TOO MANY NAMES.
	JRST		IA101.		;BUMP COUNT AGAIN AND LEAVE.

IA101A:	PUSHJ	PP,	IA59S.		;GET THE NAMTAB ADDRESS.
	PUSHJ	PP,	IA28S.		;SET UP THE HLDTAB ENTRY.
	MOVE	TA,	CURHLD		;GET THE HLDTAB ADDRESS.
	MOVEI	TB,	%HL.ER		;I AM A FILE-STATUS.
	DPB	TB,	HL.COD		;PUT IT IN HLDTAB.
	MOVS	TB,	CURFIL		;GET THE FILTAB ADDRESS.
	DPB	TB,	HL.LNK		;FILTAB LINK TO HLDTAB.
	EXCH	TA,	TB
	MOVSS	TA,	TA
	MOVSS	TB,	TB
	IDPB	TB,	SAVLST		;HLDTAB LINK TO APPROPRIATE
					; FILTAB LOCATION.
IFN ANS74,<
	SKIPN	FLGSW##			;NEED TO FLAG EXTENSIONS?
	POPJ	PP,			;GO LOOK FOR MORE NAMES OR FOR
					; SOME QUALIFICATION.
	HRRZ	TB,SAVLST+1		;SEE IF SECOND TIME THROUGH
	CAIN	TB,-7			;SO WE GIVE ERROR ONLY ONCE
	FLAGAT	NS			;FLAG AS NON-STANDARD EXTENSION
>
	POPJ	PP,			;NO


;SAW SOME QUALIFICATION.

	INTER.	IA102.
IA102.:	SKIPLE		SAVLST+1	;DO WE HAVE AN ERROR CONDITION?
	POPJ	PP,			;YES, IGNORE QUALS.
	JRST		IA59.		;GO SAVE THE QUALS.
;DISPLAY IS DISPLAY-6/9/9

	INTER.	IA106.
IA106.:	MOVEI	TC,%US.D6	;DISPLAY-6
	SKIPL	DEFDSP##	;DON'T CHANGE IF SET BY SWITCH
	HRRM	TC,DEFDSP	;SET RHS
	POPJ	PP,

	INTER.	IA107.
IA107.:	MOVEI	TC,%US.D7	;DISPLAY-7
	SKIPL	DEFDSP		;DON'T CHANGE IF SET BY SWITCH
	HRRM	TC,DEFDSP
	POPJ	PP,

	INTER.	IA109.
IA109.:	MOVEI	TC,%US.EB	;DISPLAY-9
	HRROM	TC,DEFDSP	;SET LHS -1 TO MAKE TESTS EASIER LATER
	POPJ	PP,
IFN ANS74,<

	INTER.	IA200.
IA200.:	HRLZM	LN,COLNCP##	;STORE LINE NUMBER
	HRRM	CP,COLNCP	;AND CHAR POSITION INCASE OF ERROR
	TLNN	W1,GWLIT!GWRESV	;CANNOT ALLOW EITHER LIT OR RESERVED WORD
	JUMPL	W1,IA200A	;AND BETTER NOT BE IN NAMTAB YET
	MOVEI	DW,E.709
	PUSHJ	PP,FATAL##
	SETZ	W1,		;STORE NO COLLATING SEQUENCE
	JRST	IA201.

IA200A:	PUSHJ	PP,BLDNAM##	;CREATE NAMTAB ENTRY
	HLRZ	W1,TA		;SAVE NAMTAB ENTRY
	SKPNAM

	INTER.	IA201.
IA201.:	SKIPE	COLSEQ##	;ALREADY DEFINED?
	EWARNJ	E.30		;YES, DUPLICATED
	MOVEM	W1,COLSEQ	;STORE RESERVED WORD
	JRST	IA0.G		;GET NEXT WORD

	INTER.	IA201N
IA201N:	SKIPGE	DEFDSP		;IS DEFAULT EBCDIC?
	JRST	IA201E		;YES
	SKPNAM

	INTER.	IA201S
IA201S:	MOVEI	W1,%AN.AS
	JRST	IA201.

	INTER.	IA201E
IA201E:	MOVEI	W1,%AN.EB
	JRST	IA201.

;PUT ALPHABET-NAME IN MNETAB

	INTER.	IA202.
IA202.:	HRLZ	TA,LN		;SAVE LINE NUMBER
	HRR	TA,CP		;AND CHARACTER POSITION
	PUSH	PP,TA		;FOR LATER
	MOVSI	TA,(1B6)	;ALPHABET-NAME
	PUSHJ	PP,IA44.D	;PUT IN MNETAB
	MOVE	TA,[CD.MNE,,1]	;NEED ONE MORE WORD
	PUSHJ	PP,GETENT
	POP	PP,(TA)		;SAVE LN,,CP
	POPJ	PP,
;SET ALPHABET-NAME TO BE NATIVE (EITHER ASCII OR EBCDIC)

	INTER.	IA203N
IA203N:	SKIPGE	DEFDSP		;IS DEFAULT EBCDIC?
	JRST	IA203E		;YES
	SKPNAM

;SET ALPHABET-NAME TO BE STANDARD-1 OR ASCII

	INTER.	IA203S
IA203S:	MOVE	TA,CURMNE	;GET REL ADDRESS
	ANDI	TA,77777	;OFFSET
	ADD	TA,MNELOC##	;ABS.
	HRRZ	TB,1(TA)	;GET TYPE
	JUMPN	TB,JBE16.	;DUPLICATE
	MOVEI	TB,%AN.AS	;SET TYPE BIT
	IORM	TB,1(TA)		
	POPJ	PP,

;SET ALPHABET-NAME TO BE EBCDIC

	INTER.	IA203E
IA203E:	MOVE	TA,CURMNE	;GET REL ADDRESS
	ANDI	TA,77777	;OFFSET
	ADD	TA,MNELOC	;ABS.
	HRRZ	TB,1(TA)	;GET TYPE
	JUMPN	TB,JBE16.	;DUPLICATE
	MOVEI	TB,%AN.EB	;SET TYPE BIT
	IORM	TB,1(TA)		
	POPJ	PP,

;SET ALPHABET-NAME TO BE LITERAL AND STORE FIGCON

	INTER.	IA203F
IA203F:	FLAGAT	HI
	MOVE	TA,CURMNE	;GET REL ADDRESS
	ANDI	TA,77777	;OFFSET
	ADD	TA,MNELOC	;ABS.
	HRRZ	TB,1(TA)	;GET TYPE
	JUMPN	TB,JBE16.	;DUPLICATE
	JRST	IA204F		;COPY FIRST FIGCON 

;SET ALPHABET-NAME TO BE LITERAL AND STORE FIRST INTEGER

	INTER.	IA203I
IA203I:	FLAGAT	HI
	MOVE	TA,CURMNE	;GET REL ADDRESS
	ANDI	TA,77777	;OFFSET
	ADD	TA,MNELOC	;ABS.
	HRRZ	TB,1(TA)	;GET TYPE
	JUMPN	TB,JBE16.	;DUPLICATE
	JRST	IA204I		;COPY FIRST LITERAL
;SET ALPHABET-NAME TO BE LITERAL AND STORE FIRST LITERAL

	INTER.	IA203L
IA203L:	FLAGAT	HI
	MOVE	TA,CURMNE	;GET REL ADDRESS
	ANDI	TA,77777	;OFFSET
	ADD	TA,MNELOC	;ABS.
	HRRZ	TB,1(TA)	;GET TYPE
	JUMPN	TB,JBE16.	;DUPLICATE
	SKPNAM			;COPY FIRST LITERAL

;STORE LITERAL IN MNETAB

	INTER.	IA204.
IA204.:	LDB	TA,GWVAL	;GET LITERAL SIZE
	HRLI	TA,CD.MNE
	PUSHJ	PP,GETENT
	LDB	TB,GWVAL
	MOVE	TC,[POINT 7,LITVAL]
IA204L:	ILDB	TD,TC
	SKIPGE	DEFDSP		;IS DEFAULT IS DISPLAY-9
	PUSHJ	PP,IA205C	;YES, CONVERT TO EBCDIC
	MOVEM	TD,(TA)
	ADDI	TA,1
	SOJG	TB,IA204L	;COPY LITERAL INTO MNETAB
	POPJ	PP,

;STORE FIGCON IN MNETAB

	INTER.	IA204F
IA204F:	MOVE	TA,[CD.MNE,,1]
	PUSHJ	PP,GETENT
	PUSHJ	PP,GETFCN
	MOVEM	TD,(TA)
	POPJ	PP,

;STORE INTEGER IN MNETAB

	INTER.	IA204I
IA204I:	PUSHJ	PP,IA16S.	;GET VALUE
	  JFCL			;ERROR RETURN
	CAILE	TC,^D256	;IS IT IN RANGE?
	JRST	IA205E		;NO
	SOSN	TC		;REDUCE TO INDEX
	TRO	TC,1B20		;SO ZERO WILL WORK
	PUSH	PP,TC		;SAVE VALUE
	MOVE	TA,[CD.MNE,,1]
	PUSHJ	PP,GETENT
	POP	PP,(TA)	
	POPJ	PP,
;STORE THRU LITERAL IN MNETAB

	INTER.	IA205.
IA205.:	LDB	TA,GWVAL	;GET LITERAL SIZE
	CAIE	TA,1
	JRST	IA206E
	HRLI	TA,CD.MNE
	PUSHJ	PP,GETENT
	LDB	TD,[POINT 7,LITVAL,6]
	SKIPGE	DEFDSP		;IS DEFAULT DISPLAY-9
	PUSHJ	PP,IA205C	;YES, CONVERT TO EBCDIC
	TRO	TD,1B18		;SET THRU FLAG
	MOVEM	TD,(TA)
	POPJ	PP,

;STORE THRU INTEGER IN MNETAB

	INTER.	IA205I
IA205I:	PUSHJ	PP,IA16S.	;GET VALUE
	  JFCL			;ERROR RETURN
	CAILE	TC,^D256	;IS IT IN RANGE?
	JRST	IA205E		;NO
	SUBI	TC,1
	TRO	TC,1B18		;SET THRU FLAG
	PUSH	PP,TC		;SAVE VALUE
	MOVE	TA,[CD.MNE,,1]
	PUSHJ	PP,GETENT
	POP	PP,(TA)	
	POPJ	PP,

;STORE ALSO LITERAL IN MNETAB

	INTER.	IA206.
IA206.:	LDB	TA,GWVAL	;GET LITERAL SIZE
	CAIE	TA,1
	JRST	IA206E
	HRLI	TA,CD.MNE
	PUSHJ	PP,GETENT
	LDB	TD,[POINT 7,LITVAL,6]
	SKIPGE	DEFDSP		;IS DEFAULT DISPLAY-9
	PUSHJ	PP,IA205C	;YES, CONVERT TO EBCDIC
	TRO	TD,1B19		;SET ALSO FLAG
	MOVEM	TD,(TA)
	POPJ	PP,

;STORE ALSO FIGCON IN MNETAB

	INTER.	IA206F
IA206F:	MOVE	TA,[CD.MNE,,1]
	PUSHJ	PP,GETENT
	PUSHJ	PP,GETFCN
	TRO	TD,1B19		;SET ALSO FLAG
	MOVEM	TD,(TA)
	POPJ	PP,
;STORE ALSO INTEGER IN MNETAB

	INTER.	IA206I
IA206I:	PUSHJ	PP,IA16S.	;GET VALUE
	  JFCL			;ERROR RETURN
	CAILE	TC,^D256	;IS IT IN RANGE?
	JRST	IA205E		;NO
	SUBI	TC,1
	TRO	TC,1B19		;SET ALSO FLAG
	PUSH	PP,TC		;SAVE VALUE
	MOVE	TA,[CD.MNE,,1]
	PUSHJ	PP,GETENT
	POP	PP,(TA)	
	POPJ	PP,

GETFCN:	LDB	TB,GWVAL	;GET WHICH
	SETO	TD,		;MAKE IT
	CAIN	TB,HIVAL.	;HIGH-VALUE?
	MOVEI	TD,177
	CAIN	TB,LOVAL.	;LOW-VALUE?
	SETZ	TD,
	CAIN	TB,QUOTE.	;QUOTE?
	MOVEI	TD,42
	CAIN	TB,SPACE.	;SPACE?
	MOVEI	TD," "
	CAIN	TB,ZERO.	;ZERO?
	MOVEI	TD,"0"
	JUMPGE	TD,CPOPJ	;VALID CHAR, RETURN
	POP	PP,(PP)
	JRST	JBE16.		;MUST BE ILLEGAL

IA205E:	MOVEI	DW,E.720
	PJRST	FATAL

IA206E:	MOVEI	DW,E.712
	PJRST	FATAL

IA205C:				;ROUTINE TO CONVERT AN ASCII CHAR TO EBCDIC.
	ROT	TD,-2		;FORM THE INDEX INTO THE TABLE.
	JUMPL	TD,IA205D	;LEFT OR RIGHT HALF?
	HLR	TD,ASEBC.(TD)	;LEFT.
	CAIA
IA205D:	HRR	TD,ASEBC.(TD)	;RIGHT.
	TLNN	TD,(1B1)	;IS THE CHAR RIGHT JUSTIFIED?
	LSH	TD,-^D9		;IT IS NOW.
	ANDI	TD,377		;CLEAR JUNK
	POPJ	PP,
IA210.:	HRRZ	TA,MNELOC
	ADDI	TA,1		;BYPASS ZERO
IA210L:	MOVE	TB,1(TA)	;GET 2'ND WORD
	TLNE	TB,(1B5)	;RD CODE?
	JRST	IA210D		;YES
	TLNE	TB,(1B6)	;ALPHABET-NAME?
	TRNE	TB,-1		;YES, BUT IS IT A LITERAL?
	AOJA	TA,IA210E	;NO, BUT ACCOUNT FOR <LN,,CP> WORD
	HRRZ	TB,TA		;SETUP AOBJP COUNTER
	SKIPLE	TC,3(TB)	;START OF NEXT ENTRY OR TABLE
	JRST	[TRZE	TC,1B20		;NO, CLEAR ZERO MARKER
		MOVEM	TC,3(TB)	;PUT LIT VALUE BACK
		AOBJP	TB,.-1]		;NOT YET
	HLRZ	TB,TB		;GET COUNT OF ITEMS
	HRRM	TB,1(TA)	;STORE COUNT
	HLRZ	TC,(TA)		;GET FIRST WORD
	ANDI	TC,77777	;GET INDEX TO MNETAB
	CAMN	TC,COLSEQ	;IS IT SAME AS PROGRAM COL. SEQ.?
	HRLM	TA,COLSEQ	;YES, STORE MNETAB LOCATION
	ADDI	TA,1		;ACCOUNT FOR <LN,,CP> WORD
IA210D:	ADDI	TA,(TB)		;ADD IN SIZE OF RD CODE
IA210E:	ADDI	TA,SZ.MNE	;ADD IN NORMAL SIZE
	HRRZ	TB,MNENXT##
	CAIGE	TA,(TB)		;FINISHED?
	JRST	IA210L		;NO
	HLRZ	TA,COLSEQ	;DO WE HAVE A PROGRAM COLLATING SEQUENCE
	JUMPE	TA,CPOPJ	;NO
				;YES
;;USE CODE TAKEN FROM COBOLE TO SETUP THE PROGRAM COLLATING SEQUENCE
;THIS IS NEEDED HERE SO THAT LOW-VALUES AND HIGH-VALUES CAN BE SETUP CORRECTLY
	HRRZS	COLSEQ		;RESTORE COLSEQ
	MOVE	TB,1(TA)	;GET 2'ND WORD
	TLNE	TB,(1B5)	;RD CODE?
	POPJ	PP,		;YES, SHOULD NEVER HAPPEN
	TLNN	TB,(1B6)	;ALPHABET-NAME?
	POPJ	PP,		;NO
	ANDI	TB,777		;YES, BUT IS IT A LITERAL?
	JUMPE	TB,CPOPJ	;NO
	MOVE	TC,[PRGCOL##,,PRGCOL+1]
	SETOM	PRGCOL
	BLT	TC,PRGZRL##	;INITIALIZE ALL OF TABLE
	MOVN	TB,TB
	HRL	TA,TB		;SETUP AOBJN POINTER
	SETO	TC,		;STORE POINTER (INCREMENTED BEFORE STORE)
	SETZB	TD,ILCSIX##	;ALSO COUNT AND SIXBIT OFFSET
	SETZM	EXCEBC##	;CLEAR EBCDIC ONLY COUNT
CSMNEN:	MOVE	TB,3(TA)	;GET LITERAL
	TRZE	TB,1B18		;THRU?
	JRST	CSMNET		;YES
	TRZE	TB,1B19		;ALSO?
	JRST	CSMNEA		;YES
	ADDI	TC,1(TD)	;IN CASE ALSO
	SETZ	TD,
	PUSHJ	PP,CSMTST	;STORE IF FIRST TIME
	JRST	CSMNEJ		;GET NEXT

CSMNEA:	PUSHJ	PP,CSMTST	;STORE IF FIRST TIME
	AOJA	TD,CSMNEJ	;GET NEXT

CSMNET:	ADDI	TC,0(TD)	;INCASE ANY ALSO
	MOVE	TD,TB		;SAVE THRU LIT
	MOVE	TB,2(TA)	;GET PREVIOUS LITERAL
	SUBM	TB,TD		;GET -NO. TO DO
	JUMPG	TD,CSMNER	;ORDER IS REVERSED
	ADDI	TB,1		;GET NEXT
	HRL	TB,TD		;AOBJN POINTER
	SETZ	TD,
CSMNEU:	ADDI	TC,1		;POINT TO CURRENT
	PUSHJ	PP,CSMTST	;STORE IF FIRST TIME
	AOBJN	TB,CSMNEU	;LOOP
	JRST	CSMNEJ

CSMNER:	SUBI	TB,(TD)		;GET OTHER END
	MOVN	TD,TD		;GET - LENGTH
	HRL	TB,TD		;AOBJN LOOP PTR
	MOVN	TD,TD		;+ SIZE
	ADDI	TC,1(TD)	;GET LAST FIRST
	SUBI	TD,1		;WHAT TO ADD ON WHEN FINISHED
CSMNEV:	SUBI	TC,1		;POINT TO CURRENT
	PUSHJ	PP,CSMTST	;STORE IF FIRST TIME
	AOBJN	TB,CSMNEV	;LOOP

CSMNEJ:	AOBJN	TA,CSMNEN	;NOT YET

;NOW LOOP THROUGH TABLE FILLING IN MISSING VALUES

	ADDI	TC,1(TD)	;IN CASE ANY ALSO'S LEFT
	MOVSI	TA,-40		;SCAN FIRST PART OF TABLE
	PUSH	PP,TC		;SAVE NUMBER KNOWN
CSMNEH:	SKIPL	PRGCOL(TA)
	JRST	CSMNEI
	HRLM	TC,PRGCOL(TA)	;STORE ASCII ONLY
	AOS	ILCSIX		;ACCOUNT FOR NO SIXBIT HERE
	ADDI	TC,1
CSMNEI:	AOBJN	TA,CSMNEH
	HRLI	TA,-100		;SCAN REST OF SIXBIT TABLE
CSMNEF:	SKIPL	PRGCOL(TA)	;ALREADY SET
	JRST	CSMNEG		;YES
	HRLM	TC,PRGCOL(TA)	;STORE NEW VALUE
	SUB	TC,ILCSIX	;REMOVE EFFECT OF NO SIXBIT
	HRLM	TC,PRGCOL+200(TA)
	ADD	TC,ILCSIX
	ADDI	TC,1
CSMNEG:	AOBJN	TA,CSMNEF	;TRY NEXT
	HRLI	TA,-40		;SCAN LAST PART OF TABLE
CSMNEK:	SKIPL	PRGCOL(TA)
	JRST	CSMNEM
	HRLM	TC,PRGCOL(TA)	;NO SIXBIT
	ADDI	TC,1
CSMNEM:	AOBJN	TA,CSMNEK
	POP	PP,TC		;RESTORE COUNT
	MOVSI	TA,-400		;SCAN EBCDIC TABLE
CSMNEO:	HRRE	TB,PRGCOL(TA)	;GET EBCDIC PART
	JUMPGE	TB,CSMNEP	;ALREADY SET UP
	HRRM	TC,PRGCOL(TA)
	ADDI	TC,1
CSMNEP:	AOBJN	TA,CSMNEO

;NOW LOOP THROUGH LOOKING FOR LOW-VALUES AND HIGH-VALUES
	SETOB	TB,COHVLV##	;INITIALIZE TABLE
	MOVE	TC,[COHVLV,,COHVLV+1]
	BLT	TC,COHVLV+5	;TO LOWEST VALUE
	MOVSI	TA,-200		;ASCII
HVLVA:	HLRZ	TC,PRGCOL(TA)
	JUMPN	TC,HVLVA1	;NOT LOW-VALUES
	SKIPGE	COHVLV+4	;FIRST TIME?
	HRRZM	TA,COHVLV+4	;YES, STORE CHARACTER
HVLVA1:	CAMGE	TC,TB		;HIGH-VALUE
	JRST	HVLVA2		;NO
	HRRZM	TA,COHVLV+1	;YES, STORE LATEST CANDIDATE
	MOVE	TB,TC		;UPDATE CURRENT HIGHEST
HVLVA2:	AOBJN	TA,HVLVA

	MOVSI	TA,-100		;SIXBIT
	SETO	TB,
HVLVS:	HLRZ	TC,PRGCOL+240(TA)
	JUMPN	TC,HVLVS1	;NOT LOW-VALUES
	SKIPGE	COHVLV+3	;FIRST TIME?
	HRRZM	TA,COHVLV+3	;YES, STORE CHARACTER
HVLVS1:	CAMGE	TC,TB		;HIGH-VALUE
	JRST	HVLVS2		;NO
	HRRZM	TA,COHVLV	;YES, STORE LATEST CANDIDATE
	MOVE	TB,TC		;UPDATE CURRENT HIGHEST
HVLVS2:	AOBJN	TA,HVLVS

	MOVSI	TA,-400		;EBCDIC
	SETO	TB,
HVLVE:	HRRZ	TC,PRGCOL(TA)
	JUMPN	TC,HVLVE1	;NOT LOW-VALUES
	SKIPGE	COHVLV+5	;FIRST TIME?
	HRRZM	TA,COHVLV+5	;YES, STORE CHARACTER
HVLVE1:	CAMGE	TC,TB		;HIGH-VALUE
	JRST	HVLVE2		;NO
	HRRZM	TA,COHVLV+2	;YES, STORE LATEST CANDIDATE
	MOVE	TB,TC		;UPDATE CURRENT HIGHEST
HVLVE2:	AOBJN	TA,HVLVE
	POPJ	PP,

CSMTST:	SKIPGE	DEFDSP		;IS DEFAULT DISPLAY-9
	JRST	CSMSTX		;YES
	SKIPL	PRGCOL(TB)	;ALREADY SETUP?
	POPJ	PP,		;YES, ERROR WILL BE CAUGHT BY COBOLE
	PUSH	PP,TB		;SAVE TB
CSMSTR:	CAIL	TB,200		;IN ASCII RANGE?
	SOJA	TC,CSMSNA	;NO
	HRLM	TC,PRGCOL(TB)	;STORE NEW ASCII VALUE
	HRRZ	TB,TB		;INCASE AOBJN PTR
	CAIL	TB,40		;IS IT IN SIXBIT RANGE?
	CAIL	TB,140		;...
	JRST	CSMSNS		;NO
	SUB	TC,ILCSIX	;REMOVE NON-SIXBIT COUNT
	HRLM	TC,PRGCOL+200(TB)	;STORE SIXBIT
	ADD	TC,ILCSIX	;RESTORE COUNT
CSMSTE:	SKIPGE	DEFDSP		;IS DEFAULT DISPLAY-9
	JRST	CSMSTZ		;YES, WE'RE ALL DONE

				;ROUTINE TO CONVERT AN ASCII CHAR TO EBCDIC.
	CAIL	TB,200		;IS IT OUTSIDE ASCII RANGE?
	JRST	CSMSTG		;YES, USE AS IS
	ROT	TB,-2		;FORM THE INDEX INTO THE TABLE.
	JUMPL	TB,CSMSTF	;LEFT OR RIGHT HALF?
	HLR	TB,ASEBC.##(TB)	;LEFT.
	CAIA
CSMSTF:	HRR	TB,ASEBC.##(TB)	;RIGHT.
	TLNN	TB,(1B1)	;IS THE CHAR RIGHT JUSTIFIED?
	LSH	TB,-^D9		;IT IS NOW.
	ANDI	TB,377		;CLEAR JUNK
CSMSTG:	ADD	TC,EXCEBC	;ADD IN EXCESS COUNT
	HRRM	TC,PRGCOL(TB)	;STORE EBCDIC
	SUB	TC,EXCEBC
CSMSTZ:	POP	PP,TB		;RESTORE
	POPJ	PP,

CSMSNA:	AOSA	EXCEBC		;ONE MORE THAT IS ONLY EBCDIC
CSMSNS:	AOS	ILCSIX		;ONE MORE THAT ISN'T SIXBIT
	JRST	CSMSTE		;TRY EBCDIC

CSMSTX:	HRL	TC,PRGCOL(TB)	;GET CURRENT CHAR.
	JUMPGE	TC,CPOPJ	;ALREADY EXISTS
	HRRZ	TC,TC		;CLEAR LHS.
	ADD	TC,EXCEBC	;ADD EXCESS
	HRRM	TC,PRGCOL(TB)	;SAVE EBCDIC CHAR
	SUB	TC,EXCEBC
	PUSH	PP,TB		;SAVE CHAR
	HRRZ	TB,TB		;INCASE AOBJN PTR
				;ROUTINE TO CONVERT AN EBCDIC CHAR TO ASCII.
	ROT	TB,-2		;FORM THE INDEX INTO THE TABLE.
	JUMPL	TB,CSMSTY	;LEFT OR RIGHT HALF?
	HLR	TB,EBASC.##(TB)	;LEFT.
	CAIA
CSMSTY:	HRR	TB,EBASC.##(TB)	;RIGHT.
	TLNN	TB,(1B1)	;IS THE CHAR RIGHT JUSTIFIED?
	LSH	TB,-^D9		;IT IS NOW.
	ANDI	TB,177		;CLEAR JUNK
	CAIE	TB,134		;\ IS SPECIAL
	JRST	CSMSTR		;NOW STORE ASCII
	HRRZ	TB,0(PP)	;AS IT MIGHT BE ILLEGAL CHAR
	CAIE	TB,340		;UNLESS EBCDIC \
	SOJA	TC,CSMSNA	;ILLEGAL SO DON'T STORE
	MOVEI	TB,134		;RESTORE \
	JRST	CSMSTR		;AND STORE IT

>


	END	COBOLB