Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

; UPD ID= 1231 on 6/1/83 at 5:25 PM by NIXON                            
TITLE	COBCOM FOR COBOL V13
SUBTTL	SUBROUTINES USED BY MOST OR ALL PHASES IN COBOL

	SEARCH COPYRT
	SALL

;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

COPYRIGHT (C) 1974, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	P,COBVER
IFN TOPS20,<SEARCH	MONSYM,MACSYM>
	SEARCH	UUOSYM			;TEMP
IFE TOPS20,<SEARCH	UUOSYM>		;[1014] GET SYMBOLS FOR PATH SPECIFICATION

	%%P==:%%P
	DEBUG==:DEBUG
	ONESEG==:ONESEG
	TOPS20==:TOPS20

TWOSEG	%HISEG
	.COPYRIGHT		;Put standard copyright statement in REL file

LOC	137
EXP	CBLVER

RELOC	%HISEG
SALL

;EDITS
;NAME	DATE		COMMENTS

;JEH	18-Nov-82	[1424] Add FNDFIL routine for phase C use.
;JEH	18-Mar-82	[1345] Trap illegal UUO's on TOPS-10.
;V12*****************
;DMN	23-APR-80	[1014] LIST FULL PATH ON LOOKUP/ENTER ERRORS.
;DAW	26-FEB-79	[640] FIX ILLEGAL MEMORY REFERENCE WHEN EXPANDING
;			TABLES IN PHASE O
;DMN	22-FEB-79	[636] MORE OF EDIT 510

;V10*****************
;EHM	14-SEP-77	[510] PREVENT CATASTROPHE IN PHASE E WHEN COPY
;			 TO LINKAGE SECTION IS INCORRECT SUCH THAT THERE
;			 IS NO LINK SET UP TO THE 01 LEVEL GRANDFATHER.
;EHM	11-AUG-77	[506] MAKE NEW EXIT QUITS WHICH RETURNS TO
;			COBOLA WITHOUT GOING TO COBOLK
;MFTT	8/30/77		ADD "DRFTAG" ROUTINE
;DAW	8/16/77		ADD "REFTAG" ROUTINE
;DAW	8/15/77		CHANGE TAGTAB TO A FULL-WORD-ENTRY TABLE
;DPL	18-AUG-76	[440] FIX XPANDING NAMTAB CAUSING SPURIOUS ERRORS
;DBT	12/7/74		FIX KILL TO JRST TO COBOLK IN ONESEG COMPILER
;DBT	12/1/74		CHANGE REFERENCES TO REGO TO LOCATION RATHER THAN
;			IMMEDIATE ADDRESS
;********************

;EDIT 266 ADD TTY ROUTINE TO TURN OFF USER CONTROL O

;ENTRY POINTS AND GLOBAL SYMBOLS

IFE ONESEG,<
ENTRY	COBEXO		;EXECUTE ONLY ENTRY FROM GETSEG CODE
>
IFE TOPS20,<
ENTRY	RESTRT		;RESTART COMPILATION (REENTER)
ENTRY	REDO		;RESTART COMPILATION (START)
ENTRY	DEVERA		;DEVICE TRANSMISSION ERROR
ENTRY	DEVDED		;WRITE ERROR ON SCRATCH FILE
ENTRY	EOTAPE		;PUT OUT MAG-TAPE EOT MESSAGE
EXTRY	XPNPPL
ENTRY	UUOC1		;[1345] TRAP ILLEGAL UUO'S
ENTRY	FILOUT		;TYPE OUT DEV:FILE.EXT[P,P]
ENTRY	ERATYP		;TYPE OUT ENTER/LOOKUP FAIL MESSAGE
>
ENTRY	SIXOUT		;TYPE OUT A SIXBIT WORD
ENTRY	LNKSET		;CREATE A TABLE ADDRESS FROM TABLE-LINK
ENTRY	KILL		;KILL COMPILATION, DUMP CORE AND FILES
ENTRY	KILLF		;KILL COMPILATION, DUMP FILES ONLY
ENTRY	QUITS		;[506] STOP COMPILATION, NO DUMP
ENTRY	UUOCAL		;UUO TRAP
ENTRY	TTYON		;[266] TURN TTY OUTPUTS BACK ON
ENTRY	PUTLNK,FNDLNK,FNDNXT,GETENT,GETLOC
ENTRY	GETTAG,REFTAG,DRFTAG
ENTRY	FNDPOP,FNDBRO,FNDFIL	;[1424]
ENTRY	ADDCOR		;ADD 1K TO THE IMPURE AREA
ENTRY	SETCOR		;SET WORK AREA TO IT'S INITIAL SIZE
IFN TOPS20,<
ENTRY	GETCOR		;SET CORE TO NEW SIZE
>
ENTRY	BLTUP		;MOVE UP SOME DATA
ENTRY	FATALW		;PUT OUT A FATAL DIAG FOR CURRENT WORD
ENTRY	WARNW		;PUT OUT A WARNING DIAG FOR CURRENT WORD
ENTRY	FATAL		;PUT OUT A FATAL DIAG (LN & CP HAVE BEEN SET UP)
ENTRY	WARN		;PUT OUT A WARNING DIAG (LN & CP HAVE BEEN SET UP)
ENTRY	WARNAD		;PUT OUT A WARNING DIAG WITH APPENDED DATA
ENTRY	PUTERA		;PUT OUT "DW" AS IS

INTERN	XPAND
INTERN	CPOPJ,CPOPJ1,CPOPJ2
INTERN	FLG.ER	;PUT OUT FIPS FLAGGER WARNING
INTERN	FLG.ES	;DITTO (LN & CP HAVE BEEN SET UP)
INTERN	TST.L,TST.LI,TST.HI,TST.H,TST.RP,TST.DB,TST.68,TST.IB,TST.VX,TST.8,TST.NS

IFE TOPS20,<
INTERN	OCTOUT
EXTERN	DEVDEV,DEVFIL,DEVEXT,DEVPP
EXTERN	GETFNM,GETFST,ERABHO
>
IFN TOPS20,<
EXTERN	RESTRT
>

EXTERN	KILLAC
EXTERN	LITLOC,FILLOC,DATLOC,CONLOC,PROLOC,EXTLOC,MNELOC,VALLOC
EXTERN	TOPLOC,NAMNXT,FREESP,SAVEAC,NAMLOC,NM1LOC,NM2LOC,CURNAM
EXTERN	ERALN, ERAPOS, ERAFAZ, PHASEN
EXTERN	ERADEV
EXTERN	WORDLN, WORDCP
IFE ONESEG,<
EXTERN	GETLOD,MLOAD1
>
IFN TOPS20,<
EXTERN	RITERA,ERABH
SYN ERABH,ERABHO
>

;HERE FOR EXECUTE ONLY (TOPS-10 STYLE) ENTRY
;THIS ROUTINE MUST BE THE FIRST IN THE HIGH SEGMENT

IFE ONESEG,<
COBEXO:
 IFE TOPS20,<
	PORTAL	.+1		;INCASE EXECUTE ONLY
 >
	HRRZ	17,%HISEG+.JBHSA##	;STARTING ADDRESS
	EXCH	17,GETFST	;SWAP WITH INCREMENT
	CAILE	17,2		;MAKE SURE INCREMENT IS LEGAL
	HALT	.		;NO, KILL JOB
	ADDM	17,GETFST	;ADD IN INCREMENT
	MOVE	17,SAVEAC+17	;RESTORE ACC 17
	JRST	@GETFST##	;GO TO SEGMENT START ADDRESS
>

IFE TOPS20,<
;DEVICE TRANSMISSION ERROR
;THIS ROUTINE IS ENTERED WITH RH OF "CH" POINTING TO A TABLE
;	CONSISTING OF:
;		WORD1: DEVICE NAME IN SIXBIT
;		WORD2: FILE-NAME IN SIXBIT
;		WORD3: FILE-NAME EXTENSION IN LH, IN SIXBIT
;	LH OF CH CONTAINS GETSTS FLAGS WHEN DEVERA CALLED.

