Google
 

Trailing-Edge - PDP-10 Archives - BB-R775C-BM - sources/dapper.b36
There are 24 other files named dapper.b36 in the archive. Click here to see a list.
%TITLE 'DAP Interface'

MODULE dapper (
    IDENT='2.0(104)',
    ENTRY (ROPEN, RREAD, RWRITE, RCLOSE, RDEL, RSUB, RRENM, 
    RDIRS, RDIR, RPRINT)
    ) =
BEGIN

!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1985.
!  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 THAT IS NOT SUPPLIED BY DIGITAL.

!++
! FACILITY: DAP interface
!
! ABSTRACT:
!	Provide   system-independent   remote  file   access  by   means
!	of a library  of user-callable routines  on TOPS20, TOPS10,  and
!	VMS.
!
! ENVIRONMENT: User mode.  Needs XPORT.  Debug output uses TUTIO.
!
! AUTHOR: Charlotte L. Richardson
!
! CREATION DATE: 26 May 1982
!
! MODIFIED BY:
!
!--
%sbttl 'Require files';

!
! Require files:
!

! REQUIRE 'BLI:TUTIO';
REQUIRE 'RMSUSR.R36';
%sbttl 'Library files';

!
! Library files:
!

LIBRARY 'STAR36';
LIBRARY 'VERSION';
LIBRARY 'FIELDS';
%sbttl 'Edit History';

!
! Edit History:
!

MACRO
	dit$k_version = DITVER %;	! [3] Produce 6-character name

new_version (1, 0)

edit (%o'1', '4-Oct-82', 'Charlotte L. Richardson')
%( Change version and revision standards.  DAPPER.B36, DAPPER.B32, TTT.MAC,
   TTT.BLI, RMSSTUFF.R32 )%

edit (%o'3', '14-Oct-82', 'Charlotte L. Richardson')
%( Produce a 6-character name on the 20 of DITVER for DIT$K_VERSION.
   DAPPER.B36 )%

edit (%o'7', '29-Oct-82', 'Charlotte L. Richardson')
%( Check that character strings are only ASCII.  TTT.MAC and DAPPER.B36 )%

edit (%o'25', '17-Nov-82', 'Charlotte L. Richardson')
%( DIT$_TOOMANYFIL in DAPPER.B36 should be DIT$_TOOMANY.  DAPPER.B36 )%

edit (%o'33', '24-Nov-82', 'Charlotte L. Richardson')
%( Fix DAPPER.B36 to use new RMSUSR.R36 from FTS project.  QAR 20.
   RMSUSR.R36 and DAPPER.B36 )%

edit (%o'42', '29-Dec-82', 'Charlotte L. Richardson')
%( Have CONSTRUCT_FILESPEC always insert :: into the file specification.
   This will allow the DAP code to correctly handle missing node names.
   QAR 26.  DAPPER.B36 )%

edit (%o'43', '29-Dec-82', 'Charlotte L. Richardson')
%( Teach DAPPER.B36 that RAB USZ field is in WORDS, not BYTES.  QAR 24.
   DAPPER.B36 )%

edit (%o'50', '6-Jan-83', 'Charlotte L. Richardson')
%( Update copyright notices.  DAPPER.B36 )%

edit (%o'52', '17-Jan-83', 'Charlotte L. Richardson')
%( Use DDB's macro EVERYWHERE to avoid bad argument-accessing code generated
   as a Bliss "feature".  ALL routines in DAPPER.B36 )%

edit (%o'53', '18-Jan-83', 'Charlotte L. Richardson')
%( Fix typo in edit 52.  DAPPER.B36.  QAR 33 )%

new_version (2, 0)

Edit (%O'65', '11-Apr-84', 'Sandy Clemens')
%( Add DIT V2 files to DT2:.  FILES:  DITHST.BLI, DAPPER.B36, TTT.MAC.
   This edit adds the following changes to DAPPER.B36 made by Doug Rayner:
     Have the various routines do a R$CLOSE on the FAB if the R$OPEN 
   fails. This makes sure that the DECnet logical link gets closed. 
     After the R$OPEN in ROPEN, reset the BSZ field of the FAB to 7 for
   ASCII mode access.  In some cases the opening of the link to a remote
   FAL (TOPS-10, at least can cause this) can set the byte size to 8-bits.
)%

Edit (%O'104', '8-Oct-84', 'Sandy Clemens')
  %( Add new format of COPYRIGHT notice.  FILES:  ALL )%

! End of revision history

mark_versions ('DIT')
%sbttl 'Table of Contents';

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE

ROPEN: FORTRAN_FUNC,		! Open a remote file (11).

RREAD: FORTRAN_FUNC,		! Read a remote file (18).

RWRITE: FORTRAN_FUNC,		! Write to a remote file (17).

RCLOSE: FORTRAN_FUNC,		! Close a remote file (12).

RDEL: FORTRAN_FUNC,		! Delete a remote file (13).

RSUB: FORTRAN_FUNC,		! Submit remote file for batch processing (14).

RRENM: FORTRAN_FUNC,		! Rename a remote file (19).

RDIRS: FORTRAN_FUNC,		! Set up to do a remote directory listing (16A).

RDIR: FORTRAN_FUNC,		! Perform a remote directory listing (16B).

RPRINT: FORTRAN_FUNC,		! Print a remote file (15).

DAPERR: RMS$ERCAL NOVALUE,	! Error routine for DAP interface errors.

CONSTRUCT_FILESPEC: NOVALUE,	! Construct embedded file specification

COUNTEM;			! Count significant characters in a string
%sbttl 'Macro Definitions';

!
! Macro definitions:
!

MACRO

! Reference to start of any block, so we don't have to worry if this is a
! real block or a REF of one (sigh).

$			= 0, 0, 0, 0 %,

! Return a value:

DO_RETURN (val)		= (return (DILRET (val))) %;

! Status value:

KEYWORDMACRO

sts$value	(severity = STS$K_SEVERE,	! Severity code (severe,
						! ... warning, info, success)
		 code,				! Code
		 fac_sp = 1,			! Default is facility-specific
		 fac_no = 233,		! Default to DIT
		 cust_def = 0) =		! Default is Digital-defined

		(position_field (sts$m_severity, severity) OR
		 position_field (sts$m_code    , code    ) OR
		 position_field (sts$m_fac_sp  , fac_sp  ) OR
		 position_field (sts$m_fac_no  , fac_no  ) OR
		 position_field (sts$m_cust_def, cust_def)) %;
%sbttl 'Literals';

!
! Literals
!

LITERAL

! Useful constants:

TRUE			= -1,	! Use these so that multiple
FALSE			=  0,	!... bits can be set at once.

! Maximum number of files:

MAXFILES		= 20,

! Field sizes:

USERID_SIZE		= 39,
PASSWD_SIZE		= 39,
ACCT_SIZE		= 39,
FSPEC_SIZE		= 39,

! Length of embedded file specification:
! Node name               16
! "                        1
! userid                  USERID_SIZE
! <space>                  1
! password                PASSWD_SIZE
! <space>                  1
! account                 ACCT_SIZE
! "                        1
! ::                       2
! regular filespec        FSPEC_SIZE
! TOTAL                  178

WHOLESPEC_SIZE		=178,
! File open modes:

M_MIN			=  1,
M_READ			=  1,
M_WRITE			=  2,
M_APPEND		=  3,
M_MAX			=  3,

! File type codes:

T_MIN			=  0,
T_UNDEFINED		=  0,
T_ASCII			=  1,
T_IMAGE			=  2,
![33] Remove commenting characters when MACY11 is to be supported.
![33] Also change interface files.
!T_MACY11		=  3,
!T_MAX			=  3,
T_MAX			=  2,

! Record formats:

F_MIN			=  0,
F_UNDEFINED		=  0,
F_FIXED			=  1,
F_VARIABLE		=  2,
F_VFC			=  3,
F_STREAM		=  4,
F_MAX			=  4,

! Record attributes:

A_MIN			=  0,
A_UNSPECIFIED		=  0,
A_ENVELOPE		=  1,
A_PRINT			=  2,
A_FORTRAN		=  3,
A_MACY11		=  4,
A_MAX			=  4,

! Close options:

O_MIN			=  0,
O_NOTHING		=  0,
O_SUBMIT		=  1,
O_PRINT			=  2,
O_3			=  3,		! Reserved
O_DELETE		=  4,
O_SUB_DEL		=  5,
O_PRINT_DEL		=  6,
O_MAX			=  6,
! Status values for error returns:

DIT$_HORRIBLE =		! SYSERR
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 1),
DIT$_TOOMANY =		![25] TOOMNY
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 2),
DIT$_INVARG =		! INVARG
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 3),
DIT$_NETOPRFAIL =	! NETFAL
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 4),
DIT$_CHECKSUM =		! CHKSUM
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 5),
DIT$_UNSFILETYPE =	! UNSTYP
	STS$VALUE (SEVERITY = STS$K_ERROR, CODE = 6),
DIT$_FILEINUSE =	! FILIU
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 7),
DIT$_NOFILE =		! NOFILE
	STS$VALUE (SEVERITY = STS$K_SEVERE, CODE = 8),
DIT$_EOF =		! DITEOF
	STS$VALUE (SEVERITY = STS$K_WARNING, CODE = 9),
DIT$_OVERRUN =		! OVRRUN
	STS$VALUE (SEVERITY = STS$K_WARNING, CODE = 10),
DIT$_NOMOREFILES =	! NOMORE
	STS$VALUE (SEVERITY = STS$K_INFO, CODE = 11),
! Reserved for DAP up to 100.
! Catch-all for unexpected errors from all routines:

HORRIBLE		= DIT$_HORRIBLE,

! ROPEN return codes:

ROP$TOO_MUCH		= DIT$_TOOMANY,		![25]
ROP$WRONG_TYPE		= DIT$_INVARG,
ROP$OK			= SS$_NORMAL,
ROP$NO_NETWORK		= DIT$_NETOPRFAIL,
ROP$CHECKSUM		= DIT$_CHECKSUM,
ROP$BAD_TYPE		= DIT$_UNSFILETYPE,
ROP$FILE_ACT		= DIT$_FILEINUSE,
ROP$NO_FILE		= DIT$_NOFILE,

! RREAD return codes:

RRE$WRONG_TYPE		= DIT$_INVARG,
RRE$OK			= SS$_NORMAL,
RRE$NO_NETWORK		= DIT$_NETOPRFAIL,
RRE$CHECKSUM		= DIT$_CHECKSUM,
RRE$EOF			= DIT$_EOF,
RRE$OVERRUN		= DIT$_OVERRUN,

! RWRITE return codes:

RWR$WRONG_TYPE		= DIT$_INVARG,
RWR$OK			= SS$_NORMAL,
RWR$NO_NETWORK		= DIT$_NETOPRFAIL,
RWR$CHECKSUM		= DIT$_CHECKSUM,
RWR$NO_FILE		= DIT$_NOFILE,

! RCLOSE return codes:

RCL$WRONG_TYPE		= DIT$_INVARG,
RCL$OK			= SS$_NORMAL,
RCL$NO_NETWORK		= DIT$_NETOPRFAIL,
RCL$CHECKSUM		= DIT$_CHECKSUM,

! RDEL return codes:

RDE$WRONG_TYPE		= DIT$_INVARG,
RDE$OK			= SS$_NORMAL,
RDE$NO_NETWORK		= DIT$_NETOPRFAIL,
RDE$CHECKSUM		= DIT$_CHECKSUM,
RDE$NO_FILE		= DIT$_NOFILE,

! RSUB return codes:

RSU$WRONG_TYPE		= DIT$_INVARG,
RSU$OK			= SS$_NORMAL,
RSU$NO_NETWORK		= DIT$_NETOPRFAIL,
RSU$CHECKSUM		= DIT$_CHECKSUM,
RSU$NO_FILE		= DIT$_NOFILE,

! RRENM return codes:

RRN$WRONG_TYPE		= DIT$_INVARG,
RRN$OK			= SS$_NORMAL,
RRN$NO_NETWORK		= DIT$_NETOPRFAIL,
RRN$CHECKSUM		= DIT$_CHECKSUM,
RRN$NO_FILE		= DIT$_NOFILE,

! RDIRS return codes:

