Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

module fileio	(! Intercept XPORT calls for special processing
		ident = '1',
		%if
		    %bliss(bliss32)
		%then
		    language(bliss32),
		    addressing_mode(external=general,
				    nonexternal=long_relative)
		%else
		    language(bliss36)
		%fi
		) =
begin

!
!			COPYRIGHT (C) 1982 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
! ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
! COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
! AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!

!++
! Facility:  CMS Library Processor
!
! Abstract:
!
!	Intercept various XPORT calls to add special processing
!
! Environment: Transportable
!
! Author:  Dave Knight
!
!--

!
! Table of Contents:
!
forward routine
    file$close,			!Close file
    file$get,			!get record
    print_please_wait_message,	!utility used by file$open
    file$open,			!Open specified file
    file$rename,		!rename specified file
    file$delete,		!delete specified file
    file$put;			!put record

!
! Include Files:
!

%if %bliss(bliss32) %then
   library 'sys$library:starlet';
%fi

library 'XPORT:' ;
require 'SCONFG:' ;

%if
   %bliss(bliss36)
%then
   require 'jsys:';
%fi

require 'BLISSX:' ;
require 'CNCUSR:';

!
! Equated Symbols:
!
literal
    debug = %variant eql 1,	  ! generate debug code if compiled with /VAR:1

    k_first_inform = 5,		  ! How soon do we start telling him?
    k_inform_every_nth = 30,	  ! Say hello to the user on every 30th attempt
    k_max_attempts = 240,	  ! Maximum number of times to try getting the
				  ! library before giving up.
    k_retry_seconds = 1,	  ! Number of seconds for an on-line process to
				  ! wait before trying to get the library again
    k_file_busy = step$_file_lock;! literal to test file-locked condition

!
! Own Storage:
!

!
! External References:
!
external
    test: vector,		! vector of values from /T_E_S_T_ qualifier
    as_file: vector[ch$allocation(extended_file_spec)],	
    				! storage for SHOW/append filename
    d_as_file: desc_block,	! desc for SHOW/append filename
    
				!+
				!   The following flag are set on open to 
				!   indicate that an append operation is 
				!   occurring and are cleared when the
				!   restore address is saved in the rolbck
				!   list.
				!-
				
    f_ap_his_pending,		! history file
    f_ap_err_pending,		! error file
    f_ap_shw_pending,		! Show output file that is to be appended
	
    f_as_setout;		! this flag is set by the routine SETOUT
    				! to indicate that show command is going
    				! to append an output file.
external literal
	s_inuse,		! in use message
	s_proceed,		! proceeding message
	s_rbcloseno,		! unable to close file - rolbck enacted
	s_rbgeterr,		! unable to perform GET operation on file
	s_rbopenno,		! unable to open file - rolbck enacted
	s_rbputerr,		! unable to perform PUT operation on file
	s_waiting;		! waiting message

external routine
    badbug,			! print error message without rolbck(ERRMSG)
    ersiob,			! print error message and do rolbck(ERRMSG)
    gen_lim,			! check file generation limit
    hibernate : novalue,	! Wait for the specified interval.
    nateql,			! compare filename and type for equality
    dirspc,			! extract directory part of file specification
    fuldir,			! get full specification of a directory
    io$open,			! open a file
    io$close,			! close a file
    io$get,                     ! get a record
    io$put,                     !put a record
    io$rename,			! rename a file
    io$delete,			!delete a file
    rbadd,			! add entry to rolbck list
    rbafn,			! add entry to rolbck closed filenames list
    rbcln,			! check for system logical name(ROLBCK)
				!   or otherwise inappropriate for rolbck
    rbremv,			! remove entry from rolbck list(ROBCK)
    rbsvap,			! save restore address for append(ROLBCK)
    lib$put_output,		! print message - debug***(TERMNL)
    sysmsg,			! Talk to the user.
    xpo$failure;		! name of xport standard action routine(XPORT)

routine deb_close_msg (iobadr) : novalue =

!++
! Functional Description:
!
!	Produce a message on user's terminal indicating this file has been
!	closed.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	  [iob$t_resultant] - name of file
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	none
!
! Side Effects:
!
!	Message is printed using lib$put_output.
!
!--

    begin
    bind
	iob = .iobadr : $xpo_iob();

    lib$put_output (cat('- ',iob[iob$t_resultant]));

    end;   !(of deb_close_msg)