;A MESSAGE IS TYPED OUT
;DEVERA WAITS FOR THE OPERATOR TO TYPE "CONTINUE".
;WHEN HE DOES, THE ROUTINE RETURNS TO:
;		CALL+1 IF DEVICE IS MTA
;		CALL+2 IF DEVICE IS DSK OR DTA
;		CALL+3 IF DEVICE IS CDR OR LPT

;IF THE DEVICE IS NOT DTA,DSK,MTA,CDR OR LPT, THIS ROUTINE DOES
;	A CALL [SIXBIT /EXIT/]

;DEVDED ALWAYS CALLS [SIXBIT /EXIT/]


DEVERA:	PUSH	PP,TE
	MOVE	TE,(CH)		;IS IT MTA?
	DEVCHR	TE,
	TLNE	TE,(DV.MTA)
	TLNN	CH,IO.EOT		;YES--END OF TAPE?
	JRST	.+3		;NO

	POP	PP,TE		;YES--RETURN
	POPJ	PP,

	POP	PP,TE

	PUSHJ	PP,DEVERB
	JRST	DEVERC

DEVDED:	PUSHJ	PP,DEVERB
	JRST	DEVER2

;TYPE OUT ERROR MESSAGE

DEVERB:	OUTSTR	[ASCIZ "Transmission error for "]

DVERB1:	PUSH	PP,TA
	PUSH	PP,TE

	MOVE	TA,(CH)
	PUSHJ	PP,SIXOUT
	MOVEI	TD,":"
	OUTCHR	TD

	SKIPE	TA,1(CH)
	PUSHJ	PP,SIXOUT

	HLLZ	TA,2(CH)
	JUMPE	TA,DVERB2
	MOVEI	TD,"."
	OUTCHR	TD
	PUSHJ	PP,SIXOUT
DVERB2:	POP	PP,TE
	POP	PP,TA

	OUTSTR	CRLF
	POPJ	PP,

;END OF MAG-TAPE

EOTAPE:	OUTSTR	[ASCIZ "Mount another reel on "]
	JRST	DVERB1

;GET CHARACTERISTICS OF DEVICE

