Trailing-Edge
-
PDP-10 Archives
-
AP-D489C-SB
-
srtuuo.mac
There are 7 other files named srtuuo.mac in the archive. Click here to see a list.
SUBTTL SRTUUO - TOPS-10 SPECIFIC PART OF SORT/MERGE
SUBTTL D.M.NIXON/DMN/DZN 10-APR-78
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1977, 1978 BY DIGITAL EQUIPMENT CORPORATION
IFN FTOPS20,<PRINTX ? SRTUUO should not be present in TOPS-20 SORT/MERGE.>
SUBTTL TABLE OF CONTENTS FOR SRTUUO
; Table of Contents for SRTUUO
;
;
; Section Page
;
; 1 SRTUUO - TOPS-10 SPECIFIC PART OF SORT/MERGE ............. 1
; 2 TABLE OF CONTENTS FOR SRTUUO ............................. 2
; 3 DEFINITIONS
; 3.1 TOPS-10 Specific Parameters ....................... 3
; 4 PSORT.
; 4.1 DEFCOR - Default Memory Allocation Algorithm ...... 4
; 4.2 SETSTR - Set Up Temporary Disk Structures ......... 6
; 5 GETREC
; 5.1 GETBUF - Input 1 Physical Buffer .................. 9
; 6 PUTREC
; 6.1 PUTBUF - Output 1 Physical Buffer ................. 10
; 7 FILE UTILITY ROUTINES
; 7.1 Close Master Input/Output File .................... 11
; 7.2 Delete, Rename a File ............................. 12
; 7.3 Open Output Temporary File ........................ 13
; 7.4 Open Input Temporary File ......................... 14
; 7.5 Enter a File ...................................... 15
; 7.6 Delete a Temporary Structure ...................... 16
; 7.7 Append to Temporary File .......................... 17
; 7.8 Build a Buffer Ring ............................... 18
; 7.9 Reformat Buffer Pool for Next Merge ............... 19
; 8 CLEAN UP MEMORY FOR COBOL AND FORTRAN .................... 20
; 9 ERROR MESSAGES ........................................... 21
SUBTTL DEFINITIONS -- TOPS-10 Specific Parameters
;PARAMETER DEFINITIONS NEEDED ONLY ON TOPS10
.TBS==203 ;SIZE OF TEMP FILE BUFFERS
SEGMENT HIGH
SUBTTL PSORT. -- DEFCOR - Default Memory Allocation Algorithm
PROCEDURE (PUSHJ P,DEFCOR)
BEGIN
COMMENT \
CALCULATE USER MINIMUM CORE SIZE FROM
DOUBLE BUFFERING + AT LEAST 16 RECORDS IN CORE
IF V/M SYSTEM THEN
IF USER MIN. GREATER THAN USER VIRTUAL LIMIT THEN ERROR
ELSE GET USER CORMAX
IF USER CORE MAX. LESS THAN USER PHY. LIM. THEN USER PHY. LIM. = USER CORMAX
IF USER MIN. GREATER THAN USER PHY. LIM.
THEN DEFAULT SIZE = USER MIN.
ELSE IF USER PHY LIM. LESS THAN 1/2 SYSTEM CORMAX
THEN DEFAULT SIZE = USER PHY. LIM.
ELSE IF USER MIN. GREATER THAN 1/2 SYSTEM CORMAX
THEN DEFAULT SIZE = USER MIN
ELSE DEFAULT SIZE = 1/2 SYSTEM CORMAX
ELSE SYSTEM DOES NOT HAVE V/M THEN
IF USER MIN. GREATER THAN USER CORMAX THEN ERROR
ELSE IF USER MIN. GREATER THAN 1/2 SYSTEM CORMAX
THEN DEFAULT SIZE = USER MIN
ELSE IF USER CORMAX GREATER THAN 1/2 SYSTEM CORMAX
THEN DEFAULT SIZE = 1/2 SYSTEM CORMAX
ELSE DEFAULT SIZE = USER CORMAX
\
MOVE J,.JBFF ;CURRENT FREE SPACE
IF /MERGE
IFN FTDEBUG!FTCOBOL!FTFORTRAN,<
ADD J,HISIZE ;INCLUDE HI-SEGEMENT SIZE
>
SKIPG MRGSW
JRST $T
THEN ACCOUNT FOR UP TO 15 INPUT FILES
IFE FTCOBOL,<
MOVE T1,MXDVSZ ;[215] ALLOW FOR WORST CASE
IMUL T1,ACTTMP ;FOR EACH INPUT CHAN
MOVE T2,F.OXBK ;[215] GET OUTPUT BUFFER SIZE
MOVE T2,X.DVSZ(T2) ;[215] ..
CAIGE T2,.TBS ;USE LARGER
MOVEI T2,.TBS
ADDI T1,(T2) ;PLUS OUTPUT BUFFER
LSH T1,1 ;DOUBLE BUFFERING
>
IFN FTCOBOL,<
MOVEI T1,2*.TBS ;DOUBLE BUFFER TEMP FILE
IMUL T1,MAXTMP ;* MAX. NO. OF THEM
>
ADDI J,(T1)
MOVE T2,REKSIZ
ADDI T2,RN.LEN
IMUL T2,NUMRCB ;NO. OF RECORDS
JRST $F
ELSE ITS A REGULAR SORT
MOVEI T1,.TBS ;TEMP BUFFER
IFE FTCOBOL,<
ADD T1,MXDVSZ ;[215] PLUS LARGEST INPUT BUFFER
>
LSH T1,1 ;AT LEAST DOUBLE BUFFERING
ADDI J,(T1) ;ADD THEM IN
MOVE T2,REKSIZ ;RECORD SIZE
ADDI T2,RN.LEN ;PLUS ASSOCIATED NODE
LSH T2,POW2(^D16) ;AT LEAST 16
FI;
ADDI J,(T2) ;WE NEED AT LEAST THIS MUCH
HRROI T3,.GTCVL ;CURRENT VIRTUAL/PHYSICAL LIMITS
IF A V/M SYSTEM
GETTAB T3,
JRST $T ;TRY CORMAX LIMITS
TXZ T3,1B18 ;TURN OFF LIMIT BIT
HLRZ T4,T3 ;VIRTUAL LIMIT
HRRZ T3,T3 ;PHYSICAL LIMIT
JUMPE T4,$T ;NOT A V/M SYSTEM
THEN
LSH T3,POW2(1000) ;INTO WORDS
LSH T4,POW2(1000) ;...
CAMLE J,T4 ;LESS THAN VIRTUAL LIMIT?
JRST E$$NEC ;NO
MOVE T4,[%NSCMX] ;GET USER CORMAX
GETTAB T4,
JSP P4,E$$MGF
CAMLE T3,T4 ;PHYSICAL LIM .LE. TO CORMAX?
MOVE T3,T4 ;NO, USE CORMAX INSTEAD
CAML J,T3 ;NEED MORE THAN PHYSICAL LIMIT?
JRST $F ;YES, USE WHAT WE NEED ONLY
MOVE T4,[%NSMXM] ;GET HOW MUCH SYSTEM HAS
GETTAB T4,
JSP P4,E$$MGF
LSH T4,-1 ;CUT IN HALF
CAXLE T4,700000 ;SEE THAT NUMBER IS BELOW PFH
MOVX T4,700000 ; ..
CAMG T3,T4 ;IS PHYLIM GT. 1/2 OF CORE
SKIPA J,T3 ;NO, GIVE USER PHYSICAL LIMIT
CAML J,T4 ;IS J GT. 1/2 OF CORE?
JRST $F ;YES, USE WHAT WE NEED
MOVE J,T4 ;NO, TAKE 1/2 OF CORE
JRST $F
ELSE HERE IF NOT V/M
MOVE T3,[%NSMXM] ;LARGEST CORMAX (SYSTEM SIZE)
GETTAB T3,
JSP P4,E$$MGF
SETZ T4,
CORE T4, ;GET CORE USER CAN GET
LSH T4,POW2(2000) ;ALWAYS GIVES ERROR RETURN
CAILE J,(T4) ;ENOUGH CORE?
JRST E$$NEC ;NO
LSH T3,-1 ;CUT IN HALF
CAXLE T3,700000 ;SEE THAT NUMBER IS BELOW PFH
MOVX T3,700000 ; ..
CAIL J,(T3) ;WANT MORE THAN 1/2
JRST $F ;USE ALL OF WHAT WE NEED
CAIG T3,(T4) ;USE THE SMALLER OF THE TWO
SKIPA J,T3 ;T3 SMALLER
MOVE J,T4 ;T4 SMALLER
FI;
IFN FTDEBUG!FTCOBOL!FTFORTRAN,<
IFE FTCOBOL!FTFORTRAN,<
SKIPE .JBDDT ;IF KEEPING DDT
>
SUB J,HISIZE ;DISCOUNT HI-SEGMENT SIZE
>
SKIPE CPU ;KI10 OR KL10?
SUBI J,1000 ;YES, ACCOUNT FOR UPMP
IFN FTDEBUG!FTCOBOL!FTFORTRAN,<
IFE FTCOBOL!FTFORTRAN,<
SKIPE .JBDDT ;DDT ACTUALY LOADED?
>
SKIPN T3,HISIZE ;GET HIGH SEGMENT SIZE
JRST $2 ;NO HIGH SEG OR NO DDT
HRRZ T4,.JBHRL ;HIGHEST LEGAL ADDRESS
SUBI T4,1(T3) ;GET HIGHEST LEGAL LOC IN LOW SEG
CAILE J,(T4) ;DO WE WANT TOO MUCH?
MOVEI J,(T4) ;YES, USE LIMIT
$2%
>;END IFN FTCOBOL
CAXLE J,377777 ;FOR NOW, DON'T ALLOW HUGE LOWSEGS,
MOVEI J,377777 ; SINCE TOO MANY BUGS WITH THEM
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,TSTSIZ)
MOVE T1,[%CNPGS] ;UNIT OF CORE
GETTAB T1,
MOVEI T1,2000 ;ASSUME 1K
ADDI J,-1(T1)
ANDCMI J,-1(T1) ;ROUND UP TO LIMIT
SOS P1,J ;GET WORKING COPY
SUB P1,.JBFF ;MINUS WHATS IN USE
IF /MERGE
SKIPG MRGSW
JRST $T
THEN COUNT ALL INPUT FILES
IFE FTCOBOL,<
MOVE T1,MXDVSZ ;[215] ASSUME WORST CASE
IMUL T1,ACTTMP ;* NUMBER OPEN AT ONE TIME
MOVE T2,F.OXBK ;[215] GET OUTPUT BUFFER SIZE
MOVE T2,X.DVSZ(T2) ;[215] ..
CAIGE T2,.TBS ;USE MAX
MOVEI T2,.TBS
ADDI T1,(T2) ;+ OUTPUT BUFFER
LSH T1,1 ;DOUBLE BUFFERING
>
IFN FTCOBOL,<
MOVEI T1,2*.TBS ;DOUBLE BUFFER TEMP FILE
IMUL T1,MAXTMP ;* MAX. NO. OF THEM
>
MOVE T2,REKSIZ
ADDI T2,RN.LEN ;RECORD+HEADER
IMUL T2,NUMRCB ;TOTAL WE NEED
SUBI P1,(T1)
SUBI P1,(T2)
JUMPLE P1,$3 ;NOT ENOUGH CORE
LSH T1,-1 ;PER SINGLE BUFFER
MOVNI T3,4 ;TRY TO ALLOCATE UP TO SIX
$4% SUBI P1,(T1)
JUMPL P1,$5 ;NO MORE
AOJL T3,$4 ;TRY AGAIN
$5% ADDI T3,6 ;GET ACTUAL NO.
IFE FTCOBOL,<
MOVEM T3,IBUFNO
>
MOVEM T3,TBUFNO
MOVEM T3,OBUFNO
ANDCMI P1,777 ;ONLY USE WHAT WE NEED
SUB J,P1
RETURN
ELSE DO NORMAL SORT
MOVEI T1,.TBS ;SIZE OF TEMP BUFFER
IFE FTCOBOL,<
ADD T1,MXDVSZ ;[215] SIZE OF LARGEST INPUT BUFFER
>
LSH T1,1 ;DOUBLE BUFFER REQUIRED
MOVE T2,REKSIZ ;SIZE OF 1 RECORD
ADDI T2,RN.LEN ;PLUS ASSOCIATED NODE
LSH T2,POW2(^D16) ;16 IS ABSOLUTE SMALLEST NO.
SUBI P1,(T1)
SUBI P1,(T2)
JUMPLE P1,$3 ;NOT ENOUGH SPECIFIED
ADDI P1,(T2)
LSH T2,3 ;NOW TRY FOR 128.
SUBI P1,(T2)
LSH T1,-1 ;HOW MUCH FOR ONE BUFFER EACH
MOVNI T3,4 ;TRY TO ALLOCATE UP TO SIX (4 MORE) BUFFERS
$1% SUBI P1,(T2) ;TRY FOR 128 MORE RECORDS
JUMPL P1,$2 ;FAILED
SUBI P1,(T1)
JUMPL P1,$2 ;NO MORE
AOJL T3,$1 ;1 MORE, TRY AGAIN
$2% ADDI T3,6 ;ACTUAL BUFFERS WE CAN USE
IFE FTCOBOL,<
MOVEM T3,IBUFNO ;FOR INPUT
>
MOVEM T3,TBUFNO ;FOR TMPBUF
IMULI T3,(T1) ;TOTAL NEEDED FOR BUFFERS
MOVE T1,J
SUB T1,.JBFF ;WHAT IS FREE
SUBI T1,(T3) ;MINUS BUFFERS
MOVE T2,REKSIZ ;
IDIVI T1,RN.LEN(T2) ;IS FOR RECORDS
IF /LEAVES WAS SPECIFIED
SKIPLE NUMRCB
CAMG T1,NUMRCB ;SKIP IF EXCESS
JRST $T
THEN SEE IF WE CAN REDUCE SIZE
SUB T1,NUMRCB ;GET EXCESS RECORDS
MOVE T2,REKSIZ
IMULI T1,RN.LEN(T2) ;IN WORDS
SUB J,T1 ;REDUCE SIZE
RETURN
ELSE JUST STORE NUMBER OF RECORD THAT WILL FIT IN CORE
MOVEM T1,NUMRCB ;RECORDS IN CORE
RETURN ;RETURN TO CALLING PROGRAM
FI;
FI;
$3% MOVN P1,P1 ;HOW MUCH WE WERE SHORT
ADD J,P1 ;WHAT WE REALLY NEED
$ERROR (%,NCS,<Not enough core specified>)
AOJA J,TSTSIZ ;TRY AGAIN
END;
SUBTTL PSORT. -- SETSTR - Set Up Temporary Disk Structures
SEGMENT LOW
BEGIN
PROCEDURE (PUSHJ P,SETSTR)
MOVSI U,-MX.TMP ;[214] FILL ENTIRE TABLE JUST IN CASE
MOVN S,STRNUM ;[214] BUILD AOBJN PTR FOR USER'S STRS
HRLZI S,(S) ;[214] ..
FOR EACH USER SPECIFIED STR DO
BEGIN
MOVE T1,STRNAM(U) ;[214] GET DSK STR
MOVEM T1,DSKARG+.DCNAM ;STORE NAME
MOVE T1,[.DCUPN,,DSKARG]
DSKCHR T1, ;DO UUO
JSP P4,E$$MUF
TXNN T1,DC.TYP ;GENERIC DSK IF ALL ZERO
JRST [PUSHJ P,GENSTR ;YES, TREAT IT SPECIALLY
JUMPL U,$B ;OK, SO TRY AGAIN
JRST $E] ;RAN OUT
TXNE T1,DC.HWP!DC.SWP ;WRITE PROTECTED
JRST E$$SWP ;[214] WRITE-PROTECTED--DIE
HLRZ T1,T1 ;GET TYPE IN RHS
ANDI T1,(DC.TYP) ;ONLY BITS WE NOW NEED
MOVE T2,DSKARG+.DCULN ;GET UNIT #
MOVEM T2,STRNAM(U) ;STORE AS NAME
CASE STR OF .DCTYP
JRST @[EXP $3,$3,$4,$3,$3,$4]-1(T1)
$3% MOVEM T2,STRULN(S)
MOVE T2,DSKARG+.DCSNM ;GET STRUCTURE NAME
MOVEM T2,STRSNM(S) ;SAVE IT
AOBJP S,$E ;[214] ADVANCE USER'S STR TABLE
$4% AOBJN U,$B ;LOOP
RETURN ;STRNAM IS FULL
ESAC;
END;
SETOM STRULN(S) ;MARK END OF LIST
AOBJP U,$6 ;[214] NEED TO ADVANCE AND CHECK
SETZ S, ;START AT FRONT AGAIN
WHILE STRS TO CONSIDER DO
BEGIN
PUSHJ P,NXTUNI ;GET NEXT UNIT #
JUMPE T1,$E ;ALL DONE IF NO STR LEFT
MOVEM T1,STRULN(S) ;FOR NEXT TIME
MOVEM T1,DSKARG+.DCNAM ;STORE IT
MOVE T1,[.DCUPN,,DSKARG]
DSKCHR T1,
JRST [SETZM STRULN(S) ;REMOVE FROM LIST
AOJA S,$B] ;AND TRY NEXT
MOVE T1,DSKARG+.DCULN
MOVEM T1,STRNAM(U) ;STORE
AOS STRNUM ;COUNT ONE MORE
AOBJP U,$E ;DONE IF FULL
AOBJP S,$B ;LOOP
END;
$6% RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,GENSTR)
SETOM STRARG ;-1 TO GET FIRST ARG
PUSH P,STRNAM(U) ;SAVE CURRENT GENERIC
SETZM STRNAM(U) ;IN CASE WE DON'T FIND A REPLACEMENT
MOVE T1,[3,,STRARG]
MOVE T4,STRNUM ;NO. IN USE ALREADY
SUBI T4,MX.TMP ;[214] - WHAT WE COULD HAVE
HRLZ T4,T4
HRR T4,STRNUM ;AOBJN PTR
$1% JOBSTR T1, ;GET NEXT STR
JSP P4,E$$MUF
SKIPE T2,STRARG+.DFJNM ;ENDS WITH A 0 AT FENCE
CAMN T2,[-1] ;OR AT END
JRST $3 ;RETURN
MOVE T3,STRARG+.DFJST ;CHECK STATUS
TXNE T3,DF.SWL!DF.SNC
JRST $1 ;DON'T USE THIS ONE
MOVEM T2,DSKARG+.DCNAM ;STORE NAME FOR DSKCHR
MOVE T3,[.DCFCT,,DSKARG] ;JUST GET USERS QUOTA
DSKCHR T3,
JSP P4,E$$MUF
TXNE T3,DC.HWP!DC.SWP ;PROTECTED?
JRST $1 ;YES, DON'T USE IT
SKIPN STRNAM(U) ;ALREADY FOUND REPLACEMENT?
JRST [MOVEM T2,STRNAM(U) ;NO, SO DO IT NOW
TLNE T4,-1 ;DO WE HAVE ANY ROOM?
JRST $1 ;YES, GET NEXT STR
JRST $3] ;NO, GIVE UP
MOVEM T2,STRNAM(T4) ;STORE NAME
AOS STRNUM ;COUNT ONE MORE
SUB S,[1,,0] ;[214] NOW ONE MORE STR TO CHECK
AOBJN T4,$1 ;ADVANCE PTR
$3% POP P,T2 ;GET GENERIC NAME BACK
SKIPE STRNAM(U) ;DID WE FIND A REPLACEMENT?
RETURN ;YES
MOVEM T2,STRNAM(U) ;NO, SO USE GENERIC AGAIN
AOBJN U,.+1 ;MOVE ON TO NEXT
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,NXTUNI)
$1% SKIPN T1,STRULN(S) ;GET UNIT NAME
AOJA S,$1 ;DOES NOT EXIST ANYMORE
CAMN T1,[-1] ;-1 IS END OF LIST
JRST [HLLZ S,S ;START LIST AGAIN
TLZE S,-1 ;UNLESS NONE FOUND
JRST $1
SETZ T1, ;IN WHICH CASE RETURN T1 =0
RETURN]
ANDCM T1,STRSNM(S) ;GET JUST THE UNIT #
SETZ T3, ;COUNTER
$2% TRNE T1,77 ;RIGHT JUSTIFIED?
JRST $4 ;YES
LSH T1,-6 ;NO, SHIFT RIGHT 1 CHAR
AOJA T3,$2 ;LOOP
$4% TRC T1,7 ;SEE IF LEAST SIGNIFICANT UNIT IS FULL
TRCE T1,7
AOJA T1,$3 ;ITS NOT
ADDI T1,100 ;INCREMENT
IORI T1,'00' ;INCASE WE OVERFLOWED
$3% IMULI T3,6 ;SHIFT COUNTER
LSH T1,(T3) ;PUT BACK
IOR T1,STRSNM(S) ;FORM NEW NAME
RETURN
END;
SUBTTL GETREC -- GETBUF - Input 1 Physical Buffer
BEGIN
PROCEDURE (JSP T4,GETBUF) ;GET PHYSICAL I/O BUFFER
;RETURNS
; MOVE EF,PHYEOF
; JRST 0(T4) ;ERROR
;OR
; JRST 1(T4) ;NORMAL
MOVEI T1,(F)
SUBI T1,FCBORG ;FCBLEN* TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;POSITION FOR UUO
TLO T1,(IN) ;COMPLETE IN CHN,0
XCT T1 ;ADVANCE TO NEXT BUFFER
JRST GETOK ;UNEVENTFUL INPUT !
TLC T1,(<IN>^!<GETSTS>)
HRRI T1,T1 ;FORM [GETSTS CHN,T1]
XCT T1 ;RETRIEVE FILE STATUS
TXNN T1,IO.ERR ;I/O ERRORS ?
JRST GETEOF ;NO, MUST BE END OF FILE
PUSH P,T1 ;SAVE STATUS
$ERROR (?,IRE,<Input read error, status >,+)
POP P,T1 ;RESTORE STATUS
$MORE (OCTAL,T1)
$DIE
GETEOF: MOVE EF,PHYEOF ;GET PHYSICAL E-O-F ROUTINE
JRST 0(T4) ;GIVE ERROR RETURN
GETOK: MOVE T1,[440000,,1]
ADDM T1,FILPTR(F) ;ADVANCE BYTE PTR TO FIRST WORD OF BUFFER
MOVE T1,FILCNT(F) ;BUFFER WORD COUNT TO T1
JRST 1(T4) ;GIVE OK RETURN
END;
SUBTTL PUTREC -- PUTBUF - Output 1 Physical Buffer
BEGIN
PROCEDURE (JSP T4,PUTBUF)
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;WHEN -RELOC WORKS
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;POSITION CHANNEL # FOR UUO
TLO T1,(OUT)
SKIPGE FILPTR(F) ;HAS BYTE PTR BEEN ADVANCED?
SOS FILPTR(F) ;YES, RETARD IT
IF OUT UUO SUCCEEDS
XCT T1 ;OUT CHN,0
THEN ALL IS DANDY--RETURN
JRST $F ;[215] UNEVENTFUL OUTPUT
ELSE CHECK ERROR CONDITIONS
TLC T1,(<OUT>^!<GETSTS>)
HRRI T1,T1
XCT T1 ;GETSTS CHN,T1
PUSH P,T1 ;[215] SAVE STATUS
IF THIS IS A MAGTAPE END-OF-TAPE ERROR
IFE FTFORTRAN!FTCOBOL,<
MOVE T1,FILXBK(F) ;[215] GET DEVCHR WORD
MOVE T1,X.DVCH(T1) ;[215] ..
CAXE T1,DVCHNL ;[215] IF NUL:, NOT A MAGTAPE
TXNN T1,DV.MTA ;[215] NOW CHECK IF REALLY A TAPE
JRST $T ;[215] NO--JUST PRINT ERROR STATUS
THEN JUST SIGNAL EOT FOR PUTREC
MOVX T1,FI.EOT ;[215] REMEMBER EOT
ORM T1,FILFLG(F) ;[215] ..
JRST $F ;[215] DONE HERE
ELSE PRINT ERROR STATUS
>
E$$OWE: $ERROR (?,OWE,<Output write error, status >,+)
POP P,T1
$MORE (OCTAL,T1)
$DIE
FI;
FI;
MOVE T1,[440000,,1]
ADDM T1,FILPTR(F) ;ADVANCE BYTE PTR TO FIRST WORD OF BUFFER
MOVE T1,FILCNT(F) ;BUFFER WORD COUNT TO T1
RETURN
END;
SUBTTL FILE UTILITY ROUTINES -- Close Master Input/Output File
BEGIN
PROCEDURE (PUSHJ P,CLSMST) ;CLOSE FILE INDICATED BY F
;USES T1, T2, AND T4
;CALLS CLRBUF
TDZA T4,T4 ;FINAL CLOSE FOR MASTER INPUT/OUTPUT
PROCEDURE (PUSHJ P,CLSFIL)
MOVX T4,CL.ACS!CL.DLL ;DON'T DELETE ALLOCATED BLOCKS
MOVE T1,FILHDR(F) ;GET BUFFER RING HEADER
TXNE T1,BF.IBC ;BUFFER CLEAR INHIBITED?
PUSHJ P,CLRBUF ;YES, SO CLEAR JUNK
SKIPGE FILPTR(F) ;HAS BYTE PTR BEEN ADVANCED?
SOS FILPTR(F) ;YES, RETARD IT
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
TLO T1,(CLOSE)
IOR T1,T4 ;OR IN THE SPECIAL CLOSE BITS
XCT T1
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,CLRBUF) ;CLEAR JUNK FROM END OF BUFFER
SKIPG T2,FILCNT(F) ;GET BYTE COUNT
JRST $3 ;BUFFER MUST BE FULL (OR VIRGIN)
SKIPL T1,FILPTR(F) ;GET BYTE PTR
ADDI T1,1 ;BYPASS PARTIAL WORD
TXNE T1,<POINT ^O40,,35> ;[131] SIXBIT OR BINARY?
JRST $2 ;[123] YES
TXNE T1,<POINT ^O10,,35> ;[123] EBCDIC?
LSH T2,-2 ;[123] YES
TXNE T1,<POINT 4,,35> ;[123] ASCII?
IDIVI T2,5 ;GET WORDS LEFT IF ASCII
JUMPL T1,$2 ;JUMP IF ON A NEW WORD
SETZ T3, ;GET A NULL
SUBI T1,1 ;BACKUP BYTE PTR
$1% IDPB T3,T1 ;CLEAR OUT LAST PARTIAL WORD
TXNE T1,7B2 ;[123] SEE IF DONE
JRST $1 ;NOT YET
ADDI T1,1 ;ADVANCE TO NEXT WORD AGAIN
$2% JUMPE T2,$3 ;BUFFER IS FULL
SETZM (T1) ;CLEAR FIRST WORD
SOJLE T2,$3 ;ONLY ONE WORD TO CLEAR
ADDI T2,(T1) ;END OF BLT
HRL T1,T1
ADDI T1,1
BLT T1,(T2) ;CLEAR REST OF BUFFER
$3% RETURN
END;
SUBTTL FILE UTILITY ROUTINES -- Delete, Rename a File
BEGIN
PROCEDURE (PUSHJ P,DELFIL) ;DELETE FILE INDICATED BY F
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
HRRI T1,D.RIB
TLO T1,(RENAME)
XCT T1
JRST E$$TRE ;DELETE FAILED
RETURN
END;
D.RIB: EXP 0,0,0,0
BEGIN
PROCEDURE (PUSHJ P,RELFIL) ;RELEASE DEVICE INDICATED BY F
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
TLO T1,(RELEASE)
XCT T1
RETURN
END;
SUBTTL FILE UTILITY ROUTINES -- Open Output Temporary File
BEGIN
PROCEDURE (PUSHJ P,OPOFIL) ;OPEN TEMP FILE FOR OUTPUT
HRRZ T1,TCBIDX ;GET INDEX TO TEMP STRUCTURE
IDIV T1,STRNUM ;ROUND ROBIN
MOVE T1,STRNAM(T2)
MOVEM T1,T.BLK+X.OPN+.OPDEV ;[215] STORE .TMP DEVICE
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
HRRI T1,T.BLK+X.OPN ;[215] PTR TO OPEN ARGUMENTS
MOVEI T2,FILHDR(F)
HRLZM T2,T.BLK+X.OPN+.OPBUF ;[215] POINT TO BUFFER HEADERS
TLO T1,(OPEN) ;FORM OPEN CH,TMPOPN
MOVE T2,FILHDR(F) ;PRESERVE BUFFER RING HEADER
XCT T1
JRST [PUSHJ P,DELSTR ;[214] ERROR--DELETE THIS STRUCTURE
JRST $1] ;[214] AND TRY THE NEXT
TXO T2,BF.VBR ;BUFFER RING HAS NOT BEEN REFERENCED
MOVEM T2,FILHDR(F) ;RESTORE BUFFER RING HEADER
MOVEI T1,0
HRRM T1,FILPTR(F) ;CLEAR RH OF BYTE POINTER
SETZM FILCNT(F) ;CLEAR FILE COUNT
IFE FTCOBOL,<
PJRST DSKPRI ;SET DSK PRIORITY AND RETURN
>
IFN FTCOBOL,<
RETURN ;ALL DONE
>
END;
SUBTTL FILE UTILITY ROUTINES -- Open Input Temporary File
BEGIN
PROCEDURE (PUSHJ P,OPIFIL) ;OPEN TEMP FILE FOR INPUT
HRRZ T1,FILNAM(F) ;FILE NAME
ANDI T1,77
SUBI T1,'A' ;STRUCTURE INDEX
IDIV T1,STRNUM
MOVE T1,STRNAM(T2)
MOVEM T1,T.BLK+X.OPN+.OPDEV ;[215] SAVE .TMP STRUCTURE
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
HRRI T1,T.BLK+X.OPN ;[215] BUILD OPEN UUO
MOVEI T2,FILHDR(F)
HRRZM T2,T.BLK+X.OPN+.OPBUF ;[215] POINT TO BUFFER HEADER
TLO T1,(OPEN)
MOVE T2,FILHDR(F) ;PRESERVE BUFFER RING HEADER
XCT T1
JRST ERROFF ;OPEN FAILED
HRLI T2,(BF.VBR) ;BUFFER RING HAS NOT BEEN REFERENCED
MOVEM T2,FILHDR(F) ;RESTORE BUFFER RING HEADER
IFE FTCOBOL,<
PJRST DSKPRI ;SET DISK PRIORITY LEVEL
>
IFN FTCOBOL,<
RETURN ;ALL DONE
>
END;
SUBTTL FILE UTILITY ROUTINES -- Enter a File
BEGIN
PROCEDURE (PUSHJ P,ENTFIL)
PUSHJ P,GENNAM ;GENERATE FILE NAME
MOVEM T1,T.BLK+X.RIB+.RBNAM ;[215] INSERT FOR ENTER UUO
SETZM T.BLK+X.RIB+.RBPPN ;[115,214,215] ALWAYS USE DEFAULT PATH
HLLZS T.BLK+X.RIB+.RBEXT ;[215] CLEAR EXTENDED DATE
SETZM T.BLK+X.RIB+.RBPRV ;[215] ETC
SETZM T.BLK+X.RIB+.RBSIZ ;[215] ..
SETZM T.BLK+X.RIB+.RBVER ;[215] ..
SETZM T.BLK+X.RIB+.RBEST ;[215] ..
SETZM T.BLK+X.RIB+.RBALC ;
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
HRRI T1,T.BLK+X.RIB ;[215] BUILD ENTER UUO
AOS T2,NUMTMP ;COUNT NUMBER OF RUNS
HRLM T2,FILRUN(F) ;FOR COMPAR = TEST
AOS T2,NUMENT ;HOW MANY ENTERS DONE
CAMLE T2,MAXTMP ;WRAPPED ROUND YET?
JRST APPFIL ;YES, JUST APPEND TO PREVIOUS
TLO T1,(ENTER)
$1% XCT T1
JRST $2 ;ENTER ERROR
HRRZ T1,TCBIDX ;[214] MARK THAT WE USED THE NEXT STR
IDIV T1,STRNUM ;[214] ..
ADDI T2,1 ;[214] (STRUSE IS FIRST *NOT* USED)
CAMLE T2,STRUSE ;[214] BUT ONLY IF WE HAVN'T ALREADY
MOVEM T2,STRUSE ;[214] ..
RETURN
$2% PUSH P,T1 ;[214] SAVE ENTER UUO
PUSHJ P,DELSTR ;[214] DELETE THE STRUCTURE JUST TRIED
PUSHJ P,OPOFIL ;[214] OPEN THE NEXT STRUCTURE
POP P,T1 ;[214] RESTORE ENTER UUO
HLLZS T.BLK+X.RIB+.RBEXT ;[214,215] DON'T USE ERROR CODE FOR DATE
SETZM T.BLK+X.RIB+.RBPPN ;[214,215] FIX .RBPPN SINCE ENTER MUNCHED IT
JRST $1 ;[214] TRY THE ENTER AGAIN
END;
SUBTTL FILE UTILITY ROUTINES -- Delete a Temporary Structure
BEGIN
PROCEDURE (PUSHJ P,DELSTR) ;DELETE CURRENT STRUCTURE IN STRNAM
;DELSTR IS CALLED WHENEVER AN ATTEMPT TO INITIALIZE AN OUTPUT .TMP FILE FAILED.
;THIS CAN HAPPEN, FOR INSTANCE, IF THE USER SPECIFIES DSK:/TEMP, AND ONE OF THE
;STRUCTURES IN THE SEARCH LIST FOR DSK: IS WRITE-ENABLED, BUT HAS NO DIRECTORY
;FOR THE USER. WE DELETE THE STRUCTURE FROM STRNAM WITH POSSIBLY A WARNING
;MESSAGE, THEN RETURN. HOWEVER, IF WE DELETE THE LAST STRUCTURE IN STRNAM OR IF
;THE STRUCTURE HAS ALREADY BEEN SUCCESSFULLY USED (SO THAT OTHERS DEPEND ON THE
;ORDERING OF STRNAM), THEN WE DIE WITH A FATAL ERROR MESSAGE.
;
;ENTER WITH:
; T1 UUO THAT JUST FAILED
; RH(TCBIDX)/ CURRENT .TMP FILE INDEX
; STRNAM/ TABLE OF STRUCTURES
; STRNUM/ NUMBER OF ENTRIES IN STRNAM
; STRUSE/ NUMBER OF FIRST NOT-YET-USED ENTRY IN STRNAM
IF THIS STR HAS NOT YET BEEN REFERENCED
HRRZ T2,TCBIDX ;[214] GET CURRENT .TMP INDEX
PUSH P,STRNAM(T2) ;[214] SAVE STR NAME FOR MESSAGE
IDIV T2,STRNUM ;[214] GET INDEX INTO STRNAM
CAIGE T2,1 ;[214] PASSED OVER ENTIRE TABLE
CAMGE T3,STRUSE ;[214] OR OVER USED PART?
JRST $T
THEN DELETE THE STRUCTURE
MOVE T1,STRNUM ;GET NUMBER OF STRS
HRLZI T2,STRNAM+1(T3) ;[214] COPY END OF TABLE
HRRI T2,STRNAM(T3) ;[214] DOWN TO FRONT OF TABLE
CAIE T1,1(T2) ;[214] UNLESS NO END OF TABLE
BLT T2,STRNAM-2(T1) ;[214] ..
SOSLE STRNUM ;[214] NOW 1 LESS STR IN STRNAM
PJRST ERRATD ;[214] PRINT WARNING
JRST E$$NSW ;[214] NO TEMPORARY DEVICE IS WRITABLE
ELSE DIE (STRUCTURE IN USE SO CAN'T DELETE IT)
TXNN T1,<ENTER>-<OPEN> ;SEE WHICH UUO
JRST ERROFF ;OPEN FAILED, BUT IT WORKED BEFORE!
JRST E$$TEE ;ENTER FAILED THIS TIME
FI;
END;
SUBTTL FILE UTILITY ROUTINES -- Append to Temporary File
BEGIN
PROCEDURE (PUSHJ P,APPFIL) ;APPEND TO TEMPORARY FILE
TLO T1,(LOOKUP)
XCT T1 ;LOOKUP THE FILE
JRST E$$TLE ;LOOKUP ERROR
TLC T1,(<LOOKUP>^!<ENTER>)
XCT T1 ;APPEND-ENTER
JRST E$$TEE ;ENTER ERROR
TLC T1,(<ENTER>^!<USETI>) ;USETI
HRRI T1,-1 ;-1 TO GET LAST BLOCK
XCT T1
TLC T1,(<USETI>^!<OUT>)
HLLZ T1,T1
XCT T1 ;DUMMY OUTPUT TO SETUP BUFFERS
HLRO T1,FILRUN(F) ;FAKE SIXBIT WORD COUNT
IDPB T1,FILPTR(F) ;STORE IT
MOVE T1,[440000,,1] ;WE WANT PTR TO HAVE
ADDM T1,FILPTR(F) ;ADDRESS OF NEXT WORD IN RHS
SOS FILCNT(F)
RETURN
END;
BEGIN
PROCEDURE (PUSHJ P,LKPFIL) ;LOOKUP TEMPORARY FILE
HRRZ T1,FILNAM(F) ;GET FILE NAME
HRRM T1,T.BLK+X.RIB+.RBNAM ;[215] SET VARIABLE PART
SETZM T.BLK+X.RIB+.RBPPN ;[115,214,215] ALWAYS USE DEFAULT PATH
MOVEI T1,(F)
SUBI T1,FCBORG
; MOVEI T1,-FCBORG(F) ;FCBLEN TIMES CHANNEL #
IDIVI T1,FCBLEN
HLLZ T1,CHNMAP(T1) ;GET ACTUAL CHANNEL
HRRI T1,T.BLK+X.RIB ;[215] BUILD LOOKUP UUO
TLO T1,(LOOKUP)
XCT T1
JRST E$$TLE ;LOOKUP ERROR
RETURN
END;
SUBTTL FILE UTILITY ROUTINES -- Build a Buffer Ring
BEGIN
PROCEDURE (PUSHJ P,BUFRNG) ;CREATE BUFFER RING
;ENTER WITH:
; P1/ POINTER TO X. BLOCK FOR THIS FILE
; P2/ NUMBER OF BUFFERS TO BUILD IN RING
; F/ POINTER TO FCB FOR THIS FILE
; BUFPTR/ ADDRESS WHERE BUFFERS SHOULD START; UPDATED TO END OF
; NEW BUFFERS
;
;ON RETURN, STORES ORIGINAL BUFPTR IN FILBUF(F) SO BUFFER AREA MAY BE
;REUSED. IF THIS IS AN OUTPUT FILE (CHECKS WHICH SIDE FILE WAS OPENED
;ON), THEN SET BF.IBC, INHIBIT BUFFER CLEAR.
MOVE T1,BUFPTR ;START OF BUFFER AREA
MOVEM T1,FILBUF(F) ;STORE IT
ADDI T1,1 ;HEADER POINTS TO 2ND WORD
MOVE T2,X.OPN+.OPBUF(P1) ;[215] GET BUFFER HEADER WORD FROM INIT
TLNN T2,-1 ;OUTPUT OR INPUT?
TXOA T1,BF.VBR ;INPUT, JUST SET VIRGIN RING BIT
TXO T1,BF.VBR!BF.IBC ;OUTPUT, SET INHIBIT BUFFER CLEAR ALSO
MOVEM T1,FILHDR(F) ;STORE IN FCB
MOVEI T3,-1(P2) ;[215] # OF BUFFERS REQUIRED (NOT INCLUDING LAST)
HRRZ T4,X.DVSZ(P1) ;[215] GET BUFFER SIZE
HRLI T1,-2(T4) ;DATA COUNT
MOVE T2,T1 ;COPY IT
$1% ADDI T2,(T4) ;GET TO NEXT
MOVEM T2,(T1) ;DATA COUNT,,LINK TO NEXT
SETZM 1(T1) ;[131] ZERO BOOKKEEPING AND COUNT WORD
MOVE T1,T2 ;ADVANCE
SOJG T3,$1 ;FOR ALL BUFFERS
HRR T2,FILHDR(F) ;LAST ONE IS LINKED TO FIRST
MOVEM T2,(T1) ;TO COMPLETE THE RING
SETZM 1(T1) ;[210] ZERO LAST BOOKKEEPING AND COUNT WORD
ADDI T1,-1(T4) ;ALLOCATE SPACE FOR BUFFER
HRRZM T1,BUFPTR ;BETTER SAVE IT
RETURN
END;
SUBTTL FILE UTILITY ROUTINES -- Reformat Buffer Pool for Next Merge
BEGIN
PROCEDURE (PUSHJ P,RFMBFP) ;REFORMAT BUFFER POOL FOR MERGE PHASE
MOVE T1,ACTTMP ;NO. OF TMP FILES
IMULI T1,.TBS ;TIMES SIZE
IFE FTCOBOL,<
MOVE T2,F.OXBK ;[215] SIZE OF OUTPUT BUFFER
MOVE T2,X.DVSZ(T2) ;[215] ..
CAIGE T2,.TBS ;USE LARGER OF REAL OR TEMP
MOVEI T2,.TBS ; SINCE WE DON'T KNOW WHICH TO USE YET
ADDI T1,(T2) ;PLUS 1 OUTPUT BUFFER
>
IFN FTCOBOL,<
SKIPE NUMLFT ;IF WE NEED TO DO A MERGE PASS
ADDI T1,.TBS ;NEEDED FOR MERGE OUTPUT
>
IF ENOUGH ROOM
MOVE T2,.JBFF ;[141] SEE HOW MUCH IS FREE
SUB T2,RCBEND ;ABOVE INCORE RECORDS
IDIVI T2,(T1) ;GIVES NO. OF BUFFERS EACH
CAIGE T2,2 ;DOUBLE BUFFERING AT LEAST REQUIRED
JRST $T
THEN JUST RESET PARAMETERS
MOVEM T2,TBUFNO ;NO. FOR MERGE FILES
MOVE T1,.JBFF ;[141] GET END OF CORE
SUB T1,RCBEND ;FREE SPACE AGAIN
IMUL T2,ACTTMP ;TIMES NO. OF TEMP FILES
IMULI T2,.TBS ;TIMES SIZE OF EACH
SUBI T1,(T2) ;GET HOW MUCH IS LEFT FOR OUTPUT
IFE FTCOBOL,<
MOVE T2,F.OXBK ;[215] GET OUTPUT BUFFER SIZE
MOVE T2,X.DVSZ(T2) ;[215] ..
CAIGE T2,.TBS
MOVEI T2,.TBS
IDIVI T1,(T2) ;GET NO. OF OUTPUT BUFFERS
>
IFN FTCOBOL,<
IDIVI T1,.TBS
>
MOVEM T1,OBUFNO ;STORE
RETURN
ELSE EXPAND CORE
LSH T1,1 ;DOUBLE SIZE WE NEED
ADD T1,RCBEND ;PLUS START
IFN FTFORTRAN,<
MOVE T2,.JBFF ;GET CURRENT TOP
MOVEM T2,ADDR ;TELL FOROTS
SUBI T1,(T2) ;GET INCREASE
MOVEM T1,SIZE
PUSHJ P,GETADR ;GET INCREASE FROM FOROTS
JRST E$$CGC ;ERROR
>
IFN FTCOBOL,< ;[141]
HRRZ T2,.JBFF ;[141] CORE ALREADY EXPANDED?
CAME T2,USRSPC ;[141] ..
JRST E$$CGC ;[141] YES--LOSE
MOVEM T1,USRSPC ;[141] HERE TOO
>
HRRM T1,.JBFF ;[141] OK, UPDATE NEW END
IFE FTFORTRAN,<
CORE T1, ;EXPAND
JRST E$$NEC
>
IFN FTDEBUG&FTCOBOL,< ;[141]
PUSHJ P,E$$XPN ;[141] TELL USER
>
JRST $B ;TRY AGAIN
FI;
END;
SUBTTL CLEAN UP MEMORY FOR COBOL AND FORTRAN
BEGIN
PROCEDURE (PUSHJ P,RESET%)
MOVE P1,CORSTK ;GET PTR TO ALLOCATION STACK
$1% HLRZ T1,0(P1) ;GET LENGTH OF TOP ENTRY
PUSHJ P,FRESPC ;FREE IT
POP P1,T1 ;DROP THE STACK DOWN
HRRZ T1,P1 ;SEE IF EMPTY YET
CAIE T1,CSTACK-1 ;IS IT?
JRST $1 ;NO, KEEP GOING
CAMN P1,CORSTK ;FRESPC SHOULD MAKE THIS COME OUT RIGHT
RETURN
$ERROR (%,FCR,<Core management error at RESET%>,+)
$CRLF
RETURN
END;
SUBTTL ERROR MESSAGES
;FILE LOOKUP/RENAME/ENTER ERRORS
;ENTER WITH
; T1 = UUO JUST DONE (RHS POINTS TO DATA BLOCK)
; T2 = DEVCHR UUO (NOT SETUP IF TEMP FILE)
IFE FTCOBOL,<
E$$FEE: TXNN T2,DV.DSK ;IF NOT DSK
SUBI T1,2 ;BACKUP AGAIN
TXNN T2,DV.DTA ;DTA MIGHT BE SPECIAL
JRST E$$TEE ;NOT
HRRZ T2,.RBEXT(T1) ;[215] GET ERROR CODE
CAIE T2,2 ;DIRECTORY FULL?
JRST E$$TEE ;NO
MOVEI T1,@T1 ;GET THE ACTUAL ADDRESS
PUSH P,T1 ;SAVE DATA PTR
PUSHJ P,E$$LRE
$MORE (TEXT,<ENTER error >)
MOVEI T1,[ASCIZ \(2) directory full \]
JRST LRETXT ;JOIN COMMON CODE
>
E$$TEE: MOVEI T1,@T1 ;GET THE ACTUAL ADDRESS
PUSH P,T1 ;SAVE DATA PTR
PUSHJ P,E$$LRE
$MORE (TEXT,<ENTER error >)
MOVE T1,(P) ;GET PTR BACK
HRRZ T2,.RBEXT(T1) ;[215] GET ERROR CODE
JUMPN T2,ERRLRE ;COMMON MESSAGES
MOVEI T1,[ASCIZ \(0) illegal file name \]
JRST LRETXT ;SPECIAL CASE
IFE FTCOBOL,<
E$$FLE: TXNN T2,DV.DSK ;IF NOT DSK
SUBI T1,2 ;BACKUP AGAIN
>
E$$TLE: MOVEI T1,@T1 ;GET THE ACTUAL ADDRESS
PUSH P,T1 ;SAVE DATA PTR
PUSHJ P,E$$LRE
$MORE (TEXT,<LOOKUP error >)
JRST ERRLRE ;COMMON CODE
IFE FTCOBOL,<
E$$FRE: TXNN T2,DV.DSK ;IF NOT DSK
SUBI T1,2 ;BACKUP AGAIN
>
E$$TRE: MOVEI T1,@T1 ;GET THE ACTUAL ADDRESS
PUSH P,T1 ;SAVE DATA PTR
PUSHJ P,E$$LRE
$MORE (TEXT,<RENAME error >)
JRST ERRLRE ;COMMON CODE
IFE FTCOBOL,<
E$$TDE: MOVEI T1,@T1 ;GET THE ACTUAL ADDRESS
PUSH P,T1 ;SAVE DATA PTR
PUSHJ P,E$$LRE
$MORE (TEXT,<DELETE error >)
; JRST ERRLRE ;COMMON CODE
>
ERRLRE: MOVE T1,(P) ;GET RIB PTR
HRRZ T1,.RBEXT(T1) ;[215] GET ERROR CODE
CAILE T1,LRELEN ;VALID CODE?
JRST LREUNK ;UNKNOWN ERROR CODE
MOVE T1,LRETAB(T1) ;GET TEXT PTR
LRETXT: $MORE (TEXT,T1)
POP P,T2 ;GET RIB PTR
$MORE (FILESPEC,T2)
$DIE
LREUNK: PUSH P,T1 ;NO, SAVE IT
$CHAR "(" ;OUTPUT PAREN
POP P,T1
$MORE (OCTAL,T1)
$MORE (TEXT,<) unknown cause >)
JRST LRETXT ;JOIN COMMON CODE
E$$LRE: $ERROR (?,LRE,,+)
POPJ P,
LRETAB: [ASCIZ \(0) file was not found \]
[ASCIZ \(1) no directory for project-programmer number \]
[ASCIZ \(2) protection failure \]
[ASCIZ \(3) file was being modified \]
[ASCIZ \(4) rename file name already exists \]
[ASCIZ \(5)\]; illegal sequence of UUOs \]
[ASCIZ \(6) bad UFD or bad RIB \]
[ASCIZ \(7)\]; not a SAV file \]
[ASCIZ \(10)\]; not enough core \]
[ASCIZ \(11)\]; device not available \]
[ASCIZ \(12)\]; no such device \]
[ASCIZ \(13)\]; not two reloc reg. capability \]
[ASCIZ \(14) no room or quota exceeded \]
[ASCIZ \(15) write lock error \]
[ASCIZ \(16) not enough monitor table space \]
[ASCIZ \(17) partial allocation only \]
[ASCIZ \(20) block not free on allocation \]
[ASCIZ \(21)\]; can't supersede (enter) an existing directory \]
[ASCIZ \(22)\]; can't delete (rename) a non-empty directory \]
[ASCIZ \(23) SFD not found \]
[ASCIZ \(24) search list empty \]
[ASCIZ \(25) SFD nested too deeply \]
[ASCIZ \(26) no-create on for specified SFD path \]
[ASCIZ \(27)\]; segment not on swap space \]
[ASCIZ \(30) can't update file \]
[ASCIZ \(31)\]; low segment overlaps high segment \]
LRELEN==.-LRETAB
ERROFF: PUSH P,T1
$ERROR (?,OFF,<OPEN failed for >,+)
POP P,T1 ;RESTORE
MOVEI T2,X.RIB(T1) ;FILE SPEC
$MORE (FILESPEC,T2)
$DIE
E$$MGF: $ERROR (?,MGF,<Monitor GETTAB failed >,+)
MOVE T1,@-3(P4)
$MORE (OCTAL,T1)
$DIE
E$$MUF: $ERROR (?,MUF,<Monitor UUO failed >,+)
MOVE T1,-2(P4)
$MORE (OCTAL,T1)
$DIE
E$$SWP: $ERROR (?,SWP,<Temporary structure >,+)
$MORE (SIXBIT,DSKARG)
$MORE (TEXT,<: is write-locked.>)
$DIE
E$$NSW: $ERROR (?,NSW,<No temporary device is writable.>)
ERRATD: SKIPE STRDEF ;[214] IF JUST GENERIC DSK: DON'T BOTHER
JRST ATDONE ;[214] THE USER WITH THE MESSAGE
$ERROR (%,ATD,<Attempt to use temporary device >,+)
MOVE T1,(P) ;[214] GET BACK STR NAME
$MORE (SIXBIT,T1) ;[214] TYPE IT
$MORE (TEXT,<: failed--ignoring it.>)
$CRLF ;[214] FINISH LINE
ATDONE: POP P,(P) ;[214] CLEAR STACK
POPJ P, ;[214] RETURN
E$$FEA: $ERROR (?,FEA,<Formal arg exceeds actual arg count>)
IFN FTCOBOL!FTFORTRAN,< ;[141]
E$$CGC: $ERROR (?,CGC,<Cannot get contiguous core on second expansion.>)
>