Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/iomod.bli
There are 10 other files named iomod.bli in the archive. Click here to see a list.
!SOFT:<EDT.50>IOMOD.BLI 17-Jul-87 ,Edit by PERKINS
!EDIT 50, When reading in the journal file only strip off one set of <CR><LF>'s
!SOFT:<EDT.46>IOMOD.BLI 01-Apr-87 ,Edit by PERKINS
!EDIT 46, Set the terminal width and length to zero so that the wrap around
! works correctly when displaying the help keypad on VT100's or later.
!SOFT:<EDT.45>IOMOD.BLI 01-Apr-87 ,Edit by PERKINS
!EDIT 45, Remove the part of edit 36 that changed TTBIN to TTATE. It seems
! that TOPS-20 V6.1 fixed the problem with 7 bit terminals. But with
! the TTBIN changed to TTATE 7 bit terminals don't work with V6.1.
! On KS's running V4.1, 7 bit terminals don't seem to be affected
! with or with out the patch. Also with edit 36, PUSHing and POPing
! back into EDT screws up the wrap around.
!GREEN:<ZBRAD>IOMOD.BLI.3 24-Feb-86 15:57:33, Edit by MERRILL
!EDIT 42, Add VT200 type to type table in IOMOD.
!GREEN:<ZBRAD.20808>IOMOD.BLI.31 20-Nov-85 13:32:32, Edit by MERRILL
!Edit 36 Change TTBIN to TTATE, also eat the LF of CRLF pair
%TITLE 'IOMOD - I/O for TOPS20'
MODULE IOMOD (
IDENT = '1-012'
) =
BEGIN
!
! COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1980, 1988 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 AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
!
! ABSTRACT:
!
! This module contains all the I/O interface code for TOPS20
! systems.
!
! ENVIRONMENT: TOPS20 only
!
! AUTHOR: Graham Beech, CREATION DATE: 10-DEC-1982
!
! MODIFIED BY:
!
! 1-003 - Fix terminal mode confusion after HELP in change mode. CJG 12-Jul-1983
! 1-004 - Add code for handling ^T traps. CJG 20-Oct-1983
! 1-005 - Change EDT$$FATAL_IOERR so it returns a status to the superior fork.
! The default is journal file close failure. CJG 8-Nov-1983
! 1-006 - Move the interrupt routines to T20SYS. CJG 24-Nov-1983
! 1-007 - Fix up WF_OPN so that multiple EDT's can run in the same directory. CJG 8-Dec-1983
! 1-008 - Stop EDT hanging on to unused JFNs when a rename fails. CJG 9-Dec-1983
! 1-009 - Add some control-C tests. CJG 5-Jan-1984
! 1-010 - Modify ASSERT macro to include error code. CJG 30-Jan-1984
! 1-011 - Fix problem with loss of last line of file if no <LF>. GB 3-May-1984
! 1-012 - Handle ccontrol-c in RD_CMDLN correctly. GB 29-Jun-1984
! 1-013 - Release JFN obtained in PAR_FNAME so rename will get a new one. GB 9-Nov-1984
!--
%SBTTL 'Declarations'
!
! TABLE OF CONTENTS:
!
REQUIRE 'EDTSRC:TRAROUNAM';
REQUIRE 'EDTSRC:EDTREQ';
REQUIRE 'EDTSYS:JSYS';
FORWARD ROUTINE
ERROR_PRNT : NOVALUE, ! Print a system error
EDT$$FATAL_IOERR : NOVALUE, ! Print a fatal error message
EDT$$OPN_INOUT, ! Open a file for I/O
EDT$$OPN_IFIDEF, ! Open a file for input
EDT$$OPN_OFIDEF, ! Open a file for output
EDT$$CLS_FI : NOVALUE, ! Close a file
EDT$$PAR_FNAME, ! Parse a file name
EDT$$RD_IFI, ! Read from a file
EDT$$WR_OFI, ! Write to a file
EDT$$REN_FI, ! Rename the output file
EDT$$FLUSH_OBUF, ! Flush the output file buffer
GET_JFN, ! Get a JFN for a file
EDT$$TERM_RCC : NOVALUE, ! Restore from Control-C
EDT$$TI_OPN, ! Open the terminal
EDT$$TI_RES, ! Reset the terminal
EDT$$RD_CMDLN, ! Read a command line
EDT$$TI_ENTERCHM : NOVALUE, ! Enter change mode
EDT$$TI_LEAVECHM : NOVALUE, ! Leave change mode
EDT$$TI_WRLN : NOVALUE, ! Write a line to the terminal
EDT$$TI_WRSTR : NOVALUE, ! Write a string to the terminal
EDT$$TI_GETCH : NOVALUE, ! Get a character
EDT$$TI_RDTYAHED, ! Read the typeahead
EDT$$TI_RDSTR : NOVALUE, ! Read a string
EDT$$WF_OPN, ! Open the work file
EDT$$WF_CLS, ! Close the work file
EDT$$WF_RD : NOVALUE, ! Write to the work file
EDT$$WF_WR : NOVALUE, ! Read from the work file
FIND_WINDOW, ! Find a window
WRITE_WINDOW : NOVALUE, ! Write a window
REPLACE_WINDOW, ! Replace a window
GET_WF : NOVALUE; ! Get a bucket
! EQUATED SYMBOLS:
!
LITERAL
WINDOW_SIZE = 1, ! The number of buckets in a cache slot
! IE. a window is one page.
NUM_WINDOW = 40, ! The number of windows to cache
ACCESS_BITS = PM_RD OR PM_WR; ! Read and write access to work file cache
LITERAL
TTY_MODE = TT_WKF OR ! Terminal mode
TT_WKN OR
TT_WKP OR
TT_WKA OR
FLD ($TTBIN, TT_DAM); ! [45] Terminal data mode
!
! OWN STORAGE:
!
OWN
CACHE_ADDR : VECTOR [NUM_WINDOW], ! The start and end addresses of the cache
CACHE_TIMER , ! Counter incremented for each reference
CACHE_WINDOW : VECTOR [NUM_WINDOW], ! The number of the window in a slot
CACHE_REF : VECTOR [NUM_WINDOW], ! The timer at the last reference to
CACHE_DIRTY : VECTOR [NUM_WINDOW], ! The window dirty flag.
REC_BUFFER : VECTOR [CH$ALLOCATION (255, BYTE_SIZE)], ! Input buffer
CUR_MODE,
OLD_MODE,
OLD_CCOC1, ! Old CCOC words
OLD_CCOC2,
OLD_WIDTH, ! Old terminal width
CACHE_FULL,
WF_JFN;
BIND
CRLF = UPLIT(%CHAR(13, 10));
!
! EXTERNAL REFERENCES:
!
EXTERNAL ROUTINE
EDT$$SYS_EXI,
EDT$$FMT_LIT,
EDT$$OUT_FMTBUF,
EDT$$FMT_STR,
EDT$$FMT_CRLF, ! Terminate a line
EDT$$FMT_MSG,
EDT$$OUT_ERRMSG,
EDT$$SC_RESET,
EDT$$MSG_TOSTR,
EDT$$GET_FILESPEC : NOVALUE, ! Get filespec components
EDT$$INT_CONTROL : NOVALUE, ! Enable/disable interrupts
EDT$$ALO_PAGE,
EDT$$DEA_PAGE : NOVALUE;
EXTERNAL
EDIT_MOD,
TT_OPEN,
TI_TYP,
TI_SCROLL,
TI_EDIT,
TI_DUMB,
TI_RESET,
TI_PLEN,
TI_WID,
EIGHT_BIT,
ENB_AUTRPT,
TEMP_BUFFER,
FMT_BUF,
FMT_CUR,
IOFI_NFND,
CC,
CC_WAIT,
CR_FLAG, ! [36]
GETJFN_BLOCK : VECTOR,
RDAHED,
RDAHEDBF;
MESSAGES ((INSMEM, IOERRWRK, WORFILCLO, JOUFILCLO));
%SBTTL 'ERROR_PRNT - Print a system error message'
ROUTINE ERROR_PRNT (
STS
) : NOVALUE =
BEGIN
!+
! Output system error string to terminal
!-
.STS <18, 18, 0> = $FHSLF;
_ERSTR ($PRIIN, ..STS, 0);
END;
%SBTTL 'EDT$$FATAL_IOERR - put out an I/O error message and abort'
GLOBAL ROUTINE EDT$$FATAL_IOERR ( ! Put out an I/O error message and abort
EDT_ERR_CODE, ! EDT error code
SYS_ERR_CODE ! System error code or 0
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Put out an I/O error message and abort.
!
! FORMAL PARAMETERS:
!
! EDT_ERR_CODE EDT error code.
! SYS_ERR_CODE System error code or 0 if none or -1 for the latest error
!
! IMPLICIT INPUTS:
!
! EDIT_MOD
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Calls EDT$$SC_RESET and EDT$$IO_ERRMSG. EDT$$SYS_EXI is called to
! return a status to the superior fork. Never returns to its caller.
!--
BEGIN
!+
! Reset any screen modes.
!-
IF (.EDIT_MOD EQL CHANGE_MODE) THEN EDT$$SC_RESET ();
IF (.EDT_ERR_CODE NEQ 0)
THEN
BEGIN
EDT$$MSG_TOSTR (.EDT_ERR_CODE);
EDT$$FMT_CRLF ();
END
ELSE
EDT_ERR_CODE = EDT$_JOUFILCLO;
IF (.SYS_ERR_CODE NEQ 0) THEN
_ERSTR ($PRIOU, FLD ($FHSLF, FLD_LHS) + (.SYS_ERR_CODE AND FLD_RHS), 0);
EDT$$SYS_EXI (.EDT_ERR_CODE);
END;
%SBTTL 'EDT$$OPN_INOUT - Open a file for input and output by name.'
GLOBAL ROUTINE EDT$$OPN_INOUT ( ! Open a file for input by name
FILE_DESC, ! descriptor of filename
OPN_STS ! status
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine opens a file for input and output using a name string
! It is used only for the journal file.
!
! FORMAL PARAMETERS:
!
! FILE_DESC The address of a descriptor containing the filename
!
! OPN_STS The status returned
!
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! If successful, the JFN; if the open failed, 0.
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [];
LOCAL
JFN;
LITERAL
OPN_BITS = %O'70000000000' OR OF_RD OR OF_WR;
!+
!Get a JFN
!-
JFN = GET_JFN (GJ_OLD, .FILE_DESC);
IF (.JFN GTR $ERBAS) THEN
BEGIN
.OPN_STS = .JFN;
RETURN(0);
END;
!+
!Open the file for read.
!-
IF NOT (_OPENF(.JFN, OPN_BITS;.OPN_STS)) THEN RETURN(0);
EDT$$GET_FILESPEC (.JFN, .FILE_DESC);
FILE_DESC [DSC$W_STATUS] = EDT$K_FILE_OPEN;
RETURN(.JFN);
END;
%SBTTL 'EDT$$OPN_IFIDEF - Open a file for input'
GLOBAL ROUTINE EDT$$OPN_IFIDEF (
FILE_DESC,
OPN_STS
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Open a file for input given the descriptor.
!
! FORMAL PARAMETERS:
!
! FILE_DESC Descriptor of file to open
! OPN_STS Status of open
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! 0 = Failed or JFN of file
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [];
LOCAL
JFN;
LITERAL
OPN_BITS = %O'70000000000' OR OF_RD;
!+
!Get a JFN
!-
JFN = GET_JFN (GJ_OLD, .FILE_DESC);
IF (.JFN GTR $ERBAS) THEN
BEGIN
IF (.JFN EQL GJFX24) THEN IOFI_NFND = 1;
.OPN_STS = .JFN;
RETURN(0);
END;
!+
!Open the file for read.
!-
IF NOT (_OPENF(.JFN, OPN_BITS; .OPN_STS)) THEN
BEGIN
IF (..OPN_STS EQL OPNX2) THEN IOFI_NFND = 1;
_RLJFN(.JFN);
RETURN(0);
END;
EDT$$GET_FILESPEC (.JFN, .FILE_DESC);
FILE_DESC [DSC$W_STATUS] = EDT$K_FILE_OPEN;
RETURN(.JFN);
END;
%SBTTL 'EDT$$OPN_OFIDEF - Open a file for output'
GLOBAL ROUTINE EDT$$OPN_OFIDEF (
FILE_DESC,
OPN_STS
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Open a file for write given the file descriptor.
!
! FORMAL PARAMETERS:
!
! FILE_DESC Descriptor of file to open
! OPN_STS Status of open
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! 0 If failed or JFN of file
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [];
LOCAL
JFN;
LITERAL
OPN_BITS = %O'70000000000' OR OF_WR;
!+
!Get a JFN
!-
JFN = GET_JFN (GJ_FOU, .FILE_DESC);
IF (.JFN GTR $ERBAS) THEN
BEGIN
.OPN_STS = .JFN;
RETURN(0);
END;
!+
!Open a new file for write.
!-
IF NOT (_OPENF (.JFN, OPN_BITS; .OPN_STS)) THEN RETURN (0);
EDT$$GET_FILESPEC (.JFN, .FILE_DESC);
FILE_DESC [DSC$W_STATUS] = EDT$K_FILE_OPEN;
.OPN_STS = 1;
RETURN (.JFN);
END;
%SBTTL 'EDT$$CLS_FI - Close a file'
GLOBAL ROUTINE EDT$$CLS_FI (
FILE_DESC, ! Descriptor of file to close
DEL, ! 1 = delete file, 2 = delete journal file
STS ! Status from close
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Close a file and, if the delete flag is on, delete and mark the
! file for expunge by the system.
!
! FORMAL PARAMETERS:
!
! FILE_DESC The address of the file descriptor block
!
! DEL 0 = Don't delete, 1 or 2 = delete the file
!
! STS Status return
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE - Any error codes are returned in STS
!
! SIDE EFFECTS:
!
! File is closed and may be deleted.
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [];
LOCAL
JFN;
JFN = .FILE_DESC [DSC$W_JFN];
IF (.DEL EQL 0)
THEN
!+
! Close the file normally
!-
BEGIN
IF (_CLOSF (.JFN; .STS)) THEN .STS = 1;
END
ELSE
!+
! Close and delete the file. Mark it for expunge later.
!-
BEGIN
IF (_CLOSF (.JFN + CO_NRJ + CZ_ABT; .STS)) THEN .STS = 1;
IF (_DELF (.JFN + DF_EXP; .STS)) THEN .STS = 1;
END;
FILE_DESC [DSC$W_STATUS] = EDT$K_FILE_CLOSED;
FILE_DESC [DSC$W_JFN] = 0;
END;
%SBTTL 'EDT$$PAR_FNAME - parse a file name'
GLOBAL ROUTINE EDT$$PAR_FNAME ( ! Parse a file name
FILE_DESC, ! descriptor of filename
DSK, ! set if file can be renamed
STS ! status
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine parses a file name to determine if valid before
! later attempting an open.
!
! FORMAL PARAMETERS:
!
! FILE_DESC The address of a descriptor containing the filename
!
! DSK 1 flags renameable file (disk or DECtape), 0 otherwise
!
! STS The status returned
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! If successful, 1; if failed, 0.
!
! SIDE EFFECTS:
!
! Passes back a '1' in DSK if this file can be renamed
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [];
LOCAL
DEV_CHAR,
DUM,
JFN;
!+
!Get a JFN
!-
JFN = GET_JFN (GJ_FOU + GJ_OFG, .FILE_DESC);
IF (.JFN GTR $ERBAS) THEN
BEGIN
.STS = .JFN;
RETURN (0);
END;
!+
! See if device is disk
!-
_DVCHR (.JFN <0,18>; DUM, DEV_CHAR);
IF (.DEV_CHAR AND DV_TYP) EQL $DVDSK THEN .DSK = 1;
!+
! Release the JFN just obtained so we get a new one when file
! is renamed.(Fixes strange problem with superceded JFNs)
!-
_RLJFN (.JFN);
FILE_DESC [DSC$W_JFN] = 0;
.STS = 1;
RETURN (1);
END;
%SBTTL 'EDT$$RD_IFI - Read a record from a file open for input'
GLOBAL ROUTINE EDT$$RD_IFI (
FILE_DESC,
REC_DESC,
INP_STS
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Read a record from the file specified by the descriptor.
! The <CR><LF> are removed from the end of the line and the length
! is set in the record descriptor.
!
! FORMAL PARAMETERS:
!
! FILE_DESC Descriptor of file open for input
! REC_DESC Descriptor of record read from file
! INP_STS Input status
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! Failure - 0
! Success - 1
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
LOCAL
JFN,
REC_LENGTH,
TEMP,
I,
C,
DUM;
MAP
FILE_DESC : REF BLOCK [],
REC_DESC : REF BLOCK [];
!+
! Read a record from the file
!-
JFN = .FILE_DESC [DSC$W_JFN];
IF (NOT _SIN (.JFN, CH$PTR (REC_BUFFER,, BYTE_SIZE), 255, 10;DUM, DUM, REC_LENGTH)) THEN
!+
! The read failed, find out why, ignore EOF if we read something.
!-
BEGIN
_GTSTS(.JFN;.INP_STS);
IF (..INP_STS AND GS_EOF) EQL 0 THEN RETURN (0);
IF (.REC_LENGTH EQL 255) THEN RETURN 0;
END;
!+
! Get the line length
!-
REC_LENGTH = 255 - .REC_LENGTH;
DECR I FROM .REC_LENGTH - 1 TO 0 DO
BEGIN
!+
! Remove the <CR> and <LF> which may be on the end of the line and fix the length
!-
C = CH$RCHAR (CH$PTR (REC_BUFFER, .I, BYTE_SIZE));
IF (.C NEQ ASC_K_LF) AND (.C NEQ ASC_K_CR)
THEN
EXITLOOP
ELSE
BEGIN ![50]
REC_LENGTH = .REC_LENGTH - 1;
IF (.C EQL ASC_K_CR) THEN EXITLOOP ![50] if it's the <CR> then don't
END ![50] delete any more characters
END;
!+
! Make a string descriptor for the record just read.
!-
STRING_DESC (TEMP, REC_LENGTH, REC_BUFFER);
.REC_DESC = .TEMP;
RETURN (1);
END;
%SBTTL 'EDT$$WR_OFI - Write a record to an output file'
GLOBAL ROUTINE EDT$$WR_OFI (
FILE_DESC,
REC_DESC,
OUT_STS
) =
!++
!Functional description
!
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [],
REC_DESC : REF BLOCK [];
LOCAL
JFN,
STATUS;
JFN = .FILE_DESC [DSC$W_JFN];
!+
!Write the record to the file
!-
IF (.REC_DESC [DSC$W_LENGTH] EQL 0) THEN
STATUS = _SOUT (.JFN, CH$PTR (CRLF), -2)
ELSE
STATUS = (_SOUT (.JFN, CH$PTR (.REC_DESC [DSC$A_POINTER],, BYTE_SIZE),
-.REC_DESC [DSC$W_LENGTH])) AND
(_SOUT (.JFN, CH$PTR (CRLF), -2));
IF (.STATUS) THEN
RETURN (1)
ELSE
BEGIN
_GTSTS(.JFN; .OUT_STS);
RETURN (0);
END;
END;
%SBTTL 'EDT$$REN_FI - rename a temporary file to a permanent file'
GLOBAL ROUTINE EDT$$REN_FI ( ! Rename a file
OLD_FILE_DESC, ! descriptor of old filename
NEW_FILE_DESC, ! descriptor of new filename
STS ! status word
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine renames a temporary file to a permanent output file
! name string.
!
! FORMAL PARAMETERS:
!
! OLD_FILE_DESC The address of a descriptor containing an old filename
!
! NEW_FILE_DESC The address of a descriptor containing a new filename
!
! STS The status returned
!
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! If the file is renamed successfully, 1; otherwise, 0.
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
LOCAL
JFN1,
JFN2;
MAP
OLD_FILE_DESC : REF BLOCK [],
NEW_FILE_DESC : REF BLOCK [];
!+
!Get a JFN for the new filespec.
!-
JFN2 = GET_JFN (GJ_FOU, .NEW_FILE_DESC);
IF (.JFN2 GTR $ERBAS) THEN
BEGIN
.STS = .JFN2;
RETURN (0);
END;
! IF CH$NEQ (3, CH$PTR (UPLIT ('TMP')), 3, .OLD_FILE_DESC [DSC$A_FEXTN], 0)
! THEN
BEGIN
!+
! Get a JFN for the old filespec.
!-
JFN1 = GET_JFN (GJ_OLD, .OLD_FILE_DESC);
IF (.JFN1 GTR $ERBAS) THEN
BEGIN
.STS = .JFN1;
RETURN (0);
END;
!+
! Do the rename.
!-
.STS = 1;
IF NOT _RNAMF (.JFN1, .JFN2; .STS) THEN
BEGIN
_RLJFN (.JFN1);
_RLJFN (.JFN2);
RETURN (0);
END;
END;
!+
! Get resultant filespec in place of .TMP file
!-
EDT$$GET_FILESPEC (.JFN2, .OLD_FILE_DESC);
NEW_FILE_DESC [DSC$W_STATUS] = EDT$K_FILE_CLOSED;
NEW_FILE_DESC [DSC$W_JFN] = 0;
_RLJFN (.JFN2);
RETURN (1);
END;
%SBTTL 'EDT$$FLUSH_OBUF - flush output buffers'
GLOBAL ROUTINE EDT$$FLUSH_OBUF ( ! Flush output buffers
FILE_DESC ! Descriptor of the file
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine flushes the buffers for a file which is open for output.
!
! FORMAL PARAMETERS:
!
! FILE_DESC Descriptor of the file whose buffers
! are to be flushed.
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP
FILE_DESC : REF BLOCK [];
LOCAL
JFN;
JFN = .FILE_DESC [DSC$W_JFN];
IF (NOT _CLOSF (CO_NRJ + .JFN)) THEN RETURN (0);
IF (NOT _OPENF (.JFN, FLD(7, OF_BSZ) + OF_APP)) THEN RETURN (0);
RETURN (1);
END;
%SBTTL 'GET_JFN - get a JFN for the specified file'
ROUTINE GET_JFN (
FLAGS, ! GTJFN flags
DESC ! Adrs of descriptor to use
) =
BEGIN
!+
! FUNCTIONAL DESCRIPTION:
!
! This routine checks for an existing JFN on a file descriptor. If there isn't
! one, then it sets up the GTJFN block and gets a JFN based on the flags and
! and the default items in the descriptor.
!
! FORMAL PARAMETERS:
!
! FLAGS Flags to be used in GTJFN
! DESC Address of descriptor containing defaults or spec
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! JFN of file found (or error code)
!
! SIDE EFFECTS:
!
! NONE
!
!--
MAP
DESC : REF BLOCK [];
LOCAL
PTR,
JFN;
IF (.DESC [DSC$W_JFN] NEQ 0) THEN RETURN (.DESC [DSC$W_JFN]);
GETJFN_BLOCK [$GJGEN] = .FLAGS;
GETJFN_BLOCK [$GJSRC] = FLD ($NULIO, FLD_LHS) + FLD ($NULIO, FLD_RHS);
GETJFN_BLOCK [$GJDEV] = .DESC [DSC$A_DEVICE];
GETJFN_BLOCK [$GJDIR] = .DESC [DSC$A_DIRECT];
GETJFN_BLOCK [$GJNAM] = .DESC [DSC$A_FNAME];
GETJFN_BLOCK [$GJEXT] = .DESC [DSC$A_FEXTN];
IF (.DESC [DSC$L_DESC] EQL 0)
THEN
PTR = 0
ELSE
PTR = CH$PTR (.DESC [DSC$A_POINTER],, BYTE_SIZE);
_GTJFN (GETJFN_BLOCK, .PTR; JFN);
RETURN (.JFN AND %O'777777');
END;
%SBTTL 'EDT$$TERM_RCC - Restore from control C'
GLOBAL ROUTINE EDT$$TERM_RCC ! Restore from control C
: NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Do any system dependant restoration of the terminal that is
! needed after a control-C is processed.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
RETURN;
END;
%SBTTL 'EDT$$TI_OPN - Open terminal for output'
GLOBAL ROUTINE EDT$$TI_OPN !Open terminal
=
!++
! FUNCTIONAL DESCRIPTION:
!
! Open the terminal for I/O and set the various terminal modes.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! 1 Success
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
LITERAL
$TTV52 = %O'17',
$TT100 = %O'20',
$TT125 = %O'43',
$TTK10 = %O'44',
$TT102 = %O'45',
$TT131 = %O'47',
$TT200 = %O'50';
LOCAL
TT_TYPE,
DUM1,
DUM2;
!+
! Only execute this code once
!-
IF .TT_OPEN THEN RETURN (1);
TT_OPEN = 1;
!+
!Get terminal width & type.
!+
_MTOPR($PRIIN, $MORLW; DUM1, DUM1, TI_WID);
OLD_WIDTH = .TI_WID;
IF (.TI_WID EQL 0) THEN TI_WID = 80;
!+
! Set not eightbit and page length
!-
EIGHT_BIT = 0;
TI_PLEN = 24;
_GTTYP($PRIIN; TT_TYPE);
SELECTONE .TT_TYPE OF
SET
[$TTV52] :
BEGIN
TI_TYP = TERM_VT52;
TI_SCROLL = 0;
ENB_AUTRPT = 0;
TI_EDIT = 0;
TI_DUMB = 0;
END;
[$TT100] :
BEGIN
TI_TYP = TERM_VT100;
TI_SCROLL = 1;
ENB_AUTRPT = 1;
TI_EDIT = 0;
TI_DUMB = 0;
END;
[$TT102] :
BEGIN
TI_TYP = TERM_VT100;
TI_SCROLL = 1;
ENB_AUTRPT = 1;
TI_EDIT = 0;
TI_DUMB = 0;
END;
[$TT125] :
BEGIN
TI_TYP = TERM_VT100;
TI_SCROLL = 1;
ENB_AUTRPT = 1;
TI_EDIT = 0;
TI_DUMB = 0;
END;
[$TT131] :
BEGIN
TI_TYP = TERM_VT100;
TI_SCROLL = 1;
ENB_AUTRPT = 1;
TI_EDIT = 0;
TI_DUMB = 0;
END;
[$TT200] : ![42] Add VT200 type
BEGIN
TI_TYP = TERM_VT100;
TI_SCROLL = 1;
ENB_AUTRPT = 1;
EIGHT_BIT = 1;
TI_EDIT = 1;
TI_DUMB = 0;
END;
[$TTK10] :
BEGIN
TI_TYP = TERM_VT100;
TI_SCROLL = 1;
ENB_AUTRPT = 1;
TI_EDIT = 0;
TI_DUMB = 0;
END;
[OTHERWISE] :
BEGIN
TI_TYP = TERM_HCPY;
TI_SCROLL = 0;
ENB_AUTRPT = 0;
TI_EDIT = 0;
TI_DUMB = 0;
END;
TES;
!+
! Trap Control c's
!-
EDT$$INT_CONTROL (1);
!+
! Save the terminal mode
!-
_RFMOD ($PRIOU; OLD_MODE);
!+
! Allow <ESC> to pass on output
!-
_RFCOC ($PRIOU; DUM1, DUM2);
_SFCOC ($PRIOU, .DUM1, ((.DUM2 AND NOT %O'600000') OR %O'400000'));
RETURN (1);
END;
%SBTTL 'EDT$$TI_RES - Restore the terminal'
GLOBAL ROUTINE EDT$$TI_RES ! Restore the terminal
=
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine restores the terminal characteristics to what they
! were when EDT started.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! 0 = Failed
! 1 = Success
!
! SIDE EFFECTS:
!
! Changes the terminal characteristics
!
!--
BEGIN
WHILE 1 DO
IF (_SOBE ($PRIOU)) THEN
BEGIN
!
! Reset terminal mode, width etc.
!
_SFMOD ($PRIOU, .OLD_MODE);
_SFCOC ($PRIOU, .OLD_CCOC1, .OLD_CCOC2);
_STPAR ($PRIOU, .OLD_MODE);
_MTOPR ($PRIOU, $MOSLW, .OLD_WIDTH);
CUR_MODE = 0;
EXITLOOP;
END;
RETURN (1);
END;
%SBTTL 'EDT$$RD_CMDLN - Read a command line from the terminal'
GLOBAL ROUTINE EDT$$RD_CMDLN ( !Read a command line
PROMPT, !Address of prompt string
PR_LEN, !Length of prompt string
BUF, !Address of receiving buffer
LEN, !Address of word to receive length read
BUF_LEN !Buffer length
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine reads a command string from the terminal.
! If the read is aborted by control-C then a zero length
! string is returned.
!
! FORMAL PARAMETERS:
!
! PROMPT address of prompt string
! PR_LEN length of prompt string
! BUF Address of receive buffer
! LEN Address of word to receive length of string
! BUF_LEN Maximum length of buffer
!
! IMPLICIT INPUTS:
!
! CC
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
LOCAL
PR_PTR,
TXT_ARG : VECTOR [9];
OWN
PR_BUF : BLOCK [CH$ALLOCATION (80, BYTE_SIZE)];
!+
! Copy the prompt string
!-
PR_PTR = CH$PTR (PR_BUF,, BYTE_SIZE);
CH$WCHAR (0, CH$MOVE (.PR_LEN, CH$PTR (.PROMPT,, BYTE_SIZE), .PR_PTR));
!+
! Set up argument block for TEXTI
!-
TXT_ARG [0] = 8; !8 word argument block
TXT_ARG [1] = RD_TOP OR RD_CRF OR RD_JFN OR RD_BBG; !flags
TXT_ARG [2] = $PRIIN * %O'1000000' + $PRIOU; !input & output JFNs
TXT_ARG [3] = CH$PTR (.BUF,, BYTE_SIZE); !destination buffer
TXT_ARG [4] = .BUF_LEN; !buffer length
TXT_ARG [5] = .TXT_ARG [3]; !edit limit
TXT_ARG [6] = .PR_PTR; !prompt text
TXT_ARG [7] = 0; !break mask
TXT_ARG [8] = .TXT_ARG [3]; !backup limit
_PSOUT (.PR_PTR); !Issue initial prompt
CC_WAIT = -1;
_TEXTI (TXT_ARG); !Get the command line
CC_WAIT = 0;
!+
! If the TEXTI was aborted by a control-C then set the command length
! to zero ,clear the flag and start a new line then return.
!-
IF (.CC NEQ 0)
THEN
BEGIN
.LEN = 0;
CC = 0;
EDT$$FMT_CRLF();
RETURN (0);
END;
.LEN = .BUF_LEN - .TXT_ARG [4];
IF ((.TXT_ARG [1] AND RD_BTM) NEQ 0) THEN
BEGIN
.LEN = ..LEN - 1;
IF CH$RCHAR (CH$PTR (.BUF, ..LEN, BYTE_SIZE)) EQL ASC_K_CTRL_Z THEN RETURN (1);
END;
RETURN (0);
END;
%SBTTL 'EDT$$TI_ENTERCHM - Enter change mode'
GLOBAL ROUTINE EDT$$TI_ENTERCHM !Enter change mode
: NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine sets the terminal characteristics to the
! required setting for change mode.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Changes the terminal characteristics
!
!--
BEGIN
!LITERAL
! TERM_MODE = FLD ($TTBIN, TT_DAM) OR TT_ECO;
IF (.CUR_MODE NEQ TTY_MODE) THEN
BEGIN
!+
! Set terminal mode
!-
CUR_MODE = TTY_MODE;
_SFMOD ($PRIOU, TTY_MODE);
!+
! Set the CCOC words
!-
_RFCOC ($PRIOU; OLD_CCOC1, OLD_CCOC2);
_SFCOC ($PRIOU, 0, 0);
!+
! Set the page length and width to zero
!-
_STPAR ($PRIOU, (.OLD_MODE AND %O'740000777777'));
END;
!+
! Indicate reset required and enable ^T traps.
!-
TI_RESET = 1;
EDT$$INT_CONTROL (3);
RETURN
END;
%SBTTL 'EDT$$TI_LEAVECHM - Leave change mode'
GLOBAL ROUTINE EDT$$TI_LEAVECHM !Leave change mode
: NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine restores the terminal characteristics to what they
! were when EDT entered change mode.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Changes the terminal characteristics and disable ^T traps
!
!--
BEGIN
BIND
VT100_RESET = UPLIT (%STRING (
%CHAR (ASC_K_ESC), '[m', ! Video attributes
%CHAR (ASC_K_ESC), ')B')); ! G1 to ASCII
LITERAL
VT100_RESET_LEN = 6;
!
! Set the terminal characteristics back to what they were when we
! invoked EDT.
!-
IF (.TI_TYP EQL TERM_VT100)
THEN
BEGIN
EDT$$FMT_LIT (CH$PTR (VT100_RESET), VT100_RESET_LEN);
EDT$$OUT_FMTBUF ();
END;
!+
! Restore normal terminal mode
!-
_SFMOD ($PRIOU, .OLD_MODE);
CUR_MODE = 0;
!+
! Reset the CCOC words, page length and width
!-
_SFCOC ($PRIOU, .OLD_CCOC1, .OLD_CCOC2);
_STPAR ($PRIOU, (.OLD_MODE AND %O'740000777777')); ![46]
EDT$$INT_CONTROL (4);
END;
%SBTTL 'EDT$$TI_WRLN - Write a line to the terminal.'
GLOBAL ROUTINE EDT$$TI_WRLN ( !Write a line to the terminal
BUF,
LEN
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Write a line of text to the terminal and end it with <CR><LF>
!
! FORMAL PARAMETERS:
!
! BUF Pointer to buffer
! LEN Length of string
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
!+
! Output the string followed by carriage return and line feed.
!-
IF (.LEN NEQ 0) THEN _SOUT($PRIOU, CH$PTR(.BUF,, BYTE_SIZE), .LEN, 0);
_SOUT($PRIOU, CH$PTR (CRLF), -2);
END;
%SBTTL 'EDT$$TI_WRSTR - Write a string to the terminal'
GLOBAL ROUTINE EDT$$TI_WRSTR ( !Write a string to the terminal
BUF,
LEN
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Write a non-empty string to the terminal without any <CR><LF>
!
! FORMAL PARAMETERS:
!
! BUF Pointer to buffer
! LEN Length of string
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
!+
! Output the string to the terminal.
!-
IF .LEN GTR 0 THEN _SOUT($PRIOU, CH$PTR(.BUF,, BYTE_SIZE), .LEN, 0);
END;
%SBTTL 'EDT$$TI_GETCH - Get one character from the terminal'
GLOBAL ROUTINE EDT$$TI_GETCH ( !Get on character from the terminal
C !Where to store the character
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Read a single character from the terminal.
!
! FORMAL PARAMETERS:
!
! C Location to store the character
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
CC_WAIT = -1;
!+
! Set terminal to correct mode (no echo) and read a character.
! Then restore current mode.
!-
IF (.CUR_MODE NEQ TTY_MODE) THEN
BEGIN
CUR_MODE = TTY_MODE;
_SFMOD ($PRIIN, TTY_MODE);
END;
_BIN ($PRIIN; .C);
.C = ..C AND %O'177';
IF (.CR_FLAG AND ..C EQL ASC_K_LF) THEN ![36]
BEGIN ![36]
_BIN($PRIIN; .C); ![36]
.C = ..C AND %O'177'; ![36]
END; ![36]
CR_FLAG = 0; ![36]
IF (..C EQL ASC_K_CR) ![36]
THEN CR_FLAG = 1; ![36]
CC_WAIT = 0;
END;
%SBTTL 'EDT$$TI_RDTYAHED - Read characters from type ahead'
GLOBAL ROUTINE EDT$$TI_RDTYAHED ( !Read character from type ahead
TEXT !Address of the string read
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine reads the type-ahead buffer. It returns the string in
! TEXT, the number of characters read as its value.
!
! FORMAL PARAMETERS:
!
! TEXT Address of the string read
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! The number of characters read
!
! SIDE EFFECTS
!
! NONE
!
!--
BEGIN
EXTERNAL ROUTINE
EDT$$TI_ENBLAUTREP : NOVALUE;
LOCAL
TEXT_PTR,
CHAR,
NC;
!+
! Return no. characters read and first character or 0 (Read with no echo)
!-
EDT$$TI_ENBLAUTREP (0); ! Disable auto repeat
TEXT_PTR = CH$PTR (.TEXT,, BYTE_SIZE);
IF (.CUR_MODE NEQ TTY_MODE) THEN
BEGIN
! CUR_MODE = TTY_MODE;
_SFMOD ($PRIIN, TTY_MODE);
END;
NC = 0;
CC_WAIT = -1;
WHILE (NOT _SIBE ($PRIIN)) DO
BEGIN
_BIN ($PRIIN; CHAR);
IF (.CR_FLAG AND .CHAR EQL ASC_K_LF) THEN ![36]
CR_FLAG = 0 ![36]
ELSE ![36]
BEGIN ![36]
CR_FLAG = 0; ![36]
IF (.CHAR EQL ASC_K_CR) THEN ![36]
CR_FLAG = 1; ![36]
CH$WCHAR_A (.CHAR, TEXT_PTR); ![36]
NC = .NC + 1; ![36]
END; ![36]
END; ![36]
CC_WAIT = 0;
RETURN (.NC);
END;
%SBTTL 'EDT$$TI_RDSTR - read characters until control or DEL'
GLOBAL ROUTINE EDT$$TI_RDSTR ( ! Read characters until control or DEL
BUF, ! Pointer to the buffer to read into
LEN, ! Length of that buffer
LEN_READ ! Store here the number of characters read
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine reads characters with echo on until any control character or
! a DEL character are seen.
!
! FORMAL PARAMETERS:
!
! BUF Address of the buffer to read into.
!
! LEN Length of the buffer.
!
! LEN_READ Address of a word to receive the number of characters read.
BEGIN
!+
!*********************************************************
!
! Disable this routine for now as it causes lots of problems
! when there is typeahead. GB.
.LEN_READ = 0;
RETURN;
!*********************************************************
!-
!LITERAL
! ATE_MODE = FLD ($TTATE, TT_DAM) OR TT_ECO,
! BIN_MODE = FLD ($TTBIN, TT_DAM) OR TT_ECO;
!
!LOCAL
! DUM,
! NUM_CHARS,
! PMT_LEN,
! FLD_LEN,
! CHAR,
! PTR;
!
!BIND
! BREAK_MASK = UPLIT(%O'4',
! %O'777777777760', !Ascii 0-37
! %O'0', ! " 40-77
! %O'0', ! " 100-137
! %O'20' ! " 140-177
! ),
!
! CUR_MASK = UPLIT(4, 0, 0, 0, 0);
!
! CC_WAIT = -1;
!
!!+
!! Output the prompt string if there is one.
!!-
!
! IF (PMT_LEN = .FMT_FREE) NEQ 0 THEN
! BEGIN
! _SOUT($PRIOU, CH$PTR (FMT_BUF,, BYTE_SIZE), .PMT_LEN);
! FMT_FREE = FMT_BUFLEN;
! FMT_CUR = CH$PTR (FMT_BUF,, BYTE_SIZE);
! END;
!
!!+
!! Change terminal mode to no translation of control chars
!!-
! _SFMOD ($PRIIN, ATE_MODE);
!
!!+
!! Setup the break mask and field length.
!!-
!
! FLD_LEN = MIN (.LEN, 72);
! _MTOPR ($PRIIN, $MORBM, CUR_MASK);
! _MTOPR ($PRIIN, $MOSBM, BREAK_MASK);
! _MTOPR ($PRIIN, $MOSFW, .FLD_LEN);
!
!!+
!! Wait for a break or buffer full.
!!-
!
! _BIN ($PRIIN; CHAR);
!
!!+
!! Get # chars input and read the string.
!!-
!
! _MTOPR ($PRIIN, $MORFW; DUM, DUM, NUM_CHARS);
! NUM_CHARS = .FLD_LEN - .NUM_CHARS;
! IF (.NUM_CHARS EQL 0)
! THEN
! BEGIN
! .LEN_READ = 0;
! RETURN;
! ELSE
! .LEN_READ = .NUM_CHARS - 1;
! PTR = .BUF;
! CH$WCHAR_A (.CHAR, PTR);
! IF .NUM_CHARS NEQ .FLD_LEN THEN
!
!!+
!! There was a terminator, read string then terminator.
!!-
!
! IF .NUM_CHARS EQL 1 THEN
!
!!+
!! Terminator was only char return it in type ahead
!!-
!
! BEGIN
! CH$WCHAR (.CHAR, CH$PTR (RDAHEDBF,, BYTE_SIZE));
! RDAHED = 1;
! END
!
!!+
!! More than one character typed. If only one char before break char
!! we already have it else we need to readin the rest. Then put break char
!! in type ahead buffer.
!!-
!
! ELSE
! BEGIN
! IF .NUM_CHARS GTR 2 THEN
! _SIN ($PRIIN, .PTR, -(.NUM_CHARS - 2));
!
! _BIN ($PRIIN; CHAR);
! CH$WCHAR (.CHAR, CH$PTR (RDAHEDBF,, BYTE_SIZE));
! RDAHED = 1;
! END
!
!!+
!! No terminator return all the string
!!-
!
! ELSE
! BEGIN
! _SIN ($PRIIN, .BUF, -(.NUM_CHARS - 1));
! .LEN_READ = ..LEN_READ - 1;
! END;
!!+
!! Reset original break mask and terminal mode
!!-
!
! _MTOPR ($PRIIN, $MOSBM, CUR_MASK);
! CUR_MODE = BIN_MODE;
! _SFMOD ($PRIOU, BIN_MODE);
! CC_WAIT = 0;
!
END;
%SBTTL 'EDT$$WF_OPN - Open work file'
GLOBAL ROUTINE EDT$$WF_OPN ! Open work file
=
!++
! FUNCTIONAL DESCRIPTION:
!
! Open the work file. Abort if it fails. If the file is already
! open so that we get an "Invalid simultaneous access" error,
! then try to open a secondary work file. If this fails then die.
! This allows EDT to be used after a PUSH command.
!
! The work file is opened in the current default directory.
! The cache area is allocated from virtual memory.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! WF_JFN
! CACHE_ADDR
!
! ROUTINE VALUE:
!
! 1
!
! SIDE EFFECTS:
!
! Opens the work file. Prints an error message and does not
! return if the open fails.
!
!--
BEGIN
BIND
WF_NAME = UPLIT ('EDTWORK.TMP');
LITERAL
GJ_FLAGS = GJ_TMP OR GJ_FOU OR GJ_SHT,
OPN_BITS = %O'70000000000' OR OF_WR;
LOCAL
PTR,
FILE_ID,
WF_STS;
DECR I FROM NUM_WINDOW - 1 TO 0 DO
BEGIN
CACHE_WINDOW [.I] = -1;
CACHE_REF [.I] = 0;
CACHE_DIRTY [.I] = 0;
CACHE_ADDR [.I] = 0;
END;
CACHE_FULL = 0;
CACHE_TIMER = 0;
FILE_ID = 0;
PTR = CH$MOVE (11, CH$PTR (WF_NAME), CH$PTR (TEMP_BUFFER,, BYTE_SIZE));
CH$WCHAR (0, CH$PLUS (.PTR, 1));
!+
! Loop until we find a suitable work file name or we run out of possible
! file ID's. The file ID is blank for the first and the runs from 1 to 9.
!-
WHILE (.FILE_ID LEQ %C'9') DO
BEGIN
CH$WCHAR (.FILE_ID, .PTR);
IF ( NOT _GTJFN (GJ_FLAGS, CH$PTR (TEMP_BUFFER,, BYTE_SIZE); WF_JFN))
THEN EDT$$FATAL_IOERR (EDT$_IOERRWRK, .WF_JFN);
IF ( NOT _OPENF(.WF_JFN, OPN_BITS; WF_STS))
THEN
IF (.WF_STS NEQ OPNX9)
THEN
EDT$$FATAL_IOERR (EDT$_IOERRWRK, .WF_STS)
ELSE
BEGIN
_RLJFN (.WF_JFN);
IF (.FILE_ID EQL 0) THEN FILE_ID = %C'0';
FILE_ID = .FILE_ID + 1;
END
ELSE
RETURN (1);
END;
EDT$$FATAL_IOERR (EDT$_IOERRWRK, .WF_STS);
RETURN (0);
END;
%SBTTL 'EDT$$WF_CLS - close the work file'
GLOBAL ROUTINE EDT$$WF_CLS ! Close the work file
=
!++
! FUNCTIONAL DESCRIPTION:
!
! Close the work file.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! CACHE_ADDR
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! Always 1; reports all errors.
!
! SIDE EFFECTS:
!
! Errors are reported.
!
!--
BEGIN
LOCAL
I,
PMAP_ARG1;
DECR I FROM NUM_WINDOW - 1 TO 0 DO
IF (.CACHE_ADDR [.I] NEQ 0) THEN
!+
! Unmap it and watch for errors
!-
BEGIN
PMAP_ARG1 <0, 18, 0> = .CACHE_ADDR [.I] / 512;
PMAP_ARG1 <18, 18, 0> = $FHSLF;
IF NOT (_PMAP (-1, .PMAP_ARG1, 0)) THEN EDT$$FATAL_IOERR (EDT$_IOERRWRK, -1);
!+
! Now release the cache
!-
EDT$$DEA_PAGE (%REF (WINDOW_SIZE*WF_BUKT_SIZE/512), CACHE_ADDR [.I]);
END;
!+
! Close the file and delete it
!-
IF NOT (_CLOSF (.WF_JFN + CO_NRJ + CZ_ABT; WF_JFN)) THEN
EDT$$FATAL_IOERR (EDT$_WORFILCLO, .WF_JFN);
IF NOT (_DELF (.WF_JFN + DF_EXP; WF_JFN)) THEN
EDT$$FATAL_IOERR (EDT$_WORFILCLO, .WF_JFN);
_RLJFN (.WF_JFN);
RETURN (1);
END;
%SBTTL 'EDT$$WF_RD - get new current work file bucket'
GLOBAL ROUTINE EDT$$WF_RD ( ! Get a new current work file bucket
BUKT_NUM, ! The number of the bucket to read
REC_DESC ! descriptor for record address
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called get a new current work file bucket. The
! cache is searched, and if it is not there, a window is selected
! for replacement and the bucket is read in.
!
! FORMAL PARAMETERS:
!
! BUKT_NUM The number of the bucket to read.
!
! REC_DESC Descriptor containing address of a word in which the address of the bucket
! is returned.
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Calls GET_WF with READ = 1.
!
!--
BEGIN
MAP
REC_DESC : REF BLOCK [];
LOCAL
BUF_ADDR,
TEMP,
LEN;
GET_WF (.BUKT_NUM, BUF_ADDR, 1); ! find address in cache
REC_DESC [DSC$A_POINTER] = .BUF_ADDR;
END;
%SBTTL 'EDT$$WF_WR - Mark bucket as modified'
GLOBAL ROUTINE EDT$$WF_WR ( ! Mark bucket as modified
NUM, ! Bucket number
REC_DESC ! descriptor for bucket address
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called when the current bucket has been modified by
! the work file and it is going to a new bucket. This is a logical write
! function, but since we are using a cache, it merely marks the bucket
! as dirty.
!
! FORMAL PARAMETERS:
!
! NUM the bucket number being "written".
!
! REC_DESC address of a descriptor for the bucket
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! CACHE_DIRTY
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Calls FIND_WINDOW. The bucket had better be in the cache.
!
!--
BEGIN
MAP
REC_DESC : REF BLOCK [];
LOCAL
ADDR,
FIND_WINDOW_VAL;
FIND_WINDOW_VAL = FIND_WINDOW (.NUM, ADDR);
IF .FIND_WINDOW_VAL LSS 0 THEN EDT$$FATAL_IOERR (EDT$_IOERRWRK, 0);
CACHE_DIRTY [.FIND_WINDOW_VAL] = 1;
END;
%SBTTL 'FIND_WINDOW - Find the window containing a bucket'
ROUTINE FIND_WINDOW ( ! Locate a specified bucket
BUKT_NUM, ! The bucket to locate
ADDR ! Where to put window number (address of bucket)
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Locate the window which contains a specified bucket in the cache. If it
! is not in the cache return -1; otherwise the window number is returned.
!
! FORMAL PARAMETERS:
!
! BUKT_NUM The bucket we are trying to locate.
!
! ADDR Address of a word to receive the address of the requested
! bucket.
!
! IMPLICIT INPUTS:
!
! CACHE_WINDOW
! CACHE_ADDR
!
! IMPLICIT OUTPUTS:
!
! CACHE_TIMER Incremented if window found
! CACHE_REF Set to CACHE_TIMER for the window found
!
! ROUTINE VALUE:
!
! The number of the window containing this bucket, or -1 if none found.
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
LOCAL
WINDOW_NUM;
!+
! Compute the window which contains this bucket.
!-
%IF (WINDOW_SIZE EQL 1)
%THEN
WINDOW_NUM = .BUKT_NUM - 1;
%ELSE
WINDOW_NUM = (.BUKT_NUM - 1)/WINDOW_SIZE;
%FI
!+
! Search the cache to find the window, if found, then compute the address
! of the requested bucket and return it.
!-
DECR I FROM NUM_WINDOW - 1 TO 0 DO
IF (.CACHE_WINDOW [.I] EQL .WINDOW_NUM)
THEN
BEGIN
%IF (WINDOW_SIZE EQL 1)
%THEN
.ADDR = .CACHE_ADDR [.I];
%ELSE
.ADDR = .CACHE_ADDR [.I] + ((.BUKT_NUM - 1) MOD WINDOW_SIZE)*WF_BUKT_SIZE;
%FI
CACHE_TIMER = .CACHE_TIMER + 1;
CACHE_REF [.I] = .CACHE_TIMER;
RETURN (.I);
END;
!+
! Not in the cache, return failure.
!-
RETURN (-1);
END;
%SBTTL 'WRITE_WINDOW - write out a window'
ROUTINE WRITE_WINDOW ( ! Write out a window
WINDOW_NUM ! The window number to write
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION
!
! Write out an entire window.
!
! FORMAL PARAMETERS:
!
! WINDOW_NUM The slot from which the window is written.
!
! IMPLICIT INPUTS:
!
! CACHE_ADDR
! CACHE_WINDOW
!
! IMPLICIT OUTPUTS:
!
! CACHE_DIRTY
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Writes on the work file.
! I/O errors, including the second exceeded quota, print an error and do
! not return to the caller.
!
!--
BEGIN
LOCAL
PMAP_ARG1;
!+
! Mark the window as clean.
!-
CACHE_DIRTY [.WINDOW_NUM] = 0;
!+
! Setup the arguments to unmap the relevant page of the work file.
!-
PMAP_ARG1 <0, 18, 0> = .CACHE_ADDR [.WINDOW_NUM] / 512;
PMAP_ARG1 <18, 18, 0> = $FHSLF;
!+
! Unmap it and watch for errors
!-
IF NOT (_PMAP (-1, .PMAP_ARG1, 0)) THEN EDT$$FATAL_IOERR (EDT$_IOERRWRK, -1);
END;
%SBTTL 'REPLACE_WINDOW - read a new window into the cache'
ROUTINE REPLACE_WINDOW ( ! Read a new bucket into the cache
BUKT_NUM ! The number of the bucket to read in
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called when a new work-file window must be read into the
! cache. We find the least recently used window for replacement, and write
! it out.
!
! FORMAL PARAMETERS:
!
! BUKT_NUM the number of the bucket which we need to put in the cache.
!
! IMPLICIT INPUTS:
!
! CACHE_REF
! CACHE_DIRTY
!
! IMPLICIT OUTPUTS:
!
! CACHE_TIMER
! CACHE_REF
! CACHE_WINDOW
!
! ROUTINE VALUE:
!
! The window number the bucket was allocated to.
!
! SIDE EFFECTS:
!
! May call WRITE_WINDOW
!
!--
BEGIN
LOCAL
WINDOW_NUM,
OLD_TIME,
OLD_NUM;
!+
! Determine which window the bucket is in.
!-
%IF (WINDOW_SIZE EQL 1)
%THEN
WINDOW_NUM = .BUKT_NUM - 1;
%ELSE
WINDOW_NUM = (.BUKT_NUM - 1)/WINDOW_SIZE;
%FI
IF (.WINDOW_NUM GEQ NUM_WINDOW) THEN CACHE_FULL = 1;
IF .CACHE_FULL
THEN
BEGIN
!+
! Find the least recently used window in the cache.
!-
OLD_TIME = 999999999;
DECR I FROM NUM_WINDOW - 1 TO 0 DO
IF (.CACHE_REF [.I] LSSU .OLD_TIME)
THEN
BEGIN
OLD_TIME = .CACHE_REF [.I];
OLD_NUM = .I;
END;
ASSERT (14, .OLD_TIME LSSU 999999999);
!+
! Write the sucker out if it is dirty.
!-
IF (.CACHE_DIRTY [.OLD_NUM] NEQ 0)
THEN
BEGIN
WRITE_WINDOW (.OLD_NUM);
END;
END
ELSE
OLD_NUM = NUM_WINDOW - 1 - .WINDOW_NUM;
!+
! Now, place the new bucket in the cache.
!-
CACHE_TIMER = .CACHE_TIMER + 1;
CACHE_REF [.OLD_NUM] = .CACHE_TIMER;
CACHE_WINDOW [.OLD_NUM] = .WINDOW_NUM;
RETURN (.OLD_NUM);
END;
%SBTTL 'GET_WF - find a bucket in the cache, or read it in'
ROUTINE GET_WF ( ! Find a bucket in the cache, or read it in
BUKT_NUM, ! The number of the bucket to locate
BUF_ADDR, ! Return the bucket's address here
READ ! 1 = read from disk if not in cache
) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine finds a bucket in the cache, or reads it in if necessary.
!
! FORMAL PARAMETERS:
!
! BUKT_NUM The number of the bucket we are trying to locate.
!
! BUF_ADDR Address of a word in which the bucket's address is returned.
!
! READ Flag indicating that we should read the file from disk if it
! is not in the cache.
!
! IMPLICIT INPUTS:
!
! CACHE_ADDR
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! Calls FIND_WONDOW and REPLACE_WINDOW.
! Never returns on I/O errors.
!
!--
BEGIN
LOCAL
PMAP_ARG1,
PMAP_ARG2,
WINDOW_ADDR,
WINDOW_NUM;
!+
! First, see if it is in the cache.
!-
IF (FIND_WINDOW (.BUKT_NUM, .BUF_ADDR) GEQ 0) THEN RETURN;
!+
! It's not, find a block to replace and read a block.
!-
WINDOW_NUM = REPLACE_WINDOW (.BUKT_NUM);
WINDOW_ADDR = .CACHE_ADDR [.WINDOW_NUM];
IF ((.WINDOW_ADDR EQLA 0) AND NOT .CACHE_FULL)
THEN
BEGIN
IF NOT EDT$$ALO_PAGE (%REF (WINDOW_SIZE*WF_BUKT_SIZE/512), CACHE_ADDR [.WINDOW_NUM])
THEN
BEGIN
CACHE_FULL = 1;
WINDOW_NUM = REPLACE_WINDOW (.BUKT_NUM);
END;
WINDOW_ADDR = .CACHE_ADDR [.WINDOW_NUM];
ASSERT (14, .WINDOW_ADDR NEQA 0);
%IF (WINDOW_SIZE EQL 1)
%THEN
.BUF_ADDR = .WINDOW_ADDR;
%ELSE
.BUF_ADDR = .WINDOW_ADDR + ((.BUKT_NUM - 1) MOD WINDOW_SIZE)*WF_BUKT_SIZE;
%FI
END
ELSE
BEGIN
ASSERT (14, .WINDOW_ADDR NEQA 0);
%IF (WINDOW_SIZE EQL 1)
%THEN
.BUF_ADDR = .WINDOW_ADDR;
%ELSE
.BUF_ADDR = .WINDOW_ADDR + ((.BUKT_NUM - 1) MOD WINDOW_SIZE)*WF_BUKT_SIZE;
%FI
END;
!+
! Check to see if we should read it in.
!-
IF .READ
THEN
BEGIN
PMAP_ARG1 <18, 18, 0> = .WF_JFN;
%IF (WINDOW_SIZE EQL 1)
%THEN
PMAP_ARG1 <0, 18, 0> = .BUKT_NUM + 1;
%ELSE
PMAP_ARG1 <0, 18, 0> = .BUKT_NUM / WINDOW_SIZE + 1;
%FI
PMAP_ARG2 <0, 18, 0> = .WINDOW_ADDR / 512;
PMAP_ARG2 <18, 18, 0> = $FHSLF;
IF NOT (_PMAP (.PMAP_ARG1, .PMAP_ARG2, ACCESS_BITS)) THEN
EDT$$FATAL_IOERR (EDT$_IOERRWRK, -1);
END;
END;
END !End of EDT$IOMOD
ELUDOM