DEVERC:	MOVE	CH,(CH)
	DEVCHR	CH,
	TLNN	CH,OKDEVS	;IS IT POSSIBLE TO CONTINUE?
	JRST	DEVER2		;NO

	OUTSTR	[ASCIZ "To Retry, type Continue
"]
	CALLI	1,$EXIT

	TLNN	CH,(DV.MTA)	;IS IT MAG-TAPE?
	POPJ	PP,		;YES--EXIT TO CALL+1
	TLNN	CH,(DV.DSK!DV.DTA)	;NO--IS IT DISK OR DEC-TAPE?
CPOPJ2:	AOS	(PP)		;NO--EXIT TO CALL+3
CPOPJ1:	AOS	(PP)		;YES--EXIT TO CALL+2
CPOPJ:	POPJ	PP,

;CANNOT CONTINUE--EXIT

DEVER2:	OUTSTR	[ASCIZ "?Cannot continue
"]
	JRST	RESTRT

OKDEVS==(DV.MTA!DV.DTA!DV.LPT!DV.CDR!DV.DSK)

ERATYP:	PUSHJ	PP,FILOUT	;TYPE 'DEV:FILE.EXT[PROJ,PROG]'
	OUTSTR	[ASCIZ " ("]
	HRRZ	TA,I2
	PUSHJ	PP,OCTOUT

	MOVE	TA,ERAPTR
ERAT1:	HLRZ	TB,(TA)
	CAIE	TB,(I2)
	AOBJN	TA,ERAT1

	HRRZ	TA,(TA)
	OUTSTR	(TA)
	OUTSTR	CRLF
	TSWT	FDSKC;
	SWOFF	FECOM;
	JRST	RESTRT


ERAT2:	XWD	0,[ASCIZ ") No file name"]
	XWD	1,[ASCIZ ") Incorrect proj-prog no."]
	XWD	2,[ASCIZ ") Protection failure"]
	XWD	3,[ASCIZ ") File being modified"]
	XWD	6,[ASCIZ ") Bad UFD or bad RIB"]
	XWD	14,[ASCIZ ") No room, or quota exceeded"]
	XWD	15,[ASCIZ ") Write lock"]
	XWD	16,[ASCIZ ") Not enough table space in monitor"]
	XWD	23,[ASCIZ ") SFD not found"]
	XWD	24,[ASCIZ ") Search list empty"]
	XWD	25,[ASCIZ ") SFD nest level too deep"]
	XWD	26,[ASCIZ ") No-create on for all search list"]
	XWD	0,[ASCIZ ") Unknown error"]	;Safety valve

INTERN	ERAPTR
ERAPTR:	XWD	ERAT2-.+1,ERAT2

;TYPE OUT "DEV:FILE.EXT[PROJ,PROG]""

FILOUT:	MOVE	TA,DEVDEV(DA)	;TYPE OUT DEVICE NAME
	PUSHJ	PP,SIXOUT
	MOVEI	CH,":"
	OUTCHR	CH
	SKIPE	TA,DEVFIL(DA)	;ANY FILE NAME?
	PUSHJ	PP,SIXOUT	;YES--TYPE IT OUT
	SKIPN	TA,DEVEXT(DA)	;ANY EXTENSION?
	JRST	FILO1		;NO
	MOVEI	CH,"."		;YES--TYPE IT OUT
	OUTCHR	CH
	PUSHJ	PP,SIXOUT

FILO1:	SKIPN	DEVPP(DA)	;ANY PROJ-PROG #?
	POPJ	PP,		;NO
	MOVEI	CH,"["		;YES--TYPE IT OUT
	OUTCHR	CH
	HLRZ	TA,DEVPP(DA)
IFE TOPS20,<
	JUMPE	TA,FILO4	;[1014] FULL PATH SPECIFIED IF <0,,ADDRESS>
>
	PUSHJ	PP,OCTOUT
	MOVEI	CH,","
	OUTCHR	CH
	HRRZ	TA,DEVPP(DA)
	PUSHJ	PP,OCTOUT
FILO3:	MOVEI	CH,"]"		;[1014]
	OUTCHR	CH
	POPJ	PP,

;[1014] TYPE OUT THE FULL PATH SPECIFICATION

FILO4:	PUSH	PP,DA		;[1014] IN CASE IT'S NEEDED LATER
	MOVE	DA,DEVPP(DA)	;[1014] GET THE PATH POINTER
	HLRZ	TA,.PTPPN(DA)	;[1014] GET THE PPN
	PUSHJ	PP,OCTOUT	;[1014]
	MOVEI	CH,","		;[1014]
	OUTCHR	CH		;[1014]
	HRRZ	TA,.PTPPN(DA)	;[1014]
	PUSHJ	PP,OCTOUT	;[1014]
	HRLI	DA,-5		;[1014] MAX. SFDS ALLOWED
FILO5:	SKIPN	TA,.PTSFD(DA)	;[1014] GET SFD
	JUMPE	TA,FILO6	;[1014] ALL DONE
	MOVEI	CH,","		;[1014]
	OUTCHR	CH		;[1014]
	PUSHJ	PP,SIXOUT	;[1014]
	AOBJN	DA,FILO5	;[1014] LOOP FOR ALL SFDS
FILO6:	POP	PP,DA		;[1014]
	JRST	FILO3		;[1014] FINISH OFF PATH

;TYPE OUT THE OCTAL NUMBER IN RH OF "TA"

OCTOUT:	MOVE	TB,[POINT 3,TA,17]
	ILDB	CH,TB
	TLNE	TB,770000
	JUMPE	CH,.-2

OCTO1:	ADDI	CH,"0"
	OUTCHR	CH

	TLNN	TB,770000
	POPJ	PP,
	ILDB	CH,TB
	JRST	OCTO1
>

;PUT OUT A SIXBIT WORD ONTO TTY

IFE TOPS20,<
SIXOUT:	MOVE	TE,[POINT 6,TA]
SIXO1:	ILDB	TD,TE
	JUMPE	TD,CPOPJ
	ADDI	TD,40
	OUTCHR	TD
	TLNE	TE,770000
	JRST	SIXO1
	POPJ	PP,
>
IFN TOPS20,<
SIXOUT:	PUSH	PP,T1
	MOVE	TE,[POINT 6,TA]
SIXO1:	ILDB	T1,TE
	JUMPE	T1,SIXO2
	ADDI	T1,40
	PBOUT%
	TLNE	TE,770000
	JRST	SIXO1
SIXO2:	POP	PP,T1
	POPJ	PP,
>


IFN TOPS20,<
CPOPJ2:	AOS	(PP)		;NO--EXIT TO CALL+3
CPOPJ1:	AOS	(PP)		;YES--EXIT TO CALL+2
CPOPJ:	POPJ	PP,
>
CRLF:	ASCIZ "
"

;SET UP A TABLE ADDRESS

;THIS ROUTINE IS USED TO CONVERT A TABLE LINK TO AN ADDRESS WHEN WE
; DON'T KNOW OR CARE WHAT TABLE THE LINK IS TO.

;ENTER WITH TABLE-LINK IN "TA"
;	BITS 18-20 = TABLE TYPE, BITS 21-35 = RELATIVE ADDRESS

;EXIT WITH ADDRESS IN "TA"

LNKSET:	LDB	TE,LNKCOD##	;GET TABLE CODE.
	ANDI	TA,LMASKB##	;GET THE OFFSET INTO THE TABLE.
	JUMPE	TA,BADLNK	;IF IT'S ZERO, WE'RE IN TROUBLE.
	ADD	TA,@LNKTAB(TE)	;ADD IN THE BASE ADDRESS OF THE TABLE.

	MOVE	TE,LNKTAB(TE)	;GET THE ADDRESS OF THE BASE ADDRESS.
	HRRZ	TE,1(TE)	;GET THE HIGHEST LOCATION IN THE TABLE.
	CAIL	TE,-1(TA)	;ARE WE STILL IN THE TABLE?
	POPJ	PP,		;YES, RETURN.
				;FALL INTO ERROR ROUTINE.

;IMPROPER LINK TYPE

BADLNK:
IFE TOPS20,<
	OUTSTR	[ASCIZ "Bad table-link at "]
	SOS	(PP)
	MOVSI	TE,(POINT 3,(PP),17)
BADL1:	ILDB	CH,TE
	ADDI	CH,"0"
	OUTCHR	CH
	TLNE	TE,770000
	JRST	BADL1
	OUTSTR	CRLF
>
IFN TOPS20,<
	HRROI	T1,[ASCIZ "Bad table-link at "]
	PSOUT%
	SOS	(PP)
	MOVSI	TE,(POINT 3,(PP),17)
BADL1:	ILDB	T1,TE
	ADDI	T1,"0"
	PBOUT%
	TLNE	TE,770000
	JRST	BADL1
	HRROI	T1,CRLF
	PSOUT%
>
	JRST	KILL

;SET UP TABLE ADDRESS OF OLDEST GRANDFATHER OF DATAB ITEM

;ENTER WITH TABLE-LINK IN "TA"
;	BITS 18-20 = TABLE TYPE, BITS 21-35 = RELATIVE ADDRESS

;EXIT WITH ADDRESS IN "TA"

LNKFA::	PUSHJ	PP,LNKSET	;GET ITEMS DATAB ADDR
LNKFA1::LDB	TB,DA.LVL##	;IF THIS IS TOP LEVEL, WE'RE DONE
	CAIE	TB,01
	CAIN	TB,77
	POPJ	PP,
	JRST	LNKFA3		;[510] JUMP AROUND PUSHJ TO LNKSET

LNKFA2:	JUMPE	TA,LNKFA4	;[510] NO MORE LINKS  TROUBLE
	PUSHJ	PP,LNKSET	;GET ADDR OF BROTHER OR FATHER
LNKFA3:	LDB	TB,DA.FAL##	;[501] WHICH IS IT?
	LDB	TA,DA.BRO##	;WHICHEVER, THIS IS THE LINK
	JUMPE	TB,LNKFA2	;BROTHER
	JUMPN	TA,LNKFA	;[636] IF NO FATHER, GOT ERROR IN PHASE C

LNKFA4:	SWON	FERROR		;[510] WE COULDN'T FIND 01 LEVEL
	POPJ	PP,		;[510] TURN ON ERROR FLAG AND LEAVE.

;TABLE OF ADDRESSES OF POINTERS

LNKTAB:	EXP	FILLOC
	EXP	DATLOC
	EXP	CONLOC
	EXP	LITLOC
	EXP	PROLOC
	EXP	EXTLOC
	EXP	VALLOC
	EXP	MNELOC

;PUTLNK INSERTS A TABLE ENTRY IN A NAMTAB SAME NAME CHAIN
;AT ENTRY TA==XWD TABLE ENTRY REL. ADDR.,NAMTAB REL. ADDR.
;THERE ARE NO EXIT PARAMETERS


PUTLNK:	HLRZM	TA,NEWENT##	;SAVE REL. ADDR. OF NEW ENTRY
	ANDI	TA,077777
	HRRZ	TB,NAMLOC##	;NAMTAB S.A.
	ADD	TA,TB		;NAMTAB ENTRY ABS. ADDR.
	LDB	TB,[POINT 3,NEWENT,20]
	HRRZM	TB,NEWTYP##	;TYPE CODE FOR NEW ENTRY
PUTLP:	HRRZ	TB,(TA)		;LINK ADDRESS
	JUMPN	TB,PUTCMP	;JUMP IF NOT END OF CHAIN
	HRRZ	TB,NEWENT	;MAKE CURRENT ENTRY POINT
	HRRM	TB,(TA)		;TO NEW ONE
	POPJ	PP,
PUTCMP:	HRRZ	TC,TB
	LSH	TC,-17		;TYPE OF LINK ENTRY
	CAML	TC,NEWTYP
	JRST	INSRT		;INSERT IN CHAIN
	HRRZ	TA,TB		;REL. ADDR. OF LINK
	PUSHJ	PP,LNKSET	;GET ABS. ADDR. OF LINK IN TA
	JRST	PUTLP
INSRT:	HRRZM	TB,SAVE1##	;SAVE LINK
	HRRZ	TB,NEWENT	;MAKE CURRENT ENTRY POINT
	HRRM	TB,(TA)		;TO NEW ENTRY
	HRRZ	TA,TB
	PUSHJ	PP,LNKSET	;GET ABS. ADDR. OF NEW ENTRY
	HRRZ	TB,SAVE1	;MAKE NEW ENTRY POINT WHERE
	HRRM	TB,(TA)		;CURRENT ENTRY DID
	POPJ	PP,

;FNDLNK FINDS, IN A SAME NAME CHAIN, A LINK TO A SPECIFIED TABLE
;AT ENTRY TA==XWD 0,REL. ADDR. OF NAMTAB ENTRY
;AND TB==TYPE CODE OF TABLE SOUGHT
;SUCCESS RETURN = CALLING ADDRESS + 2
;	TB==XWD REL. ADDR. OF ENTRY FOUND,ABS. ADDR. OF ENTRY FOUND
;FAILURE RETURN = CALLING ADDRESS + 1

;FNDNXT FINDS NEXT ENTRY OF SAME TYPE AS LAST ENTRY TO FNDLNK SOUGHT
;ENTRY PARAMETER IS TA==ABS. ADDR. OF LAST LINK FOUND IN CHAIN


FNDLNK:	ANDI	TA,077777	;NAMTAB REL. ADDR.
	HRRZ	TC,NAMLOC	;NAMTAB S. A.
	ADD	TA,TC		;NAMTAB ENTRY ABS. ADDR.
	HRRZM	TB,SAVE1	;SAVE TYPE SOUGHT
FNDNXT:	HRRZ	TC,(TA)		;LINK WORD
	JUMPE	TC,CPOPJ	;FAILURE
	HRLZM	TC,SLNK##	;SAVE REL. ADDR.
	HRRZ	TB,TC
	LSH	TB,-17		;TYPE OF LINK
	CAMLE	TB,SAVE1	;COMPARE TO TYPE SOUGHT
	POPJ	PP,		;FAILURE
	XCT	GETLOC(TB)	;GET TABLE S.A. IN TD
	ANDI	TC,077777	;ENTRY REL. ADDR.
	ADD	TC,TD		;ENTRY ABS. ADDR.
	HRRZ	TA,TC
	CAME	TB,SAVE1	;SKIP IF FOUND
	JRST	FNDNXT
	HRRZ	TB,TA		;ABSOLUTE ADDRESS OF ENTRY
	HLL	TB,SLNK		;RELATIVE ADDRESS OF ENTRY
	POP	PP,TE		;RETURN ADDRESS
	JRST	1(TE)		;SUCCESS EXIT

SUBTTL	COMMON DATAB SUBROUTINES

;ENTER WITH TB=RELATIVE DATAB ADDR
;EXIT TO CALL+1 IF NO FATHER
;EXIT TO CALL+2 WITH TB=REL DATAB ADDR OF FATHER

FNDPOP:	JUMPE	TB,CPOPJ
	LDB	TC,[POINT	3,TB,20]
	CAIE	TC,CD.DAT
	POPJ	PP,		;NOT DATTAB ENTRY
POP.0:	HRRZM	TB,TBLOCK##+13
	HRRZ	TA,TB
	PUSHJ	PP,LNKSET
	LDB	TB,DA.FAL##
	JUMPN	TB,POP.1
	HRRZ	TB,TBLOCK+13
	PUSHJ	PP,FNDBRO
	  POPJ	PP,
	JRST	POP.0

POP.1:	LDB	TB,DA.POP##
	JUMPE	TB,CPOPJ
	POP	PP,TA
	JRST	1(TA)


;ENTER WITH TB=RELATIVE DATAB ADDR
;EXIT TO CALL+1 IF NO BROTHER
;EXIT TO CALL+2 WITH TB=REL DATAB ADDR OF BROTHER

FNDBRO:	JUMPE	TB,CPOPJ
	LDB	TC,[POINT	3,TB,20]
	CAIE	TC,CD.DAT
	POPJ	PP,
	HRRZ	TA,TB
	PUSHJ	PP,LNKSET
	LDB	TC,DA.FAL
	JUMPN	TC,CPOPJ
	LDB	TB,DA.BRO##
	JUMPE	TB,CPOPJ
	POP	PP,TA
	JRST	1(TA)

;[1424] THIS ROUTINE FINDS THE FILE WHICH CONTAINS THE GIVEN DATAB ITEM

FNDFIL:	JUMPE	TB,CPOPJ	; [1424] NONE - ERROR
	LDB	TC,[POINT 3,TB,20]; [1424] GET TYPE OF ITEM
	CAIN	TC,CD.FIL	; [1424] IS IT A FILE-NAME?
	JRST	FIL.F		; [1424] YES GO IT
	CAIN	TC,CD.DAT	; [1424] IS ITEM A DATA-NAME?
FIL.A:	PUSHJ	PP,FNDPOP	; [1424] GET FATHER OF DATA-ITEM
	  POPJ	PP,		; [1424] NONE, ERROR, DATA ITEM NOT IN A FILE
	LDB	TC,[POINT 3,TB,20]; [1424] GET TYPE OF FATHER
	CAIN	TC,CD.DAT	; [1424] IF FATHER IS A DATA NAME
	JRST	FIL.A		; [1424] THEN LOOP TO GET NEXT FATHER
	CAIE	TC,CD.FIL	; [1424] IS FATHER A FILE-NAME?
	POPJ	PP,		; [1424] NO, ERROR, NOT A FILE OR DATA NAME
FIL.F:	HRLZM	TB,CURFIL##	; [1424] STORE THE FILE NAME RELATIVE ADDRESS
	HRRZI	TA,(TB)		; [1424] NOW GET ITS REAL
	PUSHJ	PP,LNKSET	; [1424] ADDRESS
	HRRM	TA,CURFIL	; [1424] STORE FILENAME ADDRESS
	JRST	CPOPJ1		; [1424] FOUND, SKIP RETURN

;GETENT FINDS AN ENTRY OF A GIVEN SIZE IN A SPECIFIED TABLE,
;	EXPANDING THE TABLE IF NECESSARY
;AT ENTRY TA==XWD TABLE TYPE CODE,ENTRY SIZE
;AT EXIT TA=XWD ENTRY REL. ADDR.,ENTRY ABS. ADDR.


GETENT:	HLRZ	TC,TA		;TABLE TYPE
IFN XPNTST,<			;FORCE TABLE EXPANSION
	PUSH	PP,TA		;  FOR COMPILER DEBUGGING
	CAIN	TC,CD.DAT	;ONLY FOR A CERTAIN TABLE-TYPE.
	PUSHJ	PP,@XP1TBL(TC)	;EXPAND TABLE BY 1
	POP	PP,TA		;RESTORE TA
	HLRZ	TC,TA		;RESTORE TC
>;END IFN XPNTST
	XCT	GETNXT(TC)	;NEXT-HOLE WORD IN TB
	MOVE	CP,TB		;SAVE NEXT HOLE POINTER
	HRLZ	TD,TA
	HRR	TD,TA		;ENTRY SIZE IN BOTH HALVES OF TD
	HRRZ	TE,TD		;SAVE SIZE
	ADD	TD,TB
	JUMPGE	TD,XPNIT	;NOT ENOUGH ROOM--EXPAND
	XCT	PUTNXT(TC)	;UPDATE NEXT-HOLE WORD
	HRRZI	LN,0
	PUSH	CP,LN		;CP WILL POINT TO ACTUAL ENTRY
	HRRZ	TA,CP		;ABS. ADDR. OF ENTRY IN RIGHT HALF OF TA
	XCT	GETLOC(TC)	;GET S.A. OF TABLE IN TD
	HRRZ	TB,TA		;ENTRY ABS. ADDR.
	SUB	TB,TD
	CAILE	TB,77777	;[506] IF TABLE BIGGER THAN 32768
	CAIL	TC,3		;[506] AND IF FILTAB,DATTAB OR CONTAB
	TRNA			;[506] O.K. EITHER SMALLER OR OTHER TABLE
	JRST	OVRFLO		;[506] TABLE OVERFLOW TROUBLE!!
	CAILE	TC,7
	HRRZI	TC,0
	LSH	TC,17
	OR	TB,TC		;ENTRY TYPE CODE
	HRL	TA,TB		;L. H. OF TA==REL. ADDR. OF ENTRY
	HRRZ	TB,TA		;R. H. OF TB==ABS. ADDR. OF ENTRY
	SETZM	(TB)
	ADDI	TB,1
	SOJG	TE,.-2		;ZERO OUT ENTRY
	POPJ	PP,

XPNIT:	MOVEM	TA,SAVETA##	;SAVE PARAMETER
	PUSHJ	PP,@XPNTBL(TC)	;EXPAND TABLE
	MOVE	TA,SAVETA	;RESTORE PARAMETER
	JRST	GETENT		;TRY AGAIN

OVRFLO:
IFE TOPS20,<
	OUTSTR	@GIVERR(TC)	;[506] GIVE USER PROPER ERROR MESSAGE
>
IFN TOPS20,<
	HRRO	T1,GIVERR(TC)	;[506] GIVE USER PROPER ERROR MESSAGE
	PSOUT%
>
	MOVEI	TA,"C"		;[506] QUIT NEEDS TO KNOW PHASE NUMBER
	MOVEM	TA,PHASEN##	;[506] SO BE SURE IT IS THERE
	JRST	QUITS		;[506] THERE IS NOTHING MORE WE CAN DO
				;[506] TO HELP USER  DUMP IS NO USE HERE

GIVERR:
	EXP	 [ASCIZ /?File table overflow - FILE SECTION too big/]	;[506]
	EXP	 [ASCIZ /?Data table overflow - DATA DIVISION too big/]	;[506]
	EXP	 [ASCIZ /?Condition table overflow - too many level 88's/];[506]

DEFINE TABSET (A,B,C,D,E,F,G)<
IFN G,<
	MOVE	TB,A'NXT##	;A'TAB
>>

GETNXT:	TABLES

DEFINE TABSET (A,B,C,D,E,F,G)<
IFN G,<
	MOVEM	TD,A'NXT	;A'TAB
>>

PUTNXT:	TABLES

DEFINE TABSET (A,B,C,D,E,F,G)<
IFN G,<
	HRRZ	TD,A'LOC##	;A'TAB
>>

GETLOC:	TABLES

DEFINE TABSET (A,B,C,D,E,F,G)<
IFN G,<
	XWD	0,XPN'A		;A'TAB
>>

XPNTBL:	TABLES

IFN XPNTST,<
DEFINE TABSET (A,B,C,D,E,F,G)<
IFN G,<
	XWD	0,XP1'A		;A'TAB
>>

XP1TBL:	TABLES
>;END IFN XPNTST

IFE TOPS20,<
;RESTART DUE TO "START" CONSOLE COMMAND

REDO:	MOVEI	SW,0

;RESTART DUE TO "REENTER" CONSOLE COMMAND
;	ALSO USED BY COBOLG, COBOLK, AND QUITS			[506]

RESTRT:	TSWF	FECOM;		;ANY MORE COMMANDS?
	CALLI	$EXIT		;NO--QUIT

	HRRZ	TA,%HISEG+.JBHSA##	;STARTING ADDRESS

	AND	SW,[EXP FDSKC]	;TURN OFF ALL FLAGS EXCEPT FDSKC
IFE ONESEG,<
	MOVE	TB,PHASEN	;ARE WE IN FIRST MACHINE LOAD?
	CAIG	TB,MLOAD1
>
	JRST	2(TA)		;YES--NO NEED TO LOAD IT

IFE ONESEG,<
	MOVE	TB,['COBOL ']
	MOVEM	TB,GETFNM+1
	MOVEI	TA,2		;STARTING ADDRESS INCREMENT
	MOVEM	TA,GETFST##	;INCREMENT
	JRST	GETLOD
 >
>

;IF THIS ROUTINE IS ENTERED AT "KILL", THE FOLLOWING OCCURS:
;	1) AC'S SAVED
;	2) ALL DEVICES RELEASED
;	3) CORE DUMP OF THE IMPURE AREA TAKEN
;	4) ALL SCRATCH FILES DUMPED


