Google
 

Trailing-Edge - PDP-10 Archives - bb-r775d-bm_tops20_ks_upd_4 - sources/open.bli
There are 21 other files named open.bli in the archive. Click here to see a list.
MODULE OPEN (	! Open a file using RMS or DAP
		IDENT = '20'
                %BLISS36(,ENTRY(
                                r$open,       !open a file
                                r$create,     !create a new file
                                r$close,      !close a file
                                r$reset,      !abort a file
                                r$erase,      !delete a file
                                rl$close,     !close a local file
                                dap$openfile, !open a remote file (using dap)
                                dap$close,    !close a remote file (using dap)
                                dap$handle    !RMS DAP condition handler
                                ))
		) =
BEGIN
!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 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/RMS
!
! ABSTRACT:
!     Open a file using DAP if the file is on another system,
!     or using RMS if it is on the same system.
!
! ENVIRONMENT: BLISSNET, RMS, XPORT, Transportable Code.
!
! AUTHOR:	Andrew Nourse, CREATION DATE: 2-Jan-82
!
! 20    - Poor-man's routing now invoked by setting PMRFLG to -1
! 17    - Undefined ASCII to non-stream sets CR only if no other RAT bits set
! 16    - R$OPEN should merge related filespec
!       - R$ERASE should call DAP$NEXTFILESPEC for additional filespecs
! 15    - R$OPEN & R$CREATE continue after signalling RMS$_SUP for remote-only
! 14    - Make R$RESET get rid of link.
! 13    - Have R$RESET check the NEW FILE bit in the FST
! 12    - Send ACCESS COMPLETE(PURGE) as interrupt message
! 11    - Work around IAS wierdnesses
! 10    - Tell RMS that file is stream if using block mode
! 07    - Don't set implied CRLF unless user does not know format
! 06    - Give DD's pointers to each other
! 05    - Make DAP$CLOSE eat entire DATA message also
! 04    - Make DAP$CLOSE eat entire ACCESS COMPLETE message
! 03    - Put in ENTRY points
! 02    - Eat messages in pipe on close
! 01	- The beginning
!--
!
! INCLUDE FILES:
!

LIBRARY 'RMS';
LIBRARY 'RMSBLK';
LIBRARY 'DAP';
LIBRARY 'BLISSNET';
LIBRARY 'CONDIT';

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
	R$OPEN,           !Open a file
        R$CREATE,         !Create a new file
        R$CLOSE,          !Close a file
        R$RESET,          !Abort a file
        R$ERASE,          !Delete a file
        RL$CLOSE,         !Close a local file
        DAP$OPENFILE,     !Open a remote file (using DAP)
        DAP$CLOSE,        !Close a remote file (using DAP)
        DAP$HANDLE;       !Condition handler for DAP RMS routines
!
! MACROS:
!


!
! EQUATED SYMBOLS:
!

COMPILETIME MULTIPLE_FILESPECS=1;       ![16] On for mult-filespec support

LITERAL OBJ_FAL=17;                     !The FAL Object Type

%IF %BLISS(BLISS36)
    %THEN
    %IF %SWITCHES(TOPS20)
        %THEN
            LITERAL OUR_OSTYPE=DAP$K_TOPS20;
            LITERAL MA_RETURN = 1;

        %FI
    %FI

!
! OWN STORAGE:
!

GLOBAL
    PMRFLG: INITIAL(0);                 ! Set nonzero for poor-man's routing

!
! EXTERNAL REFERENCES:
!

EXTERNAL ROUTINE
                SETAI,
                DAP$PUT_MESSAGE,
                DAP$GET_MESSAGE,
                DAP$GET_CONFIG,
                DAP$PUT_CONFIG,
                DAP$PUT_ATTRIBUTES,
                DAP$PUT_BITVECTOR,
                DAP$PUT_ACCESS,
                DAP$PUT_BYTE,
                DAP$PUT_HEADER,
                DAP$GET_HEADER,
                DAP$GET_STATUS,
                DAP$GET_ATTRIBUTES,
                DAP$ERROR_DAP_RMS,
                DAP$MERGE,
                DAP$UNGET_HEADER,
                DAP$SIZE_BITVECTOR,
                DAP$GET_BYTE,
                DAP$GET_BITVECTOR,
                RMS$DIRECTORY,
                RMS$SEARCH,
                RMS$MERGE,
                RL$CLMACY11,
                RL$ERASE,
                R$NULL,
                XPN$SIGNAL;
%IF MULTIPLE_FILESPECS
%THEN
EXTERNAL ROUTINE DAP$NEXTFILESPEC;
%FI
EXTERNAL D_CFG;
EXTERNAL T20BUG: BITVECTOR,
         VMSBUG: BITVECTOR,
         RSXBUG: BITVECTOR,
         RSTBUG: BITVECTOR,
         IASBUG: BITVECTOR,
         T10BUG: BITVECTOR,
         RTBUG:  BITVECTOR;
EXTERNAL COPYRIGHT; ! Keep the legal office happy
GLOBAL ROUTINE R$OPEN (FAB,ERR)  =	! Open a (possibly remote) file

