home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
vmskermit32.tar.gz
/
vmskermit32.tar
/
vmsfil.bli
< prev
next >
Wrap
Text File
|
1991-02-20
|
57KB
|
2,722 lines
MODULE KERFIL (IDENT = '3.3.119',
ADDRESSING_MODE(EXTERNAL = GENERAL, NONEXTERNAL = GENERAL)) =
BEGIN
!<BLF/WIDTH:90>
!++
! FACILITY:
! KERMIT-32 Microcomputer to mainframe file transfer utility.
!
! ABSTRACT:
! KERFIL contains all of the file processing for KERMIT-32. This
! module contains the routines to input/output characters to files
! and to open and close the files.
!
! ENVIRONMENT:
! VAX/VMS user mode.
!
! AUTHOR: Robert C. McQueen, CREATION DATE: 28-March-1983
!
!--
%SBTTL 'Table of Contents'
%SBTTL 'Revision History'
!++
!
! 1.0.000 By: Robert C. McQueen On: 28-March-1983
! Create this module.
! 1.0.001 By: Robert C. McQueen On: 4-April-1983
! Remove checks for <FF> in the input data stream.
!
! 1.0.002 By: Robert C. McQueen On: 31-May-1983
! Fix a bad check in wildcard processing.
!
! 1.0.003 By: Nick Bush On: 13-June-1983
! Add default file spec of .;0 so that wild-carded
! file types don't cause all version of a file to
! be transferred.
!
! 1.0.004 By: Robert C. McQueen On: 20-July-1983
! Strip off the parity bit on the compares for incoming ASCII
! files.
!
! 1.2.005 By: Robert C. McQueen On: 15-August-1983
! Attempt to improve the GET%FILE and make it smaller.
! Also start the implementation of the BLOCK file processing.
!
! 2.0.006 Release VAX/VMS Kermit-32 version 2.0
!
! 2.0.016 By: Nick Bush On: 4-Dec-1983
! Change how binary files are written to (hopefully) improve
! the performance. We will now use 510 records and only
! write out the record when it is filled (instead of writing
! one record per packet). This should cut down on the overhead
! substantially.
!
! 2.0.017 By: Nick Bush On: 9-Dec-1983
! Fix processing for VFC format files. Also fix GET_ASCII
! for PRN and FTN record types. Change GET_ASCII so that
! 'normal' CR records get sent with trailing CRLF's instead
! of <LF>record<CR>. That was confusing too many people.
!
! 2.0.022 By: Nick Bush On: 15-Dec-1983
! Add Fixed record size (512 byte) format for writing files.
! This can be used for .EXE files. Also clean up writing
! ASCII files so that we don't lose any characters.
!
! 2.0.024 By: Robert C. McQueen On: 19-Dec-1983
! Delete FILE_DUMP.
!
! 2.0.026 By: Nick Bush On: 3-Jan-1983
! Add options for format of file specification to be
! sent in file header packets. Also type out full file
! specification being sent/received instead of just
! the name we are telling the other end to use.
!
! 2.0.030 By: Nick Bush On: 3-Feb-1983
! Add the capability of receiving a file with a different
! name than given by KERMSG. The RECEIVE and GET commands
! now really are different.
!
! 2.0.035 By: Nick Bush On: 8-March-1984
! Add LOG SESSION command to set a log file for CONNECT.
! While we are doing so, clean up the command parsing a little
! so that we don't have as many COPY_xxx routines.
!
! 2.0.036 By: Nick Bush On: 15-March-1984
! Fix PUT_FILE to correctly handle carriage returns which are
! not followed by line feeds. Count was being decremented
! Instead of incremented.
!
! 2.0.040 By: Nick Bush On: 22-March-1984
! Fix processing of FORTRAN carriage control to handle lines
! which do not contain the carriage control character (i.e., zero
! length records). Previously, this type of record was sending
! infinite nulls.
!
! 3.0.045 Start of version 3.
!
! 3.0.046 By: Nick Bush On: 29-March-1984
! Fix debugging log file to correctly set/clear file open
! flag. Also make log files default to .LOG.
!
! 3.0.050 By: Nick Bush On: 2-April-1984
! Add SET SERVER_TIMER to determine period between idle naks.
! Also allow for a routine to process file specs before
! FILE_OPEN uses them. This allows individual sites to
! restrict the format of file specifications used by Kermit.
!
! 3.1.053 By: Robert C. McQueen On: 9-July-1984
! Fix FORTRAN carriage control processing to pass along
! any character from the carriage control column that is
! not really carriage control.
!
! Start version 3.2
!
! 3.2.067 By: Robert C. McQueen On: 8-May-1985
! Use $GETDVIW instead of $GETDVI.
!
! 3.2.070 By: David Stevens On: 16-July-1985
! Put "Sending: " prompt into NEXT_FILE routine, to make
! VMS KERMIT similar to KERMIT-10.
!
! 3.2.077 By: Robert McQueen On: 8-May-1986
! Fix FORTRAN CC once and for all (I hope).
!
! Start of version 3.3
!
! 3.3.105 By: Robert McQueen On: 8-July-1986
! Do some clean up and attempt to fix LINK-W-TRUNC errors
! from a BLISS-32 bug.
!
! 3.3.106 By: Robert McQueen On: 8-July-1986
! Fix problem of closing a fixed file and losing data.
!
! 3.3.111 By: Robert McQueen On: 2-Oct-1986
! Make Kermit-32 not eat the parity from a CR if a LF doesn't
! follow it when writing an ASCII file.
!
! 3.3.112 JHW0001 Jonathan H. Welch, 28-Apr-1988 12:11
! Fix the message generated in NEXT_FILE so that the
! filenames displayed (i.e. Sending: foo.bar;1 as foo.bar)
! are always terminated by a null (ASCIZ).
!
! 3.3.117 JHW006 Jonathan H. Welch, 12-May-1988
! Calls to LIB$SIGNAL with multiple arguments were
! not coded correctly. For calls with multiple arguments
! an argument count was added.
! Minor changes to KERM_HANDLER to make use of the changed
! argument passing method.
!
! 3.3.118 JHW010 Jonathan H. Welch, 23-Apr-1990 09:42
! Added SET FILE BLOCKSIZE nnn (where nnn is the record size
! in bytes) command for incoming BINARY and FIXED file transfers.
! If no blocksize has been specified the old behavior (510 byte
! records plus 2 bytes (for CR/LF) for BINARY files and 512
! byte records for FIXED files will be used.
! Also modified SHOW FILE to display record size when appropriate.
!
! 3.3.119 JHW015 Jonathan H. Welch, 16-Jul-1990 15:30
! Fixed the logic in GET_ASCII which was causing an infinite
! loop for files with print file carriage control.
!--
%SBTTL 'Forward definitions'
FORWARD ROUTINE
LOG_PUT, ! Write a buffer out
DUMP_BUFFER, ! Worker routine for FILE_DUMP.
GET_BUFFER, ! Routine to do $GET
GET_ASCII, ! Get an ASCII character
GET_BLOCK, ! Get a block character
FILE_ERROR : NOVALUE; ! Error processing routine
%SBTTL 'Require/Library files'
!
! INCLUDE FILES:
!
LIBRARY 'SYS$LIBRARY:STARLET';
REQUIRE 'KERCOM.REQ';
%SBTTL 'Macro definitions'
!
! MACROS:
!
%SBTTL 'Literal symbol definitions'
!
! EQUATED SYMBOLS:
!
!
! Various states for reading the data from the file
!
LITERAL
F_STATE_PRE = 0, ! Prefix state
F_STATE_PRE1 = 1, ! Other prefix state
F_STATE_DATA = 2, ! Data processing state
F_STATE_POST = 3, ! Postfix processing state
F_STATE_POST1 = 4, ! Secondary postfix processing state
F_STATE_MIN = 0, ! Min state number
F_STATE_MAX = 4; ! Max state number
!
! Buffer size for log file
!
LITERAL
LOG_BUFF_SIZE = 256; ! Number of bytes in log file buffer
%SBTTL 'Local storage'
!
! OWN STORAGE:
!
OWN
SEARCH_FLAG, ! Can/cannot do $SEARCH
DEV_CLASS, ! Type of device we are reading
EOF_FLAG, ! End of file reached.
FILE_FAB : $FAB_DECL, ! FAB for file processing
FILE_NAM : $NAM_DECL, ! NAM for file processing
FILE_RAB : $RAB_DECL, ! RAB for file processing
FILE_XABFHC : $XABFHC_DECL, ! XAB for file processing
FILE_MODE, ! Mode of file (reading/writing)
FILE_REC_POINTER, ! Pointer to the record information
FILE_REC_COUNT, ! Count of the number of bytes
REC_SIZE : LONG, ! Record size
REC_ADDRESS : LONG, ! Record address
FIX_SIZE : LONG, ! Fixed control region size
FIX_ADDRESS : LONG, ! Address of buffer for fixed control region
EXP_STR : VECTOR [CH$ALLOCATION (NAM$C_MAXRSS)],
RES_STR : VECTOR [CH$ALLOCATION (NAM$C_MAXRSS)],
RES_STR_D : BLOCK [8, BYTE]; ! Descriptor for the string
%SBTTL 'Global storage'
!
! Global storage:
!
GLOBAL
file_blocksize, ! Block size of for BINARY and FIXED files.
file_blocksize_set, ! 0=user has not specified a blocksize, 1=user has specified a blocksize
FILE_TYPE, ! Type of file being xfered
FILE_DESC : BLOCK [8, BYTE]; ! File name descriptor
%SBTTL 'External routines and storage'
!
! EXTERNAL REFERENCES:
!
!
! Storage in KERMSG
!
EXTERNAL
ALT_FILE_SIZE, ! Number of characters in FILE_NAME
ALT_FILE_NAME : VECTOR [CH$ALLOCATION (MAX_FILE_NAME)], ! Storage
FILE_SIZE, ! Number of characters in FILE_NAME
FILE_NAME : VECTOR [CH$ALLOCATION (MAX_FILE_NAME)],
TY_FIL, ! Flag that file names are being typed
CONNECT_FLAG, ! Indicator of whether we have a terminal to type on
FIL_NORMAL_FORM; ! File specification type
!
! Routines in KERTT
!
EXTERNAL ROUTINE
TT_OUTPUT : NOVALUE; ! Force buffered output
!
! System libraries
!
EXTERNAL ROUTINE
LIB$GET_VM : ADDRESSING_MODE (GENERAL),
LIB$FREE_VM : ADDRESSING_MODE (GENERAL),
LIB$SIGNAL : ADDRESSING_MODE (GENERAL) NOVALUE;
%SBTTL 'File processing -- FILE_INIT - Initialization'
GLOBAL ROUTINE FILE_INIT : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will initialize some of the storage in the file processing
! module.
!
! CALLING SEQUENCE:
!
! FILE_INIT();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
FILE_TYPE = FILE_ASC;
file_blocksize = 512;
file_blocksize_set = 0;
! Now set up the file specification descriptor
FILE_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
FILE_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
FILE_DESC [DSC$A_POINTER] = FILE_NAME;
FILE_DESC [DSC$W_LENGTH] = 0;
EOF_FLAG = FALSE;
END; ! End of FILE_INIT
%SBTTL 'GET_FILE'
GLOBAL ROUTINE GET_FILE (CHARACTER) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will return a character from the input file.
! The character will be stored into the location specified by
! CHARACTER.
!
! CALLING SEQUENCE:
!
! GET_FILE (LOCATION_TO_STORE_CHAR);
!
! INPUT PARAMETERS:
!
! LOCATION_TO_STORE_CHAR - This is the address to store the character
! into.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! Character stored into the location specified.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! True - Character stored into the location specified.
! False - End of file reached.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Define the various condition codes that we check for in this routine
!
EXTERNAL LITERAL
KER_EOF; ! End of file
LOCAL
STATUS; ! Random status values
IF .EOF_FLAG THEN RETURN KER_EOF;
SELECTONE .FILE_TYPE OF
SET
[FILE_ASC, FILE_BIN, FILE_FIX] :
STATUS = GET_ASCII (.CHARACTER);
[FILE_BLK] :
STATUS = GET_BLOCK (.CHARACTER);
TES;
RETURN .STATUS;
END; ! End of GET_FILE
%SBTTL 'GET_ASCII - Get a character from an ASCII file'
ROUTINE GET_ASCII (CHARACTER) =
!++
! FUNCTIONAL DESCRIPTION:
!
! CALLING SEQUENCE:
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! KER_EOF - End of file encountered
! KER_ILLFILTYP - Illegal file type
! KER_NORMAL - Normal return
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Status codes that are returned by this module
!
EXTERNAL LITERAL
KER_EOF, ! End of file encountered
KER_ILLFILTYP, ! Illegal file type
KER_NORMAL; ! Normal return
OWN
CC_COUNT, ! Count of the number of CC things to output
CC_TYPE; ! Type of carriage control being processed.
LOCAL
STATUS, ! For status values
RAT;
%SBTTL 'GET_FTN_FILE_CHARACTER - Get a character from an Fortran carriage control file'
ROUTINE GET_FTN_FILE_CHARACTER (CHARACTER) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will get a character from a FORTRAN carriage control file.
! A FORTRAN carriage control file is one with FAB$M_FTN on in the FAB$B_RAT
! field.
!
! FORMAL PARAMETERS:
!
! CHARACTER - Address of where to store the character
!
! IMPLICIT INPUTS:
!
! CC_TYPE - Carriage control type
!
! IMPLICIT OUTPUTS:
!
! CC_TYPE - Updated if this is the first characte of the record
!
! COMPLETION_CODES:
!
! System service or Kermit status code
!
! SIDE EFFECTS:
!
! Next buffer can be read from the data file.
!--
BEGIN
!
! Dispatch according to the state of the file being read. Beginning of
! record, middle of record, end of record
!
WHILE TRUE DO
CASE .FILE_FAB[FAB$L_CTX] FROM F_STATE_MIN TO F_STATE_MAX OF
SET
!
! Here at the beginning of a record. We must read the buffer from the file
! at this point. Once the buffer is read we must then determine what to do
! with the FORTRAN carriage control that at the beginning of the buffer.
!
[F_STATE_PRE ]:
BEGIN
!
! Local variables
!
LOCAL
STATUS; ! Status returned by the
! GET_BUFFER routine
!
! Get the buffer
!
STATUS = GET_BUFFER (); ! Get a buffer from the system
IF (NOT .STATUS) ! If this call failed
OR (.STATUS EQL KER_EOF) ! or we got an EOF
THEN
RETURN .STATUS; ! Just return the status
!
! Here with a valid buffer full of data all set to be decoded
!
IF .FILE_REC_COUNT LEQ 0 ! If nothing, use a space
THEN ! for the carriage control
CC_TYPE = %C' '
ELSE
BEGIN
CC_TYPE = CH$RCHAR_A (FILE_REC_POINTER);
FILE_REC_COUNT = .FILE_REC_COUNT - 1;
END;
!
! Dispatch on the type of carriage control that we are processing
!
SELECTONE .CC_TYPE OF
SET
!
! All of these just output:
! <DATA> <Carriage-control>
!
[CHR_NUL, %C'+'] :
BEGIN
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
END;
!
! This outputs:
! <LF><DATA><CR>
!
[%C'$', %C' '] :
BEGIN
.CHARACTER = CHR_LFD;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END;
!
! This outputs:
! <LF><LF><DATA><CR>
!
[%C'0'] :
BEGIN
.CHARACTER = CHR_LFD;
FILE_FAB [FAB$L_CTX] = F_STATE_PRE1;
RETURN KER_NORMAL;
END;
!
! This outputs:
! <FORM FEED><DATA><CR>
!
[%C'1'] :
BEGIN
.CHARACTER = CHR_FFD;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END;
!
! If we don't know the type of carriage control, then just return the
! character we read as data and set the carriage control to be space
! to fool the post processing of the record
!
[OTHERWISE] :
BEGIN
.CHARACTER = .CC_TYPE; ! Return the character
CC_TYPE = %C' '; ! Treat as space
FILE_REC_POINTER = CH$PLUS(.FILE_REC_POINTER,-1);
FILE_REC_COUNT = .FILE_REC_COUNT + 1;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL
END;
TES;
END;
!
! Here to add the second LF for the double spacing FORTRAN carriage control
!
[F_STATE_PRE1 ]:
BEGIN
.CHARACTER = CHR_LFD;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END;
!
! Here to read the data of the record
!
[F_STATE_DATA]:
BEGIN
!
! Here to read the data of the record and return it to the caller
! This section can only return KER_NORMAL to the caller
!
IF .FILE_REC_COUNT LEQ 0 ! Anything left in the buffer
THEN
FILE_FAB [FAB$L_CTX] = F_STATE_POST ! No, do post processing
ELSE
BEGIN
.CHARACTER = CH$RCHAR_A (FILE_REC_POINTER); ! Get a character
FILE_REC_COUNT = .FILE_REC_COUNT - 1; ! Decrement the count
RETURN KER_NORMAL; ! Give a good return
END;
END;
!
! Here to do post processing of the record. At this point we are going
! to store either nothing as the post fix, a carriage return for overprinting
! or a carriage return and then a line feed in the POST1 state.
!
[F_STATE_POST ]:
BEGIN
SELECTONE .CC_TYPE OF
SET
!
! This stat is for no carriage control on the record. This is for
! 'null' carriage control (VMS manual states: "Null carriage control
! (print buffer contents.)" and for prompt carriage control.
!
[CHR_NUL, %C'$' ]:
BEGIN
FILE_FAB [FAB$L_CTX] = F_STATE_PRE
END;
!
! This is the normal state, that causes the postfix for the data to be
! a line feed.
!
[%C'0', %C'1', %C' ', %C'+' ]:
BEGIN
.CHARACTER = CHR_CRT;
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
RETURN KER_NORMAL
END;
TES;
END;
!
! Here if we are in a state that this routine doesn't set. Just assume that
! something screwed up and give an illegal file type return to the caller
!
[INRANGE, OUTRANGE]:
RETURN KER_ILLFILTYP;
TES
END;
%SBTTL 'GET_ASCII - Main logic'
RAT = .FILE_FAB [FAB$B_RAT] AND ( NOT FAB$M_BLK);
IF .DEV_CLASS EQL DC$_MAILBOX THEN RAT = FAB$M_CR; ! Mailbox needs CR's
WHILE TRUE DO
BEGIN
SELECTONE .RAT OF
SET
[FAB$M_FTN ]:
BEGIN
RETURN GET_FTN_FILE_CHARACTER (.CHARACTER)
END;
[FAB$M_PRN, FAB$M_CR] :
CASE .FILE_FAB [FAB$L_CTX] FROM F_STATE_MIN TO F_STATE_MAX OF
SET
[F_STATE_PRE] :
BEGIN
STATUS = GET_BUFFER ();
IF NOT .STATUS OR .STATUS EQL KER_EOF THEN RETURN .STATUS;
SELECTONE .RAT OF
SET
[FAB$M_CR] :
BEGIN
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
END;
[FAB$M_PRN] :
BEGIN
LOCAL
TEMP_POINTER;
TEMP_POINTER = CH$PTR (.FILE_RAB [RAB$L_RHB]);
CC_COUNT = CH$RCHAR_A (TEMP_POINTER);
CC_TYPE = CH$RCHAR_A (TEMP_POINTER);
IF .CC_COUNT<7, 1> EQL 0
THEN
BEGIN
IF .CC_COUNT<0, 7> NEQ 0
THEN
BEGIN
.CHARACTER = CHR_LFD;
CC_COUNT = .CC_COUNT - 1;
IF .CC_COUNT GTR 0
THEN
FILE_FAB [FAB$L_CTX] = F_STATE_PRE1
ELSE
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END
ELSE
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
END
ELSE
BEGIN
SELECTONE .CC_COUNT<5, 2> OF
SET
[%B'00'] :
BEGIN
.CHARACTER = .CC_COUNT<0, 5>;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END;
[%B'10'] :
BEGIN
.CHARACTER = .CC_COUNT<0, 5> + 128;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END;
[OTHERWISE, %B'11'] :
RETURN KER_ILLFILTYP;
TES;
END;
END;
TES;
END;
[F_STATE_PRE1] :
IF .RAT EQL FAB$M_PRN
THEN
BEGIN
.CHARACTER = CHR_LFD;
CC_COUNT = .CC_COUNT - 1;
IF .CC_COUNT LEQ 0 THEN FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN KER_NORMAL;
END
ELSE
RETURN KER_ILLFILTYP;
[F_STATE_DATA] :
BEGIN
IF .FILE_REC_COUNT LEQ 0
THEN
FILE_FAB [FAB$L_CTX] = F_STATE_POST
ELSE
BEGIN
.CHARACTER = CH$RCHAR_A (FILE_REC_POINTER);
FILE_REC_COUNT = .FILE_REC_COUNT - 1;
RETURN KER_NORMAL;
END;
END;
[F_STATE_POST] :
BEGIN
SELECTONE .RAT OF
SET
[FAB$M_CR] :
BEGIN
.CHARACTER = CHR_CRT;
FILE_FAB [FAB$L_CTX] = F_STATE_POST1;
! So we get a line feed
RETURN KER_NORMAL;
END;
[FAB$M_PRN] :
BEGIN
IF .CC_TYPE<7, 1> EQL 0
THEN
BEGIN
IF .CC_TYPE<0, 7> NEQ 0
THEN
BEGIN
.CHARACTER = CHR_LFD;
CC_COUNT = .CC_TYPE;
FILE_FAB [FAB$L_CTX] = F_STATE_POST1;
RETURN KER_NORMAL;
END
ELSE
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
END
ELSE
BEGIN
SELECTONE .CC_TYPE<5, 2> OF
SET
[%B'00'] :
BEGIN
.CHARACTER = .CC_TYPE<0, 5>;
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
RETURN KER_NORMAL;
END;
[%B'10'] :
BEGIN
.CHARACTER = .CC_TYPE<0, 5> + 128;
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
RETURN KER_NORMAL;
END;
[OTHERWISE, %B'11'] :
RETURN KER_ILLFILTYP;
TES;
END;
END;
TES; ! End SELECTONE .RAT
END;
[F_STATE_POST1] :
IF .RAT EQL FAB$M_PRN
THEN
BEGIN
.CHARACTER = CHR_LFD;
CC_COUNT = .CC_COUNT - 1;
IF .CC_COUNT LEQ -1
THEN
BEGIN
.CHARACTER = CHR_CRT;
! FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
END;
RETURN KER_NORMAL;
END
ELSE
!
! Generate line feed after CR for funny files
!
IF (.RAT EQL FAB$M_CR)
THEN
BEGIN
.CHARACTER = CHR_LFD; ! Return a line feed
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
! Next we get data
RETURN KER_NORMAL;
END
ELSE
RETURN KER_ILLFILTYP;
TES; ! End of CASE .STATE
[OTHERWISE] :
BEGIN
WHILE .FILE_REC_COUNT LEQ 0 DO
BEGIN
STATUS = GET_BUFFER ();
IF NOT .STATUS OR .STATUS EQL KER_EOF THEN RETURN .STATUS;
END;
FILE_REC_COUNT = .FILE_REC_COUNT - 1;
.CHARACTER = CH$RCHAR_A (FILE_REC_POINTER);
RETURN KER_NORMAL;
END;
TES; ! End of SELECTONE .RAT
END; ! End WHILE TRUE DO loop
RETURN KER_ILLFILTYP; ! Shouldn't get here
END; ! End of GET_ASCII
%SBTTL 'GET_BLOCK - Get a character from a BLOCKed file'
ROUTINE GET_BLOCK (CHARACTER) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will return the next byte from a blocked file. This
! routine will use the $READ RMS call to get the next byte from the
! file. This way all RMS header information can be passed to the
! other file system.
!
! CALLING SEQUENCE:
!
! STATUS = GET_BLOCK(CHARACTER);
!
! INPUT PARAMETERS:
!
! CHARACTER - Address to store the character in.
!
! IMPLICIT INPUTS:
!
! REC_POINTER - Pointer into the record.
! REC_ADDRESS - Address of the record.
! REC_COUNT - Count of the number of bytes left in the record.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! KER_NORMAL - Got a byte
! KER_EOF - End of file gotten.
! KER_RMS32 - RMS error
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Status codes returned by this module
!
EXTERNAL LITERAL
KER_RMS32, ! RMS error encountered
KER_EOF, ! End of file encountered
KER_NORMAL; ! Normal return
LOCAL
STATUS; ! Random status values
WHILE .FILE_REC_COUNT LEQ 0 DO
BEGIN
STATUS = $READ (RAB = FILE_RAB);
IF NOT .STATUS
THEN
IF .STATUS EQL RMS$_EOF
THEN
BEGIN
EOF_FLAG = TRUE;
RETURN KER_EOF;
END
ELSE
BEGIN
FILE_ERROR (.STATUS);
EOF_FLAG = TRUE;
RETURN KER_RMS32;
END;
FILE_REC_POINTER = CH$PTR (.REC_ADDRESS);
FILE_REC_COUNT = .FILE_RAB [RAB$W_RSZ];
END;
FILE_REC_COUNT = .FILE_REC_COUNT - 1;
.CHARACTER = CH$RCHAR_A (FILE_REC_POINTER);
RETURN KER_NORMAL;
END; ! End of GET_BLOCK
%SBTTL 'GET_BUFFER - Routine to read a buffer.'
ROUTINE GET_BUFFER =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will read a buffer from the disk file. It will
! return various status depending if there was an error reading
! the disk file or if the end of file is reached.
!
! CALLING SEQUENCE:
!
! STATUS = GET_BUFFER ();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! FILE_REC_POINTER - Pointer into the record.
! FILE_REC_COUNT - Count of the number of bytes in the record.
!
! COMPLETION CODES:
!
! KER_NORMAL - Got a buffer
! KER_EOF - End of file reached.
! KER_RMS32 - RMS error
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! The following are the various status values returned by this routien
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_EOF, ! End of file
KER_RMS32; ! RMS error encountered
LOCAL
STATUS; ! Random status values
STATUS = $GET (RAB = FILE_RAB);
IF NOT .STATUS
THEN
IF .STATUS EQL RMS$_EOF
THEN
BEGIN
EOF_FLAG = TRUE;
RETURN KER_EOF;
END
ELSE
BEGIN
FILE_ERROR (.STATUS);
EOF_FLAG = TRUE;
RETURN KER_RMS32;
END;
FILE_REC_POINTER = CH$PTR (.REC_ADDRESS);
FILE_REC_COUNT = .FILE_RAB [RAB$W_RSZ];
RETURN KER_NORMAL;
END;
%SBTTL 'PUT_FILE'
GLOBAL ROUTINE PUT_FILE (CHARACTER) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will store a character into the record buffer
! that we are building. It will output the buffer to disk
! when the end of line characters are found.
!
! CALLING SEQUENCE:
!
! STATUS = PUT_FILE(Character);
!
! INPUT PARAMETERS:
!
! Character - Address of the character to output in the file.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! Status - True if no problems writing the character
! False if there were problems writing the character.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes
!
EXTERNAL LITERAL
KER_REC_TOO_BIG, ! Record too big
KER_NORMAL; ! Normal return
!
! Local variables
!
OWN
SAVED_CHARACTER : UNSIGNED BYTE; ! Character we may have to
! write later on
LOCAL
STATUS; ! Random status values
SELECTONE .FILE_TYPE OF
SET
[FILE_ASC] :
BEGIN
!
! If the last character was a carriage return and this is a line feed,
! we will just dump the record. Otherwise, if the last character was
! a carriage return, output both it and the current one.
!
IF .FILE_FAB [FAB$L_CTX] NEQ F_STATE_DATA
THEN
BEGIN
IF (.CHARACTER AND %O'177') EQL CHR_LFD
THEN
BEGIN
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
RETURN DUMP_BUFFER ();
END
ELSE
BEGIN
IF .FILE_REC_COUNT GEQ .REC_SIZE
THEN
BEGIN
LIB$SIGNAL (KER_REC_TOO_BIG);
RETURN KER_REC_TOO_BIG;
END;
CH$WCHAR_A (.SAVED_CHARACTER, FILE_REC_POINTER);
! Store the carriage return we deferred
FILE_REC_COUNT = .FILE_REC_COUNT + 1;
FILE_FAB [FAB$L_CTX] = F_STATE_DATA; ! Back to normal data
END;
END;
!
! Here when last character was written to the file normally. Check if
! this character might be the end of a record (or at least the start of
! end.
!
IF (.CHARACTER AND %O'177') EQL CHR_CRT
THEN
BEGIN
SAVED_CHARACTER = .CHARACTER; ! Save the character for later
FILE_FAB [FAB$L_CTX] = F_STATE_POST; ! Remember we saw this
RETURN KER_NORMAL; ! And delay until next character
END;
IF .FILE_REC_COUNT GEQ .REC_SIZE
THEN
BEGIN
LIB$SIGNAL (KER_REC_TOO_BIG);
RETURN KER_REC_TOO_BIG;
END;
FILE_REC_COUNT = .FILE_REC_COUNT + 1;
CH$WCHAR_A (.CHARACTER, FILE_REC_POINTER);
END;
[FILE_BIN, FILE_FIX] :
BEGIN
IF .FILE_REC_COUNT GEQ .REC_SIZE
THEN
BEGIN
STATUS = DUMP_BUFFER ();
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
END;
FILE_REC_COUNT = .FILE_REC_COUNT + 1;
CH$WCHAR_A (.CHARACTER, FILE_REC_POINTER);
END;
[FILE_BLK] :
BEGIN
IF .FILE_REC_COUNT GEQ .REC_SIZE
THEN
BEGIN
FILE_RAB [RAB$W_RSZ] = .FILE_REC_COUNT;
STATUS = $WRITE (RAB = FILE_RAB);
FILE_REC_COUNT = 0;
FILE_REC_POINTER = CH$PTR (.REC_ADDRESS);
END;
FILE_REC_COUNT = .FILE_REC_COUNT + 1;
CH$WCHAR_A (.CHARACTER, FILE_REC_POINTER);
END;
TES;
RETURN KER_NORMAL;
END; ! End of PUT_FILE
%SBTTL 'DUMP_BUFFER - Dump the current record to disk'
ROUTINE DUMP_BUFFER =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will dump the current record to disk. It doesn't
! care what type of file you are writing, unlike FILE_DUMP.
!
! CALLING SEQUENCE:
!
! STATUS = DUMP_BUFFER();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! KER_NORMAL - Output went ok.
! KER_RMS32 - RMS-32 error.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_RMS32; ! RMS-32 error
!
! Local variables
!
LOCAL
STATUS; ! Random status values
!
! First update the record length
!
FILE_RAB [RAB$W_RSZ] = .FILE_REC_COUNT;
!
! Now output the record to the file
!
STATUS = $PUT (RAB = FILE_RAB);
!
! Update the pointers first
!
FILE_REC_COUNT = 0;
FILE_REC_POINTER = CH$PTR (.REC_ADDRESS);
!
! Now determine if we failed attempting to write the record
!
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32
END;
RETURN KER_NORMAL
END; ! End of DUMP_BUFFER
%SBTTL 'OPEN_READING'
ROUTINE OPEN_READING =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will open a file for reading. It will return either
! true or false to the called depending on the success of the
! operation.
!
! CALLING SEQUENCE:
!
! status = OPEN_READING();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! KER_NORMAL - Normal return
! KER_RMS32 - RMS error encountered
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_RMS32; ! RMS-32 error
LOCAL
STATUS; ! Random status values
!
! We now have an expanded file specification that we can use to process
! the file.
!
IF .FILE_TYPE NEQ FILE_BLK
THEN
BEGIN
$FAB_INIT (FAB = FILE_FAB, FAC = GET, FOP = NAM, RFM = STM, NAM = FILE_NAM,
XAB = FILE_XABFHC);
END
ELSE
BEGIN
$FAB_INIT (FAB = FILE_FAB, FAC = (GET, BIO), FOP = NAM, RFM = STM,
NAM = FILE_NAM, XAB = FILE_XABFHC);
END;
$XABFHC_INIT (XAB = FILE_XABFHC);
STATUS = $OPEN (FAB = FILE_FAB);
IF (.STATUS NEQ RMS$_NORMAL AND .STATUS NEQ RMS$_KFF)
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
!
! Now allocate a buffer for the records
!
REC_SIZE = (IF .FILE_TYPE EQL FILE_BLK THEN 512 ELSE .FILE_XABFHC [XAB$W_LRL]);
IF .REC_SIZE EQL 0 THEN REC_SIZE = MAX_REC_LENGTH;
STATUS = LIB$GET_VM (REC_SIZE, REC_ADDRESS);
!
! Determine if we need a buffer for the fixed control area
!
FIX_SIZE = .FILE_FAB [FAB$B_FSZ];
IF .FIX_SIZE NEQ 0
THEN
BEGIN
STATUS = LIB$GET_VM (FIX_SIZE, FIX_ADDRESS);
END;
!
! Initialize the RAB for the $CONNECT RMS call
!
$RAB_INIT (RAB = FILE_RAB, FAB = FILE_FAB, RAC = SEQ, ROP = NLK, UBF = .REC_ADDRESS,
USZ = .REC_SIZE);
IF .FIX_SIZE NEQ 0 THEN FILE_RAB [RAB$L_RHB] = .FIX_ADDRESS;
! Store header address
STATUS = $CONNECT (RAB = FILE_RAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
FILE_REC_COUNT = -1;
FILE_FAB [FAB$L_CTX] = F_STATE_PRE;
RETURN KER_NORMAL;
END; ! End of OPEN_READING
%SBTTL 'FILE_OPEN'
GLOBAL ROUTINE FILE_OPEN (FUNCTION) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will open a file for reading or writing depending on
! the function that is passed this routine. It will handle wildcards
! on the read function.
!
! CALLING SEQUENCE:
!
! status = FILE_OPEN(FUNCTION);
!
! INPUT PARAMETERS:
!
! FUNCTION - Function to do. Either FNC_READ or FNC_WRITE.
!
! IMPLICIT INPUTS:
!
! FILE_NAME and FILE_SIZE set up with the file name and the length
! of the name.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! FILE_NAME and FILE_SIZE set up with the file name and the length
! of the name.
!
! COMPLETION CODES:
!
! KER_NORMAL - File opened correctly.
! KER_RMS32 - Problem processing the file.
! KER_INTERNALERR - Internal Kermit-32 error.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_INTERNALERR, ! Internal error
KER_RMS32; ! RMS-32 error
EXTERNAL ROUTINE
TT_TEXT : NOVALUE; ! Output an ASCIZ string
EXTERNAL ROUTINE
!
! This external routine is called to perform any checks on the file
! specification that the user wishes. It must return a true value
! if the access is to be allowed, and a false value (error code) if
! access is to be denied. The error code may be any valid system wide
! error code, any Kermit-32 error code (KER_xxx) or a user specific code,
! provided a message file defining the error code is loaded with Kermit-32.
!
! The routine is called as:
!
! STATUS = USER_FILE_CHECK ( FILE NAME DESCRIPTOR, READ/WRITE FLAG)
!
! The file name descriptor points to the file specification supplied by
! the user. The read/write flag is TRUE if the file is being read, and
! false if it is being written.
!
USER_FILE_CHECK : ADDRESSING_MODE(GENERAL) WEAK;
LOCAL
STATUS, ! Random status values
ITMLST : VECTOR [4, LONG], ! For GETDVI call
SIZE : WORD; ! Size of resulting file name
!
! Assume we can do searches
!
SEARCH_FLAG = TRUE;
DEV_CLASS = DC$_DISK; ! Assume disk file
!
! Now do the function dependent processing
!
FILE_MODE = .FUNCTION;
FILE_DESC [DSC$W_LENGTH] = .FILE_SIZE; ! Length of file name
!
! Call user routine (if any)
!
IF USER_FILE_CHECK NEQ 0
THEN
BEGIN
STATUS = USER_FILE_CHECK (FILE_DESC, %REF (.FILE_MODE EQL FNC_READ));
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
END;
!
! Select the correct routine depending on if we are reading or writing.
!
SELECTONE .FUNCTION OF
SET
[FNC_READ] :
BEGIN
!
! Determine device type
!
ITMLST [0] = DVI$_DEVCLASS^16 + 4; ! Want device class
ITMLST [1] = DEV_CLASS; ! Put it there
ITMLST [2] = ITMLST [2]; ! Put the size here
ITMLST [3] = 0; ! End the list
STATUS = $GETDVIW (DEVNAM = FILE_DESC, ITMLST = ITMLST);
!
! If not a disk, can't do search
!
IF .STATUS AND .DEV_CLASS NEQ DC$_DISK THEN SEARCH_FLAG = FALSE;
!
! Now set up the FAB with the information it needs.
!
$FAB_INIT (FAB = FILE_FAB, FOP = NAM, FNA = FILE_NAME, FNS = .FILE_SIZE,
NAM = FILE_NAM, DNM = '.;0');
!
! Now initialize the NAM block
!
$NAM_INIT (NAM = FILE_NAM, RSA = RES_STR, RSS = NAM$C_MAXRSS, ESA = EXP_STR,
ESS = NAM$C_MAXRSS);
!
! First parse the file specification.
!
STATUS = $PARSE (FAB = FILE_FAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
IF .SEARCH_FLAG
THEN
BEGIN
STATUS = $SEARCH (FAB = FILE_FAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
END;
!
! We now have an expanded file specification that we can use to process
! the file.
!
STATUS = OPEN_READING (); ! Open the file
IF NOT .STATUS THEN RETURN .STATUS; ! If we couldn't, pass error back
!
! Tell user what name we ended up with for storing the file
!
IF ( NOT .CONNECT_FLAG) AND .TY_FIL
THEN
BEGIN
IF .FILE_NAM [NAM$B_RSS] GTR 0
THEN
BEGIN
CH$WCHAR (CHR_NUL,
CH$PTR (.FILE_NAM [NAM$L_RSA],
.FILE_NAM [NAM$B_RSL]));
TT_TEXT (.FILE_NAM [NAM$L_RSA]);
END
ELSE
BEGIN
CH$WCHAR (CHR_NUL,
CH$PTR (.FILE_NAM [NAM$L_ESA],
.FILE_NAM [NAM$B_ESL]));
TT_TEXT (.FILE_NAM [NAM$L_ESA]);
END;
TT_TEXT (UPLIT (%ASCIZ' as '));
END;
END; ! End of [FNC_READ]
[FNC_WRITE] :
BEGIN
SELECTONE .FILE_TYPE OF
SET
[FILE_ASC] :
BEGIN
$FAB_INIT (FAB = FILE_FAB, FAC = PUT, FNA = FILE_NAME,
FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM,
ORG = SEQ, RFM = VAR, RAT = CR);
END;
[FILE_BIN] :
BEGIN
$FAB_INIT (FAB = FILE_FAB, FAC = PUT, FNA = FILE_NAME,
FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM,
ORG = SEQ, RFM = VAR);
END;
[FILE_FIX] :
BEGIN
$FAB_INIT (FAB = FILE_FAB, FAC = PUT, FNA = FILE_NAME,
FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM,
ORG = SEQ, RFM = FIX, MRS = (IF .file_blocksize_set
THEN .file_blocksize
ELSE 512));
END;
[FILE_BLK] :
BEGIN
$FAB_INIT (FAB = FILE_FAB, FAC = (PUT, BIO), FNA = FILE_NAME,
FNS = .FILE_SIZE, FOP = (MXV, CBT, SQO, TEF), NAM = FILE_NAM);
END;
TES;
!
! If we had an alternate file name from the receive command, use it
! instead of what KERMSG has told us.
!
IF .ALT_FILE_SIZE GTR 0
THEN
BEGIN
LOCAL
ALT_FILE_DESC : BLOCK [8, BYTE];
ALT_FILE_DESC = .FILE_DESC;
ALT_FILE_DESC [DSC$W_LENGTH] = .ALT_FILE_SIZE;
ALT_FILE_DESC [DSC$A_POINTER] = ALT_FILE_NAME;
IF USER_FILE_CHECK NEQ 0
THEN
BEGIN
STATUS = USER_FILE_CHECK (ALT_FILE_DESC, %REF (.FILE_MODE EQL FNC_READ));
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
END;
FILE_FAB [FAB$L_FNA] = ALT_FILE_NAME;
FILE_FAB [FAB$B_FNS] = .ALT_FILE_SIZE;
END;
$NAM_INIT (NAM = FILE_NAM, ESA = EXP_STR, ESS = NAM$C_MAXRSS, RSA = RES_STR,
RSS = NAM$C_MAXRSS);
!
! Now allocate a buffer for the records
!
! Determine correct buffer size
SELECTONE .FILE_TYPE OF
SET
[FILE_ASC] :
REC_SIZE = MAX_REC_LENGTH;
[FILE_BIN] :
REC_SIZE = (IF .file_blocksize_set THEN .file_blocksize
ELSE 510);
[FILE_BLK] :
REC_SIZE = 512;
[FILE_FIX] :
REC_SIZE = (IF .file_blocksize_set THEN .file_blocksize
ELSE 512);
TES;
STATUS = LIB$GET_VM (REC_SIZE, REC_ADDRESS);
!
! Now create the file
!
STATUS = $CREATE (FAB = FILE_FAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
$RAB_INIT (RAB = FILE_RAB, FAB = FILE_FAB, RAC = SEQ, RBF = .REC_ADDRESS,
ROP = <NLK, WAT>);
STATUS = $CONNECT (RAB = FILE_RAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
!
! Set the initial state into the FAB field. This is used to remember
! whether we need to ignore the line feed which follows a carriage return.
!
FILE_FAB [FAB$L_CTX] = F_STATE_DATA;
FILE_REC_COUNT = 0;
FILE_REC_POINTER = CH$PTR (.REC_ADDRESS);
!
! Tell user what name we ended up with for storing the file
!
IF ( NOT .CONNECT_FLAG) AND .TY_FIL
THEN
BEGIN
TT_TEXT (UPLIT (%ASCIZ' as '));
IF .FILE_NAM [NAM$B_RSL] GTR 0
THEN
BEGIN
CH$WCHAR (CHR_NUL,
CH$PTR (.FILE_NAM [NAM$L_RSA],
.FILE_NAM [NAM$B_RSL]));
TT_TEXT (.FILE_NAM [NAM$L_RSA]);
END
ELSE
BEGIN
CH$WCHAR (CHR_NUL,
CH$PTR (.FILE_NAM [NAM$L_ESA],
.FILE_NAM [NAM$B_ESL]));
TT_TEXT (.FILE_NAM [NAM$L_ESA]);
END;
TT_OUTPUT ();
END;
END;
[OTHERWISE] :
RETURN KER_INTERNALERR;
TES;
!
! Copy the file name based on the type of file name we are to use.
! The possibilities are:
! Normal - Just copy name and type
! Full - Copy entire name string (either resultant or expanded)
! Untranslated - Copy string from name on (includes version, etc.)
IF .DEV_CLASS EQL DC$_MAILBOX
THEN
BEGIN
SIZE = 0;
FILE_NAME = 0;
END
ELSE
SELECTONE .FIL_NORMAL_FORM OF
SET
[FNM_FULL] :
BEGIN
IF .FILE_NAM [NAM$B_RSL] GTR 0
THEN
BEGIN
CH$COPY (.FILE_NAM [NAM$B_RSL], CH$PTR (.FILE_NAM [NAM$L_RSA]),
CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME));
SIZE = .FILE_NAM [NAM$B_RSL];
END
ELSE
BEGIN
CH$COPY (.FILE_NAM [NAM$B_ESL], CH$PTR (.FILE_NAM [NAM$L_ESA]),
CHR_NUL, MAX_FILE_NAME, CH$PTR (FILE_NAME));
SIZE = .FILE_NAM [NAM$B_ESL];
END
END;
[FNM_NORMAL, FNM_UNTRAN] :
BEGIN
CH$COPY (.FILE_NAM [NAM$B_NAME], CH$PTR (.FILE_NAM [NAM$L_NAME]),
.FILE_NAM [NAM$B_TYPE], CH$PTR (.FILE_NAM [NAM$L_TYPE]), CHR_NUL,
MAX_FILE_NAME, CH$PTR (FILE_NAME));
SIZE = .FILE_NAM [NAM$B_NAME] + .FILE_NAM [NAM$B_TYPE];
END;
TES;
IF .SIZE GTR MAX_FILE_NAME THEN FILE_SIZE = MAX_FILE_NAME ELSE FILE_SIZE = .SIZE;
RETURN KER_NORMAL;
END; ! End of FILE_OPEN
%SBTTL 'FILE_CLOSE'
GLOBAL ROUTINE FILE_CLOSE (ABORT_FLAG) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will close a file that was opened by FILE_OPEN.
! It assumes any data associated with the file is stored in this
! module, since this routine is called by KERMSG.
!
! CALLING SEQUENCE:
!
! FILE_CLOSE();
!
! INPUT PARAMETERS:
!
! ABORT_FLAG - True if file should not be saved.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_RMS32; ! RMS-32 error
LOCAL
STATUS; ! Random status values
!
! If there might be something left to write
!
IF .FILE_MODE EQL FNC_WRITE AND (.FILE_REC_COUNT GTR 0 OR .FILE_FAB [FAB$L_CTX] NEQ
F_STATE_DATA)
THEN
BEGIN
SELECTONE .FILE_TYPE OF
SET
[FILE_FIX] :
BEGIN
INCR I FROM .FILE_REC_COUNT TO .REC_SIZE - 1 DO
CH$WCHAR_A (CHR_NUL, FILE_REC_POINTER);
FILE_REC_COUNT = .REC_SIZE; ! Store the byte count
STATUS = DUMP_BUFFER ();
END;
[FILE_ASC, FILE_BIN] :
STATUS = DUMP_BUFFER ();
[FILE_BLK] :
BEGIN
FILE_RAB [RAB$W_RSZ] = .FILE_REC_COUNT;
STATUS = $WRITE (RAB = FILE_RAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
STATUS = KER_RMS32;
END
ELSE
STATUS = KER_NORMAL;
END;
TES;
IF NOT .STATUS THEN RETURN .STATUS;
END;
!
! If reading from a mailbox, read until EOF to allow the process on the other
! end to terminal gracefully.
!
IF .FILE_MODE EQL FNC_READ AND .DEV_CLASS EQL DC$_MAILBOX AND NOT .EOF_FLAG
THEN
DO
STATUS = GET_BUFFER ()
UNTIL ( NOT .STATUS) OR .EOF_FLAG;
STATUS = LIB$FREE_VM (REC_SIZE, REC_ADDRESS);
IF .FIX_SIZE NEQ 0 THEN STATUS = LIB$FREE_VM (FIX_SIZE, FIX_ADDRESS);
IF .ABORT_FLAG AND .FILE_MODE EQL FNC_WRITE
THEN
FILE_FAB [FAB$V_DLT] = TRUE
ELSE
FILE_FAB [FAB$V_DLT] = FALSE;
STATUS = $CLOSE (FAB = FILE_FAB);
EOF_FLAG = FALSE;
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END
ELSE
RETURN KER_NORMAL;
END; ! End of FILE_CLOSE
%SBTTL 'NEXT_FILE'
GLOBAL ROUTINE NEXT_FILE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will cause the next file to be opened. It will
! call the RMS-32 routine $SEARCH and $OPEN for the file.
!
! CALLING SEQUENCE:
!
! STATUS = NEXT_FILE;
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! FAB/NAM blocks set up from previous processing.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! FAB/NAM blocks set up for the next file.
!
! COMPLETION CODES:
!
! TRUE - There is a next file.
! KER_RMS32 - No next file.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_NOMORFILES, ! No more files to read
KER_RMS32; ! RMS-32 error
EXTERNAL ROUTINE
TT_TEXT : NOVALUE; ! Output an ASCIZ string
LOCAL
SIZE : WORD, ! Size of the $FAO string
STATUS; ! Random status values
!
! If we can't do a search, just return no more files
!
IF NOT .SEARCH_FLAG THEN RETURN KER_NOMORFILES;
!
! Now search for the next file that we want to process.
!
STATUS = $SEARCH (FAB = FILE_FAB);
IF .STATUS EQL RMS$_NMF THEN RETURN KER_NOMORFILES;
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
!
! Now we have the new file name. All that we have to do is open the file
! for reading now.
!
STATUS = OPEN_READING ();
IF NOT .STATUS THEN RETURN .STATUS;
!
! Copy the file name based on the type of file name we are to use.
! The possibilities are:
! Normal - Just copy name and type
! Full - Copy entire name string (either resultant or expanded)
! Untranslated - Copy string from name on (includes version, etc.)
SELECTONE .FIL_NORMAL_FORM OF
SET
[FNM_FULL] :
BEGIN
IF .FILE_NAM [NAM$B_RSL] GTR 0
THEN
BEGIN
CH$COPY (.FILE_NAM [NAM$B_RSL], CH$PTR (.FILE_NAM [NAM$L_RSA]), CHR_NUL,
MAX_FILE_NAME, CH$PTR (FILE_NAME));
SIZE = .FILE_NAM [NAM$B_RSL];
END
ELSE
BEGIN
CH$COPY (.FILE_NAM [NAM$B_ESL], CH$PTR (.FILE_NAM [NAM$L_ESA]), CHR_NUL,
MAX_FILE_NAME, CH$PTR (FILE_NAME));
SIZE = .FILE_NAM [NAM$B_ESL];
END
END;
[FNM_NORMAL, FNM_UNTRAN] :
BEGIN
CH$COPY (.FILE_NAM [NAM$B_NAME], CH$PTR (.FILE_NAM [NAM$L_NAME]),
.FILE_NAM [NAM$B_TYPE], CH$PTR (.FILE_NAM [NAM$L_TYPE]), CHR_NUL,
MAX_FILE_NAME, CH$PTR (FILE_NAME));
SIZE = .FILE_NAM [NAM$B_NAME] + .FILE_NAM [NAM$B_TYPE];
END;
TES;
IF .SIZE GTR MAX_FILE_NAME THEN FILE_SIZE = MAX_FILE_NAME ELSE FILE_SIZE = .SIZE;
!
! Put prompt for NEXT_FILE sending in here
!
IF ( NOT .CONNECT_FLAG) AND .TY_FIL
THEN
BEGIN
TT_TEXT (UPLIT (%ASCIZ 'Sending: '));
.FILE_NAM [NAM$L_RSA] + .FILE_NAM [NAM$B_RSL] = 0;
TT_TEXT (.FILE_NAM [NAM$L_RSA]);
TT_TEXT (UPLIT (%ASCIZ ' as '));
TT_OUTPUT ();
END;
RETURN KER_NORMAL;
END; ! End of NEXT_FILE
%SBTTL 'LOG_OPEN - Open a log file'
GLOBAL ROUTINE LOG_OPEN (LOG_DESC, LOG_FAB, LOG_RAB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! CALLING SEQUENCE:
!
! STATUS = LOG_OPEN (LOG_DESC, LOG_FAB, LOG_RAB)
!
! INPUT PARAMETERS:
!
! LOG_DESC - Address of descriptor for file name to be opened
!
! LOG_FAB - Address of FAB for file
!
! LOG_RAB - Address of RAB for file
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! LOG_FAB and LOG_RAB updated.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Error code or true.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL, ! Normal return
KER_RMS32; ! RMS-32 error
MAP
LOG_DESC : REF BLOCK [8, BYTE], ! Name descriptor
LOG_FAB : REF $FAB_DECL, ! FAB for file
LOG_RAB : REF $RAB_DECL; ! RAB for file
LOCAL
STATUS, ! Random status values
REC_ADDRESS, ! Address of record buffer
REC_SIZE; ! Size of record buffer
!
! Get memory for records
!
REC_SIZE = LOG_BUFF_SIZE;
STATUS = LIB$GET_VM (REC_SIZE, REC_ADDRESS);
IF NOT .STATUS
THEN
BEGIN
LIB$SIGNAL (.STATUS);
RETURN .STATUS;
END;
!
! Initialize the FAB and RAB
!
$FAB_INIT (FAB = .LOG_FAB, FAC = PUT, FNA = .LOG_DESC [DSC$A_POINTER],
FNS = .LOG_DESC [DSC$W_LENGTH], FOP = (MXV, CBT, SQO, TEF), ORG = SEQ, RFM = VAR,
RAT = CR, CTX = 0, DNA = UPLIT (%ASCII'.LOG'), DNS = 4);
STATUS = $CREATE (FAB = .LOG_FAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
LIB$FREE_VM (REC_SIZE, REC_ADDRESS); ! Dump record buffer
RETURN KER_RMS32;
END;
$RAB_INIT (RAB = .LOG_RAB, FAB = .LOG_FAB, RAC = SEQ, RBF = .REC_ADDRESS,
RSZ = .REC_SIZE, UBF = .REC_ADDRESS, USZ = .REC_SIZE, ROP = <NLK, WAT>, CTX = 0);
STATUS = $CONNECT (RAB = .LOG_RAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
LIB$FREE_VM (REC_SIZE, REC_ADDRESS);
$CLOSE (FAB = .LOG_FAB);
RETURN KER_RMS32;
END
ELSE
RETURN .STATUS;
END; ! End of LOG_OPEN
%SBTTL 'LOG_CLOSE - Close a log file'
GLOBAL ROUTINE LOG_CLOSE (LOG_FAB, LOG_RAB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will close an open log file. It will also ensure that
!the last buffer gets dumped.
!
! CALLING SEQUENCE:
!
! STATUS = LOG_CLOSE (LOG_FAB, LOG_RAB);
!
! INPUT PARAMETERS:
!
! LOG_FAB - Address of log file FAB
!
! LOG_RAB - Address of log file RAB
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Resulting status.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_RMS32; ! RMS-32 error
MAP
LOG_FAB : REF $FAB_DECL, ! FAB for log file
LOG_RAB : REF $RAB_DECL; ! RAB for log file
LOCAL
STATUS, ! Random status values
REC_ADDRESS, ! Address of record buffer
REC_SIZE; ! Size of record buffer
!
! First write out any outstanding data
!
IF .LOG_RAB [RAB$L_CTX] GTR 0 THEN LOG_PUT (.LOG_RAB); ! Dump current buffer
!
! Return the buffer
!
REC_SIZE = LOG_BUFF_SIZE; ! Get size of buffer
REC_ADDRESS = .LOG_RAB [RAB$L_RBF]; ! And address
LIB$FREE_VM (REC_SIZE, REC_ADDRESS);
!
! Now disconnect the RAB
!
STATUS = $DISCONNECT (RAB = .LOG_RAB);
IF NOT .STATUS
THEN
BEGIN
FILE_ERROR (.STATUS);
RETURN KER_RMS32;
END;
!
! Now we can close the file
!
STATUS = $CLOSE (FAB = .LOG_FAB);
IF NOT .STATUS THEN FILE_ERROR (.STATUS);
!
! And return the result
!
RETURN .STATUS;
END; ! End of LOG_CLOSE
%SBTTL 'LOG_CHAR - Log a character to a file'
GLOBAL ROUTINE LOG_CHAR (CH, LOG_RAB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will write one character to an open log file.
!If the buffer becomes filled, it will dump it. It will also
!dump the buffer if a carriage return line feed is seen.
!
! CALLING SEQUENCE:
!
! STATUS = LOG_CHAR (.CH, LOG_RAB);
!
! INPUT PARAMETERS:
!
! CH - The character to write to the file.
!
! LOG_RAB - The address of the log file RAB.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Any error returned by LOG_PUT, else TRUE.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL; ! Normal return
MAP
LOG_RAB : REF $RAB_DECL; ! Log file RAB
LOCAL
STATUS; ! Random status value
!
! If this character is a line feed, and previous was a carriage return, then
! dump the buffer and return.
!
IF .CH EQL CHR_LFD
THEN
BEGIN
!
! If we seem to have overfilled the buffer, that is because we saw a CR
! last, and had no place to put it. Just reset the size and dump the buffer.
!
IF .LOG_RAB [RAB$L_CTX] GTR LOG_BUFF_SIZE
THEN
BEGIN
LOG_RAB [RAB$L_CTX] = LOG_BUFF_SIZE;
RETURN LOG_PUT (.LOG_RAB);
END;
!
! If last character in buffer is a CR, then dump buffer without the CR
!
IF CH$RCHAR (CH$PTR (.LOG_RAB [RAB$L_RBF], .LOG_RAB [RAB$L_CTX] - 1)) EQL CHR_CRT
THEN
BEGIN
LOG_RAB [RAB$L_CTX] = .LOG_RAB [RAB$L_CTX] - 1;
RETURN LOG_PUT (.LOG_RAB);
END;
END;
!
! Don't need to dump buffer because of end of line problems. Check if
! the buffer is full.
!
IF .LOG_RAB [RAB$L_CTX] GEQ LOG_BUFF_SIZE
THEN
BEGIN
!
! If character we want to store is a carriage return, then just count it and
! don't dump the buffer yet.
!
IF .CH EQL CHR_CRT
THEN
BEGIN
LOG_RAB [RAB$L_CTX] = .LOG_RAB [RAB$L_CTX] + 1;
RETURN KER_NORMAL;
END;
!
! We must dump the buffer to make room for more characters
!
STATUS = LOG_PUT (.LOG_RAB);
IF NOT .STATUS THEN RETURN .STATUS;
END;
!
! Here when we have some room to store the character
!
CH$WCHAR (.CH, CH$PTR (.LOG_RAB [RAB$L_RBF], .LOG_RAB [RAB$L_CTX]));
LOG_RAB [RAB$L_CTX] = .LOG_RAB [RAB$L_CTX] + 1;
RETURN KER_NORMAL;
END; ! End of LOG_CHAR
%SBTTL 'LOG_LINE - Log a line to a log file'
GLOBAL ROUTINE LOG_LINE (LINE_DESC, LOG_RAB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will write an entire line to a log file. And previously
! written characters will be dumped first.
!
! CALLING SEQUENCE:
!
! STATUS = LOG_LINE (LINE_DESC, LOG_RAB);
!
! INPUT PARAMETERS:
!
! LINE_DESC - Address of descriptor for string to be written
!
! LOG_RAB - RAB for log file
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! KER_NORMAL or LOG_PUT error code.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
MAP
LINE_DESC : REF BLOCK [8, BYTE], ! Descriptor for string
LOG_RAB : REF $RAB_DECL; ! RAB for file
LOCAL
STATUS; ! Random status value
!
! First check if anything is already in the buffer
!
IF .LOG_RAB [RAB$L_CTX] GTR 0
THEN
BEGIN
STATUS = LOG_PUT (.LOG_RAB); ! Yes, write it out
IF NOT .STATUS THEN RETURN .STATUS; ! Pass back any errors
END;
!
! Copy the data to the buffer
!
CH$COPY (.LINE_DESC [DSC$W_LENGTH], CH$PTR (.LINE_DESC [DSC$A_POINTER]), CHR_NUL,
LOG_BUFF_SIZE, CH$PTR (.LOG_RAB [RAB$L_RBF]));
IF .LINE_DESC [DSC$W_LENGTH] GTR LOG_BUFF_SIZE
THEN
LOG_RAB [RAB$L_CTX] = LOG_BUFF_SIZE
ELSE
LOG_RAB [RAB$L_CTX] = .LINE_DESC [DSC$W_LENGTH];
!
! Now just dump the buffer
!
RETURN LOG_PUT (.LOG_RAB);
END; ! End of LOG_LINE
%SBTTL 'LOG_FAOL - Log an FAO string to the log file'
GLOBAL ROUTINE LOG_FAOL (FAOL_DESC, FAOL_PARAMS, LOG_RAB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will write an FAOL string to the output file.
!
! CALLING SEQUENCE:
!
! STATUS = LOG_FAOL (FAOL_DESC, FAOL_PARAMS, LOG_RAB);
!
! INPUT PARAMETERS:
!
! FAOL_DESC - Address of descriptor for string to be written
!
! FAOL_PARAMS - Parameter list for FAOL call
!
! LOG_RAB - RAB for log file
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! KER_NORMAL or $FAOL or LOG_PUT error code.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! Completion codes returned:
!
EXTERNAL LITERAL
KER_NORMAL; ! Normal return
MAP
FAOL_DESC : REF BLOCK [8, BYTE], ! Descriptor for string
LOG_RAB : REF $RAB_DECL; ! RAB for file
LITERAL
FAOL_BUFSIZ = 256; ! Length of buffer
LOCAL
FAOL_BUFFER : VECTOR [FAOL_BUFSIZ, BYTE], ! Buffer for FAOL output
FAOL_BUF_DESC : BLOCK [8, BYTE], ! Descriptor for buffer
STATUS; ! Random status value
!
! Initialize descriptor for buffer
!
FAOL_BUF_DESC [DSC$B_CLASS] = DSC$K_CLASS_S;
FAOL_BUF_DESC [DSC$B_DTYPE] = DSC$K_DTYPE_T;
FAOL_BUF_DESC [DSC$A_POINTER] = FAOL_BUFFER;
FAOL_BUF_DESC [DSC$W_LENGTH] = FAOL_BUFSIZ;
!
! Now do the FAOL to generate the full text
!
STATUS = $FAOL (CTRSTR = .FAOL_DESC, OUTBUF = FAOL_BUF_DESC,
OUTLEN = FAOL_BUF_DESC [DSC$W_LENGTH], PRMLST = .FAOL_PARAMS);
IF NOT .STATUS THEN RETURN .STATUS;
!
! Dump the text into the file
!
INCR I FROM 1 TO .FAOL_BUF_DESC [DSC$W_LENGTH] DO
BEGIN
STATUS = LOG_CHAR ( .FAOL_BUFFER [.I - 1], .LOG_RAB);
IF NOT .STATUS THEN RETURN .STATUS;
END;
RETURN KER_NORMAL;
END; ! End of LOG_FAOL
%SBTTL 'LOG_PUT - Write a record buffer for a log file'
ROUTINE LOG_PUT (LOG_RAB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will output one buffer for a log file.
!
! CALLING SEQUENCE:
!
! STATUS = LOG_PUT (LOG_RAB);
!
! INPUT PARAMETERS:
!
! LOG_RAB - RAB for log file.
!
! IMPLICIT INPUTS:
!
! None.
!
! OUPTUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! Status value from RMS
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
MAP
LOG_RAB : REF $RAB_DECL; ! RAB for file
!
! Calculate record size
!
LOG_RAB [RAB$W_RSZ] = .LOG_RAB [RAB$L_CTX];
LOG_RAB [RAB$W_USZ] = .LOG_RAB [RAB$W_RSZ];
!
! Buffer will be empty when we finish
!
LOG_RAB [RAB$L_CTX] = 0;
!
! And call RMS to write the buffer
!
RETURN $PUT (RAB = .LOG_RAB);
END; ! End of LOG_PUT
%SBTTL 'FILE_ERROR - Error processing for all RMS errors'
ROUTINE FILE_ERROR (STATUS) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will process all of the RMS-32 error returns. It will
! get the text for the error and then it will issue a KER_ERROR for
! the RMS failure.
!
! CALLING SEQUENCE:
!
! FILE_ERROR();
!
! INPUT PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! STATUS - RMS error status.
! FILE_NAME - File name and extension.
! FILE_SIZE - Size of the thing in FILE_NAME.
!
! OUTPUT PARAMETERS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!
! KERMIT completion codes
!
EXTERNAL LITERAL
KER_RMS32; ! RMS-32 error
LOCAL
ERR_BUFFER : VECTOR [CH$ALLOCATION (MAX_MSG)],
ERR_DESC : BLOCK [8, BYTE] PRESET ! String descriptor to
([DSC$B_CLASS ] = DSC$K_CLASS_S, ! the error buffer
[DSC$B_DTYPE ] = DSC$K_DTYPE_T, ! standard string
[DSC$W_LENGTH ] = MAX_MSG, ! descriptor
[DSC$A_POINTER ] = ERR_BUFFER);
$GETMSG (MSGID = .STATUS,
MSGLEN = ERR_DESC [DSC$W_LENGTH],
BUFADR = ERR_DESC,
FLAGS = 1);
LIB$SIGNAL (KER_RMS32, 2, ERR_DESC, FILE_DESC);
END; ! End of FILE_ERROR
%SBTTL 'End of KERFIL'
END ! End of module
ELUDOM