Trailing-Edge
-
PDP-10 Archives
-
cobol12c
-
cobcom.mac
There are 14 other files named cobcom.mac in the archive. Click here to see a list.
; 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