



		    PNOTICE_pcsf.alm                11/27/84  1141.2r w 11/27/84  1141.1        2448



	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	56			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1984"

	aci	"C1PCSM0B0000"
	aci	"C2PCSM0B0000"
	aci	"C3PCSM0B0000"
	end




		    ibm_pc_io_.pl1                  11/19/84  0940.6r w 11/19/84  0925.1      234261



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style2 */
/*  the user ring ibm_pc io module --- ibm_pc_io_
    Uses the IBM PC-to-PC data transfer protocol as defined by IBM in their
   "Asynchronous Communication Support" manual, version 2.0.

1.  Definitions

    CR$     Carriage Return (Hex 0D) (Oct 15)
    XON$    XON Character (Hex 11) (Oct 21)
    XOFF$   XOFF Character (Hex 13) (Oct 23)
    IBG$    Begin Transmission Code (Hex 1C) (Oct 34)
    ITM$    Terminate Transmission Code (Hex 17) (Oct 27)

2.  Transmission Medium Level Protocol

    Asynchronous, 7 data bits.

    Files must be ASCII text files and have no lines longer than 250
    characters. 

3.  Message Block Level Protocol

    The standard transmission portion of the block is a variable length
    character block, maximum 250 characters, followed by a carriage return.  

4.  Program Considerations

    1.  The program loops, reading the communications line and waiting for
        reception of a text line ending with the control characters IBG$CR$.

    2.  When such a line is received, the program sends a text line ending
        with IBG$CR$.  (This line may contain an informative message as well,
        such as Starting file transmission)


    3.  The program transmits the file.  Each line in the file should
        be sent as a line ending in a Carriage Return (CR$)

    4.  While transmission is taking place the program should monitor the
        input from the communications line and take the following actions:
            a.  If an XOFF$CR$ is seen, stop transmission of lines.  When
                an XON$CR$ is seen, resume transmission.
            b.  If a line ending in ITM$CR$ is seen, stop all transmission.
                This line will contain as text the reason the receiving IBM
                Personal Computer has requested termination.
            c.  When all lines in the file have been sent, the program should
                send a line ending in ITM$CR$. (This line can contain an
                appropriate message, such as "file transmission completed".)

5. Program Considerations

    1.  The program loops, sending out a message ending in IBG$CR$ every 15
        to 20 seconds.  This message may also contain text, such as Ready to
        receive file.)

    2.  During the loop in Step 1, the communications line is continually 
        monitored for messages from the IBM Personal Computer.   When a line
        ending in IBG$CR$ is received, the program moves on to step 3.

    3.  Each line received (after the one ending in IBG$CR$) is stored as
        a file record.  As these lines end with Carriage Returns (CR$), the
        program might delete the CR$ before storing a line.  Before storing
        a line, the program checks it to see if it ends in ITM$CR$.  If it
        does, the program does not store that line, but closes the file
        and stops operation.

    4.  The program can stop transmission by the IBM Personal Computer by 
        sending a line ending with an ITM$CR$.  This line may also contain
        a message giving the reason for the termination.

    5.  If the program is receiving lines faster that they can be stored, it
        can suspend transmission by sending a line consisting of an XOFF$CR$
        to the IBM Personal Computer.  When it has caught up with the input,
        it can start up transmission by sending a line consisting of an XON$CR$
        to the IBM Personal Computer.
*/

%page;
ibm_pc_io_:
     proc;
	return;					/* not an entry  */
						/*  iox_ io module for ibm_pc protocol i/o written 6/84 by M.J. Mallmes  */

/*  Parameters  */

	dcl     arg_actual_len	 fixed bin (21);
	dcl     arg_buf_ptr		 ptr;		/* ptr to user buffer (input) */
	dcl     arg_buf_len		 fixed bin (21);	/* length of user buffer (input) */
	dcl     arg_iocbp		 ptr;		/* ptr to iocb (input) */
	dcl     code		 fixed bin (35);	/*  Multics standard error code  (output */
	dcl     com_err_switch	 bit (1) aligned;	/* ON if should call com_err_ for errors (input)  */
	dcl     mode		 fixed bin;
	dcl     option_array	 (*) char (*) varying;


/*  Automatic  */

	dcl     actual_iocbp	 ptr;		/* copy of iocb.actual_iocb_ptr */
	dcl     arg_buf_pos		 fixed bin;	/* index into passed argument buffer  */
	dcl     attach_data_ptr	 ptr;		/* ptr to iocb's attach_data  */
	dcl     buf_ptr		 ptr;
	dcl     buffer_empty	 bit (1);		/* ON if a packet is to be received  */
	dcl     buffer_full		 bit (1);		/* ON if a packet is to be sent  */
	dcl     carriage_return_found	 bit (1);
	dcl     carriage_return_needed bit (1);
	dcl     control_chars	 char (2);
	dcl     ec		 fixed bin (35);
	dcl     iocbp		 ptr;		/*  copy of arg_iocbp */
	dcl     mask		 bit (36) aligned;	/* ips mask */
	dcl     system_free_area_ptr	 ptr;

/*  Based  */

	dcl     01 attach_data	 aligned based (attach_data_ptr),
						/* iocb attach_data */
		02 attach_descrip	 char (256) varying,
		02 open_descrip	 char (32) varying,
		02 target_iocbp	 ptr,		/* ptr to target switch iocb */
		02 buf		 char (250),	/* internal buffer  */
		02 buf_pos	 fixed bin (21),	/* index into buf  */
		02 error_code	 fixed bin (35),	/* 0 if normal close operation */
		02 xon_sw		 bit (1) unal,
		02 eof_sw		 bit (1) unal;


	dcl     01 open_descrip	 based aligned,	/* open description for iocb  */
		02 length		 fixed bin (17),
		02 string		 char (0 refer (open_descrip.length));

	dcl     system_free_area	 area based (system_free_area_ptr);

/*  Constants  */

	dcl     One_Second		 fixed bin (71) static options (constant) init (1000000);
	dcl     Ten_Seconds		 fixed bin (71) static options (constant) init (10000000);
						/* 110 seconds */
	dcl     Terminate_Transmission char (2) static options (constant) init ("");
	dcl     Buf_Size		 fixed bin (21) static options (constant) init (250);
	dcl     Begin_Transmission	 char (2) static options (constant) init ("");
	dcl     Dim_name		 char (10) static options (constant) init ("ibm_pc_io_");
	dcl     XON		 char (2) static options (constant) init ("");
	dcl     XOFF		 char (2) static options (constant) init ("");
	dcl     CR		 char (1) static options (constant) init ("");

/*  Builtin    */

	dcl     (addcharno, addr, hbound, index, lbound, null, rtrim, substr)
				 builtin;

/* Conditions */

	dcl     (any_other, cleanup)	 condition;

/*  External Static  */

	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$bad_mode	 fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$end_of_info
				 fixed bin (35) ext static;
	dcl     error_table_$long_record
				 fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$no_iocb	 fixed bin (35) ext static;
	dcl     error_table_$not_attached
				 fixed bin (35) ext static;
	dcl     error_table_$not_detached
				 fixed bin (35) ext static;
	dcl     error_table_$not_open	 fixed bin (35) ext static;
	dcl     error_table_$timeout	 fixed bin (35) ext static;
	dcl     error_table_$unable_to_do_io
				 fixed bin (35) ext static;

/*  Procedures       */

	dcl     com_err_		 entry () options (variable);
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$reset_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     iox_$err_no_operation	 entry () options (variable);
	dcl     iox_$err_not_attached	 entry () options (variable);
	dcl     iox_$err_not_open	 entry () options (variable);
	dcl     iox_$err_not_closed	 entry () options (variable);
	dcl     iox_$get_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$look_iocb	 entry (char (*), ptr, fixed bin (35));
	dcl     iox_$propagate	 entry (ptr);
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     timed_io_$get_chars	 entry (ptr, fixed bin (71), ptr, fixed bin (21), fixed bin (21), fixed bin (35));


%page;

/*  Include Files    */

%include iocb;
%page;
%include iox_modes;
%page;

/*  This entry attaches the ibm_pc_io_ i/o module after verifying that
    the target switch is open for stream_input_output  */

ibm_pc_io_attach:
     entry (arg_iocbp, option_array, com_err_switch, code);

	ec = 0;
	mask = ""b;
	iocbp = arg_iocbp;

	if hbound (option_array, 1) < 1
	then call error (0, com_err_switch, error_table_$noarg, "Usage:  ibm_pc_io_ switch_name {-control_arguments}");

	attach_data_ptr = null ();
	on cleanup call clean_up_attach;

	if iocbp -> iocb.attach_descrip_ptr ^= null ()
	then call error (0, com_err_switch, error_table_$not_detached, "");

	system_free_area_ptr = get_system_free_area_ ();
	allocate attach_data in (system_free_area) set (attach_data_ptr);

/*  see if the target switch is attached and open  for stream_input_output */
	call iox_$look_iocb (rtrim (option_array (1)), target_iocbp, ec);
	if ec = error_table_$no_iocb
	then call error (1, com_err_switch, ec, rtrim (option_array (1)));
	if target_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null
	then call error (1, com_err_switch, error_table_$not_attached, rtrim (option_array (1)));
	if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null
	then call error (1, com_err_switch, error_table_$not_open, rtrim (option_array (1)));
	if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr -> open_descrip.string
	     ^= iox_modes (Stream_input_output)
	then call error (1, com_err_switch, error_table_$bad_mode, rtrim (option_array (1)));


	attach_data.attach_descrip = Dim_name || " " || rtrim (option_array (1));
	attach_data.open_descrip = "";
	attach_data.eof_sw = "0"b;
	attach_data.buf_pos = 0;
	attach_data.error_code = 0;

	call hcs_$set_ips_mask (""b, mask);
	iocbp -> iocb.attach_data_ptr = attach_data_ptr;
	iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip);
	iocbp -> iocb.detach_iocb = ibm_pc_io_detach;
	iocbp -> iocb.open_descrip_ptr = null ();
	iocbp -> iocb.open = ibm_pc_io_open;
	iocbp -> iocb.modes = iox_$err_no_operation;
	iocbp -> iocb.control = iox_$err_no_operation;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, ""b);
EXIT:
	return;


%page;
/*  Error calls com_err_ if the loud switch is set and goes to the attach return */

error:
     proc (cleanup_level, call_com_err, ec, msg);

	dcl     cleanup_level	 fixed bin;
	dcl     call_com_err	 bit (1) aligned;
	dcl     ec		 fixed bin (35);	/* Multics standard error code */
	dcl     msg		 char (*);	/* Additional error information */

	goto Err (cleanup_level);

Err (1):
	free attach_data;

Err (0):
	if call_com_err
	then call com_err_ (ec, Dim_name, "^a", msg);
	code = ec;
	goto EXIT;
     end error;


%page;

/*  This entry detaches the ibm_pc_io_ i/o module and frees the associated
    information  */

ibm_pc_io_detach:
     entry (arg_iocbp, code);

	call set_up;
	on any_other call handler;
	call hcs_$set_ips_mask ("0"b, mask);
	actual_iocbp -> iocb.attach_descrip_ptr = null ();
	actual_iocbp -> iocb.attach_data_ptr = null ();
	actual_iocbp -> iocb.open = iox_$err_not_attached;
	actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, "0"b);
	revert any_other;
	free attach_data;
	return;

%page;