routine deb_open_msg (iobadr) : novalue =
!++
! Functional Description:
!
!	Produce a message on user's terminal indicating this file has been
!	opened, the input, append, overwrite, output status is also included.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	  [iob$t_resultant] - name of file
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	none
!
! Side Effects:
!
!	Message is printed using lib$put_output.
!
!--

    begin
    bind
	iob = .iobadr : $xpo_iob();

    local
	d_attrib : $str_descriptor();

    selectone true of 
	set
	[.iob[iob$v_input]] : $str_desc_init (descriptor = d_attrib,
	    				      string = ' for input');

	[.iob[iob$v_append]] : $str_desc_init (descriptor = d_attrib,
	    				       string = ' for append');

	[.iob[iob$v_overwrite]]: $str_desc_init (descriptor = d_attrib,
	    					 string = ' for overwrite');

	[.iob[iob$v_output]] : $str_desc_init (descriptor = d_attrib,
	    				       string = ' for output');

	[otherwise]: $str_desc_init (descriptor = d_attrib,
	    			     string = ' for unknown operation');

	tes;

    lib$put_output (cat('+ ', iob[iob$t_resultant], d_attrib));

    end;   !(of deb_open_msg)

global routine file$close (iobadr,sucadr,failadr) =

!++
! Functional Description:
!
!	Close specified file
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	sucadr - success return address
!	failadr - failure return address
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	Standard $XPO_CLOSE values
!
! Side Effects:
!
!	none
!
!--

    begin	! file$close

    
    bind
        iob = .iobadr: $xpo_iob() ;		! iob
    
    local
	f_remember,			! set when remember option is set to 
					!  preserve data & ignore initialize
	f_sys_log_name,			! set when a system logical name
	f_terminal,			! i/o to terminal
	status ;			! return status from export call


    
    f_terminal = .iob[iob$v_terminal] ;

    f_sys_log_name = rbcln(iob) ;

    f_remember = .iob[iob$v_remember];
			
    !+
    !   Unconditionally disable CTRL/C interrupts
    !-
    disable_ctl_y;

%if debug %then 
    
    ! DEBUG ****
    lib$put_output(cat('closing file ',iob[iob$t_resultant])) ;
    

%fi

    IF not .f_terminal and not .f_sys_log_name
    THEN
	BEGIN

	! save filename for closed list 
	IF not rbafn(.iobadr)
	THEN
	    badbug(cat('Unable to add file ',iob[iob$t_resultant],
		       ' to Closed files list (FILE$CLOSE)')) ;
	
	IF not rbremv(.iobadr)
	THEN
	    badbug(lit('Unable to remove file from Roll Back list')) ;

	END;

    status = io$close(iob,.sucadr,0);

    ! bad I/O with start action routine specified
    IF (not .status) and .failadr eql xpo$failure
    THEN
        ! print error message and do ROLBCK
	ersiob(s_rbcloseno,.iobadr,cat('Unable to close file ',
			iob[iob$t_resultant]));
    
    ! bad I/O with user action routine specified
    IF (not .status) and .failadr neq 0
    THEN
	! call user action routine
	status=(.failadr)(xpo$k_io,.iob[iob$g_comp_code],
				.iob[iob$g_2nd_code],.iobadr);

    ! bad I/O and failure specified as 0
    IF (not .status) and failadr eql 0
    THEN
	begin
	!give the user ctrl/y back
	enable_ctl_y;
	return .status
	end;
    
    ! success - IOB cleared
    IF .status
    THEN
	BEGIN	! successful I/O

	!+
	!  Print special close message similar to -20 "SET TRAP FILE-OPENINGS".
	!-
	if .status and .test[11] gtr 0
	then
	    deb_close_msg(.iobadr);


%if debug %then 
    
        ! **** debug ****
	lib$put_output(lit('FILE$CLOSE was successful')) ;