RDS$WRONG_TYPE		= DIT$_INVARG,
RDS$OK			= SS$_NORMAL,
RDS$NO_NETWORK		= DIT$_NETOPRFAIL,
RDS$CHECKSUM		= DIT$_CHECKSUM,
RDS$NO_FILE		= DIT$_NOFILE,

! RDIR return codes:

RDR$WRONG_TYPE		= DIT$_INVARG,
RDR$OK			= SS$_NORMAL,
RDR$NO_NETWORK		= DIT$_NETOPRFAIL,
RDR$NO_MORE		= DIT$_NOMOREFILES,
RDR$NO_FILE		= DIT$_NOFILE,

! RPRINT return codes:

RPR$WRONG_TYPE		= DIT$_INVARG,
RPR$OK			= SS$_NORMAL,
RPR$NO_NETWORK		= DIT$_NETOPRFAIL,
RPR$CHECKSUM		= DIT$_CHECKSUM,
RPR$NO_FILE		= DIT$_NOFILE;
%sbttl 'Data Structures';

!
! Data structures:
!

! File status, one for each of MAXFILES files:

$FIELD file_status_block =
	SET
	in_use			= [$BIT],
	file_type		= [$INTEGER]
	TES;

LITERAL
	file_status_block_size	= $FIELD_SET_SIZE;

! Whole embedded file specification:

$FIELD wholespec_fields =
	SET
	spec			= [$STRING (WHOLESPEC_SIZE)]
	TES;

LITERAL
	wholespec_len		= $FIELD_SET_SIZE;
! Standard 10/20 calling sequence fields:

FIELD scs_arg_fields =
	SET
	scs$v_type		= [0, 23, 4, 0],	! Type of argument
	scs$v_adr		= [0, 0, 23, 0]		! Address
	TES;

MACRO
	scs_arg			= BLOCK [1] FIELD (SCS_ARG_FIELDS) %;

! Values for type code:

LITERAL
	SCS$K_FOR36_BOOL	= %O'01',	! Boolean
	SCS$K_SBF36		= %O'02',	! One-word integer
	SCS$K_FLOAT36		= %O'04',	! One-word floating
	SCS$K_RTNADR		= %O'07',	! Routine address
	SCS$K_FLOAT72		= %O'10',	! 2-word float (not G)
	SCS$K_SBF72		= %O'11',	! 2-word integer
	SCS$K_FCMPLX36		= %O'14',	! Single-precision complex
	SCS$K_DISPLAY		= %O'15',	! COBOL string descriptor
	SCS$K_ASCIZ		= %O'17';	! ASCIZ string

! COBOL byte string descriptor:

FIELD scs_descriptor_fields =
	SET
	scs$v_bytpntr		= [0, 0, 36, 0],	! Byte pointer
	scs$v_bytsiz		= [0, 24, 6, 0],	! Byte size
	scs$v_numflg		= [1, 35, 1, 0],	! (?)
	scs$v_pscalflg		= [1, 23, 1, 0],	! (?)
	scs$v_scalfac		= [1, 18, 5, 1],	! (?)
	scs$v_lng		= [1, 0, 18, 0]		! Length
	TES;

MACRO
	SCS_DESCR		= BLOCK [2] FIELD (SCS_DESCRIPTOR_FIELDS) %;
! For binding something to a string pointer which could be a COBOL byte string:

MACRO
	GET_STRING (scs_parameter) =
		(if .scs_parameter [SCS$V_TYPE] eql SCS$K_DISPLAY
		    then		! COBOL byte string
			.(dixadr (.scs_parameter [SCS$V_ADR]))		![52]
		    else		! Some other type, so make byte pointer
			POINT ((dixadr (.scs_parameter)), 36, 7, 0, 0))%;![52]

! Get the address from something which may be a byte pointer:

MACRO
	GET_STRING_ADDRESS (scs_parameter) =
		(dixadr (.scs_parameter)) %;				![52]

![7] Insert at end of parameter-handling macros:
![7] Force ASCII or an error if this is a byte pointer:

MACRO									![7]
	FORCE_ASCII (scs_parameter, error) =				![7]
		(BIND real_arg = .scs_parameter [SCS$V_ADR]: SCS_DESCR; ![7]
		 if .scs_parameter [SCS$V_TYPE] eql SCS$K_DISPLAY	![7]
		    then		![7] COBOL byte string, check byte size
			if .real_arg [SCS$V_BYTSIZ] neq 7		![7]
			    then DO_RETURN (error)) %;			![7]
%sbttl 'RMS Data Structures';

! File Access Block:

!=========================================================================!
!             FAB$H_BID              !             FAB$H_BLN              !
!-------------------------------------------------------------------------!
!             FAB$H_STS              !             FAB$H_STV              !
!-------------------------------------------------------------------------!
!                                FAB$G_CTX                                !
!-------------------------------------------------------------------------!
!             FAB$A_IFI              !             FAB$H_JFN              !
!-------------------------------------------------------------------------!
!             FAB$H_FAC              !             FAB$H_SHR              !
!-------------------------------------------------------------------------!
!             FAB$H_FOP              ! Z_ORG ! FAB$Z_BSZ !   FAB$Z_BLS    !
!-------------------------------------------------------------------------!
!                                FAB$A_FNA                                !
!-------------------------------------------------------------------------!
!             FAB$H_RAT              !             FAB$H_MRS              !
!-------------------------------------------------------------------------!
!                                FAB$G_MRN                                !
!-------------------------------------------------------------------------!
!                FAB$Z_UNUSED_0      !FAB$Z_FSZ!   FAB$Z_BKS   !FAB$Z_RFM !
!-------------------------------------------------------------------------!
!             FAB$A_JNL              !             FAB$A_XAB              !
!-------------------------------------------------------------------------!
!             FAB$H_DEV              !             FAB$H_SDC              !
!-------------------------------------------------------------------------!
!             FAB$A_TYP              !             FAB$A_NAM              !
!-------------------------------------------------------------------------!
!                               FAB$G_ALQ                                 !
!-------------------------------------------------------------------------!
!                             FAB$G_UNUSED_3                              !
!-------------------------------------------------------------------------!
!                             FAB$G_UNUSED_4                              !
!=========================================================================!

! FAB$G_ALQ  (reserved for allocation quantity) (FTS)
! FAB$H_BID  Block identifier (static)
!     FAB$B_BID_1 (FTS)
!     FAB$V_DEV_REMOTE File is on a remote system (FTS)
! FAB$Z_BKS  Default bucket size (for relative or indexed files)
! FAB$H_BLN  Block length (static), length of the FAB
! FAB$Z_BLS  Block size (only input for magtapes)
! FAB$Z_BSZ  File byte size
! FAB$G_CTX  User context word (user data for completion routine in program)

! [Continued on next page ]
! FAB$H_DEV  Device characteristics (not set by user):
!     FAB$V_DEV_CCL  Carriage control device
!     FAB$V_DEV_MDI  ?
!     FAB$V_DEV_REC  Record-oriented device (sequential)
!     FAB$V_DEV_SQD  Sequential block-oriented device
!     FAB$V_DEV_TRM  Terminal device
! FAB$H_FAC  File access (NIL for quick and dirty read):
!     FAB$V_FAC_GET  Read access
!     FAB$V_FAC_UPD  Update access
!     FAB$V_FAC_PUT  Write access
!     FAB$V_FAC_DEL  Delete access
!     FAB$V_FAC_TRN  Truncate access
!     FAB$V_FAC_BIO  Block-mode I/O (FTS)
!     FAB$V_FAC_BRO  Block and record I/O (FTS)
!     FAB$V_FAC_APP  Append only (FTS)
! FAB$A_FNA  File specification string byte pointer
! FAB$H_FOP  File-processing options:
!     FAB$V_FOP_WAT  Wait for file access
!     FAB$V_FOP_CIF  Create if nonexistent
!     FAB$V_FOP_DRJ  Do not release JFN
!     FAB$V_FOP_DFW  Deferred write to file
!     FAB$V_FOP_SUP  Supersede existing file (FTS)
!     FAB$V_FOP_SPL  Print on close (FTS)
!     FAB$V_FOP_SCF  Submit on close (FTS)
!     FAB$V_FOP_DLT  Delete on close (FTS)
!     FAB$V_FOP_NAM  Use NAM block to open file (FTS)
!     FAB$V_FOP_CTG  File is contiguous (FTS)
!     FAB$V_FOP_LKO  Override lock (FTS)
!     FAB$V_FOP_TMP  Temporary file (FTS)
!     FAB$V_FOP_MKD  Mark for delete (FTS)
! FAB$Z_FSZ  Fixed header size (FTS)
! FAB$A_IFI  Internal file identifier (not set by user) (address of FST)
! FAB$H_JFN  User's JFN, if offered
! FAB$A_JNL  Address of log block
! FAB$G_MRN  Maximum record number
! FAB$H_MRS  Maximum record size
! FAB$A_NAM  Address of NAM block (FTS)
! FAB$Z_ORG  File organization (REL, IDX, SEQ)
! FAB$H_RAT  Record attributes (BLK, MACY11)
!     FAB$V_RAT_BLK     Blocked records
!     FAB$V_RAT_MACY11  MACY11 format (FTS)
!     FAB$V_RAT_FTN     Fortran carriage control (FTS)
!     FAB$V_RAT_CR      Implied <LF><CR> envelope (FTS)
!     FAB$V_RAT_PRN     VMS print file (FTS)
!     FAB$V_RAT_EMB     Embedded carriage control (FTS)
!     FAB$V_RAT_CBL     COBOL carriage control (FTS)
! FAB$Z_RFM  Record format (FIX, VAR, LSA, STM)
! FAB$H_SDC  Spooling device characteristics (not set by user)
! FAB$H_SHR  File sharing (PUT, GET, DEL, UPD, NIL, TRN)
! FAB$H_STS  Primary completion status code (not set by user)
! FAB$H_STV  Secondary status values (not set by user)
! FAB$A_TYP  Address of TYP block (FTS)
! FAB$A_XAB  Extended attribute block (XAB) address
! Record Access Block:

!=========================================================================!
!             RAB$H_BID              !             RAB$H_BLN              !
!-------------------------------------------------------------------------!
!             RAB$H_STS              !             RAB$H_STV              !
!-------------------------------------------------------------------------!
!                                RAB$G_CTX                                !
!-------------------------------------------------------------------------!
!             RAB$A_ISI              !             RAB$A_FAB              !
!-------------------------------------------------------------------------!
!    RAB$Z_RAC    !    RAB$Z_MBF     !             RAB$H_ROP              !
!-------------------------------------------------------------------------!
!                                RAB$A_UBF                                !
!-------------------------------------------------------------------------!
!                                RAB$A_RBF                                !
!-------------------------------------------------------------------------!
!             RAB$H_RSZ              !             RAB$H_USZ              !
!-------------------------------------------------------------------------!
!                                RAB$G_RFA                                !
!-------------------------------------------------------------------------!
!    RAB$Z_KRF    !    RAB$Z_KSZ     !             RAB$H_LSN              !
!-------------------------------------------------------------------------!
!                                RAB$A_KBF                                !
!-------------------------------------------------------------------------!
!                                RAB$G_BKT                                !
!-------------------------------------------------------------------------!
!    RAB$Z_PAD    !                    RAB$Z_UNUSED_0                     !
!-------------------------------------------------------------------------!
!                             RAB$G_UNUSED_1                              !
!-------------------------------------------------------------------------!
!                             RAB$G_UNUSED_2                              !
!-------------------------------------------------------------------------!
!                             RAB$G_UNUSED_3                              !
!=========================================================================!

! RAB$H_BID  Block identifier, identifies block as RAB, cannot be changed
! RAB$G_BKT  Bucket hash code
! RAB$H_BLN  Block length of the RAB, cannot be altered by user
! RAB$G_CTX  User context field
! RAB$A_FAB  File Access Block address
! RAB$A_ISI  Internal stream identifier (not set by user)
! RAB$A_KBF  Key buffer address
! RAB$Z_KRF  Key of reference
! RAB$Z_KSZ  Key size
! RAB$H_LSN  Line sequence number
! RAB$Z_MBF  Multibuffer count
! RAB$Z_PAD  Padding character
! RAB$Z_RAC  Record access mode (SEQ, KEY, RFA, TRA, BFT)
! RAB$A_RBF  Record address (NOT byte pointer!)