/*  This entry sets the open description and the legal operation entries
    in the iocb.  Operation permitted:

             all the time: close
	   input:        get_chars, get_line
	   output:       put_chars

    Before returning it performs a handshake with the remote ibm_pc.  */


ibm_pc_io_open:
     entry (arg_iocbp, mode, com_err_switch, code);

	on cleanup call terminate_io;
	call set_up;

	if mode ^= Stream_input & mode ^= Stream_output
	then do;
		code = error_table_$bad_mode;
		return;
	     end;

	if mode = Stream_output
	then do;					/* Perform handshake - sender */
		call get_control_chars (control_chars, Ten_Seconds, ec);
		if control_chars = Terminate_Transmission
		then ec = error_table_$unable_to_do_io;

		do while ((ec = 0 | ec = error_table_$timeout) & control_chars ^= Begin_Transmission);
		     call get_control_chars (control_chars, Ten_Seconds, ec);
		     if control_chars = Terminate_Transmission
		     then ec = error_table_$unable_to_do_io;
		end;

		if ec ^= 0
		then do;
			code = error_table_$unable_to_do_io;
			return;
		     end;

/* The receiver sent IBG$CR$ so complete the handshake  */
		call send_control_chars (Begin_Transmission);
		attach_data.xon_sw = "1"b;
	     end;


	if mode = Stream_input
	then do;					/* Perform handshake - receiver */

		call send_control_chars (Begin_Transmission);
		call get_control_chars (control_chars, Ten_Seconds, ec);
		if control_chars = Terminate_Transmission
		then ec = error_table_$unable_to_do_io;

		do while ((ec = 0 | ec = error_table_$timeout) & control_chars ^= Begin_Transmission);
		     call send_control_chars (Begin_Transmission);
		     call get_control_chars (control_chars, Ten_Seconds, ec);
		     if control_chars = Terminate_Transmission
		     then ec = error_table_$unable_to_do_io;
		end;

		if ec ^= 0
		then do;
			code = error_table_$unable_to_do_io;
			return;
		     end;
	     end;

	attach_data_ptr -> attach_data.open_descrip = iox_modes (mode);
	on any_other call handler;
	call hcs_$set_ips_mask (""b, mask);
	actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip);
	actual_iocbp -> iocb.open = iox_$err_not_closed;
	actual_iocbp -> iocb.close = ibm_pc_io_close;
	actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed;
	if mode = Stream_input
	then do;
		actual_iocbp -> iocb.get_line = ibm_pc_io_get_line;
		actual_iocbp -> iocb.get_chars = ibm_pc_io_get_chars;
	     end;
	else if mode = Stream_output
	then actual_iocbp -> iocb.put_chars = ibm_pc_io_put_chars;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, ""b);
	revert any_other;

	return;

%page;
/*  This procedure closes the ibm_pc i/o switch.  If the switch was
    open for stream_output it flushes the output buffer and sends
    the ITM$CR$ control characters to the remote ibm_pc.
    If the last packet cannot be transmitted, the i/o switch is
    closed and the error code error_table_$unable_to_do_io is returned.   */

ibm_pc_io_close:
     entry (arg_iocbp, code);

	on cleanup call terminate_io;
	call set_up;

	if actual_iocbp -> iocb.open_descrip_ptr -> open_descrip.string = iox_modes (Stream_output)
	     & attach_data.error_code = 0
	then do;
		buf_ptr = addr (attach_data.buf);
		if attach_data.buf_pos ^= 0 & substr (attach_data.buf, buf_pos, 1) ^= CR
		then do;
			attach_data.buf_pos = attach_data.buf_pos + 1;
			substr (attach_data.buf, attach_data.buf_pos, 1) = CR;
		     end;
		call send_data_packet (ec);
		if attach_data.error_code = 0
		then call terminate_io;
	     end;

	on any_other call handler;
	call hcs_$set_ips_mask ("0"b, mask);
	actual_iocbp -> iocb.open_descrip_ptr = null;
	actual_iocbp -> iocb.open = ibm_pc_io_open;
	actual_iocbp -> iocb.detach_iocb = ibm_pc_io_detach;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, "0"b);
	revert any_other;
	code = ec;
	return;

/*  This entry is called to input characters received from the remote
    connection.  Packets are read until the user request is satisfied.  
    Data received, but not requested by the user, is stored in an internal
    buffer, and is available on subsequent reads.            */

ibm_pc_io_get_chars:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code);

	carriage_return_needed = "0"b;
	goto get_data;

/*  This entry is called to input characters received from the remote
    connection.  Packets are read until the user request is satisfied.
    i.e. a carriage_return is found or the user buffer is filled. Data
    received, but not requested by the user, is stored in an internal
    buffer, and is available on subsequent reads            */

ibm_pc_io_get_line:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code);

	carriage_return_needed = "1"b;

get_data:
	on cleanup call terminate_io;
	call set_up;

	if arg_buf_len = 0
	then return;
	if arg_buf_len < 0
	then do;
		code = error_table_$bad_arg;
		return;
	     end;

	carriage_return_found = "0"b;
	arg_buf_pos = 0;

	do while ("1"b);
	     ec = 0;
	     call unload_internal_buffer (buffer_empty);
	     if buffer_empty
	     then do;

		     if attach_data.eof_sw
		     then do;
			     ec = error_table_$end_of_info;
			     return;
			end;

		     call get_data_packet (ec);
		     if ec ^= 0
		     then do;
			     if ec = error_table_$end_of_info
			     then attach_data.eof_sw = "1"b;
			     else call terminate_io;
			     attach_data.buf_pos = 0;
			     goto done_receive;
			end;
		end;
	     else goto done_receive;
	end;

done_receive:
	if (ec = 0) & carriage_return_needed & ^carriage_return_found
	then ec = error_table_$long_record;
	arg_actual_len = arg_buf_pos;
	code = ec;
	return;


%page;

/*  This internal procedure moves the data from the internal buffer to the user's
    buffer during a get_chars or get_line operation.  */

unload_internal_buffer:
     proc (buffer_empty);
	dcl     buffer_empty	 bit (1);		/* ON if we need more data from the remote ibm_pc */
	dcl     n_chars		 fixed bin;
	dcl     overlay		 char (arg_buf_len) based;
						/* user buffer */
	dcl     i			 fixed bin;


	buffer_empty = "0"b;
	if attach_data.buf_pos = 0
	then do;
		buffer_empty = "1"b;
		return;
	     end;

	if arg_buf_len - arg_buf_pos > attach_data.buf_pos
	then n_chars = attach_data.buf_pos;
	else n_chars = arg_buf_len - arg_buf_pos;

	if carriage_return_needed
	then do;
		i = index (substr (attach_data.buf, 1, n_chars), CR);
		if i ^= 0
		then do;
			carriage_return_found = "1"b;
			n_chars = i;
		     end;

	     end;

	substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars) = substr (attach_data.buf, 1, n_chars);
	substr (attach_data.buf, 1, attach_data.buf_pos - n_chars) =
	     substr (attach_data.buf, n_chars + 1, attach_data.buf_pos - n_chars);
	attach_data.buf_pos = attach_data.buf_pos - n_chars;
	arg_buf_pos = arg_buf_pos + n_chars;
	if (^carriage_return_found) & (arg_buf_pos < arg_buf_len)
	then buffer_empty = "1"b;
	return;
     end unload_internal_buffer;


/*  This internal procedure gets the actual packet from the remote ibm_pc
    during a get_chars or get_line operation.  Data is received via variable
    length packets ending in a carriage return character.  */

get_data_packet:
     proc (ec);

	dcl     chase_buf_ptr	 ptr;
	dcl     ec		 fixed bin (35);
	dcl     n_read		 fixed bin (21);
	dcl     to_read		 fixed bin (21);

	ec = 0;
	attach_data.buf_pos = 0;
	to_read = Buf_Size;
	buf_ptr = addr (attach_data.buf);
	chase_buf_ptr = buf_ptr;

	do while (to_read > 0 & ec = 0);
	     call iox_$get_chars (attach_data.target_iocbp, chase_buf_ptr, to_read, n_read, ec);
	     if ec ^= 0
	     then return;
	     attach_data.buf_pos = attach_data.buf_pos + n_read;
	     if substr (attach_data.buf, attach_data.buf_pos, 1) = CR
	     then to_read = 0;
	     else to_read = Buf_Size - attach_data.buf_pos;
	     chase_buf_ptr = addcharno (buf_ptr, attach_data.buf_pos);
	end;

	if index (attach_data.buf, Terminate_Transmission) ^= 0
	then ec = error_table_$end_of_info;
	return;
     end get_data_packet;



%page;
/*  This entry is called to output characters to the remote connection.
    Data passed by the user is transmitted via variable length packets.
    Where each packet ends in a carriage return. 
    Packets are transmitted until the user request is satisfied.  */


ibm_pc_io_put_chars:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, code);
	/*** entry to perform put_chars operation */

	on cleanup call terminate_io;
	call set_up;

	if arg_buf_len = 0
	then return;
	if arg_buf_len < 0
	then do;
		code = error_table_$bad_arg;
		return;
	     end;

	arg_buf_pos = 0;
	buf_ptr = addr (attach_data.buf);

	do while ("1"b);
	     ec = 0;
	     call load_internal_buffer (buffer_full);
	     if buffer_full
	     then do;
		     call send_data_packet (ec);
		     if ec ^= 0
		     then do;
			     call terminate_io;
			     goto done_transmitting;
			end;
		     else attach_data.buf_pos = 0;
		end;
	     else goto done_transmitting;
	end;
done_transmitting:
	code = ec;
	return;


/*  This internal procedure controls the necessary buffer operations
    during a put_chars operation.  If the user's buffer contains more
    than 250 characters or the user's buffer contains a carriage return
    character then buffer_full = true.
    Otherwise, if a full packet cannot be sent (data does not end in a
    carriage return), data is stored in an internal buffer until 
    (1) subsequent writes fill the buffer, or (2) the ibm_pc switch is
    closed, or (3) a subsequent write operation passes data containing a
    carriage return.             */

load_internal_buffer:
     proc (buffer_full);

	dcl     buffer_full		 bit (1);
	dcl     CR_found		 bit (1);
	dcl     n_chars		 fixed bin;
	dcl     overlay		 char (arg_buf_len) based;
	dcl     temp_buf_len	 fixed bin (21);


	buffer_full = "0"b;
	CR_found = "0"b;
	if arg_buf_pos = arg_buf_len
	then return;

	temp_buf_len = index (substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, arg_buf_len - arg_buf_pos), CR);
	if temp_buf_len = 0
	then temp_buf_len = arg_buf_len;
	else do;
		temp_buf_len = arg_buf_pos + temp_buf_len;
		CR_found = "1"b;
	     end;

	if temp_buf_len - arg_buf_pos > Buf_Size - attach_data.buf_pos
	then n_chars = Buf_Size - attach_data.buf_pos;
	else n_chars = temp_buf_len - arg_buf_pos;

	substr (attach_data.buf, attach_data.buf_pos + 1, n_chars) =
	     substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars);

	arg_buf_pos = arg_buf_pos + n_chars;
	attach_data.buf_pos = attach_data.buf_pos + n_chars;
	if CR_found
	then buffer_full = "1"b;
	else if attach_data.buf_pos = Buf_Size
	then do;					/* force a 250-character line */
		arg_buf_pos = arg_buf_pos - 1;
		substr (attach_data.buf, Buf_Size, 1) = CR;
		buffer_full = "1"b;
	     end;

	return;
     end load_internal_buffer;




