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

; UPD ID= 3293 on 12/29/80 at 11:35 AM by NIXON                         
TITLE	COBCOM FOR COBOL V12C
SUBTTL	SUBROUTINES USED BY ALL PHASES IN COBOL		AL BLACKINGTON/CAM

	SEARCH COPYRT
	SALL

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

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

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

;EDITS
;NAME	DATE		COMMENTS

;JEH	18-MAR-82	[1345] TRAP ILLEGAL UUO'S ON TOPS10
;V12B****************
;V12*****************
;DMN	23-APR-80	[1014] LIST FULL PATH ON LOOKUP/ENTER ERRORS.
;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
;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


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

LOC	137
EXP	CBLVER

RELOC	%HISEG
SALL

;ENTRY POINTS AND GLOBAL SYMBOLS

IFE ONESEG,<
ENTRY	COBEXO		;EXECUTE ONLY ENTRY FROM GETSEG CODE
>
ENTRY	DEVERA		;DEVICE TRANSMISSION ERROR
ENTRY	DEVDED		;WRITE ERROR ON SCRATCH FILE
ENTRY	EOTAPE		;PUT OUT MAG-TAPE EOT MESSAGE
ENTRY	SIXOUT		;TYPE OUT A SIXBIT WORD
ENTRY	LNKSET		;CREATE A TABLE ADDRESS FROM TABLE-LINK
ENTRY	RESTRT		;RESTART COMPILATION (REENTER)
ENTRY	REDO		;RESTART COMPILATION (START)
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
IFE TOPS20,<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	TTYON		;[266] TURN TTY OUTPUTS BACK ON
ENTRY	PUTLNK,FNDLNK,FNDNXT,GETENT,GETLOC

INTERN	CPOPJ,CPOPJ1,CPOPJ2

$LF==12		;LINE-FEED
$CR==15		;CARRIAGE-RETURN
$EOF==32	;END OF FILE

EXTERN	KILLAC
EXTERN	DEVDEV,DEVFIL,DEVEXT,DEVPP
EXTERN	LITLOC,FILLOC,DATLOC,CONLOC,PROLOC,EXTLOC,MNELOC,VALLOC
EXTERN	GETFNM, PHASEN, GETFST, MLOAD1,TOPLOC
EXTERN  WARNW,FATALW
IFE ONESEG,<
EXTERN	GETLOD,SAVEAC
>

;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
>

;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?
	CALLI	TE,$DEVCH
	TLNE	TE,$MTA
	TLNN	CH,$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,

CRLF:	[ASCIZ "
"]

;END OF MAG-TAPE

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

;GET CHARACTERISTICS OF DEVICE

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

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

	TLNN	CH,$MTA		;IS IT MAG-TAPE?
	POPJ	PP,		;YES--EXIT TO CALL+1
	TLNN	CH,$DSK!$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=$MTA!$DTA!$LPT!$CDR!$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,

IFE TOPS20,<
;[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"

INTERN	OCTOUT
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

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,

;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:	OUTSTR	[ASCIZ "Bad table-link at "]
	SOS	(PP)
	MOVE	TE,[POINT 3,(PP),17]
BADL1:	ILDB	CH,TE
	ADDI	CH,"0"
	OUTCHR	CH
	TLNE	TE,770000
	JRST	BADL1
	OUTSTR	[ASCIZ "
"]
	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

;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
	SKIPA			;[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:	XCT	GIVERR(TC)	;[506] GIVE USER PROPER ERROR MESSAGE
	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:	OUTSTR	 [ASCIZ /?File table overflow - FILE SECTION too big/]	;[506]
	OUTSTR	 [ASCIZ /?Data table overflow - DATA DIVISION too big/]	;[506]
	OUTSTR	 [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

;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,<
 IFN ANS68,<
  IFE FT68274,<
	MOVE	TB,['COBOL ']
  >
  IFN FT68274,<
	MOVE	TB,['68274 ']
  >
 >
 IFN ANS74,<
	MOVE	TB,['CBL74 ']
 >
	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,<
 IFN ANS68,<
  IFE FT68274,<
	MOVE	TB,['COBOLK']
  >
  IFN FT68274,<
	MOVE	TB,['68274K']
  >
 >
 IFN ANS74,<
	MOVE	TB,['CBL74K']
 >
	MOVEM	TB,GETFNM+1
	MOVEM	TE,GETFST
	JRST	GETLOD
>
IFN ONESEG,<JRST COBOLK##>

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

	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

;HANDLE 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)
	MOVE	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:	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


	END