!++
! FUNCTIONAL DESCRIPTION:
!
!       Open a file.
!       If the filename contains a remote node-id,
!       communicate with FAL on the remote system to open the file,
!       otherwise, open it using RMS.
!
! FORMAL PARAMETERS:
!
!	FAB: An RMS FAB, ready to open a file.
!       ERR: Address of error routine
!    
!
! COMPLETION CODES:
!
!	RMS$_SUC or RMS error code
!
! SIDE EFFECTS:
!
!	Associated data structures (for RMS or DAP) allocated
!
!--

    BEGIN
    MAP FAB: REF $FAB_DECL;
    BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;      ! Error routine
    BIND TYP=.FAB[FAB$A_TYP]: $TYP_DECL;
    BIND NAM=.FAB[FAB$A_NAM]: $NAM_DECL;        ! Name block, if present
    LOCAL CLASS;

    IF TYP NEQ 0
    THEN CLASS=.TYP[TYP$H_CLASS]
    ELSE CLASS=TYP$K_CLASS_ASCII;

    IF .CLASS EQL 0 THEN CLASS=TYP$K_CLASS_ASCII;

    IF FIND_SUBSTRING(.FAB[FAB$A_FNA],PP('::')) NEQ 0
    THEN
        BEGIN
        FAB[FAB$V_REMOTE]=1;                    ! Remember

        IF NAM NEQ 0                            ![16] Merge related file
        THEN DAP$MERGE(FAB[$],MERGE$M_RLF,.ERR);! 

        DAP$OPENFILE(FAB[$],DAP$K_OPEN,0,.ERR)    ! File is remote.
        END
    ELSE
        BEGIN                                  ! File is Local
        LOCAL RFM, MRS;

        ! Caller can set this bit before the call to disable local files.
        IF .FAB[FAB$V_REMOTE]       ! Must it be remote?
        THEN                                   ! If caller sets the bit
            BEGIN                              ! (s)he does not support
            FAB[FAB$H_STS]=RMS$_SUP;           ! local RMS file access
            $$ERROR(OPEN,FAB[$]);              ! Which this is. complain
            RETURN .FAB[FAB$H_STS]             ![15] Do not continue
            END;

        IF (NAM NEQ 0)                         ! Fill in NAM block if any
        THEN                                   ! 
            BEGIN                              ! Name block exists
            IF .NAM[NAM$H_WCC_COUNT] EQL 0     ! If Search has not been done
            THEN                               !  then we should do one
                BEGIN                          !  so wildcarding will work
                RMS$DIRECTORY(FAB[$],.ERR);    ! Check for wildcards.
                RMS$SEARCH(FAB[$],R$NULL);     !  and fill in NAM block
                IF .FAB[FAB$V_FOP_CIF] EQL 0   ! Create-if nonexistant?
                AND (.FAB[FAB$H_STS] NEQ RMS$_SUC) ! successful?
                THEN $$ERROR(OPEN,FAB[$])      ! Give error if not
                END;                           ! with components of filespec
            END;                               ! NAM block processing

        IF (.CLASS EQL TYP$K_CLASS_MACY11)     ! For MACY11 files:
        OR .FAB[FAB$V_FAC_BIO]                 ![10] or if BLOCK I/O
        THEN                                   ! 
            BEGIN                              ! Pretend ASCII if MACY11
            RFM=.FAB[FAB$Z_RFM];               ! because RMS does not yet
            FAB[FAB$Z_RFM]=FAB$K_RFM_STM;      ! really know about MACY11 files
            MRS=.FAB[FAB$H_MRS];               ! Save the original MRS value
            END;                               ! 

        IF (.FAB[FAB$Z_RFM] EQL FAB$K_RFM_UDF) ! If record format not known
        THEN FAB[FAB$Z_RFM]=FAB$K_RFM_STM;     ! Default to /STREAM

        IF .FAB[FAB$V_FOP_CIF]                 ! If create-if, do a $CREATE
        THEN $CREATE(FAB=FAB[$],ERR=.ERR)      !  since RMS-20 ignores CIF
        ELSE $OPEN(FAB=FAB[$],ERR=.ERR);       !  on $OPEN

        IF (.CLASS EQL TYP$K_CLASS_MACY11)     ! For MACY11 files:
        OR .FAB[FAB$V_FAC_BIO]                 ![10] or if BLOCK I/O
        THEN                                   ! 
            BEGIN                              ! Restore what was
            FAB[FAB$Z_RFM]=.RFM;               ! changed to satisfy RMS
            FAB[FAB$H_MRS]=.MRS;               ! or changed by RMS
            END;                               ! 
        END;                                   ! Local File Open

    .FAB[FAB$H_STS]                     ! Returned status
    END;			!End of R$OPEN
GLOBAL ROUTINE R$CREATE (FAB,ERR)  =       ! Create a (possibly remote) file
!++
! FUNCTIONAL DESCRIPTION:
!
!       Open a new file.
!       If the filename contains a remote node-id,
!       communicate with FAL on the remote system to open the file,
!       otherwise, open it using RMS.
!
! FORMAL PARAMETERS:
!
!	FAB: An RMS FAB, ready to open a file.
!       ERR: Address of error routine
!
! COMPLETION CODES:
!
!	RMS codes
!
! SIDE EFFECTS:
!
!	A new file will be created
!
!--

    BEGIN
    MAP FAB: REF $FAB_DECL;
    BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;      ! Error routine

    BIND NAM=.FAB[FAB$A_NAM]: $NAM_DECL;        ! Name block if present
    BIND TYP=.FAB[FAB$A_TYP]: $TYP_DECL;
    LOCAL CLASS;
    LOCAL RFM, MRS;

    IF TYP NEQ 0
    THEN CLASS=.TYP[TYP$H_CLASS]
    ELSE CLASS=TYP$K_CLASS_ASCII;

    IF .CLASS EQL 0 THEN CLASS=TYP$K_CLASS_ASCII;

    IF FIND_SUBSTRING(.FAB[FAB$A_FNA],PP('::')) NEQ 0
    THEN
        BEGIN
        FAB[FAB$V_REMOTE]=1;                    ! Remember

        IF NAM NEQ 0
        THEN DAP$MERGE(FAB[$],MERGE$M_CREATE+MERGE$M_RLF,.ERR);

        DAP$OPENFILE(FAB[$],DAP$K_CREATE,0,.ERR)  ! File is remote.
        END
    ELSE
        BEGIN
        ! Caller can set this bit before the call to disable local files.
        IF .FAB[FAB$V_REMOTE]       ! Must it be remote?
        THEN
            BEGIN
            FAB[FAB$H_STS]=RMS$_SUP;
            $$ERROR(OPEN,FAB[$]);   ! Yes. complain
            RETURN .FAB[FAB$H_STS]      ![15] Do not continue
            END;

        IF NAM NEQ 0
        THEN
            BEGIN                       ! Merge related filespec, get resultant
            RMS$MERGE(FAB[$],MERGE$M_CREATE+MERGE$M_RLF,.ERR);
            END;

        IF .CLASS EQL TYP$K_CLASS_MACY11
        THEN
            BEGIN
            RFM=.FAB[FAB$Z_RFM];        ! Save real record format
            MRS=.FAB[FAB$H_MRS];
            FAB[FAB$Z_RFM]=FAB$K_RFM_STM;
            END;

        IF .FAB[FAB$Z_RFM] EQL FAB$K_RFM_UDF    ! If record format not known
        THEN FAB[FAB$Z_RFM]=FAB$K_RFM_STM;      ! Default to /STREAM

        $CREATE(FAB=FAB[$],ERR=.ERR);

        IF .CLASS EQL TYP$K_CLASS_MACY11        ! Restore real record format
        THEN
            BEGIN
            FAB[FAB$Z_RFM]=.RFM;
            FAB[FAB$H_MRS]=.MRS;
            END;
        END;
    .FAB[FAB$H_STS]                     ! Return status code
    END;			!End of R$CREATE