%fi

	END;	! successful I/O

        if 
            not (.f_remember)
        then
            BEGIN

	    %if Tops20 %then
            BIND
                resultant = iob[iob$t_resultant] : 
                               $str_descriptor(class = dynamic);

            iob[iob$v_options] = 0;	!blank the set bits in the iob
             				!unless initialized, system keeps
					!"remember" of $close, and doesn't
					!use new data
            iob[iob$v_terminal] = 0;
            iob[iob$v_eof] = 0;
            $xpo_free_mem(string = resultant);
            resultant[str$h_length] = 0;
            resultant[str$a_pointer] = 0;
	    %fi

	    %if VaxVms %then
            BIND
                fab = .iob[iob$a_rms_fab] : $fab_decl;

            iob[iob$v_options] = 0;	!blank the set bits in the iob
            iob[iob$v_terminal] = 0;
            fab[fab$l_fop] = 0;		!zero file options but
            fab[fab$v_sqo] = 1;		! this one.
            fab[fab$b_rat] = 0;
            fab[fab$b_rfm] = fab$c_var;
	    %fi
            END;
    !+
    !   Unconditionally re-enable CTRL/C interrupts
    !-
    enable_ctl_y;	    

    ! return status in any case
    .status
	
    end ;	! file$close

global routine file$get (iobadr,sucadr,failadr) =

!++
! Functional Description:
!
!      Get a record from a specified file. Start up ROLBCK by printing an error
!      message if a failure occurs with the standard action routine specified.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	sucadr - success return address
!	failadr - failure return address
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	Standard $XPO_GET values
!
! Side Effects:
!
!	none
!
!--

    begin	! file$get
	
    LOCAL
        status;

    BIND
        iob = .iobadr : $xpo_iob() ;

    !to get around an XPORT bug
    failadr = 0;


    status = io$get(.iobadr, .sucadr, 0);

    ! bad I/O with standard action routine specified
    IF (not .status) and .failadr eql xpo$failure
    THEN
        ! print error message and do ROLBCK
	ersiob(s_rbgeterr,.iobadr,
	  cat('Unable to peform GET operation on file ',iob[iob$t_resultant]));
    
    ! bad I/O with user action routine specified
    IF (not .status) and .failadr neq 0
    THEN
	! call user action routine
	status=(.failadr)(xpo$k_io,.iob[iob$g_comp_code],
				.iob[iob$g_2nd_code],.iobadr);

    ! bad I/O and failure specified as 0
    IF (not .status) and failadr eql 0
    THEN
	return .status;
	    
    ! return status in any case
    .status
    
    end ;	! file$get

routine print_please_wait_message (iobadr) =

!++
! Functional Description:
!	Determine if file is in library or is a user file, and print
!	appropriate "Please Wait" message.
!
!
! Formal Parameters:
!
!	iobadr - address of IOB
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	true  - file belongs to CMS (in CMS$LIB) and appropriate message printed.
!	false - file belongs to user and appropriate message printed.
!
! Side Effects:
!
!	none
!
!--

    begin

    map
 	iobadr : ref $xpo_iob();

    local

 	library_file,				! hold return value

	dir_name : desc_block;			! pointer to source logical name


    !+
    !  Pick up the directory part of file-name-resultant, then use FULDIR
    !  to determine if it is equivanent to CMS$LIB:
    !-

    dirspc (iobadr[iob$t_resultant] , dir_name);
    fuldir (.dir_name[desc_len], .dir_name[desc_ptr],
 	    k_null, library_file);

    !+
    !  Print message
    !-

    if .library_file then
	sysmsg(s_inuse,
	       lit(%string('Your ',fac_name,
		   ' library is in use;  please wait')),0)
    else
	sysmsg(s_inuse,
	       cat('Your file, ', iobadr[iob$t_resultant],
		   ' is in use;  please wait'),0);

    return .library_file;			! return status to caller
    end;

global routine file$open (iobadr,sucadr,failadr) =