! [Continued on next page]
! RAB$G_RFA  Record's file address
! RAB$H_ROP  Record-processing options:
!     RAB$V_ROP_EOF  Set to EOF on $CONNECT
!     RAB$V_ROP_FDL  Fast delete
!     RAB$V_ROP_LOC  Use locate mode on $GETs
!     RAB$V_ROP_RAH  Read ahead
!     RAB$V_ROP_LOA  Use load limits
!     RAB$V_ROP_WBH  Write behind
!     RAB$V_ROP_KGT  Search key greater
!     RAB$V_ROP_KGE  Search key greater than or equal to
!     RAB$V_ROP_PAD  Use pad character as filler
!     RAB$V_ROP_NRP  Set NRP on $FIND
!     RAB$V_ROP_UIF  Update existing (FTS)
!     RAB$V_ROP_ULK  Manual unlock (FTS)
!     RAB$V_ROP_TPT  Truncate to EOF (FTS)
!     RAB$V_ROP_NLK  Do not lock (FTS)
!     RAB$V_ROP_RLK  Read locked record (FTS)
!     RAB$V_ROP_BIO  Block I/O (FTS)
!     RAB$V_ROP_LIM  Key limit (FTS)
!     RAB$V_ROP_NXR  Nonexistent record (FTS)
! RAB$H_RSZ  Record size (bytes)
! RAB$H_STS  Primary completion status code (not set by user)
! RAB$H_STV  Status value (not set by user)
! RAB$A_UBF  User record area address (NOT byte pointer)
! RAB$H_USZ  User record area size (words)
! Allocation-control XAB:

!=======================================================!
!       XABALL$H_BID        !       XABALL$H_BLN        !
!-------------------------------------------------------!
! XABALL$Z_UNUSED_0 ! Z_COD !       XABALL$A_NXT        !
!-------------------------------------------------------!
!     XABALL$Z_UNUSED_1     !XABALL$Z_AID !XABALL$Z_BKZ !
!-------------------------------------------------------!
!                   XABALL$G_UNUSED_2                   !
!-------------------------------------------------------!
!                   XABALL$G_UNUSED_3                   !
!-------------------------------------------------------!
!                   XABALL$G_UNUSED_4                   !
!=======================================================!

! XABALL$Z_AID  Area identification number
! XABALL$H_BID  Block type
! XABALL$Z_BKZ  Bucket size
! XABALL$H_BLN  Block length (not set by user)
! XABALL$Z_COD  XAB type code (static)
! XABALL$A_NXT  Next XAB address
! Summary XAB:

!=======================================================!
!       XABSUM$H_BID        !       XABSUM$H_BLN        !
!-------------------------------------------------------!
! XABSUM$Z_UNUSED_0 ! Z_COD !       XABSUM$A_NXT        !
!-------------------------------------------------------!
!     XABSUM$H_UNUSED_1     !XABSUM$Z_NOK !XABSUM$Z_NOA !
!-------------------------------------------------------!
!                   XABSUM$G_UNUSED_2                   !
!-------------------------------------------------------!
!                   XABSUM$G_UNUSED_3                   !
!-------------------------------------------------------!
!                   XABSUM$G_UNUSED_4                   !
!=======================================================!

! XABSUM$H_BID  Block type
! XABSUM$H_BLN  Block length
! XABSUM$Z_COD  XAB type code
! XABALL$Z_NOA  Number of allocation areas defined for the file
! XABSUM$Z_NOK  Number of keys defined for the file
! XABSUM$A_NXT  Next XAB address
! Date and time XAB:

!=======================================================!
!       XABDAT$H_BID        !       XABDAT$H_BLN        !
!-------------------------------------------------------!
! XABDAT$Z_UNUSED_0 ! Z_COD !       XABDAT$A_NXT        !
!-------------------------------------------------------!
!                     XABDAT$G_CDT                      !
!-------------------------------------------------------!
!                     XABDAT$G_RDT                      !
!-------------------------------------------------------!
!                     XABDAT$G_EDT                      !
!=======================================================!

! XABDAT$H_BID  Block type
! XABDAT$H_BLN  Block length
! XABDAT$G_CDT  Creation date and time
! XABDAT$Z_COD  XAB type code
! XABDAT$G_EDT  Expiration (deletion) date and time
! XABDAT$A_NXT  Next XAB address
! XABDAT$G_RDT  Revision (read) date and time
! Key definition XAB:

!=======================================================!
!       XABKEY$H_BID        !       XABKEY$H_BLN        !
!-------------------------------------------------------!
! XABKEY$Z_UNUSED_0 ! Z_COD !       XABKEY$A_NXT        !
!-------------------------------------------------------!
!XABKEY$Z_UNUSED_1!  Z_DTP  !       XABKEY$H_FLG        !
!-------------------------------------------------------!
!XABKEY$Z_IAN !XABKEY$Z_DAN !XABKEY$Z_LAN !XABKEY$Z_REF !
!-------------------------------------------------------!
!       XABKEY$H_IFL        !       XABKEY$H_DFL        !
!-------------------------------------------------------!
!                     XABKEY$A_KNM                      !
!-------------------------------------------------------!
!                     XABKEY$G_RES0 (reserved)          !
!-------------------------------------------------------!
!                     XABKEY$G_RES1 (reserved)          !
!-------------------------------------------------------!
!                   XABKEY$G_UNUSED_2                   !
!-------------------------------------------------------!
!                   XABKEY$G_UNUSED_3                   !
!-------------------------------------------------------!
!                   XABKEY$G_UNUSED_4                   !
!-------------------------------------------------------!
!       XABKEY$H_POS0       !       XABKEY$H_SIZ0       !
!-------------------------------------------------------!
!       XABKEY$H_POS1       !       XABKEY$H_SIZ1       !
!-------------------------------------------------------!
!       XABKEY$H_POS2       !       XABKEY$H_SIZ2       !
!-------------------------------------------------------!
!       XABKEY$H_POS3       !       XABKEY$H_SIZ3       !
!-------------------------------------------------------!
!       XABKEY$H_POS4       !       XABKEY$H_SIZ4       !
!-------------------------------------------------------!
!       XABKEY$H_POS5       !       XABKEY$H_SIZ5       !
!-------------------------------------------------------!
!       XABKEY$H_POS6       !       XABKEY$H_SIZ6       !
!-------------------------------------------------------!
!       XABKEY$H_POS7       !       XABKEY$H_SIZ7       !
!=======================================================!

! [Continued on next page]
! XABKEY$H_BID  Block type
! XABKEY$H_BLN  Block length
! XABKEY$Z_COD  XAB type code
! XABKEY$Z_DAN  Data bucket area number
! XABKEY$H_DFL  Data bucket file size (limit)
! XABKEY$Z_DTP  Data type of the key (STG, EBC, SIX)
! XABKEY$H_FLG  Key flags
!     XABKEY$V_FLG_DUP  Duplicate keys allowed
!     XABKEY$V_FLG_CHG  Change of key allowed
!     XABKEY$V_FLG_HSH  Hash method of index org.
! XABKEY$Z_IAN  Index buckets area number
! XABKEY$H_IFL  Index bucket file size (limit)
! XABKEY$A_KNM  Key name buffer address
! XABKEY$Z_LAN  Lowest level of index area number
! XABKEY$A_NXT  Address of next XAB in chain
! XABKEY$H_POSn Key position (0 through 7)
! XABKEY$Z_REF  Key of reference
! XABKEY$H_SIZn Key size (0 through 7)
! Name Block (only really needed for wildcarding):

!=========================================================================!
!             NAM$H_BID              !             NAM$H_BLN              !
!-------------------------------------------------------------------------!
!                               NAM$A_ESA                                 !
!-------------------------------------------------------------------------!
!             NAM$H_ESL              !             NAM$H_ESS              !
!-------------------------------------------------------------------------!
!                               NAM$A_RLF                                 !
!-------------------------------------------------------------------------!
!                               NAM$A_RSA                                 !
!-------------------------------------------------------------------------!
!             NAM$H_RSS              !             NAM$H_RSL              !
!-------------------------------------------------------------------------!
!                               NAM$G_FNB                                 !
!-------------------------------------------------------------------------!
!                               NAM$T_NODE                                !
!-------------------------------------------------------------------------!
!                               NAM$T_USERID                              !
!-------------------------------------------------------------------------!
!                               NAM$T_PASSWORD                            !
!-------------------------------------------------------------------------!
!                               NAM$T_ACCOUNT                             !
!-------------------------------------------------------------------------!
!                               NAM$T_OPTIONAL_DATA                       !
!-------------------------------------------------------------------------!
!                               NAM$T_DVI                                 !
!-------------------------------------------------------------------------!
!                               NAM$T_DIR                                 !
!-------------------------------------------------------------------------!
!                               NAM$T_NAM                                 !
!-------------------------------------------------------------------------!
!                               NAM$T_EXT                                 !
!-------------------------------------------------------------------------!
!                               NAM$T_VER                                 !
!-------------------------------------------------------------------------!
!                               NAM$G_WCC                                 !
!-------------------------------------------------------------------------!
!                                    !             NAM$Z_CHA              !
!=========================================================================!

! [Continued on next page]
! NAM$T_ACCOUNT  Account
! NAM$H_BID  Block identifier (not set by user)
! NAM$H_BLN  Block length (not set by user)
! NAM$Z_CHA  What changed (EXT, NAM, DIR, STR)
! NAM$T_DIR  Directory
! NAM$T_DVI  Device identification (not set by user)
! NAM$A_ESA  Expanded string area address
! NAM$H_ESL  Expanded string length (not set by user)
! NAM$H_ESS  Expanded string area size
! NAM$T_EXT  Extension
! NAM$G_FNB  File name status bits (not set by user):
!     NAM$V_FNB_ACT      Account given
!     NAM$V_FNB_DEV      Wildcard in device
!     NAM$V_FNB_DIR      Wildcard in directory
!     NAM$V_FNB_EXT      Wildcard in extension
!     NAM$V_FNB_GND      Ignore deleted files
!     NAM$V_FNB_INV      Ignore invisible files
!     NAM$V_FNB_NAM      Wildcard in filename
!     NAM$V_FNB_NHV      Next higher generation
!     NAM$V_FNB_NODE     File specification includes a node name
!     NAM$V_FNB_PRO      Protection given
!     NAM$V_FNB_QUOTED   File specification includes a quoted string
!     NAM$V_FNB_TFS      Temporary file
!     NAM$V_FNB_UHV      Highest generation
!     NAM$V_FNB_ULV      Lowest generation
!     NAM$V_FNB_UNT      Wildcard in unit number (never)
!     NAM$V_FNB_VER      Wildcard in generation number
!     NAM$V_FNB_WILDCARD File specification string includes a wildcard
! NAM$T_NAM  Name
! NAM$T_NODE  Node name
! NAM$T_OPTIONAL_DATA  Optional data
! NAM$T_PASSWORD Password
! NAM$A_RLF  Related file NAM block address
! NAM$A_RSA  Resultant string area address
! NAM$H_RSL  Resultant string length (not set by user)
! NAM$H_RSS  Resultant string area size
! NAM$T_USERID Userid
! NAM$T_VER  Version number
! NAM$G_WCC  Wildcard context (not set by user)
! TYPE block (needed if data type is not ASCII):

!=========================================================================!
!             TYP$H_BID              !             TYP$H_BLN              !
!-------------------------------------------------------------------------!
!             TYP$H_CODE             !             TYP$H_CLASS            !
!-------------------------------------------------------------------------!
!                 !   TYP$B_SCALE    !             TYP$H_LENGTH           !
!-------------------------------------------------------------------------!
!             TYP$A_MORE             !             TYP$A_NEXT             !
!=========================================================================!

! TYP$H_BID    Block identifier
! TYP$H_BLN    Block length
! TYP$H_CLASS  Data type (ASCII, IMAGE, MACY11)
! TYP$H_CODE   Reserved for secondary data type
! TYP$H_LENGTH Reserved for length of field
! TYP$A_MORE   Alternate chain (multiple record formats)
! TYP$A_NEXT   Descriptor for next field
! TYP$B_SCALE  Reserved for scale factor
%sbttl 'Own Storage';

!
! Own storage:
!

OWN

! File status:
! in_use			TRUE if this file is in use
! file_type			T_ASCII, T_IMAGE, or T_UNDEFINED