%page;
/*  This internal procedure sends a data packet  during a put_chars operation.  */
send_data_packet:
     proc (ec);
	dcl     ec		 fixed bin (35);


	ec = 0;

	call get_control_chars (control_chars, One_Second, ec);
	if ec ^= 0 & ec ^= error_table_$timeout
	then goto send_data_error;
	if control_chars = XOFF
	then attach_data.xon_sw = "0"b;

	do while (^attach_data.xon_sw & control_chars ^= Terminate_Transmission);
	     if control_chars = XON
	     then attach_data.xon_sw = "1"b;
	     if ^attach_data.xon_sw
	     then call get_control_chars (control_chars, One_Second, ec);
	     if ec ^= 0 & ec ^= error_table_$timeout
	     then goto send_data_error;
	end;

	if control_chars = Terminate_Transmission
	then do;
		ec = error_table_$unable_to_do_io;
		attach_data.error_code = 1;
		return;
	     end;

	call iox_$put_chars (attach_data.target_iocbp, buf_ptr, attach_data.buf_pos, ec);
	if ec ^= 0
	then goto send_data_error;
	attach_data.buf_pos = 0;
	ec = 0;
	return;

send_data_error:
	call terminate_io;
	return;
     end send_data_packet;


/*  This internal procedure sends a control character */

send_control_chars:
     proc (control_chars);
	dcl     control_chars	 char (2);
	dcl     control_char_ptr	 ptr;


	control_char_ptr = addr (control_chars);
	call iox_$put_chars (attach_data_ptr -> attach_data.target_iocbp, control_char_ptr, 2, (0));
	return;
     end send_control_chars;




/*  Get a packet control character  */

get_control_chars:
     proc (control_chars, interval, ec);
	dcl     control_buf		 char (1);
	dcl     control_buf_ptr	 ptr;
	dcl     control_chars	 char (2);
	dcl     ec		 fixed bin (35);
	dcl     interval		 fixed bin (71);
	dcl     n_read		 fixed bin (21);

	ec = 0;
	control_chars = " ";
	control_buf_ptr = addr (control_buf);
	control_buf = " ";

	do while (ec = 0);
	     call timed_io_$get_chars (attach_data.target_iocbp, interval, control_buf_ptr, 1, n_read, ec);
	     if ec ^= 0
	     then return;
	     if control_buf ^= CR
	     then substr (control_chars, 1, 1) = control_buf;
	     else do;
		     substr (control_chars, 2, 1) = control_buf;
		     return;
		end;
	end;
	return;
     end get_control_chars;


set_up:
     proc;					/* fill in */
	ec = 0;
	mask = ""b;
	actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr;
	return;
     end set_up;



/*  Cleans up the attach data and allocated storage if the attach operation is aborted  */

clean_up_attach:
     proc;

	if mask ^= ""b
	then call handler;				/* Fatal error */
	if attach_data_ptr = null ()
	then return;
	free attach_data_ptr -> attach_data;
	return;
     end clean_up_attach;


terminate_io:
     proc;

	attach_data.error_code = 1;
	call send_control_chars (Terminate_Transmission);
	return;
     end;

%page;
/*  Internal procedure to handle faults while IPS interrupts are masked.  For a
    fault while masked, the process is terminated (with the reason "unable to do
    critical I/O")  because the I/O control blocks are in an inconsistent state  */

handler:
     procedure options (non_quick);			/* visible in ifd */

	dcl     error_table_$unable_to_do_io
				 fixed (35) ext;
	if mask ^= ""b
	then call terminate_this_process (error_table_$unable_to_do_io);
	else return;
     end handler;



terminate_this_process:
     proc (cd);

	dcl     cd		 fixed bin (35);
	dcl     terminate_process_	 entry (char (*), ptr);
	dcl     01 ti		 aligned automatic,
		02 version	 fixed,
		02 code		 fixed (35);

	ti.version = 0;
	ti.code = code;
	call terminate_process_ ("fatal_error", addr (ti));

     end terminate_this_process;
     end;




		    micro_transfer.pl1              10/17/88  1109.7r w 10/17/88  1034.1      244836



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */

/* **************************************************************************
   *                                                                        *
   *   Name: micro_transfer, mt                                             *
   *                                                                        *
   *   This program acts as an interface between the Multics file system    *
   *   and I/O modules (protocols), when transferring files between Multics *
   *   and a microcomputer.                                                 *
   *                                                                        *
   *   Status:                                                              *
   *                                                                        *
   *    0) 24 August 1984:  Initial coding, M. Mallmes.                     *
   *                                                                        *
   *    1) 31 January 1985: Modified, M.Mallmes                             *
   *            Changed the iocb-pointer passed to iox_$modes and           *
   *            iox_$control to use the user-supplied field and to          *
   *            default to the user_i/o switch iocb-pointer.                *
   *            Previous version always used the user_i/o switch            *
   *            iocb-pointer even when the user supplied a different        *
   *            switch.  In summary, iox_$user_io has been replaced         *
   *            with mt_options.ts_iocbp.                                   *
   *                                                                        *
   *            mt_options.new_modes now contains 'force'.                  *
   *            deletes file if modes can't be set.                         *
   *                                                                        *
   *                                                                        *
   ************************************************************************* */


micro_transfer:
mt:
     procedure () options (variable);


/*  Automatic  */


	dcl     absolute_path	 char (168);
	dcl     active_protocol	 fixed bin;
	dcl     argument_count	 fixed bin;
	dcl     arg_idx		 fixed bin;
	dcl     argument_lth	 fixed bin (21);
	dcl     argument_ptr	 ptr;
	dcl     bit_count		 fixed bin (24);
	dcl     buff		 char (256) aligned;
	dcl     buf_ptr		 ptr;
	dcl     call_com_err	 bit (1);
	dcl     chars_written	 fixed bin (35);
	dcl     code		 fixed bin (35);
	dcl     default_modes	 bit (1);
	dcl     dl_file		 bit (1);
	dcl     message		 char (200);
	dcl     modes_set		 bit (1) init ("0"b);
	dcl     01 mt_options	 unal,
		02 ts_iocbp	 ptr aligned,
		02 atd		 char (512),
		02 eof_char	 char (256) var,
		02 eol_str	 char (256) var,
		02 io_switch	 char (32) var,
		02 new_modes	 char (512),
		02 path		 char (200),
		02 protocol	 char (32),
		02 sending	 bit (1),
		02 receiving	 bit (1);
	dcl     my_cl_intermediary	 entry variable;
	dcl     n_read		 fixed bin (21);
	dcl     new_delay_ptr	 ptr;
	dcl     01 new_delay_struc	 like delay_struc;
	dcl     old_delay_ptr	 ptr;
	dcl     01 old_delay_struc	 like delay_struc;
	dcl     old_modes		 char (256);
	dcl     protocol_iocb_ptr	 ptr;
	dcl     protocol_mode	 fixed bin;
	dcl     protocol_swn	 char (32);
	dcl     reset_cl_intermediary	 bit (1);
	dcl     saved_cl_intermediary	 entry variable;
	dcl     seg_iocb_ptr	 ptr;
	dcl     seg_mode		 fixed bin;
	dcl     seg_ptr		 ptr;
	dcl     seg_swn		 char (32);
	dcl     source_dir		 character (168);
	dcl     source_ename	 character (32);
	dcl     start_of_eol	 char (32) var;
	dcl     01 ti		 like terminal_info;
	dcl     ti_ptr		 ptr;
	dcl     transmission_time	 fixed bin (35);
	dcl     whoami		 char (32);

/*  Based   */

	dcl     argument		 character (argument_lth) based (argument_ptr);

/*  Constants  */

	dcl     Buf_Size		 fixed bin (21) internal static options (constant) init (256);
	dcl     Del_Switches	 bit (6) internal static options (constant) init ("100100"b) aligned;
	dcl     IBM_PC		 fixed bin internal static options (constant) init (1);
	dcl     MT_VERSION		 char (3) internal static options (constant) init ("1.0");
	dcl     NL		 char (1) internal static options (constant) init ("
");
	dcl     OTHER		 fixed bin internal static options (constant) init (2);
	dcl     XMODEM		 fixed bin internal static options (constant) init (0);

/*  Builtin  */

	dcl     (abs, addr, after, before, ceil, index, length, mod, reverse, rtrim, null, substr, trunc)
				 builtin;

/*  Conditions */
	dcl     cleanup		 condition;

/*  External  */

	dcl     error_table_$action_not_performed
				 fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$empty_file fixed bin (35) ext static;
	dcl     error_table_$long_record fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$regexp_too_long fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$end_of_info fixed bin (35) ext static;
	dcl     error_table_$short_record fixed bin (35) ext static;

/*  Procedures  */

	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry returns (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$cl		 entry (1 aligned, 2 bit (1) unal, 2 bit (35) unal);
	dcl     cu_$generate_call	 entry (entry, ptr);
	dcl     cu_$get_cl_intermediary entry (entry);
	dcl     cu_$set_cl_intermediary entry (entry);
	dcl     delete_$path	 entry (char (*), char (*), bit (6) aligned, char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed (35));
	dcl     iox_$get_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$look_iocb	 entry (char (*), ptr, fixed bin (35));
	dcl     iox_$modes		 entry (ptr, char (*), char (*), fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     nd_handler_		 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));

/*  Include */
%page;
%include access_mode_values;
%page;
%include iox_modes;
%page;
%include terminal_info;
%page;
%include terminate_file;
%page;
%include tty_convert;
%page;

/*  micro_transfer: mt:     procedure () options (variable);  */

	old_delay_ptr = null ();
	new_delay_ptr = null ();
	protocol_iocb_ptr = null ();
	seg_iocb_ptr = null ();
	seg_ptr = null ();
	old_modes = "";
	whoami = "micro_transfer";
	reset_cl_intermediary = "0"b;
	dl_file = "0"b;
	ti_ptr = addr (ti);
	ti.version = terminal_info_version;
	old_delay_struc.version = DELAY_VERSION;
	new_delay_struc.version = DELAY_VERSION;

	on cleanup call clean_up (0);


/*  Initialize control arguments, setting defaults where applicable */

	mt_options.receiving = "0"b;
	mt_options.sending = "0"b;
	mt_options.eof_char = "";
	mt_options.eol_str = "";
	mt_options.protocol = " ";
	mt_options.io_switch = " ";
	mt_options.atd = "xmodem_io_ user_i/o";
	mt_options.new_modes = " ";
	default_modes = "1"b;


	call cu_$arg_count (argument_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami);
		return;
	     end;

	if argument_count = 0
	then do;
USAGE:
		call com_err_ (error_table_$noarg, whoami, "^/Usage: ^a path {-control_args}", whoami);
		return;
	     end;


	call cu_$arg_ptr (1, argument_ptr, argument_lth, code);
						/* get path */
	if code ^= 0
	then do;
		call com_err_ (error_table_$noarg, whoami, "^/Usage: ^a path {-control_args}", whoami);
		return;
	     end;

	if index (argument, "-") ^= 1
	then path = argument;

	else do;
		call com_err_ (error_table_$noarg, whoami, "^/Usage: ^a path {-control_args}", whoami);
		return;
	     end;


/* Scan for control arguments */

	arg_idx = 2;
	do while (arg_idx <= argument_count);
	     call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, argument, "Fetching argument #^d.", arg_idx);
		     return;
		end;

	     else if argument = "-send"
	     then do;
		     mt_options.sending = "1"b;
		     mt_options.receiving = "0"b;
		end;


	     else if argument = "-receive"
	     then do;
		     mt_options.receiving = "1"b;
		     mt_options.sending = "0"b;
		end;

	     else if argument = "-modes"
	     then do;
		     arg_idx = arg_idx + 1;
		     call get_sub_arg;
		     mt_options.new_modes = argument;
		     default_modes = "0"b;
		end;

	     else if argument = "-attach_description" | argument = "-atd"
	     then do;
		     arg_idx = arg_idx + 1;
		     call get_sub_arg;
		     mt_options.atd = argument;
		end;

	     else if argument = "-eof"
	     then do;
		     arg_idx = arg_idx + 1;
		     call get_sub_arg;
		     mt_options.eof_char = argument;
		end;

	     else if argument = "-eol"
	     then do;
		     arg_idx = arg_idx + 1;
		     call get_sub_arg;
		     mt_options.eol_str = argument;
		end;

	     else do;