GLOBAL ROUTINE R$ERASE (FAB,ERR)  =       ! Delete a (possibly remote) file

!++
! FUNCTIONAL DESCRIPTION:
!
!       Delete a file.
!       If the filename contains a remote node-id,
!       communicate with FAL on the remote system to delete the file,
!       otherwise, delete it using RMS.
!
! FORMAL PARAMETERS:
!
!	FAB: An RMS FAB, ready to open a file.
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! COMPLETION CODES:
!
!	RMS$_SUC or RMS error code
!
! SIDE EFFECTS:
!
!	NONE
!
!--

    BEGIN
    MAP FAB: REF $FAB_DECL;

    IF FIND_SUBSTRING(.FAB[FAB$A_FNA],PP('::')) NEQ 0
    THEN
        BEGIN
        %IF MULTIPLE_FILESPECS          ![16] Try for multiple filespecs
        %THEN
        DO  BEGIN
            FAB[FAB$V_REMOTE]=1;                     ! Remember
            DAP$OPENFILE(FAB[$],DAP$K_ERASE,0,.ERR)  ! File is remote.
            END WHILE DAP$NEXTFILESPEC(FAB[$],.ERR)  ![16] try for more
        %ELSE
        FAB[FAB$V_REMOTE]=1;                     ! Remember
        DAP$OPENFILE(FAB[$],DAP$K_ERASE,0,.ERR)  ! File is remote.
        %FI
        END
    ELSE RL$ERASE(FAB[$],.ERR);
    .FAB[FAB$H_STS]                     ! Return status code
    END;			!End of ERASE
GLOBAL ROUTINE R$CLOSE (FAB,ERR)  =	! Close a (possibly remote) file

!++
! FUNCTIONAL DESCRIPTION:
!
!       Close a file
!
! FORMAL PARAMETERS:
!
!	FAB: An RMS FAB for open file.
!       ERR: Address of error routine
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! COMPLETION CODES:
!
!	RMS$_SUC or RMS error code
!
! SIDE EFFECTS:
!
!	Internal blocks deallocated
!
!--

    BEGIN
    MAP FAB: REF $FAB_DECL;

    IF .FAB[FAB$V_REMOTE]
    THEN
        BEGIN
        DAP$CLOSE(FAB[$],DAP$K_ACCOMP_COMMAND,.ERR)     ! File is remote.
        END
    ELSE
        BEGIN
        RL$CLOSE(FAB[$],.ERR);          ! Call local close routine
        END;
    .FAB[FAB$H_STS]                     ! Returned status code
    END;			!End of R$CLOSE
GLOBAL ROUTINE R$RESET (FAB,ERR)  =	! Reset a (possibly remote) file
!++
! FUNCTIONAL DESCRIPTION:
!
!       Reset (close/abort) a file
!
! FORMAL PARAMETERS:
!
!	FAB: An RMS FAB for open file.
!       ERR: Address of error routine
!
! COMPLETION CODES:
!
!	RMS$_SUC or RMS error code
!
! SIDE EFFECTS:
!
!	Internal blocks deallocated
!
!--

    BEGIN
    MAP FAB: REF $FAB_DECL;

    IF .FAB[FAB$V_REMOTE]
    THEN                                ! File is remote.
        BEGIN
        DAP$CLOSE(FAB[$],DAP$K_ACCOMP_PURGE,.ERR);      ! Close file

        IF (.FAB[FAB$H_FOP] NEQ RMS$_SUC)       ![14] If close failed
        AND (.FAB[FAB$V_FOP_DRJ] EQL 0) ![14] and link should close too
        THEN
            BEGIN
            BIND DIB=.FAB[FAB$A_IFI]: $DIB;
            DIB[DIB$V_ACCESS_ACTIVE]=DIB[DIB$V_FILE_OPEN]=0; ![14] just break
            DAP$CLOSE(FAB[$],DAP$K_ACCOMP_PURGE,.ERR)        ![14] link
            END;                        
        END
    ELSE
        BEGIN
        BIND FST=.FAB[FAB$A_IFI]: $RMS_FST;
        IF .FST[FST$V_NEW_FILE]              ![13] NEVER DELETE AN OLD FILE
        THEN $FAB_STORE(FAB=FAB[$],FOP=DLT); ! Set DELETE bit
        R$CLOSE(FAB[$],.ERR);           ! and close it
        END;
    .FAB[FAB$H_STS]                     ! Returned status code
    END;			!End of R$RESET
