Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/cobcom.mac
There are 14 other files named cobcom.mac in the archive. Click here to see a list.
; 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
;MJC 4-NOV-85 [1613] Check for table overflow
;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
;[1613]CHECK FOR TABLE OVERFLOW
XPAND1: HRRZ TA,SAVEAC ;[1613]GET TABLE POINTER
HLRZ TE,SAVEAC ;[1613]AMOUNT OF GROTH
ADD TE,1(TA) ;[1613]TABLE WILL GROW TO THIS SIZE
HRRZ TD,(TA) ;[1613]THE START OF THE TABLE
HRRZ TE,TE ;[1613]RIGHT HALF ONLY
SUB TE,TD ;[1613]LESS THE START ADDRESS
MOVE TD,TE ;[1613]SAVE THE DIFFERENCE
ANDI TE,700000 ;[1613]MORE THAN 15 BITS?
CAIN TE,0 ;[1613]OVERFLOW IF SO
JRST XPAND6 ;[1613]OK - NO TABLE OVERFLOW
;[1613]SEE IF WE CAN EXPAND ONE LAST TIME BY SOME SMALLER AMOUNT
ANDI TD,77777 ;[1613]THE AMOUNT OF OVERLAP
HLRZ TE,SAVEAC ;[1613]EXPANSION WANTED
SUB TE,TD ;[1613]WHAT WILL FIT
HLRE TD,1(TA) ;[1613]LEFT UNUSED FROM LAST EXPANSION
ADD TE,TD ;[1613]INCLUDE IT TOO
SOS TE ;[1613]OFF BY ONE
CAIG TE,20 ;[1613]ENOUGH TO SALVAGE?
JRST TBLOVF ;[1613]NO - GIVE UP
HRLM TE,SAVEAC ;[1613]YES - EXPAND BY THAT MUCH
JRST XPAND6 ;[1613]CONTINUE WITH A SMALLER EXPANSION
TBLOVF: OUTSTR [ASCIZ /?Compiler table overflow. Compilation aborted.
/] ;[1613]
JRST RESTRT ;[1613]ABORT AND RESTART
XPAND6: MOVE TE,SAVEAC ;[1613]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