file_status: BLOCKVECTOR [MAXFILES, file_status_block_size]
	FIELD (file_status_block),

! File Access Blocks: Describe files and contain file-related information.

fabs: BLOCKVECTOR [MAXFILES, FAB$K_BLN]
	FIELD ($FAB_BLOCK_FIELDS),

! Record Access Blocks: Describe records and contain record-related information.

rabs: BLOCKVECTOR [MAXFILES, RAB$K_BLN]
	FIELD ($RAB_BLOCK_FIELDS),

! Type blocks:

types: BLOCKVECTOR [MAXFILES, TYP$K_BLN]
	FIELD ($TYP_BLOCK_FIELDS),

! Complete embedded file specifications:

wholespec: BLOCKVECTOR [MAXFILES, WHOLESPEC_LEN]
	FIELD (WHOLESPEC_FIELDS),

! FAB for directory:

dirfab: $FAB_DECL,

! FAB for other static uses:

afab: $FAB_DECL,

dfab: $FAB_DECL,

! Embedded file specifications:

dirspec: BLOCK [WHOLESPEC_LEN] FIELD (WHOLESPEC_FIELDS),

wholespeca: BLOCK [WHOLESPEC_LEN] FIELD (WHOLESPEC_FIELDS),

wholespecd: BLOCK [WHOLESPEC_LEN] FIELD (WHOLESPEC_FIELDS);
%sbttl 'Builtins';

![52]
![52] Builtins
![52]

BUILTIN	POINT;		![52] Generate a real honest-to-goodness bptr
%sbttl 'External References';

!
! External references:
!

EXTERNAL ROUTINE

	DIXADR,			![52] DIX$$GET_ARGADR Get by-reference
				![52] argument address (Bliss makes bad code)

	R$OPEN,			! Open an existing local or remote file.

	R$CREATE,		! Open a new local or remote file.

	R$ERASE,		! Delete a local or remote file.

	R$CLOSE,		! Close a local or remote file.

	R$GET,			! Get a record from an open file.

	R$PUT,			! Write a record to an open file.

	R$DIRECTORY,		! Open a directory for listing.

	R$SEARCH,		! Get directory information for a file.

	R$LIST,			! Create directory listing line.

	R$RENAME,		! Rename a file.

	R$CONNECT,		! Connect FAB to RAB.

	DILRET;			! Return status values
%sbttl 'ROPEN: Open a remote file (11)'

GLOBAL ROUTINE ROPEN (fnumber, fname, userid, passwd, acct, mode,
	dtype, rformat, rattrs, rsize, runits): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Open a remote or local file for sequential processing.
!
! FORMAL PARAMETERS:
!	fnumber		File number, assigned by this routine.
!	fname		File name, including node name, in ASCII.
!	userid		USERID_SIZE ASCII character user code.
!	passwd		PASSWD_SIZE character ASCII password.
!	acct		ACCT_SIZE ASCII character account.
!	mode		Mode to open file:
!			M_READ to read,
!			M_WRITE to write,
!			M_APPEND to append.
!	dtype		File data type:
!			T_UNDEFINED for undefined,
!			T_ASCII for ASCII, or
!			T_IMAGE for image.
!	rformat		Record format:
!			F_UNDEFINED for undefined,
!			F_FIXED for fixed length,
!			F_VARIABLE for variable length,
!			F_VFC for variable with fixed-length control (VFC),
!			or F_STREAM for ASCII stream format.
!	rattrs		Record attributes:
!			A_UNSPECIFIED for unspecified,
!			A_ENVELOPE for implied <LF><CR> envelope,
!			A_PRINT for VMS printer carriage control,
!			A_FORTRAN for Fortran carriage control, or
!			A_MACY11 for MACY11 format.
!	rsize		Record size.  The record size, if required, is
!			measured in bytes of the size given by the user as the
!			record size units.
!	runits		Record size units, in bits.  This parameter is currently
!			included only for user convenience and does not affect
!			how the data is actually transmitted by the network.
!			Zero is assumed to mean characters for ASCII or words
!			(on the local system) for image files.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	ROP$TOO_MUCH if another file cannot be opened.  The maximum is
!		MAXFILES.
!	ROP$WRONG_TYPE if an argument is of the wrong type or is invalid
!		Mode, dtype, rformat, or rattrs is out of range, or
!		the file name has invalid syntax (RMS$_FSI).
!	ROP$OK if the operation succeeded.
!	ROP$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	ROP$CHECKSUM if there was a checksum error (RMS$_CRC).
!	ROP$BAD_TYPE if the user-specified file type for writing a file
!		cannot be done.
!	ROP$FILE_ACT if file activity precludes this operation.
!	ROP$NO_FILE if the file does not exist or is not available
!		(RMS$_FEX, RMS$_FNF, RMS$_FLK, RMS$_PRV).
!	HORRIBLE if some other error occurs.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

BEGIN	! ROPEN

MAP
	fname:		SCS_ARG,
	userid:		SCS_ARG,
	passwd:		SCS_ARG,
	acct:		SCS_ARG;

BIND
	a_fnumber =	(dixadr (.fnumber)),				![52]
	a_fname =	GET_STRING (fname),
	a_userid =	GET_STRING (userid),
	a_passwd =	GET_STRING (passwd),
	a_acct =	GET_STRING (acct),				![52]
	a_mode =	(dixadr (.mode)),				![52]
	a_dtype =	(dixadr (.dtype)),				![52]
	a_rformat =	(dixadr (.rformat)),				![52]
	a_rattrs =	(dixadr (.rattrs)),				![52]
	a_rsize =	(dixadr (.rsize)),				![52]
	a_runits =	(dixadr (.runits));				![52]

LOCAL
	error_code,
	rsz;

! TTY_PUT_QUO ('DAP: Entering ROPEN');  TTY_PUT_CRLF ();

! Check parameters.

![7] Check byte pointers for ASCII in ROPEN.
FORCE_ASCII (fname, ROP$WRONG_TYPE);			![7]
FORCE_ASCII (userid, ROP$WRONG_TYPE);			![7]
FORCE_ASCII (passwd, ROP$WRONG_TYPE);			![7]
FORCE_ASCII (acct, ROP$WRONG_TYPE);			![7]
if (.a_mode lss M_MIN) or (.a_mode gtr M_MAX)		![52]
    then DO_RETURN (ROP$WRONG_TYPE);
if (.a_dtype lss T_MIN) or (.a_dtype gtr T_MAX)		![52]
    then DO_RETURN (ROP$WRONG_TYPE);
if (.a_rformat lss F_MIN) or (.a_rformat gtr F_MAX)	![52]
    then DO_RETURN (ROP$WRONG_TYPE);
if (.a_rattrs lss A_MIN) or (.a_rattrs gtr A_MAX)	![52][53]
    then DO_RETURN (ROP$WRONG_TYPE);

! Get a file slot.

! TTY_PUT_QUO ('DAP: ROPEN find file slot');  TTY_PUT_CRLF ();
a_fnumber = (incr i from 0 to MAXFILES - 1 do		![52]
    if not .file_status [.i, in_use] then exitloop .i);
if (.a_fnumber eql MAXFILES) or (.a_fnumber eql -1)	![52]
    then DO_RETURN (ROP$TOO_MUCH);

file_status [.a_fnumber, in_use] = TRUE;		![52]

! Construct embedded file specification.

! TTY_PUT_QUO ('DAP: ROPEN call CONSTRUCT_FILESPEC');  TTY_PUT_CRLF ();
CONSTRUCT_FILESPEC (a_fname, a_userid, a_passwd, a_acct,
    wholespec [.a_fnumber, spec]);

! Construct File Access Block.

! FAB input fields:
! BKS  Bucket size (ignored if allocation XAB present)
! BLS  Blocksize (magtape only)
! FAC  File access
! FNA  File specification string address
! FOP  File-processing options (NAM, SCF, or SPL only for $CREATE)
! IFI  Internal file identifier (must be zero)
! MRN  Maximum record number (relative organization only)
! MRS  Maximum record size
! NAM  Name block address
! ORG  File organization (REL, IDX, SEQ)
! RAT  Record attributes (BLK, MACY11)
! RFM  Record format, unit record devices only (FIX, VAR, LSa, STM)
! SHR  File sharing (PUT, GET, DEL, UPD, NIL, TRN)
! XAB  Extended attribute block address

! FAB output fields:
! BKS  Bucket size; not used for sequential files
! BLS  Block size (sequential organization only)
! DEV  Device characteristics
! FOP  File-processing options
! IFI  Internal file identifier
! MRN  Maximum record number, for relative files only
! MRS  Maximum record size
! ORG  File organization
! RAT  Record attributes
! RFM  Record format
! SDC  Spooling device characteristics
! STS  Completion status code
! STV  Status value (I/O channel number)

! NAM input fields:
! DVI  Device identification (if NAM bit set in FOP of FAB)
! ESA  Expanded string area address
! ESS  Expanded string area size
! RLF  Related file NAM block address (if nonzero, RSA and RSL are input from
!      related file NAM block)
! RSA  Resultant string area address
! RSS  Resultant string area size

! NAM output fields:
! DVI  Device identification
! ESL  Expanded string length
! FNB  File name status bits
! RSL  Resultant string length

! TTY_PUT_QUO ('DAP: ROPEN checking dtype');  TTY_PUT_CRLF ();
if (.a_dtype eql T_IMAGE)						![52]
    then				! Image mode
	if (.a_runits eql 0)						![52]
	    then rsz = .a_rsize						![52]
	    else rsz = (.a_runits * .a_rsize + 1) / 36			![52]
    else				! ASCII or undefined mode
	if (.a_runits eql 0)						![52]
	    then rsz = .a_rsize						![52]
	    else rsz = (.a_runits * .a_rsize + 1) / 7;			![52]

! TTY_PUT_QUO ('DAP: ROPEN Initialize FAB');  TTY_PUT_CRLF ();
$FAB_INIT (FAB = fabs [.a_fnumber, $], CTX = .a_fnumber, ORG = SEQ,	![52]
    FNA = CH$PTR (wholespec [.a_fnumber, $]), MRS = .rsz,		![52]
    TYP = types [.a_fnumber, $]);					![52]

! Do type:

! TTY_PUT_QUO ('DAP: ROPEN do type');  TTY_PUT_CRLF ();
file_status [.a_fnumber, file_type] = .a_dtype;				![52]
![33] Change in .a_dtype code in ROPEN	CLR	24-Nov-82
case .a_dtype from T_MIN to T_MAX of				![33][52]
    SET								![33]
    [T_UNDEFINED]:	;					![33]
    [T_ASCII]:							![33]
	$TYP_INIT (TYP = types [.a_fnumber, $],			![33][52]
	    CLASS = TYP$K_CLASS_ASCII);				![33] ASCII/undefined
    [T_IMAGE]:							![33]
	$TYP_INIT (TYP = types [.a_fnumber, $],			![33][52]
	    CLASS = TYP$K_CLASS_IMAGE);				![33] Image
![33] Remove commenting characters when MACY11 is to be supported.
!   [T_MACY11]:							![33]
!	$TYP_INIT (TYP = types [.a_fnumber, $],			![33][52]
!	    CLASS = TYP$K_CLASS_MACY11);			![33] MACY11
    TES;							![33]
![33]if ..dtype neq T_IMAGE
![33]    then $TYP_INIT (TYP = types [..fnumber, $],
![33]	CLASS = TYP$K_CLASS_ASCII)	! ASCII/undefined
![33]    else $TYP_INIT (TYP = types [..fnumber, $],
![33]	CLASS = TYP$K_CLASS_IMAGE);	! Image

! Do record format:

! TTY_PUT_QUO ('DAP: ROPEN do record format');  TTY_PUT_CRLF ();
case .a_rformat from F_MIN to F_MAX of				![52]
    SET
![33] Change in F_UNDEFINED case of .a_rformat in ROPEN	CLR	24-Nov-82
![33]    [F_UNDEFINED]:	;		! Undefined
    [F_UNDEFINED]:			![33] Undefined
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RFM = UDF);	![33][52]
    [F_FIXED]:				! Fixed length
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RFM = FIX);	![52]
    [F_VARIABLE]:			! Variable length
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RFM = VAR);	![52]
    [F_VFC]:				! VFC
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RFM = VFC);	![52]
    [F_STREAM]:				! ASCII stream
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RFM = STM);	![52]
    TES;