BADOPT:
		     call com_err_ (error_table_$badopt, whoami, "^a", argument);
		     return;
		end;
	     arg_idx = arg_idx + 1;
	end;


/*  Check arguments  */

	if ^mt_options.sending & ^mt_options.receiving
	then do;					/*  User didn't specify direction */
		call com_err_ (error_table_$noarg, whoami, "^a ^a", "-send", "-receive");
		return;
	     end;

	if length (mt_options.eol_str) > 32
	then do;
		call com_err_ (error_table_$regexp_too_long, whoami, "^a", mt_options.eol_str);
		return;
	     end;

	if length (mt_options.eof_char) > 1
	then do;
		call com_err_ (error_table_$regexp_too_long, whoami, "^a", mt_options.eof_char);
		return;
	     end;

	call set_implicit_args;

	call expand_pathname_ (path, source_dir, source_ename, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami, "^a", path);
		return;
	     end;

	absolute_path = pathname_ (rtrim (source_dir), rtrim (source_ename));

	if mt_options.receiving
	then do;					/*  Check file on Multics side   */
		call check_target_file (call_com_err, code);
		if code ^= 0
		then do;
			if code = error_table_$action_not_performed
			then call clean_up (0);
			else if call_com_err
			then call com_err_ (code, whoami, "^a", rtrim (absolute_path));
			return;
		     end;
		seg_mode = Stream_output;
		protocol_mode = Stream_input;
	     end;

	else do;					/*  Check file on Multics side   */
		call check_source_file (code, bit_count);
		if code ^= 0
		then do;
			call com_err_ (code, whoami, "^a", rtrim (absolute_path));
			return;
		     end;
		seg_mode = Stream_input;
		protocol_mode = Stream_output;
	     end;


	seg_swn = unique_chars_ (""b) || "." || rtrim (source_ename);
	protocol_swn = unique_chars_ (""b) || "." || rtrim (mt_options.protocol);

/*  Attach vfile_ */
	call iox_$attach_name (seg_swn, seg_iocb_ptr, "vfile_ " || rtrim (absolute_path), null, code);
	if code ^= 0
	then do;
		call clean_up (0);
		call com_err_ (code, whoami, "^a", rtrim (absolute_path));
		return;
	     end;

	call iox_$open (seg_iocb_ptr, seg_mode, "0"b, code);
	if code ^= 0
	then do;
		call clean_up (0);
		call com_err_ (code, whoami, "^a", rtrim (absolute_path));
		return;
	     end;

	if mt_options.receiving then dl_file = "1"b;

	call iox_$look_iocb ((mt_options.io_switch), mt_options.ts_iocbp, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami, "^a", mt_options.io_switch);
		return;
	     end;

/* Multics side okay, greet user  */

	call ioa_ ("Micro Transfer^xVersion^x^a", MT_VERSION);

	if mt_options.receiving
	then call ioa_ ("Receiving file ^a", rtrim (absolute_path));
	else call display_send_info (bit_count);


/* setup line modes */
/* Delays */
	old_delay_ptr = addr (old_delay_struc);
	new_delay_ptr = addr (new_delay_struc);

	new_delay_struc.default = 0;
	new_delay_struc.delay.vert_nl = 0;
	new_delay_struc.delay.horz_nl = 0;
	new_delay_struc.delay.const_tab = 0;
	new_delay_struc.delay.var_tab = 0;
	new_delay_struc.delay.backspace = 0;
	new_delay_struc.delay.vt_ff = 0;

	call iox_$control (mt_options.ts_iocbp, "get_delay", old_delay_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami);
		call clean_up (0);
		return;
	     end;

	call iox_$control (mt_options.ts_iocbp, "set_delay", new_delay_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, whoami);
		call clean_up (0);
		return;
	     end;

/*  Modes and cl_intermediary  */
	call cu_$get_cl_intermediary (saved_cl_intermediary);
	my_cl_intermediary = do_cl_intermediary;
	call cu_$set_cl_intermediary (my_cl_intermediary);
	reset_cl_intermediary = "1"b;

	call iox_$modes (mt_options.ts_iocbp, mt_options.new_modes, old_modes, code);

	if code ^= 0
	then do;
		call com_err_ (code, whoami, "^a", mt_options.new_modes);
		call clean_up (0);
		return;
	     end;
	modes_set = "1"b;


/*  Attach the I/O module  */
	call iox_$attach_name (protocol_swn, protocol_iocb_ptr, rtrim (mt_options.atd), null, code);

	if code ^= 0
	then do;
		call clean_up (0);
		call com_err_ (code, whoami, "^a", mt_options.protocol);
		return;
	     end;


	call iox_$open (protocol_iocb_ptr, protocol_mode, "0"b, code);
	if code ^= 0
	then do;
		call clean_up (0);
		call com_err_ (code, whoami, "^a", mt_options.protocol);
		return;
	     end;


/*  Do i/o  */

	dl_file = "0"b;
	buf_ptr = addr (buff);

	if protocol_mode = Stream_output
	then call send_data (code, message);

	else call get_data (code, message);

	if code ^= 0
	then do;
		call clean_up (0);
		call com_err_ (code, whoami, "^a", rtrim (message));
		return;
	     end;

	call clean_up (code);			/*  Care about the close here */

	if code ^= 0
	then do;
		call com_err_ (code, whoami, "^a", mt_options.protocol);
		return;
	     end;

	if mt_options.eof_char ^= "" & seg_mode = Stream_output
	then call strip_remote_eof (code);

	if code ^= 0
	then call com_err_ (code, whoami, "^/a, ^a", "Unable to translate end-of-file character ",
		rtrim (absolute_path));


%page;
/*  This procedure returns the STR portion of a control argument  */

get_sub_arg:
     proc;

	if arg_idx > argument_count
	then do;
		call com_err_ (error_table_$noarg, whoami);
		goto EXIT;
	     end;
	call cu_$arg_ptr (arg_idx, argument_ptr, argument_lth, code);
	if code ^= 0
	then do;
		call com_err_ (code, argument, "Fetching argument #^d.", arg_idx);
		goto EXIT;
	     end;
     end get_sub_arg;

%page;
/*  This procedure sets variables based on the command line input  */

set_implicit_args:
     proc;

	mt_options.protocol = before (mt_options.atd, " ");
	mt_options.io_switch = before (after (mt_options.atd, " "), " ");

	if rtrim (mt_options.protocol) = "xmodem_io_"
	then do;
		active_protocol = XMODEM;
		if default_modes
		then mt_options.new_modes =
			"force,no_outp,8bit,breakall,^echoplex,rawi,^crecho,^lfecho,^tabecho,rawo";
	     end;
	else if rtrim (mt_options.protocol) = "ibm_pc_io_"
	then do;
		active_protocol = IBM_PC;
		if default_modes
		then mt_options.new_modes = "force,^8bit,breakall,^echoplex,rawi,^crecho,^lfecho,^tabecho,rawo";
	     end;

	else do;
		active_protocol = OTHER;
		if default_modes
		then mt_options.new_modes = "force,no_outp,8bit,breakall,^echoplex,rawi,^crecho,^lfecho,^tabecho,rawo";
	     end;
	return;
     end set_implicit_args;


%page;
/*  This procedure checks out the integrity of the file to be received  */

check_target_file:
     proc (call_com_err, ec);

	dcl     bit_count		 fixed bin (24);
	dcl     call_com_err	 bit (1);
	dcl     ec		 fixed bin (35);

	call_com_err = "1"b;

	call initiate_file_ (source_dir, source_ename, N_ACCESS, seg_ptr, bit_count, ec);
	if ec = error_table_$noentry
	then ec = 0;

	if seg_ptr ^= null
	then do;
		call nd_handler_ (whoami, source_dir, source_ename, ec);
		call_com_err = "0"b;
	     end;
	return;
     end check_target_file;


%page;
/*  This procedure checks out the integrity of the file to be sent */

check_source_file:
     proc (ec, bit_count);

	dcl     bit_count		 fixed bin (24);
	dcl     ec		 fixed bin (35);


	call initiate_file_ (source_dir, source_ename, R_ACCESS, seg_ptr, bit_count, ec);
	if ec ^= 0
	then return;

	if bit_count = 0
	then do;
		ec = error_table_$empty_file;
		return;
	     end;

     end check_source_file;

%page;
/*  This procedure displays file information before sending a Multics file */

display_send_info:
     proc (bit_count);

	dcl     bit_count		 fixed bin (24);
	dcl     char_length		 fixed bin;
	dcl     char_count		 fixed bin (35);
	dcl     ec		 fixed bin (35);
	dcl     packet_length	 fixed bin;
	dcl     packet_overhead	 fixed bin;

	char_count = bit_count / 9;
	call ioa_ ("Sending file ^a:^x^d^xcharacters", rtrim (absolute_path), char_count);

	call iox_$control (mt_options.ts_iocbp, "terminal_info", ti_ptr, ec);

	if ec = 0
	then do;
		goto init_info (active_protocol);

init_info (0):					/* XMODEM */
		packet_overhead = 4;
		packet_length = 128;
		char_length = 8;
		goto end_init_info;

init_info (1):					/* IBM_PC */
		packet_overhead = 1;
		packet_length = 1;			/*  Variable length packets  */
		char_length = 7;
		goto end_init_info;


init_info (2):					/* OTHER */
		packet_overhead = 1;
		packet_length = 1;
		char_length = 8;

end_init_info:
		bit_count =
		     (char_count * char_length)
		     + (abs (packet_length - mod (char_count, packet_length)) * char_length)
		     + (ceil (char_count / packet_length) * packet_overhead);
						/*  Real bit transmission count  */

		transmission_time = ceil (bit_count / ti.baud_rate);
		call ioa_ ("Approximate Send Time: ^d minutes, ^d seconds at ^d baud", trunc (transmission_time / 60),
		     mod (transmission_time, 60), ti.baud_rate);
	     end;
	return;
     end display_send_info;

%page;
/*  mt's cl intermediary  */

do_cl_intermediary:
     procedure;

	call mt_call_out (cu_$cl, cu_$arg_list_ptr ());
	return;
     end do_cl_intermediary;



/* This procedure handles modes setting in the event of a quit  */

mt_call_out:
     procedure (Entry, Arg_list);

	dcl     Entry		 variable entry parameter;
	dcl     Arg_list		 ptr parameter;

	call iox_$modes (mt_options.ts_iocbp, old_modes, (""), 0);
	call cu_$set_cl_intermediary (saved_cl_intermediary);
	call cu_$generate_call (Entry, Arg_list);
	call iox_$modes (mt_options.ts_iocbp, mt_options.new_modes, old_modes, 0);
	call cu_$set_cl_intermediary (my_cl_intermediary);
	return;
     end mt_call_out;