;IF THIS ROUTINE IS ENTERED AT "KILLF", THE FOLLOWING OCCURS
;	1) ALL DEVICES RELEASED
;	2) ALL SCRATCH FILES DUMPED

KILL:
IFE ONESEG,<
	PORTAL	.+1		;INCASE EXECUTE ONLY
>
	MOVEM	17,KILLAC+17	;SAVE AC'S
	MOVEI	17,KILLAC
	BLT	17,KILLAC+16
	JSP	TB,SETUP
	SETZ	TE,		;STARTING ADDRESS INCREMENT
	JRST	KILLCALL

KILLF:	JSP	TB,SETUP
IFE ONESEG,<	MOVEI	TE,2>		;STARTING ADDRESS INCREMENT
IFN ONESEG,<	JRST	COBOLK##+2>


KILLCALL:
IFE ONESEG,<
	MOVE	TB,['COBOLK']
	MOVEM	TB,GETFNM+1
	MOVEM	TE,GETFST
	JRST	GETLOD
>
IFN ONESEG,<JRST COBOLK##>

SETUP:	SKIPE	TA,TOPLOC
	MOVEM	TA,.JBFF##

IFN TOPS20,<
	PUSHJ	PP,CLZBIN##	;CLOSE REL
	PUSHJ	PP,CLZLST##	; AND LIST BEFORE CLOSING ALL
	MOVX	T1,CZ%NRJ+.FHSLF	;DON'T RELEASE JFN'S
	CLZFF%			;CLOSE ALL FILES
