github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-03-06 11:03:21 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
PDP-10.stacken/files/stacken-tape-backup/dskb:10_7/dil/dilsrc/dapper.b36
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

2837 lines
90 KiB
Plaintext
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
%TITLE 'DAP Interface'
MODULE dapper (
IDENT='2.1(113)',
ENTRY (ROPEN, RREAD, RWRITE, RCLOSE, RDEL, RSUB, RRENM,
RDIRS, RDIR, RPRINT)
) =
BEGIN
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1986.
! 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 )%
new_version (2, 1)
Edit (%O'112', '1-Jun-86', 'Sandy Clemens')
%( Add sources for version 2.1. Update copyright notices. )%
Edit (%O'113', '28-Jul-86', 'Sandy Clemens')
%( Recoginze EOF as a valid return code from a $CLOSE so that DIT$_HORRIBLE
wont' be returned. (EOF is a valid success status for $CLOSE). )%
! 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$_EOF]: ; ! End of file ok also
[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
Reference in New Issue View Git Blame Copy Permalink