%page;
/*  This procedure reads from the protocol I/O module and writes the data
   to the Multics segment performing end-of-line and translations
   as necessary.  */

get_data:
     proc (ec, message);

	dcl     ec		 fixed bin (35);
	dcl     eof		 bit (1);
	dcl     message		 char (200);

	eof = "0"b;
	ec = 0;
	start_of_eol = "";

	call iox_$get_chars (protocol_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec);


	do while (^eof);
	     if ec = error_table_$end_of_info
	     then do;
		     eof = "1"b;
		end;

	     else if ec ^= 0
	     then goto error_protocol_in;

	     if mt_options.eol_str ^= ""
	     then call translate_remote_eol (n_read, eof);

	     call iox_$put_chars (seg_iocb_ptr, buf_ptr, n_read, ec);
	     if ec ^= 0
	     then goto error_file_out;

	     if ^eof
	     then call iox_$get_chars (protocol_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec);
	end;
	ec = 0;
	return;

error_protocol_in:
	message = mt_options.protocol;
	return;
error_file_out:
	message = absolute_path;
	return;
     end get_data;

%page;
/*  This procedure reads from the Multics segment and writes to the protocol
   I/O module performing end-of-line and end-of-file conversions as necessary */

send_data:
     proc (ec, message);

	dcl     ec		 fixed bin (35);
	dcl     eof_set		 bit (1);
	dcl     message		 char (200);

	chars_written = 0;
	if mt_options.eol_str ^= ""
	then call iox_$get_line (seg_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec);
	else call iox_$get_chars (seg_iocb_ptr, buf_ptr, Buf_Size, n_read, ec);

	do while (ec ^= error_table_$end_of_info);
	     if mt_options.eol_str ^= "" & n_read ^= 0
	     then call translate_mu_eol (n_read);

	     chars_written = chars_written + n_read;	/* need for xmodem  */

	     if ec = error_table_$short_record
	     then do;
		     if mt_options.eof_char ^= ""
		     then do;
			     call add_remote_eof (n_read);
			     eof_set = "1"b;
			end;
		end;

	     else if ec = error_table_$long_record
	     then ;
	     else if ec ^= 0
	     then goto error_file_in;

	     call iox_$put_chars (protocol_iocb_ptr, buf_ptr, n_read, ec);
	     if ec ^= 0
	     then goto error_protocol_out;

	     if mt_options.eol_str ^= ""
	     then call iox_$get_line (seg_iocb_ptr, buf_ptr, Buf_Size - length (mt_options.eol_str), n_read, ec);
	     else call iox_$get_chars (seg_iocb_ptr, buf_ptr, Buf_Size, n_read, ec);
	end;

	if ^eof_set & mt_options.eof_char ^= ""
	then do;
		call add_remote_eof (n_read);
		call iox_$put_chars (protocol_iocb_ptr, buf_ptr, n_read, ec);
		if ec ^= 0
		then goto error_protocol_out;
	     end;

	ec = 0;
	return;

error_protocol_out:
	message = mt_options.protocol;
	return;
error_file_in:
	message = absolute_path;
	return;
     end send_data;


%page;
/*  This procedure adds the remote's eof character(s) */

add_remote_eof:
     proc (n_read);

	dcl     i			 fixed bin;
	dcl     n_pad		 fixed bin;
	dcl     n_read		 fixed bin (21);

	goto case (active_protocol);

case (0):						/* XMODEM */
	n_pad = Buf_Size / 2 - mod (chars_written, 128);
	do i = n_read + 1 to n_read + n_pad;
	     substr (buff, i, 1) = mt_options.eof_char;
	end;
	n_read = n_read + n_pad;
	goto end_case;

case (1):						/* IBM_PC */
case (2):						/* OTHER */
	substr (buff, n_read + 1, 1) = mt_options.eof_char;
	n_read = n_read + 1;
end_case:
	return;

     end add_remote_eof;


%page;
/*  This procedure strips the remote eof character (s)  */

strip_remote_eof:
     proc (ec);

	dcl     char_count		 fixed bin (35);
	dcl     done_searching	 bit (1);
	dcl     ec		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     seg_ptr		 ptr;
	dcl     overlay		 char (char_count) based (seg_ptr);

	call initiate_file_ (source_dir, source_ename, N_ACCESS, seg_ptr, bit_count, ec);
	if seg_ptr ^= null & ec = 0
	then do;
		char_count = bit_count / 9;
		done_searching = "0"b;
		i = char_count;

		do while (i >= 1 & ^done_searching);
		     if substr (seg_ptr -> overlay, i, 1) ^= mt_options.eof_char
		     then i = i - 1;
		     else do;
			     do while (i >= 1 & ^done_searching);
				if substr (seg_ptr -> overlay, i, 1) = mt_options.eof_char
				then i = i - 1;
				else done_searching = "1"b;
			     end;
			end;
		end;

		if i ^= char_count & done_searching
		then do;				/* Have to reset the bit count  */
			bit_count = i * 9;
			call hcs_$set_bc_seg (seg_ptr, bit_count, ec);
		     end;
	     end;

	if seg_ptr ^= null
	then call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0);

	return;
     end strip_remote_eof;


%page;

/*  This procedure translates a Multics NL to the remote eol character (s)  */

translate_mu_eol:
     proc (n_read);

	dcl     n_read		 fixed bin (21);

	if substr (buff, n_read, 1) = NL
	then do;
		substr (buff, n_read, length (mt_options.eol_str)) = mt_options.eol_str;
		n_read = n_read + length (mt_options.eol_str) - 1;
	     end;
     end translate_mu_eol;


/* This procedure translates the remote eol character (s) to a Multics NL.  */

translate_remote_eol:
     proc (n_read, eof);

	dcl     buf_pos		 fixed bin;
	dcl     eof		 bit (1);
	dcl     i			 fixed bin;
	dcl     n_read		 fixed bin (21);
	dcl     out_buf		 char (288) var;


	buf_pos = 0;
	out_buf = "";

/* See if we've got the last half of the end-of-line sequence */
	if start_of_eol || substr (buff, 1, length (mt_options.eol_str) - length (start_of_eol)) = mt_options.eol_str
	then do;					/* yes  */
		buf_pos = length (mt_options.eol_str) - length (start_of_eol);
		out_buf = NL;
	     end;

	else out_buf = start_of_eol;			/* No  */

	start_of_eol = "";

/* Now convert all full end-of-line sequences to a NL  */
	i = index (substr (buff, buf_pos + 1, n_read - buf_pos), mt_options.eol_str);

	do while (i ^= 0);
	     out_buf = out_buf || substr (buff, buf_pos + 1, i - 1) || NL;
	     buf_pos = buf_pos + i + length (mt_options.eol_str) - 1;
	     i = index (substr (buff, buf_pos + 1, n_read - buf_pos), mt_options.eol_str);
	end;

	out_buf = out_buf || substr (buff, buf_pos + 1, n_read - buf_pos);
	n_read = length (out_buf);

/* See if we still might have an end-of-line sequence beginning at the
   end of the buffer.  i.e. split across two buffers  */

	if ^eof
	then do;
		i = index (reverse (out_buf), substr (mt_options.eol_str, 1, 1));

		if i ^= 0
		then do;
			buf_pos = length (out_buf) + 1 - i;
			if i < length (mt_options.eol_str)
			then do;
				if substr (out_buf, buf_pos, i) = substr (mt_options.eol_str, 1, i)
				then n_read = buf_pos - 1;
			     end;
		     end;

/* There was a split, so save the first portion of the end-of-line sequence */
		if n_read < length (out_buf)
		then start_of_eol = substr (out_buf, n_read + 1, i);
	     end;


	substr (buff, 1, n_read) = substr (out_buf, 1, n_read);
	return;
     end translate_remote_eol;


%page;
/*  This procedure restores the environment */

clean_up:
     proc (ec);

	dcl     ec		 fixed bin (35);

	ec = 0;

	if protocol_iocb_ptr ^= null ()
	then do;
		call iox_$close (protocol_iocb_ptr, ec);
		call iox_$detach_iocb (protocol_iocb_ptr, 0);
	     end;

	if seg_iocb_ptr ^= null ()
	then do;
		call iox_$close (seg_iocb_ptr, 0);
		call iox_$detach_iocb (seg_iocb_ptr, 0);
	     end;

	if reset_cl_intermediary
	then call cu_$set_cl_intermediary (saved_cl_intermediary);

	if modes_set
	then call iox_$modes (mt_options.ts_iocbp, old_modes, "", 0);

	if old_delay_ptr ^= null
	then call iox_$control (mt_options.ts_iocbp, "set_delay", old_delay_ptr, 0);

	if seg_ptr ^= null
	then call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0);

	if dl_file then call delete_$path (source_dir, source_ename, Del_Switches, whoami, 0);

	return;
     end clean_up;

EXIT:
     end;




		    xmodem_io_.pl1                  11/19/84  0940.6r w 11/19/84  0925.2      309870



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style2 */
/*  the user ring xmodem io module --- xmodem_io_
    Uses the xmodem protocol, defined by Ward Christensen, for data
    transfer.    

    1. Definitions
    
         <soh>  01(HEX)  01(OCT)
         <eot>  04(HEX)  04(OCT)
         <ack>  06(HEX)  06(OCT)
         <nak>  15(HEX)  25(OCT)
    
    2. Transmission Medium Level Protocol
    
         Asynchronous, 8 data bits, no parity, one stop bit.
    
         There are no restrictions on the contents of the data being 
    transmitted.  Any kind of data may be sent: binary, ASCII, etc.  No 
    control characters are looked for in the 128-byte data messages.
    
    3. Message Block Level Protocol
         The standard transmission portion of the block is a 132 character
    block without framing characters.  Each block of the transfer looks like:
    
         <SOH><blk #><255-blk #><..128 data bytes..><chksum> where:
    
         <SOH>       =   01 (Hex).
         <blk #>     =   binary number, starts at 01 increments by 1
                         and wraps 0FF (Hex) to 00 (Hex).
         <255-blk #> =   The one's complement of the block number.
         <cksum>     =   The sum of the data bytes only.
    
    4. File Level Protocol
    
    4a. Common to Both Sender and Receiver
    
         All errors are retried 10 times.  
    
    4b. Receive Program Considerations
    
     The receiver has a 10-second timeout.  Once transmission begins, it
sends a <nak> every time it times out.

Before transmission begins, the receiver performs a handshake with the 
sender to determine the type of error detecting code to be used during 
transmission.  If in checksum mode, the receiver's first timeout sends
a <nak> to request checksum mode, and signals the transmitter to start.
If in CRC mode, the receiver's first timeout sends a "C" to request
CRC mode.  It then waits for up to 10 seconds for an <soh>.  This process 
continues until either (1) six "C"'s have been sent without receiving an
<soh>, or (2) an <soh> is received within 10 seconds of sending a "C".  If
an <soh> is received within 10 seconds of sending a "C", it is assumed that 
the "C" was accepted by the sender and that it will send in CRC mode. 
If six "C"'s are sent without receiving an <soh>, the receiver switches to
checksum mode and sends  out a <nak>.

     Once into receiving a block, the receiver goes into a one-second
timeout for each character and the checksum.  If a valid block is
received, the receiver will transmit an <ack>.  For invalid blocks,
a <nak> is transmitted.

    
    4c. Sending Program Considerations
         
         The sender has a high-level 110-second timeout.  If a timeout occurs,
    transmission is aborted.

         The sender starts transmission upon receipt of a <nak> or a "C".
    An initial <nak> causes the sender to transmit in checksum mode, while
    a "C" signals the sender to transmit in CRC mode.

    If the block was successfully received (receiver sends an <ack>),
    the next block is sent.  If the receiver responds with a <nak>,
    the sender retransmits the last block.  When the sender has no more 
    data, it sends an <eot>, and awaits an <ack>, resending the <eot> if
    it doesn't get one.

    Status:
    0) 24 August 1984:  Initial coding, M. Mallmes.
*/

