Google
 

Trailing-Edge - PDP-10 Archives - BB-AE97C-BM - sources/iomod.bli
There are 10 other files named iomod.bli in the archive. Click here to see a list.
 %TITLE 'IOMOD - I/O for TOPS20'
MODULE IOMOD (
		IDENT = '1-012'
		) =
BEGIN
!
!		      COPYRIGHT (c) 1980, 1985, 1981 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!		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 'SYS: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);

!
! 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 terminal modes
    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,
    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
	    REC_LENGTH = .REC_LENGTH - 1;
	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';
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;

    _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;

    [$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;

!+
! Set not eightbit and page length
!-

    EIGHT_BIT = 0;
    TI_PLEN = 24;

!+
! 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);

    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';
    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);
	CH$WCHAR_A (.CHAR, TEXT_PTR);
	NC = .NC + 1;
	END;

    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