!++
! Functional Description:
!
!	When attempting to obtain the desired access, the routine will
!	wait a reasonable interval for other users to relinquish the
!	library.  The current user will be informed about this wait
!	and the reason for it.  If the wait is excessive (on the order of
!	4 minutes) XPO$_FILE_LOCK will be returned.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	sucadr - success return address
!	failadr - failure return address
!
! Implicit Inputs:
!
!	lots
!
! Implicit Outputs:
!
!	lots
!
! Routine Value:
! Completion Codes:
!
!	Standard $XPO_OPEN values
!
! Side Effects:
!
!	The file is opened for the type of access requested.  This may
!	involve a delay until the desired access can be obtained.
!
!--

    begin	! file$open

    map
	iobadr : ref $xpo_iob();

    bind
	file_spec=.iobadr[iob$a_file_spec] : $str_descriptor();

    local
        library_file : initial(true),	! File being opened is in library
					!   used to control messages to user
	attempts,			! Number of unsuccessful attempts
					! to open the file.
	d_file: desc_block,		! temp desc
	ren_count,			! keep track of rename tries
	status;				! Status code from XPORT.
   

    IF .iobadr[iob$v_append]
    THEN
	BEGIN	! append file

	!+
	!   Check for append file operation and if so then set pending flag
	!   until the first put operation is completed thereby save the 
	!   restore address in the rolbck list.
	!-
		
	! check for 00fac_name.err file
	IF nateql(lit(erlg),file_spec)
	THEN
	    f_ap_err_pending = true ;
	
	! check for 00fac_name.his file
	IF nateql(lit(log),file_spec)
	THEN
	    f_ap_his_pending = true ;
	
	! is this append due to SHOW/APPEND (from the SETOUT Routine)
	IF .f_as_setout
	THEN
	    BEGIN	! save name of show output file

	    $str_desc_init(descriptor=d_as_file,
			   string=(extended_file_spec,ch$ptr(as_file))) ;
	    
	    f_ap_shw_pending = true ;
	    
	    END;	! save name of show output file
	END;	! append file

    !+
    !   Unconditionally disable CTRL/C interrupts
    !-
    disable_ctl_y;

    ! Grab the file as soon as it is available.
    attempts = 0 ;
    ren_count = 0;
    
    until
	(status = io$open(.iobadr,.sucadr,0))
    do
	begin	! Failed to get the file.

	!+
	!   If this is the case of the 00fac_name.LOK file no further attempts
	!   at retrying the open are done here.  The retry mechanism is 
	!   different in the case of the 00fac_name.LOK file and is perform in
	!   the saflib routine(SHARE).
	!-

	if .status eql k_file_busy
	    and
	    nateql(iobadr[iob$t_resultant],lit(%string(lib,lok)))
	then
	    begin
	    !give the user back his ctrl/y
	    enable_ctl_y;
	    return .status
	    end;
		
	! Limit the number of attempts.
	! Also quit if the error was not a file locked error
	attempts = .attempts + 1 ;
	if
	    .attempts geq k_max_attempts or
	    .status neq k_file_busy
	then

	    !Make it look like a normal call
	    begin
	    !try to resolve file version number overflow in the
	    ! library
	    if
		(%if VaxVms %then
		 .iobadr[iob$g_2nd_code]  eql ss$_badfilever
		 %fi
		 %if Tops20 %then
		 .iobadr[iob$g_comp_code] eql gjfx20 ^ 3
		 %fi)
		and .ren_count eql 0
	    then
		begin
		!+
		!  here for file version overflow
		!-
		ren_count=.ren_count+1;
		if
		    not gen_lim(.iobadr[iob$a_file_spec])
		then
		    begin

		    ! bad I/O with standard action routine specified
		    IF (not .status) and .failadr eql xpo$failure
		    THEN
    		       ! print error message and do ROLBCK
		        ersiob(s_rbopenno,.iobadr,cat('Unable to open file ',
				iobadr[iob$t_resultant]));
	
		    if
			.failadr neq 0 and
			not .status
		    then
			!don't forget to call the user's failure action routine
			status=(.failadr)(xpo$k_io,.iobadr[iob$g_comp_code],
						.iobadr[iob$g_2nd_code],.iobadr);
		    exitloop
		    end
		end
	    else if %IF %BLISS(BLISS32) %THEN
                        .status eql rms$_cre
                        and .iobadr[iob$g_2nd_code] eql ss$_exdiskquota 
                    %else
                        .status eql step$_no_space
                     %fi
	    then
		begin
		!+
		!  Here if user's disk quota exceeded or device full.  Ignore
		!  callers failure action routine and do following.  There is
		!  no return.
		!-
		ersiob(s_rbopenno,.iobadr,
		       cat('Unable to open file ', iobadr[iob$t_resultant]));
		end
	    else
		begin

		! bad I/O with start action routine specified
		IF (not .status) and .failadr eql xpo$failure
		THEN
    		    ! print error message and do ROLBCK
		    ersiob(s_rbopenno,.iobadr,cat('Unable to open file ',
				iobadr[iob$t_resultant]));
    
		if
		    .failadr neq 0 and
		    not .status
		then
		    !don't forget to call the user's failure action routine
		    status=(.failadr)(xpo$k_io,.iobadr[iob$g_comp_code],
				  .iobadr[iob$g_2nd_code],.iobadr);
		exitloop
		end
	    end;

	!turn on ctrl/y while we wait.  This is safe since
	!we don't yet have the file we want.
	enable_ctl_y;

	if
	    .attempts eql k_first_inform
	then
	    begin
	    !+
	    !  First time through.  Print message asking user to wait.
	    !-

	    library_file = print_please_wait_message (.iobadr);
	    end
	else
	    if
		.attempts gtr k_first_inform and
		((.attempts - 1) mod k_inform_every_nth) eql 0
	    then
		sysmsg(s_waiting,lit('Still waiting'),0) ;

	hibernate(k_retry_seconds) ;

	!now turn ctrl/y back off
	disable_ctl_y

	end ;	! Failed to get the library.


    ! Check for success
    IF .status
    THEN
	BEGIN	! success status
	
	IF 
            not .iobadr[iob$v_terminal] and not rbcln(.iobadr)
	THEN
	    BEGIN	! valid file for rb
	
	    ! add this entry to the Roll Back list
	    IF not rbadd(.iobadr)
	    THEN
		badbug(cat('Unable to add entry for file ',iobadr[iob$t_resultant],
    		   ' to Roll Back List (FILE$OPEN)')) ;

	    IF .f_as_setout and .f_ap_shw_pending 
	    THEN
		BEGIN
		$str_desc_init(descriptor=d_file,string=iobadr[iob$t_resultant]) ;
		d_as_file[desc_len] =.d_file[desc_len] ;
		$str_copy(string=iobadr[iob$t_resultant],target=d_as_file) ;	    
		END;

	    END;	 ! valid file for rb	

	END;	! success status

    !+
    !   unconditionally re-enable CTRL/C interrupts
    !-
    enable_ctl_y;

    !+
    !  Print special open message similar to -20 "SET TRAP FILE-OPENINGS".
    !  Do print after re-enableing CTRL-C since this is relativly slow.
    !-
    if .status and .test[11] gtr 0
    then
	deb_open_msg(.iobadr);
	    
    ! Tell the user his vigil is over.
    if
	(.attempts geq k_first_inform) and .status
    then
	sysmsg(s_proceed,lit('Proceeding'),0) ;

    .status

    end ;	! file$open