%page;
xmodem_io_:
     proc;
	return;					/* not an entry  */
						/*  iox_ io module for xmodem protocol i/o written 6/84 by M.J. Mallmes  */

/*  Parameters  */

	dcl     arg_actual_len	 fixed bin (21);
	dcl     arg_buf_ptr		 ptr;		/* ptr to user buffer (input) */
	dcl     arg_buf_len		 fixed bin (21);	/* length of user buffer (input) */
	dcl     arg_iocbp		 ptr;		/* ptr to iocb (input) */
	dcl     code		 fixed bin (35);	/*  Multics standard error code  (output */
	dcl     com_err_switch	 bit (1) aligned;	/* ON if should call com_err_ for errors (input)  */
	dcl     mode		 fixed bin;
	dcl     option_array	 (*) char (*) varying;


/*  Automatic  */

	dcl     actual_iocbp	 ptr;		/* copy of iocb.actual_iocb_ptr */
	dcl     arg_buf_pos		 fixed bin;	/* index into passed argument buffer  */
	dcl     attach_data_ptr	 ptr;		/* ptr to iocb's attach_data  */
	dcl     block_rx		 char (1);
	dcl     block_rx_1		 char (1);
	dcl     check_char		 (2) char (1);
	dcl     buf_ptr		 ptr;
	dcl     ec		 fixed bin (35);
	dcl     edc		 fixed bin;
	dcl     i			 fixed bin;
	dcl     iocbp		 ptr;		/*  copy of arg_iocbp */
	dcl     mask		 bit (36) aligned;	/* ips mask */
	dcl     newline_found	 bit (1);
	dcl     newline_needed	 bit (1);
	dcl     packet_type		 char (1);
	dcl     retry_count		 fixed bin;
	dcl     system_free_area_ptr	 ptr;
	dcl     successful		 bit (1);
	dcl     buffer_empty	 bit (1);		/* ON of a packet is to be received  */
	dcl     buffer_full		 bit (1);		/* ON of a packet is to be sent  */

/*  Based  */

	dcl     01 attach_data	 aligned based (attach_data_ptr),
						/* iocb attach_data */
		02 attach_descrip	 char (256) varying,
		02 open_descrip	 char (32) varying,
		02 target_iocbp	 ptr,		/* ptr to target switch iocb */
		02 buf		 char (128),	/* internal buffer  */
		02 buf_pos	 fixed bin (21),	/*  index into buf  */
		02 my_rx_n	 uns fixed bin (9) unal,
						/* packet number when receiving */
		02 my_tx_n	 uns fixed bin (9) unal,
						/* packet number when sending */
		02 error_code	 fixed bin (35),	/* 0 if normal close operation */
		02 crc_init	 bit (1) unal,
		02 block_check_type	 fixed bin;	/* Check type being used  */

	dcl     01 open_descrip	 based aligned,	/* open description for iocb  */
		02 length		 fixed bin (17),
		02 string		 char (0 refer (open_descrip.length));

	dcl     system_free_area	 area based (system_free_area_ptr);

/*  Constants  */

	dcl     Abort_Interval	 fixed bin (71) static options (constant) init (100000000);
						/* 110 seconds */
	dcl     ACK		 char (1) static options (constant) init ("");
	dcl     Buf_Size		 fixed bin (21) static options (constant) init (128);
	dcl     CAN		 char (1) static options (constant) init ("");
	dcl     Check_Sum		 fixed bin static options (constant) init (1);
	dcl     Cyclic_Redundancy_Code fixed bin static options (constant) init (2);
	dcl     Dim_name		 char (10) static options (constant) init ("xmodem_io_");
	dcl     EOT		 char (1) static options (constant) init ("");
	dcl     NAK		 char (1) static options (constant) init ("");
	dcl     NL		 char (1) static options (constant) init ("
");
	dcl     NUL		 char (1) static options (constant) init ("");
	dcl     Retry_Threshold	 fixed bin static options (constant) init (10);
	dcl     SOH		 char (1) static options (constant) init ("");
	dcl     Timeout_Interval	 fixed bin (71) static options (constant) init (10000000);
						/* 10 seconds */

/*  Builtin    */

	dcl     (addcharno, addr, byte, bool, hbound, index, lbound, mod, null, rank, rtrim, substr, unspec)
				 builtin;

/* Conditions */

	dcl     (any_other, cleanup)	 condition;

/*  External Static  */

	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$bad_mode	 fixed bin (35) ext static;
	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$end_of_info
				 fixed bin (35) ext static;
	dcl     error_table_$incompatible_attach
				 fixed bin (35) ext static;
	dcl     error_table_$long_record
				 fixed bin (35) ext static;
	dcl     error_table_$noarg	 fixed bin (35) ext static;
	dcl     error_table_$no_iocb	 fixed bin (35) ext static;
	dcl     error_table_$not_attached
				 fixed bin (35) ext static;
	dcl     error_table_$not_detached
				 fixed bin (35) ext static;
	dcl     error_table_$not_open	 fixed bin (35) ext static;
	dcl     error_table_$timeout	 fixed bin (35) ext static;
	dcl     error_table_$unable_to_do_io
				 fixed bin (35) ext static;

/*  Procedures       */

	dcl     com_err_		 entry () options (variable);
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$reset_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     iox_$err_no_operation	 entry () options (variable);
	dcl     iox_$err_not_attached	 entry () options (variable);
	dcl     iox_$err_not_open	 entry () options (variable);
	dcl     iox_$err_not_closed	 entry () options (variable);
	dcl     iox_$look_iocb	 entry (char (*), ptr, fixed bin (35));
	dcl     iox_$propagate	 entry (ptr);
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     timed_io_$get_chars	 entry (ptr, fixed bin (71), ptr, fixed bin (21), fixed bin (21), fixed bin (35));


%page;

/*  Include Files    */

%include iocb;
%page;
%include iox_modes;
%page;

/*  This entry attaches the xmodem_io_ i/o module after verifying that
    the target switch is open for stream_input_output  */

xmodem_io_attach:
     entry (arg_iocbp, option_array, com_err_switch, code);

	ec = 0;
	mask = ""b;
	iocbp = arg_iocbp;

	if hbound (option_array, 1) < 1
	then call error (0, com_err_switch, error_table_$noarg, "Usage:  xmodem_io_ switch_name {-control_arguments}");

	attach_data_ptr = null ();
	on cleanup call clean_up_attach;

	if iocbp -> iocb.attach_descrip_ptr ^= null ()
	then call error (0, com_err_switch, error_table_$not_detached, "");

	system_free_area_ptr = get_system_free_area_ ();
	allocate attach_data in (system_free_area) set (attach_data_ptr);

/*  see if the target switch is attached and open  for stream_input_output */
	call iox_$look_iocb (rtrim (option_array (1)), target_iocbp, ec);
	if ec = error_table_$no_iocb
	then call error (1, com_err_switch, ec, rtrim (option_array (1)));
	if target_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null
	then call error (1, com_err_switch, error_table_$not_attached, rtrim (option_array (1)));
	if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null
	then call error (1, com_err_switch, error_table_$not_open, rtrim (option_array (1)));
	if target_iocbp -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr -> open_descrip.string
	     ^= iox_modes (Stream_input_output)
	then call error (1, com_err_switch, error_table_$bad_mode, rtrim (option_array (1)));

	edc = Check_Sum;
	do i = lbound (option_array, 1) + 1 to hbound (option_array, 1);
	     if option_array (i) = "-error_detection_code" | option_array (i) = "-edc"
	     then do;
		     i = i + 1;
		     if i > hbound (option_array, 1)
		     then call error (1, com_err_switch, error_table_$noarg,
			     "-edc given without an error correction code");
		     if option_array (i) = "cyclic_redundancy_code" | option_array (i) = "crc"
		     then edc = Cyclic_Redundancy_Code;
		     else if option_array (i) = "check_sum" | option_array (i) = "cs"
		     then edc = Check_Sum;
		     else call error (1, com_err_switch, error_table_$badopt, rtrim (option_array (i)));
		end;
	     else call error (1, com_err_switch, error_table_$badopt, rtrim (option_array (i)));
	end;

	attach_data.attach_descrip = Dim_name || " " || rtrim (option_array (1));
	attach_data.open_descrip = "";
	attach_data.block_check_type = edc;
	if edc = Cyclic_Redundancy_Code
	then attach_data.crc_init = "1"b;
	else attach_data.crc_init = "0"b;
	attach_data.my_rx_n = 1;
	attach_data.my_tx_n = 1;
	attach_data.buf_pos = 0;
	attach_data.error_code = 0;

	call hcs_$set_ips_mask (""b, mask);
	iocbp -> iocb.attach_data_ptr = attach_data_ptr;
	iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip);
	iocbp -> iocb.detach_iocb = xmodem_io_detach;
	iocbp -> iocb.open_descrip_ptr = null ();
	iocbp -> iocb.open = xmodem_io_open;
	iocbp -> iocb.modes = iox_$err_no_operation;
	iocbp -> iocb.control = iox_$err_no_operation;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, ""b);
EXIT:
	return;


%page;
/*  Error calls com_err_ if the loud switch is set and goes to the attach return */

error:
     proc (cleanup_level, call_com_err, ec, msg);

	dcl     cleanup_level	 fixed bin;
	dcl     call_com_err	 bit (1) aligned;
	dcl     ec		 fixed bin (35);	/* Multics standard error code */
	dcl     msg		 char (*);	/* Additional error information */

	goto Err (cleanup_level);

Err (1):
	free attach_data;

Err (0):
	if call_com_err
	then call com_err_ (ec, Dim_name, "^a", msg);
	code = ec;
	goto EXIT;
     end error;


%page;

/*  This entry detaches the xmodem_io_ i/o module and frees the associated
    information  */

xmodem_io_detach:
     entry (arg_iocbp, code);

	call set_up;
	on any_other call handler;
	call hcs_$set_ips_mask ("0"b, mask);
	actual_iocbp -> iocb.attach_descrip_ptr = null ();
	actual_iocbp -> iocb.attach_data_ptr = null ();
	actual_iocbp -> iocb.open = iox_$err_not_attached;
	actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, "0"b);
	revert any_other;
	free attach_data;
	return;

%page;

/*  This entry sets the open description and the legal operation entries
    in the iocb.  Operation permitted:

             all the time: close
	   input:        get_chars, get_line
	   output:       put_chars

    Before returning it performs a handshake with the remote xmodem,
    determining the type of error correction code to be used.      */