! Do access mode:

! TTY_PUT_QUO ('DAP: ROPEN do access mode');  TTY_PUT_CRLF ();
if .a_mode neq M_READ
    then $FAB_STORE (FAB = fabs [.a_fnumber, $], FAC = PUT)	![52] Not read
    else $FAB_STORE (FAB = fabs [.a_fnumber, $], FAC = GET);	![52] Read

! Do record attributes:

! TTY_PUT_QUO ('DAP: ROPEN do record attributes');  TTY_PUT_CRLF ();
case .a_rattrs from A_MIN to A_MAX of				![52]
    set
    [A_UNSPECIFIED]:	;	! Unspecified
    [A_ENVELOPE]:		! Implied <LF><CR> envelope
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RAT = CR);	![52]
    [A_PRINT]:			! VMS printer carriage control
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RAT = PRN);	![52]
    [A_FORTRAN]:		! Fortran carriage control
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RAT = FTN);	![52]
    [A_MACY11]:			! MACY11 format
	$FAB_STORE (FAB = fabs [.a_fnumber, $], RAT = MACY11);	![52]
    tes;

! Ensure treatment as a remote file.

fabs [.a_fnumber, FAB$V_DEV_REMOTE] = TRUE;			![52]

! Do the operation.

! TTY_PUT_QUO ('DAP: ROPEN Do operation');  TTY_PUT_CRLF ();
case .a_mode from M_MIN to M_MAX of				![52]
    set
    [M_READ]:					! Read existing file
		R$OPEN (fabs [.a_fnumber, $], DAPERR);		![52]
    [M_WRITE]:					! Write new file
		R$CREATE (fabs [.a_fnumber, $], DAPERR);	![52]
    [M_APPEND]:	begin				! Append to file
		$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = CIF);	![52]
		R$OPEN (fabs [.a_fnumber, $], DAPERR);		![52]
		end;
    tes;

! TTY_PUT_QUO ('DAP: ROPEN after $CREATE or $OPEN');  TTY_PUT_CRLF ();

!
! Now, depending on who we connected to, we might have had the BSZ field
! changed (FAL-10 is a know culprit).  So, for safety sake, in the case
! of an ASCII file, reset the value to 7-bit bytes.
!
IF .a_dtype EQL T_ASCII
THEN
    $FAB_STORE (FAB = fabs [.a_fnumber, $], BSZ = 7);

error_code = 0;
selectone .fabs [.a_fnumber, FAB$H_STS] of			![52]
    set

    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FEX,			! File already exists
     RMS$_FNF,			! File not found
     RMS$_FLK,			! File locked; not available
     RMS$_PRV]:			! File protection violation
			error_code = (ROP$NO_FILE);

    [RMS$_FSI]:			! File spec contains invalid syntax
			error_code = (ROP$WRONG_TYPE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			error_code = (ROP$NO_NETWORK);

!   [RMS$_AID,			! Area XABs not ascending by AID value
!    RMS$_BKZ,			! BKZ in AREA XAB greater than 31
!    RMS$_BLN,			! FAB or entry in XAB chain has bad BLN
!    RMS$_CGJ,			! Cannot get JFN for file
!    RMS$_COD,			! Entry on XAB chain has bad COD
!    RMS$_COF,			! Cannot open file
!    RMS$_DAN,			! DAN in KEY XAB greater than highest AID
!    RMS$_DEV,			! Device is not disk
!    RMS$_DTP,			! DTP in KEY XAB invalid or disagrees
!				! with BSZ of FAB
!    RMS$_IAN,			! IAN in KEY XAB greater than highest AID
!    RMS$_IMX,			! Multiple copies of DATE or SUMMARY XAB
!    RMS$_ORD,			! KEY XABs not in ascending order by REF field
!				! or AREA XABs not in ascending order by AID
!    RMS$_RAT,			! BLK specified for stream file
!    RMS$_REF,			! KEY XABs are not ascending by REF field value
!    RMS$_SIZ]:			! Number of bytes in data key exceeds 255
    [OTHERWISE]:	error_code = (HORRIBLE);

    tes;
IF .error_code NEQ 0
THEN
    BEGIN
    R$CLOSE (fabs [.a_fnumber, $], DAPERR);	!if error on OPEN, close link
    DO_RETURN (.error_code);
    END;

! Construct Record Access Block.

! TTY_PUT_QUO ('DAP: ROPEN construct RAB');  TTY_PUT_CRLF ();
$RAB_INIT (RAB = rabs [.a_fnumber, $], FAB = fabs [.a_fnumber, $], RAC = TRA);![52][53]

! If APPEND mode, position to EOF.

if .a_mode eql M_APPEND							![52]
    then $RAB_STORE (RAB = rabs [.a_fnumber, $], ROP = EOF);		![52]

! Connect RAB to file.

! TTY_PUT_QUO ('DAP: ROPEN connect RAB to FAB');  TTY_PUT_CRLF ();
R$CONNECT (rabs [.a_fnumber, $], DAPERR);				![52]

! TTY_PUT_QUO ('DAP: ROPEN after CONNECT');  TTY_PUT_CRLF ();
error_code = 0;
selectone .rabs [.a_fnumber, RAB$H_STS] of				![52]
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			error_code = (ROP$NO_NETWORK);

!   [RMS$_CCR,			! Cannot connect RAB
!    RMS$_IFI,			! Bad IFI value (file not open?)
!    RMS$_KRF,			! Bad KRF value
!    RMS$_PEF]:			! Cannot position to EOF for append
!				! (file not sequential)
    [OTHERWISE]:	error_code = (HORRIBLE);

    tes;
IF .error_code NEQ 0
THEN
    BEGIN
    R$CLOSE (fabs [.a_fnumber, $], DAPERR);	!if error on OPEN, close link
    DO_RETURN (.error_code);
    END;

! TTY_PUT_QUO ('DAP: Leaving  ROPEN');  TTY_PUT_CRLF ();
DO_RETURN (ROP$OK);

END;	! ROPEN
%sbttl 'RREAD: Read a remote file (18)'

GLOBAL ROUTINE RREAD (fnumber, runits, rmax, data): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Read an ASCII or image record from a file opened by ROPEN.
!
!   Note that line sequence  numbers and page  marks will be removed from
! TOPS10/TOPS20  files which are  opened in an  ASCII mode.   If the user
! needs to read the line sequence numbers as data, he should use an image
! mode, not ASCII.
!
! FORMAL PARAMETERS:
!	fnumber		File number, from the ROPEN routine.
!	runits		Data unit size.  Ignored if the file is in ASCII;
!			otherwise the data length unit size in bits.  If
!			zero, the data is in words.  This parameter is
!			currently only included for user convenience and
!			does not affect how data is actually shipped
!			through the network.
!	rmax		Maximum record size (or zero), returned as the
!			length of data returned, in characters if ASCII
!			or in bytes of the data unit size given by the
!			user (or words), if image.
!	data		Data read.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RRE$WRONG_TYPE if an argument is of the wrong type or is
!		invalid.  The file number may be incorrect or
!		may refer to a file which is not open.
!	RRE$OK if the operation succeeded.
!	RRE$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RRE$CHECKSUM if there was a checksum error (RMS$_CRC).
!	RRE$EOF if end of file occurred (RMS$_EOF).
!	RRE$OVERRUN if the record is too large for the user buffer (RMS$_RTB).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

BEGIN	! RREAD

MAP
	data:		SCS_ARG;

BIND
	a_fnumber =	(dixadr (.fnumber)),			![52]
	a_runits =	(dixadr (.runits)),			![52]
	a_rmax =	(dixadr (.rmax)),			![52]
	a_data =	GET_STRING_ADDRESS (data);

LOCAL
	size;

! TTY_PUT_QUO ('DAP: Entering RREAD');  TTY_PUT_CRLF ();

! Check parameters.

if (.a_fnumber lss 0) or (.a_fnumber geq MAXFILES)		![52]
    then DO_RETURN (RRE$WRONG_TYPE);
if not .file_status [.a_fnumber, in_use]			![52]
    then DO_RETURN (RRE$WRONG_TYPE);

! Initialize the RAB.

! RAB input fields:
! ISI  Internal stream identifier
! KBF  Key buffer address
! KRF  Key of reference
! KSZ  Key buffer size
! RAC  Record access mode (SEQ, KEY, RFA, TRA, BFT)
! RFA  Record's address (only for RAC = RFA)
! ROP  Record-processing options (EOF, FDL, LOC, RAH, LOA, WBH, KGT, KGE, PAD, NRP)
! UBF  User record area address
! USZ  User record area size

! RAB output fields:
! BKT  Bucket code (relative record number for relative file accessed
!      sequentially)
! RBF  Record address
! RFA  Record's file address
! RSZ  Record size
! STS  Completion status code
! STV  Status value (termination character for terminal input, or record length
!      if record too large for user buffer area)

![43] Correctly set USZ field of RAB before R$GET in RREAD to know that
![43] the value is in words, not bytes.
if .file_status [a_fnumber, file_type] eql T_IMAGE		![52]
    then			! Image file type
	if .a_runits eql 0	![52][43] words
	    then size = .a_rmax	![52][43] Already in words
	    else size = (.a_rmax * .a_runits + 35) / 36	![52][43] Convert to words
    else			! ASCII or undefined file type
![43]	if ..runits eql 0
![43]	    then size = ..rmax
![43]	    else size = (..rmax * ..runits + 1) / 7;
	size = (.a_rmax + 4) / 5;	![52][43] Convert ASCII bytes to words

$RAB_STORE (RAB = rabs [.a_fnumber, $], UBF = a_data, USZ = .size);	![52]

R$GET (rabs [.a_fnumber, $], DAPERR);					![52]

selectone .rabs [.a_fnumber, RAB$H_STS] of				![52]
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_EOF]:			! End of file
			DO_RETURN (RRE$EOF);

    [RMS$_RTB]:			! Warning: record too large for user buffer
			DO_RETURN (RRE$OVERRUN);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RRE$NO_NETWORK);

!   [RMS$_DEL,			! RFA access to deleted record
!    RMS$_FAC,			! GET in FAC not set
!    RMS$_IOP,			! Key access to SEQ file or RFA access to
!				! stream file
!    RMS$_ISI,			! RAB is not connected
!    RMS$_KBF,			! No key buffer pointer (only if KEY)
!    RMS$_KEY,			! Record number 0 or greater than MRN
!				! (only if KEY and REL)
!    RMS$_KRF,			! Invalid key of reference (only if IDX and KEY)
!    RMS$_KSZ,			! KSZ greater than key identified by KRF
!    RMS$_LSN,			! Line-sequence-number of accessed record is bad
!    RMS$_RFA,			! Bad RFA value in RFA field (if RFA)
!    RMS$_RLK,			! Record locked by another stream
!    RMS$_RNF,			! Record not found
!    RMS$_UBF]:			! No user buffer pointer
    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

![43] Set the "rmax" parameter to indicate how many bytes of size "rsize"
![43] were read, using the RSZ field in the RAB, which is in bytes for ASCII
![43] files or words for image files.

size = .rabs [.a_fnumber, RAB$H_RSZ];			![43][52]
if .file_status [.a_fnumber, file_type] eql T_IMAGE	![43][52]
    then						![43] image file type
	if .a_runits eql 0				![43][52]
	    then a_rmax = .size				![52][43] image words
	    else a_rmax = (.size * 36) / .a_runits	![52][43] image bytes
    else						![43] ASCII file type
	a_rmax = .size;					![52][43] ASCII characters

! TTY_PUT_QUO ('DAP: Leaving  RREAD');  TTY_PUT_CRLF ();
DO_RETURN (RRE$OK);

END;	! RREAD
%sbttl 'RWRITE: Write to a remote file (17)'