GLOBAL ROUTINE RL$CLOSE (FAB: REF $FAB_DECL, ERR)=
    BEGIN
    IF .FAB[FAB$A_IFI] NEQ 0        ! File really open?
    THEN
        BEGIN
        BIND TYP=.FAB[FAB$A_TYP]: $TYP_DECL;        ! Datatype block
        LOCAL DRJ;
        LOCAL CLASS;
        DRJ=.FAB[FAB$V_FOP_DRJ];        ! Save DRJ bit
        IF .FAB[FAB$V_FOP_DLT] THEN FAB[FAB$V_FOP_DRJ]=1; ! Keep JFN if delete
        CLASS=(IF TYP NEQ 0 THEN .TYP[TYP$H_CLASS] ELSE TYP$K_CLASS_ASCII);
        CASE .CLASS FROM 0 TO TYP$K_CLASS_MAX OF
             SET
             [TYP$K_CLASS_MACY11]: RL$CLMACY11(FAB[$],.ERR);
             [INRANGE]:  $CLOSE(FAB=FAB[$],ERR=.ERR);
             [OUTRANGE]: SIGNAL(FAB[FAB$H_STS]=RMS$_BUG,0,FAB[$]);
             TES;

        IF .FAB[FAB$V_FOP_DLT]              ! Should we delete it?
        THEN $ERASE(FAB=FAB[$]);            ! yes indeed

        FAB[FAB$V_FOP_DRJ]=.DRJ;        ! Restore DRJ
        END;

    %IF %SWITCHES(TOPS20)
        %THEN
            BEGIN
            LIBRARY 'TWENTY';
            REQUIRE 'JSYSDEF';
            IF (.FAB[FAB$H_JFN] NEQ 0)      ! Is the JFN still there?
            AND (.FAB[FAB$V_FOP_DRJ] EQL 0) !  and should go away
            THEN
                BEGIN
                JSYS_RLJFN(.FAB[FAB$H_JFN]); ! Try to release it
                FAB[FAB$H_JFN]=0;            !  and zero it
                END;
            END;
        %FI
    .FAB[FAB$H_STS]                     ! Return status
    END;                                ! RL$CLOSE
GLOBAL ROUTINE DAP$OPENFILE (FAB: REF $FAB_DECL,
                             FUNCTION,
                             NFAB: REF $FAB_DECL,
                             ERR): =