global routine file$rename (iobadr,sucadr,failadr) =

!++
! Functional Description:
!
!	Like an XPORT rename only we use RMS to save time.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	sucadr - success return address
!	failadr - failure return address
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	Standard $RENAME values
!
! Side Effects:
!
!	none
!
!--
    BEGIN

    bind
        iob = .iobadr: $xpo_iob();

    LOCAL
        status;

        status = io$rename(iob,.sucadr,0);

    ! bad I/O with start action routine specified
    IF (not .status) and .failadr eql xpo$failure
    THEN
        ! print error message and do ROLBCK
	ersiob(s_rbcloseno,.iobadr,cat('Unable to rename file ',
			iob[iob$t_resultant]));
    
    ! bad I/O with user action routine specified
    IF (not .status) and .failadr neq 0
    THEN
	! call user action routine
	status=(.failadr)(xpo$k_io,.iob[iob$g_comp_code],
				.iob[iob$g_2nd_code],.iobadr);

    ! bad I/O and failure specified as 0
    IF (not .status) and failadr eql 0
    THEN
	begin
	return .status
	end;
    

.status
END;

global routine file$delete (iobadr,sucadr,failadr) =

!++
! Functional Description:
!
!	Like an XPORT delete only we use RMS to save time.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	sucadr - success return address
!	failadr - failure return address
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	Standard $delete values
!
! Side Effects:
!
!	none
!
!--
    BEGIN

    bind
        iob = .iobadr: $xpo_iob();

    LOCAL
        status;


        status = io$delete(iob,.sucadr,0);

    ! bad I/O with start action routine specified
    IF (not .status) and .failadr eql xpo$failure
    THEN
        ! print error message and do ROLBCK
	ersiob(s_rbcloseno,.iobadr,cat('Unable to delete file ',
			iob[iob$t_resultant]));
    
    ! bad I/O with user action routine specified
    IF (not .status) and .failadr neq 0
    THEN
	! call user action routine
	status=(.failadr)(xpo$k_io,.iob[iob$g_comp_code],
				.iob[iob$g_2nd_code],.iobadr);

    ! bad I/O and failure specified as 0
    IF (not .status) and failadr eql 0
    THEN
	begin
	return .status
	end;
    


.status
END;