GLOBAL ROUTINE RWRITE (fnumber, runits, length, data): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Write an ASCII or image record into a file opened by ROPEN.
!
! FORMAL PARAMETERS:
!	fnumber		File number, from the ROPEN routine.
!	runits		Data unit size.  Ignored if the file is in ASCII;
!			otherwise the data length unit size in bits.  If
!			zero, the data is in words.  This parameter currently
!			is only included for user convenience and does not
!			affect how the data is actually transmitted through
!			the network.
!	length		Length of data.  This is the number of characters to
!			write, if ASCII, or the number of bytes (or words) of
!			the size specified by the user as the data unit size,
!			if image.
!	data		Data to write.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RWR$WRONG_TYPE if an argument is of the wrong type or is
!		invalid.  The file number may be incorrect or may refer to
!		a file which is not open.
!	RWR$OK if the operation succeeded.
!	RWR$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RWR$CHECKSUM if there was a checkum error (RMS$_CRC).
!	RWR$NO_FILE if the file does not exist or is not available (RMS$_PRV).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

BEGIN	! RWRITE

MAP
	data:		SCS_ARG;

BIND
	a_fnumber =	(dixadr (.fnumber)),				![52]
	a_runits =	(dixadr (.runits)),				![52]
	a_length =	(dixadr (.length)),				![52]
	a_data =	GET_STRING_ADDRESS (data);

LOCAL
	size;

! TTY_PUT_QUO ('DAP: Entering RWRITE');  TTY_PUT_CRLF ();

! Check parameters.

if (.a_fnumber lss 0) or (.a_fnumber geq MAXFILES)			![52]
    then DO_RETURN (RWR$WRONG_TYPE);
if not .file_status [.a_fnumber, in_use]				![52]
    then DO_RETURN (RWR$WRONG_TYPE);

! Initialize the RAB.

! RAB input fields:
! ISI  Internal stream identifier
! KBF  Key buffer address
! KSZ  Key size
! RAC  Record access mode (SEQ, KEY, RFA, TRA, BFT)
! RBF  Record address
! RSZ  Record size (bytes)
! ROP  Record-processing options (WBH only)

! RAB output fields:
! BKT  Bucket code (set to relative record number for sequential access to
!      relative files)
! RFA  Record's file address
! STS  Completion status code
! STV  Status value

![43] Fix RWRITE to know that RSZ field of RAB is in ASCII bytes or words.
if .file_status [.a_fnumber, file_type] eql T_IMAGE	![52]
    then			! Image file type
	if .a_runits eql 0				![52]
	    then size = .a_length			![52][43] words
	    else size = (.a_length * .a_runits + 35) / 36	![52][43] make words
    else			! ASCII or undefined file type
![43]	if ..runits eql 0
![43]	    then size = ..length
![43]	    else size = (..length * ..runits + 1) / 7;
	size = .a_length;				![52][43] ASCII bytes

$RAB_STORE (RAB = rabs [.a_fnumber, $], RSZ = .size, RBF = a_data);	![52]

R$PUT (rabs [.a_fnumber, $], DAPERR);					![52]

selectone .rabs [.a_fnumber, RAB$H_STS] of				![52]
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_PRV]:			! Privilege violation; access denied
			DO_RETURN (RWR$NO_FILE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RWR$NO_NETWORK);

!   [RMS$_OK_DUP,		! Record inserted has duplicate key value
!    RMS$_OK_IDX,		! Record successfully inserted, but error
!				! occurred on index update which could cause
!				! slow access
!    RMS$_OK_REO,		! Reorganize file
!    RMS$_OK_RRV,		! Record inaccessible from secondary index
!    RMS$_DUP,			! Duplicate key detected
!    RMS$_FAC,			! PUT in FAC not set
!    RMS$_FUL,			! File is 256K pages already
!    RMS$_IOP,			! Key access to seq file or RFA access to
!				! stream file
!    RMS$_ISI,			! Usually means RAB is not connected
!    RMS$_KBF,			! No key buffer pointer (only if REL and KEY)
!    RMS$_KEY,			! Record number 0 or > MRN (if KEY and REL)
!    RMS$_LSN,			! LSN greater than 99999 (if LSN)
!    RMS$_NEF,			! NRP not set at end-of-file (only if SEQ)
!    RMS$_RBF,			! No record buffer pointer
!    RMS$_RSZ,			! RSZ greater than MRS or not equal to MRS
!				! and RFM is FIX
!    RMS$_SEQ,			! Key in $PUT SEQ less than key on prior
!				! $PUT SEQ
!    RMS$_REX,			! Record already exists in target record cell
!    RMS$_RLK]:			! Record locked by another task
    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! TTY_PUT_QUO ('DAP: Leaving  RWRITE');  TTY_PUT_CRLF ();
DO_RETURN (RWR$OK);

END;	! RWRITE
%sbttl 'RCLOSE: Close a remote file (12)'

GLOBAL ROUTINE RCLOSE (fnumber, option): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Close a file opened by ROPEN.
!
! FORMAL PARAMETERS:
!	fnumber		File number, assigned by ROPEN.
!	option		Close option:
!			O_NOTHING to do nothing,
!			O_SUBMIT to submit the file for remote batch
!			processing,
!			O_PRINT to submit the file for remote printing,
!			O_DELETE to delete the remote file,
!			O_SUB_DEL to submit the file and then delete it (not
!			implemented yet on some systems), or
!			O_PRINT_DEL to print the file and then delete it
!			(not implemented yet on some systems).
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RCL$WRONG_TYPE if an argument is of the wrong type or is invalid.
!		The close option may have an undefined value, or the file
!		number may be incorrect or refer to a file which is
!		not open.
!	RCL$OK if the operation succeeded.
!	RCL$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RCL$CHECKSUM if there was a checksum error (RMS$_CRC).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RCLOSE

BIND									![52]
	a_fnumber =	(dixadr (.fnumber)),				![52]
	a_option =	(dixadr (.option));				![52]

! TTY_PUT_QUO ('DAP: Entering RCLOSE');  TTY_PUT_CRLF ();

! Check parameters.

if (.a_option lss O_MIN) or (.a_option gtr O_MAX)			![52]
    then DO_RETURN (RCL$WRONG_TYPE);
if (.a_fnumber lss 0) or (.a_fnumber geq MAXFILES)			![52]
    then DO_RETURN (RCL$WRONG_TYPE);
if not .file_status [.a_fnumber, in_use]				![52]
    then DO_RETURN (RCL$WRONG_TYPE);

! Put close options into the FOP.

case .a_option from O_MIN to O_MAX of					![52]
    SET
    [O_NOTHING]:	;			! Nothing
    [O_SUBMIT]:					! Submit
	$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = SCF);		![52]
    [O_PRINT]:					! Print
	$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = SPL);		![52]
    [O_3]:	;				! Nothing
    [O_DELETE]:					! Delete
	$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = DLT);		![52]
    [O_SUB_DEL]:	begin			! Submit and delete
		$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = SCF);	![52]
		$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = DLT);	![52]
		end;
    [O_PRINT_DEL]:	begin			! Print and delete
		$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = SPL);	![52]
		$FAB_STORE (FAB = fabs [.a_fnumber, $], FOP = DLT);	![52]
		end;
    TES;

! Need to set FAB fields:
! FOP  File-processing options (NAM, SCF, DLT, or SPL)
! IFI  Internal file identifier (gets zeroed)
! NAM  Name block address (used only if NAM is set in FOP)
! XAB  Extended attribute block address
! Sets STS to completion status, STV to status value

R$CLOSE (fabs [.a_fnumber, $], DAPERR);					![52]

selectone .fabs [.a_fnumber, FAB$H_STS] of				![52]
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RCL$NO_NETWORK);

!   [RMS$_OK_REO,		! File should be reorganized
!    RMS$_CCF,			! Cannot close file
!    RMS$_EDQ,			! Cannot unlock file
!    RMS$_IFI,			! Bad IFI value (file not open?)
!    RMS$_PRV]:			! File protection violation
    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

file_status [.a_fnumber, in_use] = FALSE;				![52]

! TTY_PUT_QUO ('DAP: Leaving  RCLOSE');  TTY_PUT_CRLF ();
DO_RETURN (RCL$OK);

END;	! RCLOSE
%sbttl 'RDEL: Delete a remote file (13)'

GLOBAL ROUTINE RDEL (fname, userid, passwd, acct): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Delete a file.  Only closed files may be deleted.
!
! FORMAL PARAMETERS:
!	fname		File name, including node name, in ASCII.
!	userid		USERID_SIZE ASCII character user code.
!	passwd		PASSWD_SIZE ASCII character password.
!	acct		ACCT_SIZE ASCII character account.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RDE$WRONG_TYPE if an argument is of the wrong type or is invalid
!		(RMS$_FSI).
!	RDE$OK if the operation succeeded.
!	RDE$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RDE$CHECKSUM if there was a checksum error (RMS$_CRC).
!	RDE$NO_FILE if the file does not exist or is not available
!		(RMS$_FLK, RMS$_FNF, RMS$_PRV).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RDEL

LOCAL
	error_code;

MAP
	fname:		SCS_ARG,
	userid:		SCS_ARG,
	passwd:		SCS_ARG,
	acct:		SCS_ARG;

BIND
	a_fname =	GET_STRING (fname),
	a_userid =	GET_STRING (userid),
	a_passwd =	GET_STRING (passwd),
	a_acct =	GET_STRING (acct);

! TTY_PUT_QUO ('DAP: Entering RDEL');  TTY_PUT_CRLF ();

![7] Check byte strings for ASCII in RDEL.
FORCE_ASCII (fname, RDE$WRONG_TYPE);			![7]
FORCE_ASCII (userid, RDE$WRONG_TYPE);			![7]
FORCE_ASCII (passwd, RDE$WRONG_TYPE);			![7]
FORCE_ASCII (acct, RDE$WRONG_TYPE);			![7]

! Construct embedded file specification.

CONSTRUCT_FILESPEC (a_fname, a_userid, a_passwd, a_acct,
    wholespeca);

! Construct FAB.

! FAB input fields:
! FNA  File specification string address
! FOP  File-processing options (NAM bit only)
! IFI  Internal file identifier (must be zero)
! NAM  NAM block address

! FAB output fields:
! STS  Completion status code
! STV  Status value

! NAM block input fields:
! DVI  Device identification (if NAM set in FOP)
! ESA  Expanded string area address
! ESS  Expanded string area size
! RLF  Related file NAM block address (if NAM set in FOP)
! RSA  Resultant string area address
! RSS  Resultant string area size

! NAM block output fields:
! DVI  Device identification
! ESL  Expanded string length
! FNB  Filename status bits
! RSL  Resultant string length

$FAB_INIT (FAB = afab, FNA = CH$PTR (wholespeca), FAC = DEL);

R$ERASE (afab, DAPERR);