xmodem_io_open:
     entry (arg_iocbp, mode, com_err_switch, code);

	on cleanup attach_data.error_code = 1;
	call set_up;

	if mode = Stream_input | mode = Stream_output
	then do;
		if mode = Stream_output & crc_init
		then do;
			code = error_table_$incompatible_attach;
			return;
		     end;
		else attach_data_ptr -> attach_data.open_descrip = iox_modes (mode);
	     end;

	else do;
		code = error_table_$bad_mode;
		return;
	     end;

	if mode = Stream_output
	then do;					/* Perform handshake - sender */
		call get_char (packet_type, Abort_Interval, ec);
		retry_count = 2;

		do while (ec = 0 & packet_type ^= NAK & packet_type ^= "C" & retry_count <= Retry_Threshold);
		     call get_char (packet_type, Abort_Interval, ec);
		     retry_count = retry_count + 1;
		end;

		if retry_count > Retry_Threshold | ec ^= 0
		then do;
			if ec = error_table_$timeout | retry_count > Retry_Threshold
			then code = error_table_$unable_to_do_io;
			else code = ec;
			return;
		     end;

		if packet_type = "C"
		then attach_data.block_check_type = Cyclic_Redundancy_Code;
		else attach_data.block_check_type = Check_Sum;
	     end;


	if mode = Stream_input
	then do;					/* Perform handshake - receiver */

		if attach_data.crc_init
		then do;
			call get_data_packet (ec);
			if ec ^= 0
			then do;
				attach_data.buf_pos = 0;
				code = ec;
				return;
			     end;
			attach_data.my_rx_n = mod (attach_data.my_rx_n + 1, 256);
			attach_data.crc_init = "0"b;
		     end;
	     end;


	on any_other call handler;

	call hcs_$set_ips_mask (""b, mask);
	actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip);
	actual_iocbp -> iocb.open = iox_$err_not_closed;
	actual_iocbp -> iocb.close = xmodem_io_close;
	actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed;
	if mode = Stream_input
	then do;
		actual_iocbp -> iocb.get_line = xmodem_io_get_line;
		actual_iocbp -> iocb.get_chars = xmodem_io_get_chars;
	     end;
	else if mode = Stream_output
	then actual_iocbp -> iocb.put_chars = xmodem_io_put_chars;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, ""b);
	revert any_other;

	return;

%page;
/*  This procedure closes the xmodem i/o switch.  If the switch was
    open for stream_output it flushes the output buffer and sends
    an EOT control character to the remote xmodem.
    If the last packet cannot be transmitted, the i/o switch is
    closed and the error code error_table_$unable_to_do_io is returned.   */

xmodem_io_close:
     entry (arg_iocbp, code);

	on cleanup attach_data.error_code = 1;
	call set_up;

	if actual_iocbp -> iocb.open_descrip_ptr -> open_descrip.string = iox_modes (Stream_output)
	     & attach_data.error_code = 0
	then do;
		call flush_output (ec);

		if ec = 0
		then do;				/*  send EOT */
			call send_char (EOT);
			call get_char (packet_type, Timeout_Interval, ec);
			do retry_count = 2 to Retry_Threshold
			     while (packet_type ^= ACK | ec = error_table_$timeout);
			     call send_char (EOT);
			     call get_char (packet_type, Timeout_Interval, ec);
			end;
		     end;

		if ec = error_table_$timeout | retry_count > Retry_Threshold
		then ec = error_table_$unable_to_do_io;
	     end;

	on any_other call handler;
	call hcs_$set_ips_mask ("0"b, mask);
	actual_iocbp -> iocb.open_descrip_ptr = null;
	actual_iocbp -> iocb.open = xmodem_io_open;
	actual_iocbp -> iocb.detach_iocb = xmodem_io_detach;
	call iox_$propagate (actual_iocbp);
	call hcs_$reset_ips_mask (mask, "0"b);
	revert any_other;
	code = ec;
	return;

/*  flush_output transmits any remaining data to the remote xmodem during
    a close operation.  The last data packet sent is filled with the NUL
    ascii character, if and only if it is not a multiple of 128.  */

flush_output:
     proc (ec);

	dcl     ec		 fixed bin (35);
	dcl     n_chars		 fixed bin;

	ec = 0;

	buf_ptr = addr (attach_data.buf);
	if attach_data.buf_pos = 0
	then return;

	do n_chars = attach_data.buf_pos + 1 to Buf_Size;
	     substr (attach_data.buf, n_chars, 1) = NUL;
	end;

	call send_data_packet (ec);

	return;
     end flush_output;

%page;

/*  This entry is called to input characters received from the remote
    connection.  Packets are read until the user request is satisfied.  
    Data received, but not requested by the user, is stored in an internal
    buffer, and is available on subsequent reads.            */

xmodem_io_get_chars:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code);

	newline_needed = "0"b;
	goto get_data;

/*  This entry is called to input characters received from the remote
    connection.  Packets are read until the user request is satisfied.
    i.e. a newline is found or the user buffer is filled. Data
    received, but not requested by the user, is stored in an internal
    buffer, and is available on subsequent reads            */

xmodem_io_get_line:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_actual_len, code);

	newline_needed = "1"b;

get_data:
	on cleanup attach_data.error_code = 1;
	call set_up;

	if arg_buf_len = 0
	then return;
	if arg_buf_len < 0
	then do;
		code = error_table_$bad_arg;
		return;
	     end;

	newline_found = "0"b;
	arg_buf_pos = 0;
	do while ("1"b);
	     ec = 0;
	     call unload_internal_buffer (buffer_empty);
	     if buffer_empty
	     then do;
		     call get_data_packet (ec);
		     if ec ^= 0
		     then do;
			     attach_data.buf_pos = 0;
			     attach_data.error_code = ec;
			     goto done_receive;
			end;
		     else attach_data.my_rx_n = mod (attach_data.my_rx_n + 1, 256);
		end;
	     else goto done_receive;
	end;

done_receive:
	if (ec = 0) & newline_needed & ^newline_found
	then ec = error_table_$long_record;
	arg_actual_len = arg_buf_pos;
	code = ec;
	return;


%page;

/*  This internal procedure moves the data from the internal buffer to the user's
    buffer during a get_chars or get_line operation.  */

unload_internal_buffer:
     proc (buffer_empty);
	dcl     buffer_empty	 bit (1);		/* ON if we need more data from the remote xmodem */
	dcl     n_chars		 fixed bin;
	dcl     overlay		 char (arg_buf_len) based;
						/* user buffer */
	dcl     i			 fixed bin;


	buffer_empty = "0"b;
	if attach_data.buf_pos = 0
	then do;
		buffer_empty = "1"b;
		return;
	     end;

	if arg_buf_len - arg_buf_pos > attach_data.buf_pos
	then n_chars = attach_data.buf_pos;
	else n_chars = arg_buf_len - arg_buf_pos;

	if newline_needed
	then do;
		i = index (substr (attach_data.buf, 1, n_chars), NL);
		if i ^= 0
		then do;
			newline_found = "1"b;
			n_chars = i;
		     end;

	     end;

	substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars) = substr (attach_data.buf, 1, n_chars);
	substr (attach_data.buf, 1, attach_data.buf_pos - n_chars) =
	     substr (attach_data.buf, n_chars + 1, attach_data.buf_pos - n_chars);
	attach_data.buf_pos = attach_data.buf_pos - n_chars;
	arg_buf_pos = arg_buf_pos + n_chars;
	if (^newline_found) & (arg_buf_pos < arg_buf_len)
	then buffer_empty = "1"b;
	return;
     end unload_internal_buffer;


/*  This internal procedure gets the actual packet from the remote xmodem
    during a get_chars or get_line operation.  Data is received via packets
    of the following form:
        <SOH><BLOCK #><^BLOCK #><128 data characters><CHECKSUM>

    Acknowledge its receipt by sending either an ACK or NAK  */

get_data_packet:
     proc (ec);
	dcl     bad_char		 bit (1);
	dcl     chase_buf_ptr	 ptr;
	dcl     ec		 fixed bin (35);
	dcl     n_read		 fixed bin (21);
	dcl     soh_eot_char	 char (1);
	dcl     to_read		 fixed bin (21);


	retry_count = 1;

	do while (retry_count <= Retry_Threshold);
	     bad_char = "0"b;
	     ec = 0;

/*  Get the SOH character  */
	     call get_char (soh_eot_char, Timeout_Interval, ec);
	     if ec ^= 0
	     then goto try_again;

	     if soh_eot_char = EOT
	     then do;
		     ec = error_table_$end_of_info;
		     call send_char (ACK);
		     return;
		end;

	     else if soh_eot_char ^= SOH
	     then do;
		     bad_char = "1"b;
		     goto try_again;
		end;

/*  Get the block number  */
	     call get_char (block_rx, Timeout_Interval, ec);
	     if ec ^= 0
	     then goto try_again;

	     if attach_data.my_rx_n ^= rank (block_rx)
	     then do;				/* Our last ACK may have been garbled */
		     if attach_data.my_rx_n ^= mod (rank (block_rx) + 1, 256)
		     then bad_char = "1"b;
		     goto try_again;
		end;

/* Get the block number complement  */
	     call get_char (block_rx_1, Timeout_Interval, ec);
	     if ec ^= 0
	     then goto try_again;

	     if (255 - attach_data.my_rx_n) ^= rank (block_rx_1)
	     then do;				/* Bad complement */
		     bad_char = "1"b;		/* only complement bad so try again */
		     goto try_again;
		end;

/*  Get the data  (128 characters)  */
	     buf_ptr = addr (attach_data.buf);
	     chase_buf_ptr = buf_ptr;
	     attach_data.buf_pos = 0;
	     to_read = Buf_Size;

	     do while (to_read > 0 & ec = 0);
		call timed_io_$get_chars (attach_data.target_iocbp, Timeout_Interval, chase_buf_ptr, to_read, n_read,
		     ec);
		if ec ^= 0
		then goto try_again;
		else do;
			attach_data.buf_pos = n_read + attach_data.buf_pos;
			chase_buf_ptr = addcharno (buf_ptr, attach_data.buf_pos);
			to_read = Buf_Size - attach_data.buf_pos;
		     end;
	     end;

/*  Get the checksum character */
	     call get_char (check_char (1), Timeout_Interval, ec);
	     if ec ^= 0
	     then goto try_again;

/*  Verify the data received  */
	     if attach_data.block_check_type = Check_Sum
	     then do;
		     if rank (check_char (1)) ^= my_checksum ()
		     then bad_char = "1"b;
		end;

	     else do;
		     call get_char (check_char (2), Timeout_Interval, ec);
		     if ec ^= 0
		     then goto try_again;
		     if ^good_crc (check_char)
		     then bad_char = "1"b;
		end;

	     if ^bad_char
	     then do;
		     call flush_input;
		     call send_char (ACK);
		     return;
		end;

try_again:
	     call flush_input;

	     if (ec ^= 0) | bad_char
	     then do;
		     if attach_data.crc_init		/* First time, must agree on error code */
		     then do;
			     if retry_count <= 6
			     then call send_char ("C");
			     else do;
				     attach_data.crc_init = "0"b;
				     attach_data.block_check_type = Check_Sum;
				     call send_char (NAK);
				end;
			end;
		     else call send_char (NAK);
		end;
	     else call send_char (ACK);
	     retry_count = retry_count + 1;
	end;
	if retry_count > Retry_Threshold
	then ec = error_table_$unable_to_do_io;
	return;
     end get_data_packet;




/*  flush_input throws out any data that was sent by the remote xmodem but is
    not required during a get_chars operation because:
	   1.  It is known that the current packet is bad.
	   2.  An ACK or NAK is to be sent in response to the packet
                 received, or not received.        */