>
IFE TOPS20,<
	MOVSI	TA,(RELEASE)	;RELEASE ALL DEVICES
KILL1:	XCT	TA
	ADD	TA,[Z 1,]
	CAME	TA,[RELEASE 17,0]
	JRST	KILL1
>

	MOVE	0,PHASEN	;SAVE PHASE NUMBER FOR COBOLK
	JRST	(TB)

;[506] THIS ROUTINE STOPS COMPILATION, RELEASES ALL DEVICSE AND
;[506]	RETURNS TO COBOLA WITHOUT DOING A DUMP OR GIVING CATASTROPHE
;[506]	IN PHASE ? MESSAGE   FOR USER ERROR WHEN COMPILER CAN'T CONTINUE

QUITS:	OUTSTR	[ASCIZ /
?Cannot continue compilation
/]					;[506] TELL USER WE ARE QUITTING
	JSP	TB,SETUP		;[506] RELEASE ALL DEVICES
	MOVE	0,KILLAC		;[506]
	JRST	RESTRT			;[506] RESTART AT COBOLA

SUBTTL	HANDLE COBOL UUO TRAPS

UUOCAL:
IFE TOPS20,<
	PORTAL	.+1		;INCASE EXECUTE ONLY
>
	MOVEM	TE,KILLAC+1	;SAVE TE
	LDB	TE,[POINT 9,.JBUUO##,8]; GET OP-CODE OF UUO
	CAILE	TE,HIUUO	;ONE WE RECOGNIZE?
	JRST	UUOC1		;NO--ERROR

	PUSHJ	PP,@UUOTAB(TE)	;YES--EXECUTE A ROUTINE
	MOVE	TE,KILLAC+1	;RESTORE TE
	POPJ	PP,

UUOC1:	MOVEM	CH,KILLAC	;SAVE CH
	OUTSTR	[ASCIZ "Illegal UUO at location "]
	SOS	(PP)
	MOVSI	TE,(POINT 3,(PP),17)

UUOC2:	ILDB	CH,TE
	ADDI	CH,"0"
	OUTCHR	CH
	TLNE	TE,770000
	JRST	UUOC2

	OUTSTR	[ASCIZ "
"]
	MOVE	TE,KILLAC+1
	MOVE	CH,KILLAC
	JRST	KILL

UUOTAB:	EXP	UUOC1		;0 - ILLEGAL
	EXP	UUO1		;1 - WARNING DIAG
	EXP	UUO2		;2 - WARNING DIAG (POP OFF ONE RETURN)
	EXP	UUO3		;3 - FATAL DIAG
	EXP	UUO4		;4 - FATAL DIAG (POP OFF ONE RETURN)

HIUUO==.-UUOTAB-1	;HIGHEST LEGAL UUO


UUO2:	POP	PP,DW		;POP OFF ONE RETURN
	MOVEM	DW,(PP)
UUO1:	HRRZ	DW,.JBUUO
	JRST	WARNW

UUO4:	POP	PP,DW		;POP OFF ONE RETURN
	MOVEM	DW,(PP)
UUO3:	HRRZ	DW,.JBUUO
	JRST	FATALW

; TURN ON THE USERS TTY OUTPUT IF HE DID A CONTROL O

TTYON:
IFE TOPS20,<
	SETO	TA,		;[266] GET USERS
	GETLCH	TA		;[266] TTY LINE
	HRRZS	TA		;[266] STORE UNIVERSAL INDEX NUMBER
TTYLP:	MOVE	TC,[XWD 2,TB]	;[266] SET UP TO SEE
	MOVEI	TB,1000		;[266] CHECK TOIP BIT OF
	TRMOP.	TC,		;[266] USERS TTY OUTPUT
	  JRST	TTYDON		;[266] NO TRMOP. UUO- TRY TO FORCE IT
	JUMPE	TC,TTYDON	;[266] OUTPUT IN PROGRESS; IF SO SLEEP
TTYSLP: MOVEI	TB,1		;[266] FOR SLEEPING
	MOVEI	TC,100		;[266] SLEEP 100MS
	HIBER	TC,		;[266]
	  SLEEP	TB,		;[266] SLEEP 1 SEC IF NO HIBER
	JRST	TTYLP		;[266] TRY AGAIN

TTYDON:	SKPINC	 		;[266] THIS TURN OFF CONTROL BIT
	  JFCL			;[266] DON'T CARE WHAT IS IN TTY BUFFER
	POPJ	PP,		;[266] RETURN
>

IFN TOPS20,<
	PUSH	PP,T1
	PUSH	PP,T2
	MOVEI	T1,.PRIOU
	RFMOD%			;READ TTY MODE WORD
	TXZE	T2,TT%OSP	;DON'T SUPPRESS OUTPUT
	SFMOD%
	POP	PP,T2
	POP	PP,T1
	POPJ	PP,
>

SUBTTL	HANDLE APR TRAPS
IFE TOPS20,<

;THIS ROUTINE HANDLES APR TRAPS FOR:
;	1) ILLEGAL MEMORY REFERENCES (MEMORY PROTECTION FAILURE)
;	2) NON-EXISTENT MEMORY REFERENCES
;	3) PUSH-DOWN OVERFLOW