error_code = 0;
selectone .afab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FLK,			! Invalid simultaneous access
     RMS$_FNF,			! File not found
     RMS$_PRV]:			! File protection violation
			error_code = (RDE$NO_FILE);

    [RMS$_FSI]:			! File spec contains invalid syntax
			error_code = (RDE$WRONG_TYPE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			error_code = (RDE$NO_NETWORK);

!   [RMS$_CEF,			! Cannot erase file
!    RMS$_CGJ,			! Cannot get JFN for file
!    RMS$_FNC]:			! File is not closed
!   [OTHERWISE]:	error_code = (HORRIBLE);

    tes;
IF .error_code NEQ 0
THEN
    BEGIN
    R$CLOSE (afab, DAPERR);	!if error on OPEN, close link
    DO_RETURN (.error_code);
    END;

! TTY_PUT_QUO ('DAP: Leaving  RDEL');  TTY_PUT_CRLF ();
DO_RETURN (RDE$OK);

END;	! RDEL
%sbttl 'RSUB: Submit a remote file for batch processing (14)'

GLOBAL ROUTINE RSUB (fname, userid, passwd, acct): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Submit a remote file for batch processing.
!
! FORMAL PARAMETERS:
!	fname		File name, including node name, in ASCII.
!	userid		USERID_SIZE ASCII character user code.
!	passwd		PASSWD_SIZE ASCII character password.
!	acct		ACCT_SIZE ASCII character account.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RSU$WRONG_TYPE  if an argument is of the wrong type or is
!		invalid (RMS$_FSI).
!	RSU$OK if the operation succeeded.
!	RSU$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RSU$CHECKSUM if there was a checksum error (RMS$_CRC).
!	RSU$NO_FILE if the file does not exist or is not available
!		(RMS$_FNF, RMS$_PRV).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RSUB

LOCAL
	error_code;

MAP
	fname:		SCS_ARG,
	userid:		SCS_ARG,
	passwd:		SCS_ARG,
	acct:		SCS_ARG;

BIND
	a_fname =	GET_STRING (fname),
	a_userid =	GET_STRING (userid),
	a_passwd =	GET_STRING (passwd),
	a_acct =	GET_STRING (acct);

! TTY_PUT_QUO ('DAP: Entering RSUB');  TTY_PUT_CRLF ();

![7] Check byte pointers for ASCII in RSUB.
FORCE_ASCII (fname, RSU$WRONG_TYPE);			![7]
FORCE_ASCII (userid, RSU$WRONG_TYPE);			![7]
FORCE_ASCII (passwd, RSU$WRONG_TYPE);			![7]
FORCE_ASCII (acct, RSU$WRONG_TYPE);			![7]

! Construct embedded file specification.

CONSTRUCT_FILESPEC (a_fname, a_userid, a_passwd, a_acct,
    wholespeca);

! Construct the FAB.

$FAB_INIT (FAB = afab, FNA = CH$PTR (wholespeca));

! Ensure treatment as a remote file.

afab [FAB$V_DEV_REMOTE] = TRUE;

R$OPEN (afab, DAPERR);

error_code = 0;
selectone .afab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FNF,			! File not found
     RMS$_PRV]:			! File protection violation
			error_code = (RSU$NO_FILE);

    [RMS$_FSI]:			! File spec contains invalid syntax
			error_code = (RSU$WRONG_TYPE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			error_code = (RSU$NO_NETWORK);

!   [RMS$_AID,			! Area XABs are not ascending by AID field value
!    RMS$_BKZ,			! BKZ in area XAB greater than 31
!    RMS$_BLN,			! FAB on entry in XAB chain has bad BLN
!    RMS$_CGJ,			! Cannot get JFN on file
!    RMS$_COD,			! Entry in XAB chain has bad COD
!    RMS$_COF,			! Cannot open file
!    RMS$_DAN,			! DAN in KEY XAB greater than highest AID
!    RMS$_DEV,			! Device is not disk
!    RMS$_DTP,			! DTP in KEY XAB invalid or disagrees with
!				! BSZ of FAB
!    RMS$_FEX,			! File already exists
!    RMS$_FLK,			! File locked
!    RMS$_IAN,			! IAN in KEY XAB greater than highest AID
!    RMS$_IMX,			! Multiple copies of DATE or SUMMARY XAB
!    RMS$_ORD,			! KEY XABs not in ascending order by REF field
!				! or AREA XABs not in ascending order by AID
!    RMS$_RAT,			! BLK specified for stream file
!    RMS$_REF,			! KEY XABs are not ascending by REF field value
!    RMS$_SIZ]:			! Number of bytes in data key exceeds 255
    [OTHERWISE]:	error_code = (HORRIBLE);

    tes;
IF .error_code NEQ 0
THEN
    BEGIN
    R$CLOSE (afab, DAPERR);	!if error on OPEN, close link
    DO_RETURN (.error_code);
    END;

! Close file for submission.

$FAB_STORE (FAB = afab, FOP = SCF);

R$CLOSE (afab, DAPERR);

selectone .afab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_PRV]:			! File protection violation
			DO_RETURN (RSU$NO_FILE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RSU$NO_NETWORK);

!   [RMS$_OK_REO,		! File should be reorganized
!    RMS$_CCF,			! Cannot close file
!    RMS$_EDQ,			! Cannot unlock file
!    RMS$_IFI]:			! Bad IFI value (file not open?)
    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! TTY_PUT_QUO ('DAP: Leaving  RSUB');  TTY_PUT_CRLF ();
DO_RETURN (RSU$OK);

END;	! RSUB
%sbttl 'RRENM: Rename a remote file (19)'

GLOBAL ROUTINE RRENM (cfname, nfname, userid, passwd, acct): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Rename a file.  The file must be closed.
!
! FORMAL PARAMETERS:
!	cfname		Current file name, including node name, in ASCII.
!	nfname		New file name, in ASCII.
!	userid		USERID_SIZE ASCII character user code.
!	passwd		PASSWD_SIZE ASCII character password.
!	acct		ACCT_SIZE ASCII character account.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RRN$WRONG_TYPE if an argument is of the wrong type or is
!		invalid.
!	RRN$OK if the operation succeeded.
!	RRN$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RRN$CHECKSUM if there was a checksum error (RMS$_CRC).
!	RRN$NO_FILE if the file does not exist or is not available
!		(RMS$_FEX, RMS$_FNF, RMS$_PRV).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RRENM

MAP
	cfname:		SCS_ARG,
	nfname:		SCS_ARG,
	userid:		SCS_ARG,
	passwd:		SCS_ARG,
	acct:		SCS_ARG;

BIND
	a_cfname =	GET_STRING (cfname),
	a_nfname =	GET_STRING (nfname),
	a_userid =	GET_STRING (userid),
	a_passwd =	GET_STRING (passwd),
	a_acct =	GET_STRING (acct);

! TTY_PUT_QUO ('DAP: Entering RRENM');  TTY_PUT_CRLF ();

! Caveat: This code has not been tested!

! Also, remote rename is not supported by most FALs.

![7] Check byte pointers for ASCII in RRENM.
FORCE_ASCII (cfname, RRN$WRONG_TYPE);			![7]
FORCE_ASCII (nfname, RRN$WRONG_TYPE);			![7]
FORCE_ASCII (userid, RRN$WRONG_TYPE);			![7]
FORCE_ASCII (passwd, RRN$WRONG_TYPE);			![7]
FORCE_ASCII (acct, RRN$WRONG_TYPE);			![7]

! Construct embedded file specifications.

CONSTRUCT_FILESPEC (a_cfname, a_userid, a_passwd, a_acct, wholespeca);
CONSTRUCT_FILESPEC (a_nfname, a_userid, a_passwd, a_acct, wholespecd);

! Construct source and destination FABs.

! FAB input fields:
! FNA  File specification string address
! IFI  Internal file identifier (must be zero)
! NAM  NAM block address

! NAM input fields:
! ESA  Expanded string area address (must be nonzero)
! ESS  Expanded string area size (must be nonzero)
! RLF  Related file NAM block address
! RSA  Resultant string area address
! RSS  Resultant string area size

! Related file NAM block fields:
! RSA  Resultant string area address
! RSL  Resultant string length

! Output in first FAB:
! STS  Completion status code
! STV  Status value

! Output in NAM blocks:
! DVI  Device identification
! ESL  Expanded string length
! FNB  File name status bits
! RSL  Resultant string length
! WCC  Wildcard context

$FAB_INIT (FAB = afab, FNA = CH$PTR (wholespeca));
$FAB_INIT (FAB = dfab, FNA = CH$PTR (wholespecd));

! Ensure treatment as a remote file.

afab [FAB$V_DEV_REMOTE] = TRUE;
dfab [FAB$V_DEV_REMOTE] = TRUE;

R$RENAME (afab, dfab, DAPERR);

selectone .afab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FEX,			! File already exists; not superseded
     RMS$_FNF,			! File not found
     RMS$_PRV]:			! File protection violation
			DO_RETURN (RRN$NO_FILE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RRN$NO_NETWORK);

    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! TTY_PUT_QUO ('DAP: Leaving  RRENM');  TTY_PUT_CRLF ();
DO_RETURN (RRN$OK);

END;	! RRENM
%sbttl 'RDIRS: Set up to perform a remote directory listing (16A)'

GLOBAL ROUTINE RDIRS (fname, userid, passwd, acct): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Set up to read a directory of remote files.
!
! FORMAL PARAMETERS:
!	fname		File specification, including node name, in ASCII.
!	userid		USERID_SIZE ASCII character user code.
!	passwd		PASSWD_SIZE ASCII character password.
!	acct		ACCT_SIZE ASCII character account.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RDS$WRONG_TYPE if an argument is of the wrong type or is
!		invalid.
!	RDS$OK if the operation succeeded.
!	RDS$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RDS$CHECKSUM if there was a checksum error (RMS$_CRC).
!	RDS$NO_FILE if the directory does not exist or is not available.
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RDIRS

MAP
	fname:		SCS_ARG,
	userid:		SCS_ARG,
	passwd:		SCS_ARG,
	acct:		SCS_ARG;

BIND
	a_fname =	GET_STRING (fname),
	a_userid =	GET_STRING (userid),
	a_passwd =	GET_STRING (passwd),
	a_acct =	GET_STRING (acct);

! TTY_PUT_QUO ('DAP: Entering RDIRS');  TTY_PUT_CRLF ();

! Caveat: This code has not been tested!

![7] Check byte pointers for ASCII in RDIRS.
FORCE_ASCII (fname, RDS$WRONG_TYPE);			![7]
FORCE_ASCII (userid, RDS$WRONG_TYPE);			![7]
FORCE_ASCII (passwd, RDS$WRONG_TYPE);			![7]
FORCE_ASCII (acct, RDS$WRONG_TYPE);			![7]

! Construct embedded file specification.

CONSTRUCT_FILESPEC (a_fname, a_userid, a_passwd, a_acct, dirspec);

! Construct wild FAB.

$FAB_INIT (FAB = dirfab, FNA = CH$PTR (dirspec));

! Ensure treatment as a remote file.

dirfab [FAB$V_DEV_REMOTE] = TRUE;

R$DIRECTORY (dirfab, DAPERR);

selectone .dirfab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RDS$NO_NETWORK);

    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! TTY_PUT_QUO ('DAP: Leaving  RDIRS');  TTY_PUT_CRLF ();
DO_RETURN (RDS$OK);

END;	! RDIRS
%sbttl 'RDIR: Perform a remote directory listing (16B)'

GLOBAL ROUTINE RDIR (length, data): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Get one entry of a remote file directory set up by RDIRS.
!
! FORMAL PARAMETERS:
!	length		Maximum length of directory data to be returned,
!			returned as the actual length.
!	data		Returned ASCII directory information.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RDR$WRONG_TYPE if an argument is of the wrong type or is
!		invalid.
!	RDR$OK if the operation succeeded.
!	RDR$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RDR$NO_MORE if there are no more directory entries to return
!		without another call to RDIRS (RMS$_NMF).
!	RDR$NO_FILE if a file does not exist or is not available
!		(RMS$_FNF, RMS$_PRV).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RDIR

MAP
	data:		SCS_ARG;

BIND
	a_length =	(dixadr (.length)),				![52]
	a_data =	GET_STRING (data);

! TTY_PUT_QUO ('DAP: Entering RDIR');  TTY_PUT_CRLF ();

! Caveat: This code has not been tested!

![7] Check that byte pointers are ASCII in RDIR.
FORCE_ASCII (data, RDR$WRONG_TYPE);			![7]

! Required FAB fields:
! IFI  Internal file identifier (must be zero)
! NAM  Name block address

! Required NAM fields:
! DVI  Device identification of device containing directory to be searched
! ESA  Expanded string area address
! ESL  Expanded string length
! FNB  File name status bits (wildcard bits only)
! RSA  Resultant string area address
! RSL  Resultant string area length
! RSS  Resultant string area size
! WCC  Wildcard context

! FAB output fields:
! STS  Completion status code
! STV  Status value

! NAM output fields:
! RSL  Resultant string length
! WCC  Wildcard context

R$SEARCH (dirfab, DAPERR);

selectone .dirfab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FNF,			! File not found
     RMS$_PRV]:			! File protection violation
			DO_RETURN (RDR$NO_FILE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RDR$NO_NETWORK);

    [RMS$_NMF]:			! No more files
			DO_RETURN (RDR$NO_MORE);

    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! Updated FAB.

! Call R$LIST to get directory listing.

R$LIST (dirfab, a_data, .a_length, 3, DAPERR);			![52]

