Trailing-Edge
-
PDP-10 Archives
-
ap-c800d-sb
-
cobcom.mac
There are 14 other files named cobcom.mac in the archive. Click here to see a list.
; UPD ID= 1715 on 2/22/79 at 9:46 AM by N:<NIXON>
TITLE COBCOM FOR COBOL V12
SUBTTL SUBROUTINES USED BY ALL PHASES IN COBOL AL BLACKINGTON/CAM
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1974, 1979 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
DEBUG==:DEBUG
ONESEG==:ONESEG
;EDITS
;NAME DATE COMMENTS
;V12*****************
;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 [266]
LOC 137
XWD VERSION,VEDIT
TWOSEG
RELOC 400000
ENTRY LSTMES ;PUT AN ASCII STRING ONTO LISTING FILE
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 GETFAZ ;GET NEXT MACHINE LOAD OF INSTRUCTIONS
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
ENTRY FILOUT ;TYPE OUT DEV:FILE.EXT[P,P]
ENTRY ERATYP ;TYPE OUT ENTER/LOOKUP FAIL MESSAGE
ENTRY TTYON ; TURN TTY OUTPUTS BACK ON [266]
INTERN CPOPJ,CPOPJ1,CPOPJ2
EXTERN GETLOD, PUTLST, WARNW
;PRINT ASCII TEXT
;ENTER WITH A BYTE POINTER TO THE TEXT STRING IN "TE".
PUSHJ PP,PUTLST
LSTMES: ILDB CH,TE
JUMPN CH,LSTMES-1
POPJ PP,
;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: TTCALL 3,[ASCIZ "TRANSMISSION ERROR FOR "]
DVERB1: PUSH PP,TA
PUSH PP,TE
MOVE TA,(CH)
PUSHJ PP,SIXOUT
MOVEI TD,":"
TTCALL 1,TD
SKIPE TA,1(CH)
PUSHJ PP,SIXOUT
HLLZ TA,2(CH)
JUMPE TA,DVERB2
MOVEI TD,"."
TTCALL 1,TD
PUSHJ PP,SIXOUT
DVERB2: POP PP,TE
POP PP,TA
TTCALL 3,[ASCIZ "
"]
POPJ PP,
;END OF MAG-TAPE
EOTAPE: TTCALL 3,[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
TTCALL 3,[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: TTCALL 3,[ASCIZ "?CANNOT CONTINUE
"]
JRST RESTRT
OKDEVS=$MTA!$DTA!$LPT!$CDR!$DSK
ERATYP: PUSHJ PP,FILOUT ;TYPE 'DEV:FILE.EXT[PROJ,PROG]'
TTCALL 3,[ASCIZ "("]
HRRZ TA,I2
PUSHJ PP,OCTOUT
MOVE TA,ERAPTR
ERAT1: HLRZ TB,(TA)
CAIE TB,(I2)
AOBJN TA,ERAT1
HRRZ TA,(TA)
TTCALL 3,(TA)
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 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,":"
TTCALL 1,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
TTCALL 1,CH
PUSHJ PP,SIXOUT
FILO1: SKIPN TA,DEVPP(DA) ;ANY PROJ-PROG #?
JRST FILO2 ;NO
MOVEI CH,"[" ;YES--TYPE IT OUT
TTCALL 1,CH
HLRZ TA,DEVPP(DA)
PUSHJ PP,OCTOUT
MOVEI CH,","
TTCALL 1,CH
HRRZ TA,DEVPP(DA)
PUSHJ PP,OCTOUT
MOVEI CH,"]"
TTCALL 1,CH
FILO2: TTCALL 3,[ASCIZ "
"]
POPJ PP,
;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"
TTCALL 1,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
TTCALL 1,TD
TLNE TE,770000
JRST SIXO1
POPJ PP,
;PUT MESSAGE ONTO THE LISTING
ENTRY DBMESS
DBMESS: MOVEI CH,440700
HRLM CH,(PP)
JRST DBMES2
DBMES1: PUSHJ PP,PUTLST
DBMES2: ILDB CH,(PP)
JUMPN CH,DBMES1
AOS (PP)
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: TTCALL 3,[ASCIZ "BAD TABLE-LINK AT "]
SOS (PP)
MOVE TE,[POINT 3,(PP),17]
BADL1: ILDB CH,TE
ADDI CH,"0"
TTCALL 1,CH
TLNE TE,770000
JRST BADL1
TTCALL 3,[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
;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,REGO ;STARTING ADDRESS
AND SW,[EXP FDSKC] ;TURN OFF ALL FLAGS EXCEPT FDSKC
MOVE TB,PHASEN ;ARE WE IN FIRST MACHINE LOAD?
CAIG TB,MLOAD1
JRST 2(TA) ;YES--NO NEED TO LOAD IT
IFN ANS68,<
MOVE TB,['COBOL ']
>
IFN ANS74,<
MOVE TB,['CBL74 ']
>
MOVEM TB,GETFNM+1
MOVEI TA,2 ;STARTING ADDRESS INCREMENT
MOVEM TA,GETFST## ;INCREMENT
JRST GETLOD
GETFAZ: MOVEM TA,GETFNM+1
SETZM GETFST ;STARTING ADDRESS 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: 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:
IFN ANS68,<
MOVE TB,['COBOLK']
>
IFN ANS74,<
MOVE TB,['CBL74K']
>
MOVEM TB,GETFNM+1
IFE ONESEG,< 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: TTCALL 3,[ASCIZ /
/] ;[506]
TTCALL 3,[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: 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
TTCALL 3,[ASCIZ "ILLEGAL UUO AT LOCATION "]
SOS (PP)
MOVE TE,[POINT 3,(PP),17]
UUOC2: ILDB CH,TE
ADDI CH,"0"
TTCALL 1,CH
TLNE TE,770000
JRST UUOC2
TTCALL 3,[ASCIZ "
"]
MOVE TE,KILLAC+1
MOVE CH,KILLAC
JRST KILL
UUOTAB: EXP UUOC1 ;0
EXP UUO1 ;1 - WARNING DIAG
EXP UUO2 ;2 - WARNING 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
; TURN ON THE USERS TTY OUTPUT IF HE DID A CONTROL O
TTYON: SETO TA, ; GET USERS [266]
GETLCH TA ; TTY LINE [266]
HRRZS TA ; STORE UNIVERSAL INDEX NUMBER [266]
TTYLP: MOVE TC,[XWD 2,TB] ; SET UP TO SEE [266]
MOVEI TB,1000 ; CHECK TOIP BIT OF [266]
TRMOP. TC, ; USERS TTY OUTPUT [266]
JRST TTYDON ; NO TRMOP. UUO- TRY TO FORCE IT [266]
JUMPE TC,TTYDON ; OUTPUT IN PROGRESS; IF SO SLEEP [266]
TTYSLP: MOVEI TB,1 ; FOR SLEEPING [266]
MOVEI TC,100 ;SLEEP 100MS [266]
HIBER TC, ; [266]
SLEEP TB, ; SLEEP 1 SEC IF NO HIBER [266]
JRST TTYLP ; TRY AGAIN [266]
TTYDON: TTCALL 13,0 ; THIS TURN OFF CONTROL BIT [266]
JFCL ; DON'T CARE WHAT IS IN TTY BUFFER [266]
POPJ PP, ; RETURN [266]
$LF==12 ;LINE-FEED
$CR==15 ;CARRIAGE-RETURN
$EOF==32;END OF FILE
EXTERNAL KILLAC
EXTERNAL DEVDEV,DEVFIL,DEVEXT,DEVPP
EXTERNAL LITLOC,FILLOC,DATLOC,CONLOC,PROLOC,EXTLOC,MNELOC,VALLOC
EXTERNAL GETFNM, PHASEN, GETFST, MLOAD1,TOPLOC
END