XPNPPL:	MOVEM	PP,KILLAC	;SAVE AC'S
	MOVE	PP,ACXWD
	BLT	PP,KILLAC+3
	MOVE	TA,.JBCNI##	;GET APR FLAGS
	TRNE	TA,AP.POV	;PUSH-DOWN OVERFLOW?
	JRST	XPNPL1		;YES
	TRNE	TA,AP.ILM	;ILEGAL MEMORY REFERENCE?
	JRST	XPNPL2		;YES
	TRNE	TA,AP.NXM	;NON-EXISTENT MEMORY?
	SKIPA	TA,[[ASCIZ "Non-existent Memory Reference"]]
	MOVEI	TA,[ASCIZ "Unknown APR trap"]
	JRST	XPNPL6

XPNPL1:	SKIPA	TA,[[ASCIZ "Push-down Overflow"]]
XPNPL2:	MOVEI	TA,[ASCIZ "Illegal Memory Reference"]

XPNPL6:	OUTSTR	(TA)		;TYPE MESSAGE
	OUTSTR	[ASCIZ " at location "]
	MOVE	TA,[POINT 3,.JBTPC##,17]	;TYPE OUT LOCATION
XPNPL7:	ILDB	TC,TA
	ADDI	TC,"0"
	OUTCHR	TC
	TLNE	TA,770000
	JRST	XPNPL7
	OUTSTR	CRLF
	MOVS	PP,ACXWD	;RESTORE AC'S
	BLT	PP,TA
	MOVE	PP,KILLAC
	JRST	KILL

ACXWD:	TC,,KILLAC+1
>

SUBTTL	PUT OUT A DIAGNOSTIC

;ENTER WITH DIAG NUMBER IN "DW"

FATALW:	MOVE	LN,WORDLN	;SET UP LN &
	MOVE	CP,WORDCP	;  CP
	JRST	FATAL

WARNW:	MOVE	LN,WORDLN
	MOVE	CP,WORDCP
	JRST	WARN


;ENTER WITH DIAG NUMBER IN "DW", LINE NUMBER IN "LN", AND
;	CHARACTER POSITION IN "CP".

FATAL:	IORI	DW,DWFATL	;SET "FATAL" FLAG
	SWON	FFATAL		;SET "FATAL" SWITCH
IFE DEBUG,<SETZM BINDEV##>	;OMIT REL FILE IF FATAL ERROR

WARN:	DPB	LN,ERALN	;INSERT LN INTO DW
	DPB	CP,ERAPOS	;INSERT CP INTO DW
	MOVE	TE,PHASEN	;PUT PHASE NUMBER INTO
	DPB	TE,ERAFAZ	;  DW

;ENTER WITH "DW" ALL SET UP

PUTERA:	SOSG	ERABHO+2	;IS BUFFER FULL?
	PUSHJ	PP,RITERA	;YES--GO WRITE IT OUT
	IDPB	DW,ERABHO+1	;PUT "DW" INTO BUFFER
	POPJ	PP,

;HERE FOR ERRORS FOUND IN THE SYNTAX SCAN (PHASE B, C, & D)

	INTER.	TST.L
TST.L:	MOVEI	TA,%LV.L	;LOW
	JRST	TST.ER

	INTER.	TST.LI
TST.LI:	MOVEI	TA,%LV.LI	;LOW-INTERMEDIATE
	JRST	TST.ER

	INTER.	TST.HI
TST.HI:	MOVEI	TA,%LV.HI	;HIGH-INTERMEDIATE
	JRST	TST.ER

	INTER.	TST.H
TST.H:	MOVEI	TA,%LV.H	;HIGH
	JRST	TST.ER

	INTER.	TST.RP
TST.RP:	MOVEI	TA,%LV.RP	;REPORT WRITER
	JRST	TST.ER

	INTER.	TST.DB
TST.DB:	MOVEI	TA,%LV.DB	;DATA BASE 
	JRST	TST.ER

	INTER.	TST.68
TST.68:	MOVEI	TA,%LV.68	;COBOL-68 LEFTOVER
	JRST	TST.ER

	INTER.	TST.IB
TST.IB:	MOVEI	TA,%LV.IB	;IBM COMPATIBILITY
	JRST	TST.ER

	INTER.	TST.VX
TST.VX:	MOVEI	TA,%LV.VX	;VAX COBOL-74 COMPATIBLE
	JRST	TST.ER

	INTER.	TST.8
TST.8:	MOVEI	TA,%LV.8	;COBOL-8x EXTENSION
	JRST	TST.ER

	INTER.	TST.NS
TST.NS:	MOVEI	TA,%LV.NS	;NON-STANDARD
TST.ER:	SKIPN	FLGSW##		;DO WE WANT FIPS FLAGGING?
	POPJ	PP,		;NO
;	JRST	FLG.ER		;YES, TEST LEVEL REQUIRED

;ENTER WITH TA CONTAINING THE LEVEL FLAG

FLG.ER:	MOVE	LN,WORDLN	;SET UP LN &
	MOVE	CP,WORDCP	;  CP
FLG.ES:	ANDCM	TA,FLGSW	;CLEAR THE BITS WE ALLOW
	JUMPE	TA,CPOPJ	;RETURN IF ITS WITHIN LIMITS
	PUSH	PP,TB		;SAVE NEXT ACC
	MOVE	TB,TA
	JFFO	TB,.+1		;GET LEFT MOST 1
	MOVEI	TB,^D36
	SUB	TB,TA		;GET BIT NUMBER
	MOVS	TA,TB		;LEVEL FOUND IN LHS
	POP	PP,TB
	HRRI	TA,E.507	;WARNING NO. WITH EXTRA DATA
;	JRST	WARNAD		; SO WE CAN GIVE EXACT MESSAGE

;PUT OUT A WARNING DIAG WITH APPENDED NAME.
;ENTER WITH LH OF "TA" CONTAINING A TABLE-LINK TO NAME TO BE PRINTED,
;	RH OF "TA" CONTAINING DIAGNOSTIC NUMBER.

WARNAD:	HRRZ	DW,TA		;GET DIAG NUMBER
	PUSHJ	PP,WARN		;WRITE OUT FIRST WORD
	HLRZ	DW,TA		;GET TABLE LINK
	JRST	PUTERA		;WRITE IT OUT AND RETURN

IFE TOPS20,<
;EMPTY THE BUFFER

RITERA:	OUT	ERA,
	  POPJ	PP,		;NO ERRORS -- RETURN

	MOVEI	CH,ERADEV	;ERROR -- WE LOSE
	JRST	DEVDED		;NEVER RETURN
>

SUBTTL	GET NEXT TAG NUMBER TO BE USED


;NOTE: THE ONLY ROUTINES THAT SHOULD EVER TOUCH TAGNXT
;  ARE GETTAG AND XPNTAG

GETTAG:
IFN XPNTST,<
	PUSHJ	PP,XP1TAG	;EXPAND TAGTAB BY 1 LOCATION
>
	MOVE	CH,TAGCNT##	;GET NEXT TAG NUMBER
	HRLS	CH		;  MAKE N,,N
	ADD	CH,TAGLOC##	;CREATE NEW TAGNXT
	JUMPL	CH,GETTA1	;IF COUNT STILL NEG, NEW TAG FITS

	PUSHJ	PP,XPNTAG	;OTHERWISE, EXPAND TABLE
	JRST	GETTAG		;RECOMPUTE NEW TAGNXT

GETTA1:	MOVEM	CH,TAGNXT##	;STORE NEW VALUE FOR TAGNXT
	SETZM	(CH)		;CLEAR ENTRY

	MOVE	CH,TAGCNT	;GET TAG NUMBER TO RETURN TO CALLER
	IORI	CH,AS.TAG##	;PUT IN ASSEMBLER CODE

	AOS	TAGCNT		;RESET TAGCNT FOR NEXT CALL TO GETTAG
	POPJ	PP,

;ROUTINE TO REFERENCE A TAG - ENTER WITH TA= TAG #.
;USES TE

REFTAG:	TRCN	TA,700000	;SKIP IF POSSIBLY AS.TAG SET
	JRST	REFTG1		;NOTHING
	TRCE	TA,AS.TAG	;ONLY REFERENCE IF ADDRESS TYPE IS AS.TAG
	POPJ	PP,		;SOMETHING ELSE - FORGET IT
REFTG1:	ANDI	TA,77777	;LEAVE ONLY THE TAG NUMBER
	ADD	TA,TAGLOC##	;RH (TA) IS ADDRESS OF THE TAG ENTRY
	MOVSI	TE,1		;ADD 1 TO LEFT HALF
	ADDM	TE,(TA)		; (REFERENCE COUNT)
	POPJ	PP,		;RETURN


;ROUTINE TO DE-REFERENCE A TAG.  ENTER WITH TAG IN TA.
;USES TEMP AC TE
;SKIP RETURN WHEN REFERENCE COUNT EQUAL ZERO.

DRFTAG:	ANDI	TA,77777	;LEAVE ONLY TAG NUMBER
	ADD	TA,TAGLOC	;RH (TA) IS NOW THE ADDRESS OF ENTRY
	MOVE	TE,(TA)		;TE=ENTRY
DRFTG2:	TLNE	TE,(1B0!1B1)	;IS THIS AN INDIRECT REFERENCE?
	 JRST	DRFTG1		;YES
	LDB	TE,[POINT 15,TE,17] ;GET REFERENCE COUNT
	SOJL	TE,DOKILL	;SUBTRACT ONE, IF NEGATIVE, COMPLAIN
	SKIPN	TE		;SKIP IF NON-ZERO
	AOS	(PP)		;SKIP RETURN FOR ZERO COUNT
	DPB	TE,[POINT 15,(TA),17] ;STORE DECREMENTED COUNT
	POPJ	PP,

DRFTG1:	TRC	TE,AS.PRO##	;A PARA-NAME?
	TRNN	TE,700000
	 POPJ	PP,		;YES-DON'T DO ANYTHING
	HRRZ	TA,TE
	JRST	DRFTAG

DOKILL:	OUTSTR [ASCIZ/?Tag count less than zero in DRFTAG
/]
	PJRST	KILL		;DIE

SUBTTL	EXPAND THE SIZE OF ANY TABLE

XPAND:

	DEFINE TABSET (A,B,C,E,F,G,H),<
	IFN C,<
	ENTRY XPN'A
XPN'A:	MOVEM	TA,SAVEAC+17
	IFN DEBUG,<
	MOVE	TA,[POINT 6,[SIXBIT "E"]]
	PUSHJ	PP,XPMESS
	>
	MOVE	TA,A'XPS
	JRST	XPAND0
A'XPS:	XWD	^D'C,A'LOC##
IFN XPNTST,<
	ENTRY XP1'A
XP1'A:	MOVEM	TA,SAVEAC+17
	SKIPN	TYPXPN##
	 JRST	.+3
	MOVE	TA,[POINT 7,[ASCIZ "E"]]
	PUSHJ	PP,TPMESS
	MOVE	TA,A'XP1
	JRST	XPAND0
A'XP1:	XWD	1,A'LOC##
>;END IFN XPNTST
	>>



	TABLES

XPAND0:	MOVEM	TA,SAVEAC	;SAVE AC'S TG THRU TB
	MOVE	TA,[XWD TG,SAVEAC+1]
	BLT	TA,SAVEAC+6

	HLRZ	TD,FREESP	;ENOUGH FREE CORE?
	HLRZ	TE,SAVEAC
	CAMG	TE,TD
	JRST	XPAND1		;YES

	PUSHJ	PP,ADDCOR	;NO--GET MORE CORE

	MOVE	TE,PHASEN	;IF WE ARE
	CAIE	TE,"E"		;[640] IN PHASE E, OR
	CAIN	TE,"O"		;[640] IN PHASE O, THEN
	JRST	XPND0B		;  DON'T MOVE NAME TABLE

	HRRZ	TE,NAMNXT	;MOVE UP NAMTAB
	ADDI	TE,2000
	HRRZ	TB,NM1LOC
	PUSHJ	PP,BLTUP
	MOVEI	TE,2000
	ADDM	TE,NAMLOC
	ADDM	TE,NM1LOC
	ADDM	TE,NM2LOC
	ADDM	TE,NAMNXT
	ADDM	TE,NAMADR##	;[440]
	SKIPE	CURNAM
	ADDM	TE,CURNAM

XPND0B:	MOVSI	TE,2000		;INCREMENT AMOUNT OF FREE SPACE
	ADDM	TE,FREESP

XPAND1:	MOVE	TE,SAVEAC	;ANY TABLES ABOVE THIS ONE?
	SKIPN	3(TE)
	JRST	XPAND4		;NO


;MOVE HIGHER TABLES UP IN CORE
	HRRZ	TA,3(TE)	;TG_XWD  -<SIZE TO MOVE>,<TOP LOCATION>
	HRRZ	TB,FREESP
	SUB	TA,TB
	MOVS	TG,TA
	HRRI	TG,-1(TB)

	MOVE	TA,[XWD AOBUP,TF]	;SET UP AC'S
	BLT	TA,TB
	HLR	TE,SAVEAC
	JRST	TF

;INCREMENT POINTERS TO ALL TABLES JUST MOVED
XPAND2:	MOVE	TE,SAVEAC	;TE_ADDRESS OF CURRENT POINTERS
	HLRZ	TD,SAVEAC	;TD_AMOUNT OF OFFSET

XPAND3:	ADDI	TE,3
	HRRZ	TF,(TE)		; [D] IF THIS TABLE IS EMPTY,
	JUMPE	TF,XPAND5	; [D] DON'T CHANGE ANYTHING.
	ADDM	TD,0(TE)	;INCREMENT X'LOC
	ADDM	TD,1(TE)	;INCREMENT X'NXT
	SKIPE	2(TE)		;INCREMENT CUR'X IF NON-ZERO
	ADDM	TD,2(TE)
XPAND5:	SKIPE	3(TE)
	JRST	XPAND3


;RESET LEFT HALF OF POINTERS FOR EXPANDED TABLE
XPAND4:	HRRZ	TA,SAVEAC
	HLLZ	TE,SAVEAC
	MOVNS	TE
	ADDM	TE,(TA)
	ADDM	TE,1(TA)

;RESET BOTH HALVES OF FREESP

	HLR	TE,SAVEAC
	ADDM	TE,FREESP


;RESTORE ALL AC'S
	MOVS	TA,[XWD TG,SAVEAC+1]
	BLT	TA,TB
	MOVE	TA,SAVEAC+17
	POPJ	PP,			;RETURN

;BLT UP A BLOCK OF WORDS OF LENGTH >1K
;ENTER WITH:
;	TE SET TO LAST RECEIVING ADDRESS
;	TB SET TO FIRST SENDING ADDRESS

BLTUP:	MOVE	TD,TE
	ANDI	TE,776000		;TE_FIRST LOCATION IN THAT 1K BLOCK

BLTUP1:	MOVEI	TC,-2000(TE)		;TC_FIRST LOCATION IN LOWER 1K BLOCK
	CAMGE	TC,TB			;BELOW FIRST SENDING ADDRESS?
	MOVE	TC,TB			;YES--RESET TO FIRST SENDING ADDRESS

	MOVS	TA,TC			;CREATE XWD
	HRRI	TA,2000(TC)
	BLT	TA,(TD)			;MOVE DATA UP

	CAMN	TC,TB			;DONE?
	POPJ	PP,			;YES--RETURN
	MOVEI	TD,-1(TE)		;NO--DROP DOWN ONE 1K BLOCK
	SUBI	TE,2000
	JRST	BLTUP1			;LOOP



;THE FOLLOWING ROUTINE IS COPIED TO AC'S TF THRU TB.
;IT MOVES CONTENTS OF LOCATIONS UP IN CORE BY AMOUNT EXPANDED.

AOBUP:	MOVE	TA,(TG)
	MOVEM	TA,(TG)		;THE ADDRESS OF THIS WILL BE AMOUNT TO EXPAND
	SUBI	TG,2
	AOBJN	TG,TF
	JRST	XPAND2

	TF==TE-1
	TG==TF-1

;PRINT OUT DEBUG MESSAGE

IFN DEBUG,<EXTERNAL LSTMES,PUTLST,LCRLF

IFN XPNTST,<
;TYPE MESSAGE ON TTY
TPMESS:	PUSH	PP,CH
	PUSH	PP,TE
	MOVE	TE,[POINT 7,[ASCIZ "Expanding "]]
	PUSHJ	PP,TPMSST	;TYPE STRING
	MOVE	TE,TA		;GET TABLE B.P.
	PUSHJ	PP,TPMSST	;PRINT THAT STRING TOO
	MOVE	TE,[POINT 7,[ASCIZ " at "]]
	PUSHJ	PP,TPMSST
	MOVE	TE,[POINT 3,-2(PP),17]

TPMS1:	ILDB	CH,TE
	ADDI	CH,"0"
	OUTCHR	CH
	TLNE	TE,770000
	JRST	TPMS1
	MOVE	TE,[POINT 7,CRLF]
	PUSHJ	PP,TPMSST
	POP	PP,TE		;RESTORE SAVED ACS
	POP	PP,CH
	POPJ	PP,

TPMSST:	ILDB	CH,TE		;GET CHAR OF STRING
	JUMPE	CH,CPOPJ	;DONE, RETURN
	OUTCHR	CH		;TYPE IT
	JRST	TPMSST		;LOOP
>;END IFN XPNTST

XPMESS:	PUSH	PP,CH
	PUSH	PP,TE
	MOVE	TE,[POINT 7,[ASCIZ "Expanding "]]
	PUSHJ	PP,LSTMES

XPM1:	ILDB	CH,TA
	JUMPE	CH,XPM2
	ADDI	CH,40
	PUSHJ	PP,PUTLST
	TLNE	TA,770000
	JRST	XPM1

XPM2:	MOVE	TE,[POINT 7,[ASCIZ " at "]]
	PUSHJ	PP,LSTMES
	MOVE	TA,[POINT 3,-2(PP),17]

XPM3:	ILDB	CH,TA
	ADDI	CH,"0"
	PUSHJ	PP,PUTLST
	TLNE	TA,770000
	JRST	XPM3

	MOVE	TE,[POINT 7,[ASCIZ " in Phase "]]
	PUSHJ	PP,LSTMES
	MOVE	CH,PHASEN
	PUSHJ	PP,PUTLST
	PUSHJ	PP,LCRLF

	POP	PP,TE
	POP	PP,CH
	POPJ	PP,

>

SUBTTL GET MORE CORE

;SETCOR IS ENTERED WITH DESIRED NEW JOBREL VALUE IN "TE"

SETCOR:	IORI	TE,1777
	CAMN	TE,.JBREL##	;AREA BEING CHANGED?
	POPJ	PP,		;NO--RETURN
IFE TOPS20,<
	CORE	TE,		;TRY TO GET CORE
	  JRST	NOSET		;CAN'T--NO COMPILATION POSSIBLE
>
	JRST	ADCOR1

ADDCOR:	HRRZ	TE,.JBREL	;FORM NEW JOBREL
	ADDI	TE,2000
IFE TOPS20,<
	CORE	TE,		;TRY TO GRAB CORE
	  JRST	NOADD		;CAN'T GET MORE--ABORT COMPILATION
>

ADCOR1:
IFN TOPS20,<
	CAIL	TE,%HISEG	;CHECK AGAINST BOTTOM OF HIGH SEG
	JRST	NOADD		;TOO BIG
ADCOR2:	EXCH	TE,.JBREL##	;SAVE NEW HIGHEST LOC
	SETZM	1(TE)		;CLEAR FIRST WORD
	HRLI	TE,1(TE)	;FROM
	HRRI	TE,2(TE)	;TO
	BLT	TE,@.JBREL	;NEW TOP
>
	HRRZ	TE,.JBREL
	ADDI	TE,1
	MOVEM	TE,TOPLOC
	POPJ	PP,

IFN TOPS20,<
;SET CORE TO NEW SIZE
;RETURNS
;	+1 FAILURE
;	+2 OK OR NOT REQUIRED

GETCOR:	IORI	TE,1777
	CAMN	TE,.JBREL##	;AREA BEING CHANGED?
	JRST	CPOPJ1		;NO--RETURN
	CAIL	TE,%HISEG	;CHECK AGAINST BOTTOM OF HIGH SEG
	POPJ	PP,		;TOO BIG, GIVE ERROR RETURN
	AOS	(PP)		;GIVE SKIP RETURN
	JRST	ADCOR2		;SEE IF WE HAVE TO ZERO DATA
>

IFE TOPS20,<
;CANNOT EXPAND CORE

NOADD:	OUTSTR	[ASCIZ "?Not enough memory to continue compilation
"]
	JRST	RESTRT

;CANNOT SET CORE TO INITIAL SIZE

NOSET:	OUTSTR	[ASCIZ "?Not enough memory to start compilation
"]
	CALLI	$EXIT
>

IFN TOPS20,<
NOADD:	HRROI	T1,[ASCIZ "?Not enough memory to continue compilation
"]
	PSOUT%
	HALTF%
	JRST	NOADD
>


	END