!++
! FUNCTIONAL DESCRIPTION:
!
!   OPEN/CREATE/... A REMOTE FILE
!
! FORMAL PARAMETERS:
!
!   FAB: An RMS FAB with a NODEID embedded in the filespec.
!   FUNCTION: ACCESS message function code (DAP) or 0 to exchange configs only
!   NFAB: New FAB for Rename
!   ERR: Address of error routine
!
! COMPLETION CODES:
!
!   RMS codes
!
! SIDE EFFECTS:
!
!  If .FAB[FAB$A_DIB] is zero:
!   A DIB is allocated.  FAB[FAB$A_DIB] will point to it
!   A NLB is allocated.  DIB[DIB$A_NLB] will point to it
!   2 $DAP_DESCRIPTORs are allocated, DIB[DIB$A_(I,O)_DD] point to them
!   A Configuration Block is allocated. DIB[DIB$A_CONFIG] will point to it
!
!   For ERASE and EXECUTE, the requested operation will have been completed
!   and the above data strucures de-allocated.
!--
    BEGIN
    MAP FAB: REF $FAB_DECL;
    MAP NFAB: REF $FAB_DECL;          ! New name for rename
    LOCAL FABSAV: VOLATILE;

    LOCAL NLB : REF $XPN_NLB();
    LOCAL DIB : REF $DIB;
    LOCAL ACCOPT: BITVECTOR[35] INITIAL(0),
          DISPLAY: BITVECTOR[28] INITIAL(0);
    LOCAL CFGBLK: REF $CONFIG;
    LOCAL OBUF,
          IDD: REF $DAP_DESCRIPTOR,
          ODD: REF $DAP_DESCRIPTOR;
    LOCAL CLASS;
    LOCAL ERRSAV: VOLATILE;

    ENABLE DAP$HANDLE(FABSAV,ERRSAV);
    ERRSAV=.ERR;
    FABSAV=.FAB;                        ! Handler will need this

    IF .FAB[FAB$A_DIB] EQL 0
    THEN
        BEGIN
        $XPO_GET_MEM(UNITS=DAP$K_BUFFER_SIZE %BLISS36(/4), RESULT=OBUF);
                                            ! Allocate output buffer

        $XPO_GET_MEM(UNITS=DAP$K_DESCRIPTOR_LEN, RESULT=ODD, FILL=0);
        $XPN_DESC_INIT(DESCRIPTOR=ODD[$],CLASS=DYNAMIC_BOUNDED,
                       BINARY_DATA=(DAP$K_BUFFER_SIZE,.OBUF,BYTES));

        $XPO_GET_MEM(UNITS=DAP$K_DESCRIPTOR_LEN, RESULT=IDD, FILL=0);
        $XPN_DESC_INIT(DESCRIPTOR=IDD[$],CLASS=BOUNDED);

        $XPO_GET_MEM(UNITS=NLB$K_LENGTH, RESULT=NLB, FILL=0); ! Allocate an NLB
        $XPN_NLB_INIT(NLB=NLB[$]);

        $XPO_GET_MEM(UNITS=DIB$K_LENGTH, RESULT=DIB, FILL=0); ! Allocate a DIB

        !Now set up the pointers:
        !
        !   +---------+   +---------+   +---------+
        !   |   FAB   |-->|   DIB   |-->| CONFIG  |
        !   +---------+   +----+----+   +---------+
        !            ,----'    V    `-.
        !   +---------+   +---------+ :  
        !   |   IDD   |   |   ODD   | :  
        !   +---------+   +--+------+ :
        !            `--.    V        ;
        !            +-----------+<--'
        !            |    NLB    |
        !            +-----------+
        ! 

        FAB[FAB$A_DIB]=DIB[$];              ! Point the Fab at the DIB
        DIB[DIB$A_NLB]=NLB[$];              ! Point the DIB at the NLB
        DIB[DIB$A_I_DD]=IDD[$];             !  ... and the input descriptor
        DIB[DIB$A_O_DD]=ODD[$];             !  ... and the output descriptor

        ODD[DAP$A_NLB]=NLB[$];              ! Output descriptor points to NLB
        IDD[DAP$A_NLB]=NLB[$];              ! Input descriptor ...

        IDD[DAP$A_OTHER_DD]=ODD[$];         ![6] DD's should point
        ODD[DAP$A_OTHER_DD]=IDD[$];         ![6]  to each other

        $XPO_GET_MEM(UNITS=CONFIG$K_LEN, RESULT=CFGBLK, FILL=0); ! Alloc config
        DIB[DIB$A_CONFIG]=CFGBLK[$];        ! Point the Dib at it

        SET_ACCESS_INFO (NLB[$],.FAB[FAB$A_FNA]);   ! Extract access info
                                                        ! from nodename

        !++
        ! Open the link
        !--

        IF .PMRFLG NEQ 0  ![10] PMRFLG is patched to enable poor-man's routing
        THEN
        $XPN_OPEN (NLB=NLB[$], OBJECT=OBJ_FAL, TYPE=ACTIVE,
                   OPTIONS=(WAIT,PMR),                  ! ask for PMR
                   BUFFER_SIZE=DAP$K_BUFFER_SIZE,       ! Tell PMR buffer size
                   TIMEOUT = 180, FAILURE=XPN$SIGNAL)
        ELSE
        $XPN_OPEN (NLB=NLB[$], OBJECT=OBJ_FAL, TYPE=ACTIVE,
                   OPTION=WAIT,
                   TIMEOUT = 180, FAILURE=XPN$SIGNAL);

        DAP$PUT_CONFIG(ODD[$],DAP$K_BUFFER_SIZE);
        DAP$PUT_MESSAGE(ODD[$]);                    ! Send configuration

        DAP$GET_CONFIG(IDD[$],CFGBLK[$]);           ! Get one back

        ! Workaround VMS BYTLM bug.
        ! If user BYTLM is less than our buffersize, VMS FAL hangs
        ! trying to send a message that is too large.
        ! Currently we set a limit of what the VAX sends us - 256
        IF .VMSBUG[VMS_BUG_BYTLM_HANG]  ! VMS does not check its own limit
        AND (.CFGBLK[CONFIG$B_OSTYPE] EQL DAP$K_VMS)
        THEN
            BEGIN                   ! Exchange new configurations
            LOCAL BUFSIZ;           ! Gets lower of our max or vms's
            OWN VMSSLP: INITIAL(256);  !! Patchable

            BUFSIZ=MIN(.CFGBLK[CONFIG$H_BUFSIZ]-.VMSSLP, DAP$K_BUFFER_SIZE);

            DAP$PUT_CONFIG(ODD[$],.BUFSIZ);
            DAP$PUT_MESSAGE(ODD[$]);
            DAP$GET_CONFIG(IDD[$],CFGBLK[$]);
            CFGBLK[CONFIG$H_BUFSIZ]=.BUFSIZ;        ! Don't forget the slop
            END;
        END
    ELSE
        BEGIN                           ! Set up local pointers
        DIB=.FAB[FAB$A_DIB];
        IDD=.DIB[DIB$A_I_DD];
        ODD=.DIB[DIB$A_O_DD];
        NLB=.DIB[DIB$A_NLB];
        CFGBLK=.DIB[DIB$A_CONFIG];
        END;

    ! Remember the function we were trying to do
    DIB[DIB$B_OPERATION]=.FUNCTION;
    DIB[DIB$A_NEW_FAB]=NFAB[$];         ! Remember new FAB (for RENAME)

    IF (.CFGBLK[CONFIG$H_BUFSIZ] GTR 0)
    THEN ODD[DAP$H_MESSAGE_LENGTH]=     ![14] Use remote buffer size if smaller
           MIN(.ODD[DAP$H_MESSAGE_LENGTH],.CFGBLK[CONFIG$H_BUFSIZ]);

    ! The link is now open, and CONFIG messages have been exchanged.
    ! Subsequent accesses over the same link can skip this block

    IF (.DIB[DIB$V_FILE_OPEN] AND .FAB[FAB$V_FOP_DRJ]) ! Already opened
    OR (.FUNCTION EQL 0)                       ! or didn't want to
    THEN RETURN (FAB[FAB$H_STS]=RMS$_SUC);     ! Return if that's all we wanted

    !
    ! Check for unsupported features
    !

    ! Block mode is only permissible between homogenous systems
    IF .FAB[FAB$V_FAC_BIO] AND (.CFGBLK[CONFIG$B_OSTYPE] NEQ OUR_OSTYPE)
    THEN SIGNAL(FAB[FAB$H_STS]=RMS$_SUP,
                FAB[FAB$H_STV]=DAP$K_MAC_UNSUPPORTED+DAP$K_MIC_ACCESS_FAC,
                FAB[$]);

    ! Default to ASCII if no datatype specified

    IF .FAB[FAB$A_TYP] NEQ 0
    THEN CLASS=.BLOCK[.FAB[FAB$A_TYP],TYP$H_CLASS]
    ELSE CLASS=0;

    IF .CLASS EQL 0 THEN CLASS=TYP$K_CLASS_ASCII;

    ! Default the RFM to something reasonable if this is an ASCII file

    IF (.CLASS EQL TYP$K_CLASS_ASCII) AND (.FAB[FAB$Z_RFM] EQL FAB$K_RFM_UDF)
    THEN
        BEGIN
        CASE .CFGBLK[CONFIG$B_OSTYPE]
        FROM 1 TO DAP$K_OSTYPE_MAX OF
        SET
        [DAP$K_RSTS,
         DAP$K_TOPS10,
         DAP$K_TOPS20,
         DAP$K_RT11,
         DAP$K_OS8,
         DAP$K_RTS8]:  FAB[FAB$Z_RFM]=FAB$K_RFM_STM;
        [INRANGE]:
             BEGIN
             FAB[FAB$Z_RFM]=FAB$K_RFM_VAR;      ![7] Variable
             IF .FAB[FAB$H_RAT] EQL 0           ![17] If no record attributes
             THEN FAB[FAB$V_RAT_CR]=1;          ![7] Set Implied CRLF
             END;
        [OUTRANGE]: SIGNAL(RMS$_DPE,
                           DAP$K_MAC_INVALID+DAP$K_MIC_CONFIG_OSTYPE,
                           FAB[$]);
        TES;
        END;     

    IF .FAB[FAB$V_FOP_CIF] THEN FAB[FAB$V_FOP_SUP]=0; ![11] CIF overrides SUP

    DAP$PUT_ATTRIBUTES(ODD[$],FAB[$]);          ! Send Attributes
    
    ! If FOP bit CIF (Create-if) is set, make CREATE into OPEN
    IF .FAB[FAB$V_FOP_CIF] AND (.FUNCTION EQL DAP$K_CREATE)
    THEN FUNCTION=DAP$K_OPEN;

    ! Now see what attributes we want back on the access.
    ! We will ask for whatever we have XAB's, etc for.
    IF .FAB[FAB$A_NAM] NEQ 0 THEN DISPLAY[DAP$V_DISPLAY_NAM]=1; ! File name

        BEGIN
        LOCAL XAB: REF $XABDAT_DECL;

        XAB=.FAB[FAB$A_XAB];                        ! Search the XAB chain
        WHILE .XAB NEQ 0
        DO  BEGIN
            CASE .XAB[XABDAT$Z_COD] FROM XABKEY$K_COD TO XABSUM$K_COD OF
                SET
    !            [XABKEY$K_COD]: DISPLAY[DAP$V_DISPLAY_KEY]=1;
    !            [XABALL$K_COD]: DISPLAY[DAP$V_DISPLAY_ALL]=1;
                [XABDAT$K_COD]: DISPLAY[DAP$V_DISPLAY_DTM]=1;
    !            [XABSUM$K_COD]: DISPLAY[DAP$V_DISPLAY_SUM]=1;
    !            [XABPRO$K_COD]: DISPLAY[DAP$V_DISPLAY_PRO]=1;
                [INRANGE]:;
                TES;
            XAB=.XAB[XABDAT$A_NXT];                 ! On to the next one
            END;
        END;
        DISPLAY[DAP$V_DISPLAY_ATT]=1;   ! Always get main attributes

    DAP$PUT_ACCESS(ODD[$],FAB[$],.FUNCTION,ACCOPT,DISPLAY,NFAB[$]);! And Access
    DAP$PUT_MESSAGE(ODD[$]);

    DIB[DIB$V_ACCESS_ACTIVE]=1;                 ! Access is now active

    SELECT .FUNCTION OF
    SET

    [DAP$K_DIRECTORY]:
        RETURN FAB[FAB$H_STS]= RMS$_SUC;        ! Get directory info on SEARCH

    [OTHERWISE]:
        DAP$GET_ATTRIBUTES(IDD[$],FAB[$]);      ! Get returned Attributes

    [DAP$K_OPEN, DAP$K_CREATE, DAP$K_SUBMIT]:
        DIB[DIB$V_FILE_OPEN]=.DIB[DIB$V_ACCESS_ACTIVE]; ! File is open, or
                                                        ! access is complete
    [DAP$K_EXECUTE, DAP$K_ERASE]:
        DIB[DIB$V_FILE_OPEN]=0;           ! These operations do not open files
    TES;

    IF (.FAB[FAB$V_FOP_DRJ] EQL 0)
    AND (.DIB[DIB$V_FILE_OPEN] EQL 0)
    THEN
        BEGIN                           ! Close the link & free data strs
        DAP$CLOSE(FAB[$],DAP$K_ACCOMP_COMMAND,.ERR);
        DIB[DIB$V_ACCESS_ACTIVE]=0;
        END;

    FAB[FAB$H_STS]=RMS$_SUC
    END;			!End of DAP$OPENFILE
GLOBAL ROUTINE DAP$CLOSE (FAB,FUNCTION,ERR): =
!++
! FUNCTIONAL DESCRIPTION:
!
!   Close a remote file
!
! FORMAL PARAMETERS:
!
!   FAB: An RMS FAB with a NODEID embedded in the filespec.
!   FUNCTION: ACCESS message function code (DAP)
!   ERR: Address of error routine
!
! SIDE EFFECTS:
!
!   If there are no more files coming:
!    The link is closed
!    The DIB attatched to the FAB, and its subsidiary data structures are freed
!   If there is another file (wildcarding), the attributes are read into FAB
!--
    BEGIN
    MAP FAB: REF $FAB_DECL;
    BIND DIB=.FAB[FAB$A_DIB]: $DIB;
    BIND ODD=.DIB[DIB$A_O_DD]: $DAP_DESCRIPTOR;
    BIND IDD=.DIB[DIB$A_I_DD]: $DAP_DESCRIPTOR;
    BIND NLB=.DIB[DIB$A_NLB]: $XPN_NLB();
    BIND C=.DIB[DIB$A_CONFIG]: $CONFIG;
    LOCAL V;                            ! Temp for returned value
    LOCAL FABSAV: VOLATILE;
    LOCAL ERRSAV: VOLATILE;
    LOCAL SEND_INTERRUPT: INITIAL(0);   ![12] Flag for interrupt message

    ENABLE DAP$HANDLE(FABSAV,ERRSAV);   ! Setup Condition handler
    ERRSAV=.ERR;
    FABSAV=.FAB;                        ! Handler will need this

    IF .FAB[FAB$A_IFI] EQL 0            ! Make sure it's open
    THEN
        BEGIN                           ! No DIB there
        FAB[FAB$H_STS]=RMS$_IFI;        ! Don't do it
        SIGNAL(RMS$_IFI,0,FAB[$]);
        RETURN .FAB[FAB$H_STS];         ! Even if handler doesn't care
        END;

    IF .FUNCTION EQL DAP$K_ACCOMP_PURGE ![12] Purge is sent as interrupt
    THEN
        BEGIN
        SEND_INTERRUPT=1;

        ! Forget what we were going to send
        ODD[DAP$H_BYTES_REMAINING]=16;   ! Max length for interrupt message
        ODD[DAP$A_DATA]=CH$PLUS(.ODD[DAP$A_DATA],-.ODD[DAP$H_BYTES_USED]);
        ODD[DAP$H_BYTES_USED]=0;                          !to data in message
        END;

    IF (.FAB[FAB$V_FAC_PUT] EQL 0) AND (.FUNCTION EQL DAP$K_ACCOMP_PURGE)
    THEN FUNCTION=DAP$K_ACCOMP_COMMAND; ! Some FAL's interpret purge as
                                        ! erase, even for input files!!

    IF .DIB[DIB$V_FILE_OPEN]            ! Send Access complete if file open,
    THEN                                ! otherwise don't bother
        BEGIN
        LOCAL FOP: BITVECTOR[42] INITIAL(REP ((%BPUNIT+41)/%BPUNIT) OF (0));
        LOCAL FOPLENGTH;

        $DAP_MOVE_BITS(FAB,FAB$V_FOP_,FOP,DAP$V_FOP_,
                       RWO,RWC,POS,DLK,LCK,
                       CTG,SUP,NEF,TMP,MKD,DMO,
                       WCK,RCK,CIF,LKO,SQO,MXV,SPL,
                       SCF,DLT,CBT,WAT,DFW,TEF,OPF,
                       DRJ,DFW);

        IF .IASBUG[IAS_BUG_ACM_FOP]     ![11] IAS does not like most fop bits
        AND (.C[CONFIG$B_OSTYPE] EQL DAP$K_IAS)
        THEN FOP=(.FOP AND DAP$V_FOP_SPL);

	FOPLENGTH=DAP$SIZE_BITVECTOR(FOP,6,0);

        INIT_MESSAGE(ODD[$]);
        ODD[DAP$B_OPERATOR]=DAP$K_ACCESS_COMPLETE;
        ODD[DAP$V_MFLAGS_LENGTH]=1;
        ODD[DAP$H_LENGTH]=.FOPLENGTH+1; ! Count length of FOP
        DAP$PUT_HEADER(ODD[$]);
        DAP$PUT_BYTE(ODD[$],.FUNCTION); ! COMMAND (normal) or PURGE (punt)

        IF .FOPLENGTH NEQ 0             ! Send FOP if needed
        THEN DAP$PUT_BITVECTOR(ODD[$],FOP,6);

        IF .SEND_INTERRUPT NEQ 0        ![12] Interrupt message?
        THEN ODD[DAP$V_INTERRUPT]=1;    ! 
        DAP$PUT_MESSAGE(ODD[$]);            ! Send it

        WHILE 1 DO                      ![2] Clean out pipeline
            BEGIN
            V=DAP$GET_HEADER(IDD[$]); ! Get response

            SELECT .V OF SET
            [DAP$K_ACCESS_COMPLETE]:
                BEGIN                               ! Yes,
                LOCAL CMPFUNC;
                LOCAL FOP: BITVECTOR[42];

                CMPFUNC=DAP$GET_BYTE(IDD[$]);         ![4] Eat rest of message
                IF .CMPFUNC NEQ DAP$K_ACCOMP_RESPONSE ![4] Is it a response
                THEN SIGNAL(RMS$_DPE,0,FAB[$]);       ![4] Error if not

                DIB[DIB$V_FILE_OPEN]=0;             ! File is not open any more
                DIB[DIB$V_ACCESS_ACTIVE]=0;         ! No access any more

                IF .IDD[DAP$H_BYTES_REMAINING] GTR 0
                THEN
                    BEGIN
                    DAP$GET_BITVECTOR(IDD[$],FOP,6);  ![4] Eat FOP field if any
                    $DAP_MOVE_BITS(FOP,DAP$K_FOP_,FAB,FAB$V_FOP_,
                                   RWO,RWC,POS,DLK,LCK,
                                   CTG,SUP,NEF,TMP,MKD,DMO,
                                   WCK,RCK,CIF,LKO,SQO,MXV,SPL,
                                   SCF,DLT,CBT,WAT,DFW,TEF,OPF,
                                   DRJ,DFW);
                    END;

                EXITLOOP FAB[FAB$H_STS]=RMS$_SUC;
                END;
            [DAP$K_NAME]:
                BEGIN
                EXITLOOP DAP$UNGET_HEADER(IDD[$]);  ! Back up for SEARCH
                END;                             
            [DAP$K_STATUS]:
                BEGIN
                LOCAL E;
                E=DAP$GET_STATUS(IDD[$]);   ! End of file or error
                FAB[FAB$H_STS]=DAP$ERROR_DAP_RMS(.E);
                FAB[FAB$H_STV]=.E<DAPCODE>;
                IF .FAB[FAB$H_STS] NEQ RMS$_EOF ! Break out for unusual errors
                THEN EXITLOOP SIGNAL(.FAB[FAB$H_STS],.FAB[FAB$H_STV],FAB[$]);
                END;                            ! error code

            [DAP$K_DATA]: WHILE .IDD[DAP$H_LENGTH] GTR 0 ![2] Eat data
                          DO DAP$GET_BYTE(IDD[$]);                ![2] 

            [OTHERWISE]: SIGNAL(RMS$_DPE,0,FAB[$]);
            TES;
            END; ! WHILE 1
        END;

    ! Note that DRJ must be set, if wildcarding,
    ! until all files have been read.

    IF (.FAB[FAB$V_FOP_DRJ] EQL 0)      ! Should we keep things open?
    THEN
        BEGIN
        $XPN_CLOSE(NLB=NLB[$], FAILURE=0);  ! Close the link

        $XPO_FREE_MEM(BINARY_DATA=(DAP$K_DESCRIPTOR_LEN,IDD[$]));
        $XPO_FREE_MEM(BINARY_DATA=(NLB$K_LENGTH,NLB[$]));    
        $XPO_FREE_MEM(BINARY_DATA=(DAP$K_BUFFER_SIZE %BLISS36(/4),
                                   %BLISS36( .(ODD[DAP$A_DATA])<0,18>)+1 )
                                  );       ! Deallocate output buffer
        $XPO_FREE_MEM(BINARY_DATA=(DAP$K_DESCRIPTOR_LEN,ODD[$]));
        $XPO_FREE_MEM(BINARY_DATA=(DIB$K_LENGTH,DIB[$]));
        FAB[FAB$A_DIB]=0;
            END;

    .V
    END;                ! DAP$CLOSE
GLOBAL ROUTINE DAP$HANDLE (SIGNAL_ARGS,MECH_ARGS,ENABLE_ARGS) =
!++
! FUNCTIONAL DESCRIPTION:
!
!       Condition handler for requests
!
! FORMAL PARAMETERS:
!
!	SIGNAL_ARGS: addr of vector of SIGNAL arguments,
!       MECH_ARGS: not used,
!       ENABLE_ARGS: args passed when this handler was established
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! COMPLETION CODES:
!
!	0: Resignal, 1: Continue
!
! SIDE EFFECTS:
!
!	NONE
!
!--

    BEGIN
    MAP SIGNAL_ARGS: REF VECTOR,
        MECH_ARGS: REF VECTOR,
        ENABLE_ARGS: REF VECTOR;

    BIND BLK=..ENABLE_ARGS[1]: $FAB_DECL;          ! RMS block
    BIND ROUTINE $$ERRRTN=..ENABLE_ARGS[2]: RMS_ERCAL;       ! Error routine

    LOCAL SEVERITY;

    SEVERITY= .(SIGNAL_ARGS[1])<0,3>;

    SELECT .SIGNAL_ARGS[1] OF
           SET
           [SS$_UNWIND]:
                         BEGIN
                         RETURN STS$K_NORMAL;
                         END;
           [RMS$K_SUC_MIN TO RMS$K_SUC_MAX]: SEVERITY=SS$_NORMAL;

           [RMS$K_ERR_MIN TO RMS$K_ERR_MAX]:
                         SEVERITY=SS$_ERROR;
           [RMS$K_ERR_MIN TO RMS$K_ERR_MAX, RMS$K_SUC_MIN TO RMS$K_SUC_MAX]:
                         BEGIN
                         BLK[FAB$H_STS]=.SIGNAL_ARGS[1];
                         BLK[FAB$H_STV]=.SIGNAL_ARGS[2];
                         END;

           [DAP$K_FACILITY_CODE TO DAP$K_FACILITY_CODE+%O'7777777']:
                         BEGIN
                         BLK[FAB$H_STS]=DAP$ERROR_DAP_RMS(.SIGNAL_ARGS[1]);
                         BLK[FAB$H_STV]=.(SIGNAL_ARGS[1])<DAPCODE>;
                         END;

           [XPN$$SELECT_XPN_ERRORS]:
                         IF NOT .SEVERITY       ! If this is a connect error
                         THEN                   ! then change to RMS code
                             BEGIN
                             BLK[FAB$H_STS]=RMS$_CON;
                             BLK[FAB$H_STV]=.SIGNAL_ARGS[1]; ! XPN code
                             END;

           [XPN$_ABORTED, XPN$_DISCONN]:
                         BEGIN
                         MAP BLK: $RAB_DECL;
                         BIND FAB=(IF .BLK[RAB$H_BID] EQL RAB$K_BID
                                   THEN .BLK[RAB$A_FAB]
                                   ELSE BLK[$]): $FAB_DECL;

                         BIND DIB=.FAB[FAB$A_DIB]: $DIB;

                         FAB[FAB$V_FOP_DRJ]=0;  ![14] Link is no good any more
                         DIB[DIB$V_FILE_OPEN]=DIB[DIB$V_ACCESS_ACTIVE]=0;
                                      ![14] Abort means it is not open any more
                         SEVERITY=STS$K_ERROR;  ! Treat as error
                         BLK[RAB$H_STS]=RMS$_NLB;
                         END;       ! Network link broken (Abort or Disconnect)

           [XPN$_NO_OPEN, XPN$_REJECTED]:
                         BLK[FAB$H_STV]=.SIGNAL_ARGS[2];
                         ! DECnet reason code will be STV for
                         ! unspecified open error

           [OTHERWISE]:
                BEGIN
                BLK[FAB$H_STS]=RMS$_BUG;        ! Should not occur
                BLK[FAB$H_STV]=.SIGNAL_ARGS[1]; !
                SEVERITY=SS$_FATAL;             !
                END;
           TES;


    CASE .SEVERITY FROM 0 TO 7 OF
         SET
         [STS$K_ERROR]:
                BEGIN
                $$ERROR(OPEN,BLK);              !? Should get operation too
                SETUNWIND();
                MECH_ARGS[MA_RETURN]=.BLK[FAB$H_STS];   ! Return status code
                RETURN 0;
                END;
         [STS$K_WARNING]:  
                BEGIN
                $$ERROR(OPEN,BLK);              !? Should get operation too
                RETURN STS$K_NORMAL;
                END;
         [STS$K_NORMAL, STS$K_INFO]: RETURN STS$K_NORMAL;
         [STS$K_FATAL,INRANGE]: ;
         TES;

    SS$_RESIGNAL
    END;			!End of DAP$HANDLE
END            !End of module
ELUDOM