flush_input:
     proc;

	dcl     bad_char		 char (1);
	dcl     bad_char_ptr	 ptr;
	dcl     ec		 fixed bin (35);
	dcl     interval		 fixed bin (71) init (1000000);
						/* one second */
	dcl     n_read		 fixed bin (21);


	ec = 0;

	bad_char_ptr = addr (bad_char);
	do while (ec = 0);
	     call timed_io_$get_chars (attach_data.target_iocbp, interval, bad_char_ptr, 1, n_read, ec);
	end;
	return;
     end flush_input;


%page;

/*  This entry is called to output characters to the remote connection.
    Data passed by the user is transmitted via packets of the following form:
          <SOH><BLOCK #><^BLOCK #><128 data characters><CHECKSUM>
 
    Packets are transmitted until the user request is satisfied.
    If a full packet cannot be sent, data is stored in an internal
    buffer until (1) subsequent writes fill the buffer, or (2) the xmodem
    switch is closed            */

xmodem_io_put_chars:
     entry (arg_iocbp, arg_buf_ptr, arg_buf_len, code);
	/*** entry to perform put_chars operation */

	on cleanup attach_data.error_code = 1;
	call set_up;

	if arg_buf_len = 0
	then return;
	if arg_buf_len < 0
	then do;
		code = error_table_$bad_arg;
		return;
	     end;

	arg_buf_pos = 0;
	buf_ptr = addr (attach_data.buf);

	do while ("1"b);
	     ec = 0;
	     call load_internal_buffer (buffer_full);
	     if buffer_full
	     then do;
		     call send_data_packet (ec);
		     if ec ^= 0
		     then do;
			     attach_data.error_code = ec;
			     goto done_transmitting;
			end;
		     else do;
			     attach_data.my_tx_n = mod (attach_data.my_tx_n + 1, 256);
			     attach_data.buf_pos = 0;
			end;
		end;
	     else goto done_transmitting;
	end;
done_transmitting:
	code = ec;
	return;


/*  This internal procedure controls the necessary buffer operations
    during a put_chars operation.  If the user's buffer is a multiple
    of 128 characters then the data is sent directly from the user's
    buffer; otherwise the data is placed in an internal buffer before
    transmission. */

load_internal_buffer:
     proc (buffer_full);

	dcl     buffer_full		 bit (1);
	dcl     n_chars		 fixed bin;
	dcl     overlay		 char (arg_buf_len) based;


	buffer_full = "0"b;
	if arg_buf_pos = arg_buf_len
	then return;

	if mod (arg_buf_len - arg_buf_pos, Buf_Size) = 0 & (attach_data.buf_pos = 0)
	then do;					/* User's buffer is a multiple of 128 characters */
		buf_ptr = addcharno (arg_buf_ptr, arg_buf_pos);
		arg_buf_pos = arg_buf_pos + Buf_Size;
		buffer_full = "1"b;
		return;
	     end;

	if arg_buf_len - arg_buf_pos > Buf_Size - attach_data.buf_pos
	then n_chars = Buf_Size - attach_data.buf_pos;
	else n_chars = arg_buf_len - arg_buf_pos;

	substr (attach_data.buf, attach_data.buf_pos + 1, n_chars) =
	     substr (arg_buf_ptr -> overlay, arg_buf_pos + 1, n_chars);

	arg_buf_pos = arg_buf_pos + n_chars;
	if attach_data.buf_pos + n_chars = Buf_Size
	then buffer_full = "1"b;
	else attach_data.buf_pos = attach_data.buf_pos + n_chars;
	return;
     end load_internal_buffer;




%page;
/*  This internal procedure sends a data packet  during a put_chars operation.
    The data packet is retransmitted until a timeout occurs, the packet
    is acknowledged, or the Retry_Threshold is reached   */

send_data_packet:
     proc (ec);
	dcl     ec		 fixed bin (35);


	ec = 0;
	successful = "0"b;
	retry_count = 1;
	do while (^successful & retry_count <= Retry_Threshold);
						/*  Send packet  */
	     call send_char (SOH);
	     call send_char (byte (attach_data.my_tx_n));
	     call send_char (byte (255 - attach_data.my_tx_n));
	     call send_data;
	     if attach_data.block_check_type = Check_Sum
	     then call send_char (byte (my_checksum ()));
	     else do;
		     call my_crc (check_char);
		     call send_char (check_char (1));
		     call send_char (check_char (2));
		end;

	     call get_char (packet_type, Abort_Interval, ec);
	     if ec ^= 0
	     then do;
		     if ec = error_table_$timeout
		     then ec = error_table_$unable_to_do_io;
		     return;
		end;

	     if packet_type = CAN
	     then do;
		     ec = error_table_$unable_to_do_io;
		     return;
		end;

	     if packet_type = ACK
	     then successful = "1"b;
	     else retry_count = retry_count + 1;
	end;

	if retry_count > Retry_Threshold
	then do;
		ec = error_table_$unable_to_do_io;
		return;
	     end;

	attach_data.buf_pos = 0;
	ec = 0;
	return;
     end send_data_packet;

/*  This internal procedure sends the data portion of the packet during a
    put_chars operation.  */

send_data:
     proc;

	call iox_$put_chars (attach_data.target_iocbp, buf_ptr, Buf_Size, code);
	return;
     end send_data;

/*  This internal procedure sends a control character */

send_char:
     proc (control_char);

	dcl     control_char	 char (1);
	dcl     control_char_ptr	 ptr;

	control_char_ptr = addr (control_char);
	call iox_$put_chars (attach_data_ptr -> attach_data.target_iocbp, control_char_ptr, 1, (0));

	return;
     end send_char;

%page;

/*  Get the checksum character for the packet (8 bits).  It is the sum
    of the data characters only  */

my_checksum:					/* checksum, 8-bit sum of data bytes only */
     proc returns (fixed bin (9));
	dcl     chksum		 fixed bin (9);
	dcl     i			 fixed bin;
	dcl     overlay		 (128) char (1) based unal;

	chksum = 0;

	do i = 1 to Buf_Size;
	     chksum = mod (chksum + rank (buf_ptr -> overlay (i)), 256);
	end;
	return (chksum);
     end my_checksum;



/*
This procedure performs the CRC-CCITT calculation resulting in a 16-bit
error-detecting-code.

   1.  Let r be the degree of the generator polynomial, G(x), where
       G(x) = x**16 + x**12 + x**5 + 1.
       Append r zero bits to the low-order end of the message, so it
       now contains m+r bits.

   2.  Divide the bit string corresponding to G(x) into the bit
       string corresponding to m+r bits. (m+r bits is hereafter referred
       to as M(x).

   3.  Subtract the remainder (which is alway r or fewer bits) from
       the bit string M(x) using modulo 2 subtraction.  The result is the
       checksummed message to be transmitted.
*/
my_crc:						/* CRC-CCITT */
     proc (crc_char);
	dcl     crc_char		 (2) char (1);
	dcl     dividend		 bit (1168) var;
	dcl     i			 fixed bin;

	dcl     01 overlay		 (128) based unal,
		02 pad		 bit (1),
		02 mx_char	 bit (8);
	dcl     remainder		 bit (16);

	dividend = ""b;
	do i = 1 to 128;
	     dividend = dividend || buf_ptr -> overlay.mx_char (i);
	end;

	dividend = dividend || "0000"b4;
	remainder = mod2_div (dividend);
	unspec (crc_char (1)) = "0"b || substr (remainder, 1, 8);
	unspec (crc_char (2)) = "0"b || substr (remainder, 9, 8);
	return;
     end;

/*  Receiving - divide the message by the generator polynomial.
    If there is no remainder, the message is correct           */

good_crc:
     proc (crc_char) returns (bit (1));
	dcl     crc_char		 (2) char (1);
	dcl     crc_bits		 (2) bit (9) based (addr (crc_char));
	dcl     dividend		 bit (1168) var;
	dcl     i			 fixed bin;
	dcl     01 overlay		 (128) based unal,
		02 pad		 bit (1),
		02 mx_char	 bit (8);
	dcl     remainder		 bit (16);

	dividend = ""b;
	do i = 1 to 128;
	     dividend = dividend || buf_ptr -> overlay.mx_char (i);
	end;

	dividend = dividend || substr (crc_bits (1), 2, 8) || substr (crc_bits (2), 2, 8);
	remainder = mod2_div (dividend);
	if remainder = "0"b
	then return ("1"b);
	else return ("0"b);
     end good_crc;


mod2_div:
     proc (dividend) returns (bit (16));
	dcl     dividend		 bit (*) var;	/*128 data words + 16-bit crc */
	dcl     GX		 bit (17) init ("10001000000100001"b);
	dcl     i			 fixed bin;
	dcl     length		 builtin;
	dcl     remainder		 bit (16);
	dcl     XOR		 bit (4) init ("0110"b);

	remainder = "0"b;
	i = index (dividend, "1"b);
	if i ^= 0
	then dividend = substr (dividend, i, length (dividend) - i + 1);
	else dividend = "0"b;

	do while (length (dividend) > length (GX) - 1);
	     dividend =
		bool (substr (dividend, 1, length (GX)), GX, XOR)
		|| substr (dividend, length (GX) + 1, length (dividend) - length (GX));
	     i = index (dividend, "1"b);
	     if i ^= 0
	     then dividend = substr (dividend, i, length (dividend) - i + 1);
	     else dividend = "0"b;
	end;
	substr (remainder, length (remainder) - length (dividend) + 1, length (dividend)) = dividend;
	return (remainder);
     end mod2_div;

/*  Get a packet control character  */

get_char:
     proc (packet_type, interval, ec);

	dcl     packet_type		 char (1);
	dcl     ec		 fixed bin (35);
	dcl     interval		 fixed bin (71);
	dcl     n_read		 fixed bin (21);
	dcl     packet_type_ptr	 ptr;

	packet_type = "";
	packet_type_ptr = addr (packet_type);
	call timed_io_$get_chars (attach_data.target_iocbp, interval, packet_type_ptr, 1, n_read, ec);
	return;
     end get_char;




set_up:
     proc;					/* fill in */
	ec = 0;
	mask = ""b;
	actual_iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr;
	return;
     end set_up;



/*  Cleans up the attach data and allocated storage if the attach operation is aborted  */

clean_up_attach:
     proc;

	if mask ^= ""b
	then call handler;				/* Fatal error */
	if attach_data_ptr = null ()
	then return;
	free attach_data_ptr -> attach_data;
	return;
     end clean_up_attach;



%page;
/*  Internal procedure to handle faults while IPS interrupts are masked.  For a
    fault while masked, the process is terminated (with the reason "unable to do
    critical I/O")  because the I/O control blocks are in an inconsistent state  */

handler:
     procedure options (non_quick);			/* visible in ifd */

	dcl     error_table_$unable_to_do_io
				 fixed (35) ext;
	if mask ^= ""b
	then call terminate_this_process (error_table_$unable_to_do_io);
	else return;
     end handler;



terminate_this_process:
     proc (cd);

	dcl     cd		 fixed bin (35);
	dcl     terminate_process_	 entry (char (*), ptr);
	dcl     01 ti		 aligned automatic,
		02 version	 fixed,
		02 code		 fixed (35);

	ti.version = 0;
	ti.code = code;
	call terminate_process_ ("fatal_error", addr (ti));

     end terminate_this_process;
     end;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