global routine file$put (iobadr,sucadr,failadr) =

!++
! Functional Description:
!
!	Put a record out as specified by the user. In the case of an append
! 	operation, CTRL/C is disabled and re-enabled, and if the append
!	operation is successful a file address of where the first record was 
!	written is saved in the rolbck list entry. This allows the roll back
!	processor to truncate the file back to its original state in the event
!	of a transaction abort.
!
! Formal Parameters:
!
!	iobadr - address of IOB
!	sucadr - success return address
!	failadr - failure return address
!
! Implicit Inputs:
!
!	none
!
! Implicit Outputs:
!
!	none
!
! Routine Value:
! Completion Codes:
!
!	Standard $XPO_PUT values
!
! Side Effects:
!
!	none
!
!--

    begin	! file$put
    
    bind
	iob = .iobadr: $xpo_iob() ;
	
    local
	cty_off_flag,			! true if ctrl/y turned off
	f_first_append,			! true if doing first put to an append file
	f_err,				! error file
	f_his,				! history file
	f_shw,				! show output file
	status;
    
    cty_off_flag = false;
    f_first_append = false;
	
    ! set local flags if applicable
    IF (.iob[iob$v_append] and
 	(.f_ap_err_pending or .f_ap_his_pending or .f_ap_shw_pending))
    THEN
	BEGIN	! local flags
	
	! initialize
	f_err = false ;
	f_his = false ;
	f_shw = false ;

	IF nateql(lit(erlg),iob[iob$t_resultant])
	THEN
	    f_err = true ;
	
	IF nateql(lit(log),iob[iob$t_resultant])
	THEN
	    f_his = true ;
	
	IF .f_ap_shw_pending
	THEN
	    BEGIN
	    
	    IF nateql(d_as_file,iob[iob$t_resultant])
	    THEN
		f_shw = true ;
	    END;
	    
	f_first_append = .f_err or .f_his or .f_shw;

	IF  .f_first_append
	THEN
	    BEGIN	! disable interrupts for first append operation

	    cty_off_flag = true;
	    disable_ctl_y;

	    %if Tops20 %then
	    IF not .iob[iob$v_terminal] and not rbcln(iob)
	    THEN
		BEGIN
		IF not rbsvap(.iobadr)
		THEN
		    badbug(lit('Unable to save restore address for appended file')) ;
		END;
	    %fi

	    END;	! disable interrupts for append operation

	END;	! local flags

    status = io$put(.iobadr, .sucadr, 0);

    ! bad I/O with start action routine specified
    IF (not .status) and .failadr eql xpo$failure
    THEN
        ! print error message and do ROLBCK
	ersiob(s_rbputerr,.iobadr,cat('Unable to issue put on file ',
			iob[iob$t_resultant]));
    
    ! bad I/O with user action routine specified
    IF (not .status) and .failadr neq 0
    THEN
	! call user action routine
	status=(.failadr)(xpo$k_io,.iob[iob$g_comp_code],
				.iob[iob$g_2nd_code],.iobadr);

    ! bad I/O and failure specified as 0
    IF (not .status) and failadr eql 0
    THEN
	begin
	if
	    .cty_off_flag
	then
	    enable_ctl_y;
	return .status
	end;

    ! check for success
    IF .STATUS
    THEN
	BEGIN	! success
    
	IF .f_first_append
	THEN
	    BEGIN	! save restore address and re-enable interrupts

	    %if VaxVms %then
	    IF not .iob[iob$v_terminal] and not rbcln(iob)
	    THEN
		BEGIN

		IF not rbsvap(.iobadr)
		THEN
		    badbug(lit('Unable to save restore address for appended file')) ;
		
		END;
	    %fi
	    	    
	    !re-enable ctrl/y if it was turned off
	    if
		.cty_off_flag
	    then
		begin
		enable_ctl_y;
		cty_off_flag=false
		end;

	    ! clear flags

	    IF .f_err
	    THEN
		f_ap_err_pending = false;
	    
	    IF .f_his
	    THEN
		f_ap_his_pending = false;
	    
	    IF .f_shw
	    THEN
		f_ap_shw_pending = false ;
	    	    
	    END;	! save restore address and re-enable interrupts

	end;	! SUCCESS

    !make sure of ctrl/y
    if
	.cty_off_flag
    then
	enable_ctl_y;

    ! return the status in any case
    .status
    
    end ;	! file$put

end				! Module fileio
eludom