selectone .dirfab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FNF,			! File not found
     RMS$_PRV]:			! File protection violation
			DO_RETURN (RDR$NO_FILE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			DO_RETURN (RDR$NO_NETWORK);

    [RMS$_NMF]:			! No more files
			DO_RETURN (RDR$NO_MORE);

    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! TTY_PUT_QUO ('DAP: Leaving  RDIR');  TTY_PUT_CRLF ();
DO_RETURN (RDR$OK);

END;	! RDIR
%sbttl 'RPRINT: Print a remote file (15)'

GLOBAL ROUTINE RPRINT (fname, userid, passwd, acct): FORTRAN_FUNC =
!++
! FUNCTIONAL DESCRIPTION:
!	Print a remote file at the remote node.
!
! FORMAL PARAMETERS:
!	fname		File specification, including node name, in ASCII.
!	userid		USERID_SIZE ASCII character user code.
!	passwd		PASSWD_SIZE ASCII character password.
!	acct		ACCT_SIZE ASCII character account.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	RPR$WRONG_TYPE if an argument is of the wrong type or is invalid
!		(RMS$_FSI).
!	RPR$OK if the operation succeeded.
!	RPR$NO_NETWORK if the network operation could not be done
!		(RMS$_CON, RMS$_DPE, RMS$_NLB, RMS$_SUP).
!	RPR$CHECKSUM if there was a checksum error (RMS$_CRC).
!	RPR$NO_FILE if the file does not exist or is not available
!		(RMS$_FEX, RMS$_FLK, RMS$_FNF, RMS$_PRV).
!	HORRIBLE if some other error occurred.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! RPRINT

LOCAL
	error_code;

MAP
	fname:		SCS_ARG,
	userid:		SCS_ARG,
	passwd:		SCS_ARG,
	acct:		SCS_ARG;

BIND
	a_fname =	GET_STRING (fname),
	a_userid =	GET_STRING (userid),
	a_passwd =	GET_STRING (passwd),
	a_acct =	GET_STRING (acct);

! TTY_PUT_QUO ('DAP: Entering RPRINT');  TTY_PUT_CRLF ();

![7] Check that byte pointers are ASCII in RPRINT.
FORCE_ASCII (fname, RPR$WRONG_TYPE);			![7]
FORCE_ASCII (userid, RPR$WRONG_TYPE);			![7]
FORCE_ASCII (passwd, RPR$WRONG_TYPE);			![7]
FORCE_ASCII (acct, RPR$WRONG_TYPE);			![7]

! Construct embedded file specification.

CONSTRUCT_FILESPEC (a_fname, a_userid, a_passwd, a_acct, wholespeca);

! Construct FAB.

$FAB_INIT (FAB = afab, FNA = CH$PTR (wholespeca));

! Ensure treatment as a remote file.

afab [FAB$V_DEV_REMOTE] = TRUE;

! Open remote file.

R$OPEN (afab, DAPERR);

error_code = 0;
selectone .afab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_FEX,			! File already exists
     RMS$_FLK,			! File locked
     RMS$_FNF,			! File not found
     RMS$_PRV]:			! File protection violation
			error_code = (RPR$NO_FILE);

    [RMS$_FSI]:			! File spec contains invalid syntax
			error_code = (RPR$WRONG_TYPE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link broken
     RMS$_SUP]:			! Operation not supported on remote system
			error_code = (RPR$NO_NETWORK);

!   [RMS$_AID,			! Area XABs not in ascending order by AID
!    RMS$_BKZ,			! BKZ in AREA XAB greater than 31
!    RMS$_BLN,			! FAB on entry in XAB chain has bad BLN
!    RMS$_CGJ,			! Cannot get JFN on file
!    RMS$_COD,			! Entry in XAB chain has bad COD
!    RMS$_COF,			! Cannot open file
!    RMS$_DAN,			! DAN in KEY XAB greater than highest AID
!    RMS$_DEV,			! Device is not disk
!    RMS$_DTP,			! DTP in KEY XAB invalid or disagrees with
!				! BSZ of FAB
!    RMS$_IAN,			! IAN in KEY XAB greater than highest AID
!    RMS$_IMX,			! Multiple copies of DATE or SUMMARY XAB
!    RMS$_ORD,			! KEY XABs not in ascending order by REF field
!				! or AREA XABs not in ascending order by AID
!    RMS$_RAT,			! BLK specified for stream file
!    RMS$_REF,			! KEY XABs are not ascending by REF field value
!    RMS$_SIZ]:			! Number of bytes in data key exceeds 255
    [OTHERWISE]:	error_code = (HORRIBLE);

    tes;

IF .error_code NEQ 0
THEN
    BEGIN
    R$CLOSE (afab, DAPERR);	!if error on OPEN, close link
    DO_RETURN (.error_code);
    END;

! Set up SPL bit in FOP.

$FAB_STORE (FAB = afab, FOP = SPL);

! Close for printing.

R$CLOSE (afab, DAPERR);

selectone .afab [FAB$H_STS] of
    set
    [RMS$_NORMAL]:	;	! Operation successful

    [RMS$_PRV]:			! File protection violation
			DO_RETURN (RPR$NO_FILE);

    [RMS$_CON,			! Can't connect to FAL
     RMS$_DPE,			! DAP protocol error
     RMS$_NLB,			! Network link borken
     RMS$_SUP]:			! Operation not supported by remote system
			DO_RETURN (RPR$NO_NETWORK);

!   [RMS$_OK_REO,		! File should be reorganized
!    RMS$_CCF,			! Cannot close file
!    RMS$_EDQ,			! Cannot unlock file
!    RMS$_IFI]:			! Bad IFI value (file not open?)
    [OTHERWISE]:	DO_RETURN (HORRIBLE);

    tes;

! TTY_PUT_QUO ('DAP: Leaving  RPRINT');  TTY_PUT_CRLF ();
DO_RETURN (RPR$OK);

END;	! RPRINT
%sbttl 'DAPERR: Error routine for DAP interface errors'

ROUTINE DAPERR (operation, theblock): RMS$ERCAL NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!	Handle errors from the DAP interface routines.
!
! FORMAL PARAMETERS:
!	operation		operation which failed
!	theblock		pointer to the failing block
!				(status code is always in the same place)
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	None
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	TBS
!
!--

BEGIN	! DAPERR

MAP
	theblock:	REF $FAB_DECL;  ! FAB or RAB; doesn't matter which,
					! since the status code is in the same
					! place.

! TTY_PUT_QUO ('DAP: Entering DAPERR');  TTY_PUT_CRLF ();
! TTY_PUT_QUO ('DAP: DAPERR error is ');
! TTY_PUT_INTEGER (.theblock [FAB$H_STS], 8, 8);
! TTY_PUT_CRLF ();

! TTY_PUT_QUO ('DAP: Leaving  DAPERR');  TTY_PUT_CRLF ();

END;	! DAPERR
%sbttl 'CONSTRUCT_FILESPEC: Construct embedded file specification'

ROUTINE CONSTRUCT_FILESPEC (fname, userid, passwd, acct, result): NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!	Construct an embedded file specification.
!
! FORMAL PARAMETERS:
!	fname:			Byte pointer to FSPEC_SIZE ASCII file name,
!				including node name.
!	userid:			Byte pointer to USERID_SIZE ASCII character
!				userid.
!	passwd:			Byte pointer to PASSWD_SIZE character ASCII
!				password.
!	acct:			Byte pointer to ACCT_SIZE ASCII character
!				account.
!	result:			Address of where to place resulting string.
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	None
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	TBS
!
!--

BEGIN	! CONSTRUCT_FILESPEC

LOCAL
	indexs,		! Source index pointer
	indexr,		! Result index pointer
	node_flag,	! TRUE if there was a node name in the file name
	char,		! A character
	count;		! Count of significant characters in a string

! TTY_PUT_QUO ('DAP: Entering CONSTRUCT_FILESPEC');  TTY_PUT_CRLF ();

indexr = CH$PTR (.result);
node_flag = TRUE;
indexs = .fname;
incr i from 0 to FSPEC_SIZE - 1 do			! Look for node name
    if ((char = CH$RCHAR_A (indexs)) eql %C':')
	then exitloop					! Found a colon
	else if (.char eql 0) or (.char eql %C' ') or (.i eql FSPEC_SIZE - 1)
	    then begin					! End of string
	    ! TTY_PUT_QUO ('DAP: C_S no nodename');  TTY_PUT_CRLF ();
	    node_flag = FALSE;
	    indexs = .fname;
	    exitloop;
	    end;
if .node_flag eql TRUE					! May be node name
    then if CH$RCHAR_A (indexs) eql %C':'		! Another colon?
	then begin					! Node name
	    ! TTY_PUT_QUO ('DAP: C_S move node name');  TTY_PUT_CRLF ();
	    CH$MOVE (CH$DIFF (.indexs, .fname) - 2, .fname, .indexr);
	    indexr = CH$PLUS (.indexr, CH$DIFF (.indexs, .fname) - 2);
	    end
	else begin					! Device name
	    indexs = .fname;
	    node_flag = FALSE;
	    ! TTY_PUT_QUO ('DAP: C_S no node name but colon');  TTY_PUT_CRLF ();
	    indexr = CH$PTR (.result);
	    end;
if (CH$RCHAR (.userid) neq %C' ') and (CH$RCHAR (.userid) neq 0)
    then begin						! User id
	! TTY_PUT_QUO ('DAP: C_S userid'); TTY_PUT_CRLF ();
	CH$WCHAR_A (%C'"', indexr);
	count = COUNTEM (.userid, USERID_SIZE);
	CH$MOVE (.count, .userid, .indexr);		! Move userid
	indexr = CH$PLUS (.indexr, .count);
	if (CH$RCHAR (.passwd) neq %C' ') and (CH$RCHAR (.passwd) neq 0)
	    then begin					! Password
	    ! TTY_PUT_QUO ('DAP: C_S password');  TTY_PUT_CRLF ();
	    CH$WCHAR_A (%C' ', indexr);
	    count = COUNTEM (.passwd, PASSWD_SIZE);
	    CH$MOVE (.count, .passwd, .indexr);		! Move password
	    indexr = CH$PLUS (.indexr, .count);
	    if (CH$RCHAR (.acct) neq %C' ') and (CH$RCHAR (.acct) neq 0)
		then begin				! Account
		! TTY_PUT_QUO ('DAP: C_S account');  TTY_PUT_CRLF ();
		CH$WCHAR_A (%C' ', indexr);
		count = COUNTEM (.acct, ACCT_SIZE);
		CH$MOVE (.count, .acct, .indexr);	! Move account
		indexr = CH$PLUS (.indexr, .count);
		end;
	    end;
	CH$WCHAR_A (%C'"', indexr);			! Quote after access
    end;

![42] In CONSTRUCT_FILESPEC, always insert a double colon after the optional
![42] embedded access information in the file speciifcation being created.
![42] This will allow the DAP code to properly handle a missing (default)
![42] nodename.
![42]if .node_flag eql TRUE					! Need colons
![42]    then begin
    ! TTY_PUT_QUO ('DAP: C_S double colon');  TTY_PUT_CRLF ();
    CH$WCHAR_A (%C':', indexr);
    CH$WCHAR_A (%C':', indexr);
![42]    end;

! Collect up the rest of the filespec.

! TTY_PUT_QUO ('DAP: C_S rest of filespec');  TTY_PUT_CRLF ();
! TTY_PUT_QUO ('DAP: C_S length is ');
count = COUNTEM (.indexs, FSPEC_SIZE - CH$DIFF (.indexs, .fname));
! TTY_PUT_INTEGER (.count, 10, 10);
! TTY_PUT_CRLF ();
CH$MOVE (.count, .indexs, .indexr);			! Move remaining
indexr = CH$PLUS (.indexr, .count);

! Make the file name string ASCIZ.

CH$WCHAR_A (0, indexr);				! Add a null
! TTY_PUT_QUO ('DAP: CONSTRUCT_FILESPEC made ');
! TTY_PUT_MSG (.result, WHOLESPEC_SIZE);  TTY_PUT_CRLF ();

! TTY_PUT_QUO ('DAP: Leaving  CONSTRUCT_FILESPEC');  TTY_PUT_CRLF ();

END;	! CONSTRUCT_FILESPEC
%sbttl 'COUNTEM: Count significant characters in a string'

ROUTINE COUNTEM (string, length) =
!++
! FUNCTIONAL DESCRIPTION:
!	Count the significant (nonblank, nonnull) characters in a
!	left-justified string and return the count.
!
! FORMAL PARAMETERS:
!	string			Byte pointer to the ASCII string
!	length			Maximum length of the string
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	The number of sigificant characters in the string.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!
!--

BEGIN	! COUNTEM

LOCAL
	char,
	ptr;

ptr = .string;
incr counter from 0 to .length - 1 do
    if ((char = CH$RCHAR_A (ptr)) eql %C' ') or (.char eql 0)
	then return .counter;
return .length;

END;	! COUNTEM

END
ELUDOM