



		    find_input_switch_.pl1          11/18/82  1708.0rew 11/18/82  1629.5       28332



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


find_input_switch_: proc (a_info_p, a_block, a_sw_idx, a_code);

/* This procedure accepts a list of IO switches and searches for the first one in the list which has input
   available for a successful read operation (get_chars)  without blocking.  The index of this iocbp
   in the info structure is returned.  If no switch currently has input available,  the procedure will
   either block until input is available or return an index of zero as determined by the a_block bit.
*/

/* Written by J. C. Whitmore, Feb 1980 */

dcl  a_info_p ptr parameter;				/* pointer to the switch info structure (INPUT) */
dcl  a_block bit (1);				/* TRUE - if we are to block until input is available (INPUT) */
dcl  a_sw_idx fixed bin;				/* index of iocbp to be read (OUTPUT) */
dcl  a_code fixed bin (35);				/* system error code (OUTPUT) */


dcl  max_switches fixed bin;
dcl  idx fixed bin;

dcl 1 read_info aligned,				/* for the read_status control order */
    2 read_ev_chan fixed bin (71),
    2 input_available bit (1) unal;

dcl 1 wait_info aligned,				/* data returned from ipc_$block */
    2 ev_chan fixed bin (71),
    2 ev_msg fixed bin (71),
    2 sender_proc_id bit (36),
    2 origin fixed bin,
    2 wait_list_idx fixed bin;

dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));

dcl  error_table_$bad_arg fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

dcl  addr builtin;

%include find_input_sw_info;



	a_sw_idx, a_code = 0;			/* clear the output values */
	sw_info_p = a_info_p;			/* set up automatic based references */

	if sw_info.version ^= sw_info_version_1 then do;	/* enforce the version number */
	     a_code = error_table_$unimplemented_version;
	     return;
	end;

	max_switches = sw_info.n_iocb_ptrs;		/* there is one ipc_ channel per iocbp */
	if max_switches ^= sw_info.n_channels then do;	/* just a consistency check */
no_go:	     a_code = error_table_$bad_arg;
	     return;
	end;

check_for_input:

	read_info.input_available = "0"b;		/* because some IO modules forget to clear this */

	do idx = 1 to max_switches;

	     call iox_$control (sw_info.iocbp (idx), "read_status", addr (read_info), a_code);
	     if a_code ^= 0 then return;

	     if read_info.input_available then do;
		a_sw_idx = idx;
		return;
	     end;
	end;

	if ^a_block then return;

	call ipc_$block (addr (sw_info.wait_list), addr (wait_info), a_code);
	if a_code ^= 0 then do;
	     call convert_ipc_code_ (a_code);
	     return;
	end;

	go to check_for_input;

     end find_input_switch_;




		    hasp_host_.pl1                  10/17/88  1109.4r w 10/17/88  1034.0      582489



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* I/O Module for communications with a HASP host: This I/O module is designed
   for use by the I/O daemon's workstation simulator (hasp_ws_sim_driver_).  
   It communicates with the HASP host through a TTY channel controlled by the 
   ring-0 HASP demultiplexer.

   As each TTY channel connected through the HASP demultiplexer communicates 
   with only a single device of the physical HASP host, this I/O module will
   ensure that all I/O switches attached to a given channel have the same
   device type.  (Multiple I/O switches are allowed to support multiple 
   request types being attached to the same channel.) 

   Note: The signon_record control order does not validate that supplied IPC
         channel is an event-wait channel */


/****^  HISTORY COMMENTS:
  1) change(80-02-01,GPalter), approve(), audit(), install():
     Created.
     Modified: 1 September 1980 by G. Palter to remove stream mode support.
     Modified: 2 December 1980 by G. Palter to properly set return code for
        io_call control order.
     Modified: 18 December 1980 by G. Palter to support -terminal_type for
        input/output translations.
     Modified: 13 January 1981 by G. Palter to pass the representation of a
        space in the transmission medium's character code to hasp_util_.
     Modified: 22 July 1981 by G. Palter to convert to version 2
        dial_manager_, invoke release_channel when done with a particular
        channel, and convert -signon/-no_signon from attach parameters to
        control orders.
     Modified: 26 July 1982 by G. Palter to add get_channel_info control order.
     Modified: October 1982 by G. Palter to drastically improve write_record
        performance by changing the order of calls to hcs_$tty_order,
        hcs_$tty_write, and ipc_$block and to use mvt_ rather than the PL/I
        translate builtin where appropriate.
     Modified: 14 December 1982 by G. Palter to fix bugs in the read_record
        entrypoint's handling of partial or very long input records
        (HASP #001 and HASP #002) and to insure proper behavior of the
        read_record entrypoint when the input record will not fit in the
        caller's buffer.
  2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030):
     Changed ttd_version to ttd_version_3.
                                                   END HISTORY COMMENTS */


/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */

hasp_host_:
     procedure ();

	return;					/* not an entry */


/* Parameters */

dcl  P_iocb_ptr pointer parameter;			/* *: -> I/O switch being operated upon */
dcl  P_code fixed binary (35) parameter;

dcl  P_attach_options (*) character (*) varying parameter;	/* attach: attachment arguments */
dcl  P_loud_sw bit (1) parameter;			/* attach: ON => attachment errors should call com_err_ */

dcl  P_open_mode fixed binary parameter;		/* open: opening mode */
dcl  P_open_sw bit (1) parameter;			/* open: obsolete parameter */

dcl  P_record_lth fixed binary (21) parameter;		/* read_record: set to size of terminal_io_record read into
						   buffer in characters;
						   get_chars: set to # of characters read into buffer;
						   write_record, put_chars: size of terminal_io_record to be
						   written in characters */

dcl  P_buffer_ptr pointer parameter;			/* read_record, get_chars: -> area to place result of read */
dcl  P_buffer_lth fixed binary (21) parameter;		/* read_record, get_chars: size of area in characters */

dcl  P_record_ptr pointer parameter;			/* write_record, put_chars: -> terminal_io_record
						   to be written */

dcl  P_order character (*) parameter;			/* control: name of control order to be performed */
dcl  P_info_ptr pointer parameter;			/* control: -> additional information required to execute the
						   control order */

dcl  P_new_modes character (*) parameter;		/* modes: new modes to be set */
dcl  P_old_modes character (*) parameter;		/* modes: set to modes in effect before change */


/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);

dcl  argument character (argument_lth) based (argument_ptr);/* based on attach options */
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  loud_sw bit (1) aligned;

dcl  open_mode fixed binary;

dcl  order character (32);
dcl  info_ptr pointer;


/* Remaining declarations */

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  argument_idx fixed binary;			/* # of attach option being processed */

dcl  (tty_channel, device_name) character (32);		/* required components of attach description */
dcl  have_comm bit (1) aligned;			/* ON => -comm option given (required) */
dcl  terminal_type character (32);			/* terminal type specifying translations (optional) */
dcl  other_attach_options character (256) varying;	/* optional portions supplied by caller */

dcl  device_type fixed binary;			/* local copy used for argument processing */
dcl  idx fixed binary;

dcl  character_value character (32);			/* unused values from argument processing */
dcl  numeric_value fixed binary (35);

dcl  1 ttd aligned like terminal_type_data;		/* used to call ttt_info_$terminal_data */

dcl  1 dma aligned like dial_manager_arg;		/* used to attach the channel */

dcl  1 local_event_wait_info aligned like event_wait_info;	/* for calls to ipc_$block */

dcl  dialup_msg_channel character (32);			/* arguments to convert_dial_message_ */
dcl  1 dialup_msg_flags aligned,
       2 dialed_up bit (1) unaligned,
       2 hungup bit (1) unaligned,
       2 control bit (1) unaligned,
       2 pad bit (33) unaligned;

dcl  state fixed binary;				/* MCS channel state value */

dcl  multiplexer_device_type fixed binary;		/* for "get_device_type" control order */

dcl  1 tty_modes aligned,				/* used to change MCS modes */
       2 modes_lth fixed binary,
       2 modes character (256);

dcl  1 read_status aligned,				/* for "read_status" control order */
       2 event_channel fixed binary (71),		/* channel to block on waiting for input to arrive */
       2 input_available bit (1);			/* ON => data in ring-0 waiting to be read */

dcl  1 write_status aligned,				/* for "write_status" control order */
       2 event_channel fixed binary (71),		/* channel to block on waiting for write to complete */
       2 output_pending bit (1);			/* ON => data in ring-0 waiting to be sent */

dcl  ips_mask bit (36);				/* IPS mask */

dcl  cv_string_buffer character (cv_string_buffer_lth) based (cv_string_buffer_ptr);
dcl  cv_string_buffer_used character (cv_string_buffer_used_lth) based (cv_string_buffer_ptr);
dcl  (cv_string_buffer_lth, cv_string_buffer_used_lth) fixed binary (21);
dcl  (cv_string_buffer_ptr, new_cv_string_buffer_ptr) pointer;

dcl  io_buffer character (io_buffer_lth) unaligned based (io_buffer_ptr);
dcl  (io_buffer_lth, io_buffer_used, io_buffer_read) fixed binary (21);
dcl  io_buffer_ptr pointer;				/* buffer for I/O to/from the channel */

dcl  cv_string_buffer_space character (384);		/* local space large enough for most conversions */
dcl  io_buffer_space character (256) unaligned;		/* local space large enough for most I/O */

dcl  (compress_code, expand_code) fixed binary (35);	/* code from hasp_util_$compress_text/expand_text */

dcl  terminal_io_record_header_lth fixed binary (21);

dcl  previous_data character (64) varying;		/* large enough for an SCB and associated data */

dcl  (have_srcb, more_data_needed) bit (1) aligned;

dcl  srcb_read character (1);				/* SRCB read from the device */

dcl  srcb character (1) unaligned based (srcb_ptr);	/* SRCB character being constructed/interpreted */
dcl  srcb_ptr pointer;

dcl  1 hasp_printer_srcb unaligned based (srcb_ptr) like hasp_printer_srcb_byte;

dcl  1 read_status_info aligned like read_status based (info_ptr);
						/* data used by "read_status" control order */

dcl  1 hangup_proc_info aligned based (info_ptr),		/* data used by "hangup_proc" control order */
       2 procedure entry variable,			/* procedure to invoke when line is hungup */
       2 data_ptr pointer,				/* user's data to be supplied to said procedure */
       2 priority fixed binary;			/* priority of this event call channel */

dcl  1 get_channel_info aligned based (info_ptr) like tty_get_channel_info;

dcl  NAME character (32) static options (constant) initial ("hasp_host_");

/* format: off */
dcl (NUL		initial (""),
     ASCII_SPACE	initial (" "),
     EBCDIC_SPACE	initial ("@"))
	character (1) static options (constant);

dcl (LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"),
     UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
	character (26) static options (constant);

dcl  ascii_to_ebcdic_$ae_table character (128) external;
dcl  ebcdic_to_ascii_$ea_table character (256) external;

dcl (error_table_$action_not_performed, error_table_$bad_conversion, error_table_$bad_mode, error_table_$badopt,
     error_table_$device_type_unknown, error_table_$eof_record, error_table_$improper_data_format,
     error_table_$incorrect_device_type, error_table_$invalid_read,
     error_table_$invalid_write, error_table_$io_no_permission, error_table_$long_record, error_table_$noalloc,
     error_table_$noarg, error_table_$not_attached, error_table_$not_closed, error_table_$not_detached,
     error_table_$not_open, error_table_$null_info_ptr, error_table_$short_record, error_table_$smallarg,
     error_table_$undefined_order_request, error_table_$unimplemented_version, error_table_$wrong_no_of_args)
	fixed binary (35) external;
/* format: on */

dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  convert_dial_message_
	entry (bit (72) aligned, character (*), character (*), fixed binary, 1 aligned like dialup_msg_flags,
	fixed binary (35));
dcl  convert_ipc_code_ entry (fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  dial_manager_$privileged_attach entry (pointer, fixed binary (35));
dcl  dial_manager_$release_channel entry (pointer, fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hasp_util_$compress_text
	entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21),
	character (1) aligned, fixed binary (35));
dcl  hasp_util_$expand_text
	entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21),
	character (1) aligned, fixed binary (35));
dcl  hcs_$assign_channel entry (fixed binary (71), fixed binary (35));
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  hcs_$tty_abort entry (fixed binary, fixed binary, fixed binary, fixed binary (35));
dcl  hcs_$tty_attach entry (character (*), fixed binary (71), fixed binary, fixed binary, fixed binary (35));
dcl  hcs_$tty_detach entry (fixed binary, fixed binary (71), fixed binary, fixed binary (35));
dcl  hcs_$tty_order entry (fixed binary, character (*), pointer, fixed binary, fixed binary (35));
dcl  hcs_$tty_read
	entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary,
	fixed binary (35));
dcl  hcs_$tty_write
	entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary,
	fixed binary (35));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  iox_$err_no_operation entry ();
dcl  iox_$propagate entry (pointer);
dcl  ipc_$block entry (pointer, pointer, fixed binary (35));
dcl  ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$decl_ev_call_chn entry (fixed binary (71), entry, pointer, fixed binary, fixed binary (35));
dcl  ipc_$decl_ev_wait_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  mvt_ entry (pointer, pointer, fixed binary (21), character (512) aligned);
dcl  timer_manager_$alarm_wakeup entry (fixed binary (71), bit (2), fixed binary (71));
dcl  ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35));

dcl  (any_other, area, cleanup) condition;

dcl  (addr, binary, copy, currentsize, divide, dimension, hbound, lbound, length, max, min, mod, null, rel,
     rtrim, string, substr, translate, unspec) builtin;
%page;

/* Data describing a single switch attached through this I/O module */

dcl  1 had aligned based (had_ptr),
       2 attach_description character (256) varying,	/* attach description for this I/O switch */
       2 open_description character (24) varying,		/* open description (mode) */
       2 channel_info_ptr pointer,			/* -> description of the channel */
       2 translations,
         3 input character (512),			/* received data -> ASCII translate table */
         3 output character (512),			/* ASCII -> transmittable data translate table */
         3 space character (1),			/* an ASCII space in remote device's character code */
       2 chain,					/* chain of I/O switches attached to this channel */
         3 next pointer,
         3 previous pointer;

dcl  had_ptr pointer;


/* Data describing a single TTY channel attached through this I/O module */

dcl  1 channel_info aligned based (channel_info_ptr),
       2 name character (32),				/* name of channel described by this entry */
       2 device_type fixed binary,			/* type of device attached on this channel */
       2 devx fixed binary,				/* MCS identifier of this channel */
       2 event_channel fixed binary (71),		/* MCS signals events via this ipc_ channel */
       2 attach_event_channel fixed binary (71),		/* used to obtain the channel from the Answering Service */
       2 hads,					/* chain of I/O switches attached to this channel */
         3 first pointer,
         3 last pointer,
       2 held_input_ptr pointer,			/* -> input from this channel waiting for processing */
       2 chain,					/* chain of channels attached via this I/O module */
         3 previous pointer,
         3 next pointer,
       2 flags,
         3 attached bit (1) unaligned,			/* ON => channel has been attached from answering service */
         3 attach_channel_is_call bit (1) unaligned,	/* ON => attach channel has been converted to call channel */
         3 eof_pending bit (1) unaligned,		/* ON => next read should return error_table_$eof_record */
         3 pad bit (33) unaligned;

dcl  channel_info_ptr pointer;

dcl  first_channel_info_ptr pointer internal static initial (null ());
dcl  last_channel_info_ptr pointer internal static initial (null ());


/* Held input:  The read_record operation may read more data from ring-0 than necessary; this data is held in this
   structure for later processing */

dcl  1 held_input aligned based (held_input_ptr),
       2 n_elements_used fixed binary (21),		/* # of characters still being held */
       2 n_elements_allocated fixed binary (21),		/* # of characters initially held */
       2 data character (held_input_n_elements_allocated refer (held_input.n_elements_allocated));

dcl  held_input_ptr pointer;
dcl  held_input_n_elements_allocated fixed binary (21);
%page;
/* Attach an I/O switch to a device of a HASP host */

hasp_host_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code = 0;					/* assume no errors yet */

	had_ptr = null ();				/* avoid freeing garbage if I/O switch already attached */

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_detached;	/* special case this error */
	     if loud_sw then call com_err_ (P_code, NAME, "For switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call cleanup_attachment ((0));


/* Process attachment options */

	if hbound (P_attach_options, 1) < 1 then
	     call abort_attachment (error_table_$noarg,
		"At least ""-comm"", ""-tty"", and  ""-device"" must be supplied.");

	allocate had in (system_area) set (had_ptr);

	have_comm = "0"b;				/* haven't seen -comm yet */
	tty_channel = "";				/* haven't seen -tty yet */
	device_name = "";				/* haven't seen -device yet */
	terminal_type = "";				/* haven't seen -terminal_type yet */

	other_attach_options = "";			/* optional stuff goes here */

	had.open_description = "";
	call set_translation (had.translations.input,	/* assume input is EBCDIC */
	     addr (ebcdic_to_ascii_$ea_table), length (ebcdic_to_ascii_$ea_table));
	call set_translation (had.translations.output, addr (ascii_to_ebcdic_$ae_table),
	     length (ascii_to_ebcdic_$ae_table));
	had.translations.space = EBCDIC_SPACE;		/* default translations */
	had.channel_info_ptr = null ();		/* prevents abort from prematurely detaching channel */


	do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);

	     argument_ptr = substraddr (P_attach_options (argument_idx), 1);
						/* make accessing simpler */
	     argument_lth = length (P_attach_options (argument_idx));

	     if substr (argument, 1, 1) ^= "-" then	/* do not allow non-control arguments */
		call abort_attachment (error_table_$wrong_no_of_args, "All options must be control arguments.");

	     if (argument = "-comm") then do;		/* communications module: must be "hasp" */
		character_value = get_string_argument ();
		if (argument ^= "hasp") then call abort_attachment (0, "Communications module must be ""hasp"".");
		have_comm = "1"b;			/* got the right value */
	     end;

	     else if (argument = "-tty") then		/* specification of TTY channel */
		tty_channel = get_string_argument ();

	     else if (argument = "-device") then do;	/* type of device on other end of channel */
		device_name = get_string_argument ();
		device_type = -1;
		do idx = lbound (HASP_DEVICE_NAMES, 1) to hbound (HASP_DEVICE_NAMES, 1) while (device_type = -1);
		     if HASP_DEVICE_NAMES (idx) = device_name then device_type = idx;
		end;
		if device_type = -1 then		/* unknown type */
		     call abort_attachment (error_table_$device_type_unknown,
			"Device type must be one of ^v(""^a"", ^)or ""^a""; not ""^a"".",
			(dimension (HASP_DEVICE_NAMES, 1) - 1), HASP_DEVICE_NAMES, device_name);
	     end;

	     else if (argument = "-terminal_type") | (argument = "-ttp") then do;
						/* terminal type: specifies input/output translations */
		terminal_type = get_string_argument ();
		terminal_type = translate (terminal_type, UPPERCASE, LOWERCASE);
		ttd.version = ttd_version_3;		/* try to get input/output translations */
		call ttt_info_$terminal_data (terminal_type, -1, 0, addr (ttd), code);
		if code ^= 0 then call abort_attachment (code, "-terminal_type ^a", terminal_type);
		if (ttd.tables.input_tr_ptr = null ()) | (ttd.tables.output_tr_ptr = null ()) then
		     call abort_attachment (0, "Terminal type ""^a"" does not specify input and output translations.",
			terminal_type);
		call set_translation (had.translations.input,
		     addr (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value),
		     dimension (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value, 1));
		call set_translation (had.translations.output,
		     addr (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value),
		     dimension (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value, 1));
		had.translations.space = translate (ASCII_SPACE, had.translations.output);
	     end;

	     else if (argument = "-physical_line_length") | (argument = "-pll") then do;
						/* supplied by calling I/O module:  ignored here */
		numeric_value = get_numeric_argument ();
		other_attach_options = other_attach_options || " -physical_line_length ";
		other_attach_options = other_attach_options || argument;
	     end;

	     else if (argument = "-ebcdic") then	/* supplied by calling I/O module:  ignored here */
		other_attach_options = other_attach_options || " -ebcdic";

	     else if (argument = "-ascii") then		/* hasp_host_ doesn't support ASCII data */
		call abort_attachment (0, "ASCII is not supported by this I/O module.");

	     else if (argument = "-horizontal_tab") | (argument = "-htab") then
		call abort_attachment (0, "Horizontal tabs are not supported by this I/O module.");

	     else call abort_attachment (error_table_$badopt, """^a""", argument);
	end;					/* of argument processing loop */


/* Validate that all required information has been supplied and apply any needed defaults */

	if ^have_comm then				/* must specify -comm */
	     call abort_attachment (error_table_$noarg, """-comm""");

	if (tty_channel = "") then			/* must specify -tty */
	     call abort_attachment (error_table_$noarg, """-tty""");

	if (device_name = "") then			/* must specify -device */
	     call abort_attachment (error_table_$noarg, """-device""");


/* Build the attach description */

	had.attach_description = rtrim (NAME);
	had.attach_description = had.attach_description || " -comm hasp -tty ";
	had.attach_description = had.attach_description || rtrim (tty_channel);
	had.attach_description = had.attach_description || " -device ";
	had.attach_description = had.attach_description || rtrim (device_name);
	if (terminal_type ^= "") then do;		/* optional -terminal_type was given */
	     had.attach_description = had.attach_description || " -terminal_type ";
	     had.attach_description = had.attach_description || rtrim (terminal_type);
	end;
	had.attach_description = had.attach_description || other_attach_options;


/* Find the description of this channel:  Validate that all I/O switches attached to this channel are of for the same type
   of I/O daemon device (printer, reader, etc.) */

	do channel_info_ptr = first_channel_info_ptr repeat (channel_info.chain.next)
	     while (channel_info_ptr ^= null ());
	     if channel_info.name = tty_channel then go to FOUND_CHANNEL;
	end;

FOUND_CHANNEL:
	if (channel_info_ptr = null ()) then do;	/* first use of the channel */
	     allocate channel_info in (system_area) set (channel_info_ptr);
	     channel_info.name = tty_channel;
	     channel_info.device_type = device_type;
	     channel_info.devx, channel_info.event_channel, channel_info.attach_event_channel = -1;
	     channel_info.hads = null ();		/* no switches connected yet */
	     channel_info.held_input_ptr = null ();	/* no read ahead yet */
	     string (channel_info.flags) = ""b;		/* no special conditions yet */
	     if first_channel_info_ptr = null () then
		first_channel_info_ptr = channel_info_ptr;
	     else last_channel_info_ptr -> channel_info.chain.next = channel_info_ptr;
	     channel_info.chain.previous = last_channel_info_ptr;
	     channel_info.chain.next = null ();
	     last_channel_info_ptr = channel_info_ptr;
	end;

	else					/* channel in use: insure that device type is correct */
	     if channel_info.device_type ^= device_type then
	     call abort_attachment (error_table_$incorrect_device_type, "Device type of ^a is ""^a""; not ""^a"".",
		tty_channel, HASP_DEVICE_NAMES (channel_info.device_type), HASP_DEVICE_NAMES (device_type));

	if channel_info.hads.first = null () then
	     channel_info.hads.first = had_ptr;		/* first switch for this channel */
	else channel_info.hads.last -> had.chain.next = had_ptr;
	had.chain.previous = channel_info.hads.last;
	had.chain.next = null ();
	channel_info.hads.last = had_ptr;

	had.channel_info_ptr = channel_info_ptr;


/* Acquire and attach the channel if necessary */

	if channel_info.devx = -1 then do;

/* Request the TTY channel from the Answering Service */

	     call ipc_$create_ev_chn (channel_info.attach_event_channel, code);
	     if code ^= 0 then call convert_ipc_code_ (code);
	     if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel.");

	     dma.version = dial_manager_arg_version_2;
	     dma.dial_channel = channel_info.attach_event_channel;
	     dma.channel_name = tty_channel;
	     dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = "";

	     call dial_manager_$privileged_attach (addr (dma), code);
	     if code = error_table_$action_not_performed then go to ASSUME_ATTACHED;
	     if code ^= 0 then call abort_attachment (code, "Attempting to attach ^a.", tty_channel);

	     event_wait_channel.n_channels = 1;
	     event_wait_channel.channel_id (1) = channel_info.attach_event_channel;

WAIT_FOR_ANSWERING_SERVICE:
	     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
						/* wait for answering service to give it to us */
	     if code ^= 0 then call convert_ipc_code_ (code);
	     if code ^= 0 then call abort_attachment (code, "Waiting for attachment to ^a.", tty_channel);

	     call convert_dial_message_ (unspec (local_event_wait_info.message), dialup_msg_channel, ((32)" "), (0),
		dialup_msg_flags, code);
	     if code ^= 0 then call abort_attachment (code, "Interpreting attachment to ^a.", tty_channel);

	     if ^dialup_msg_flags.dialed_up then do;
		call com_err_ (0, NAME,
		     "For switch ^a: Unexpected signal from answering service - ^[hangup^;control^] for channel ^a.",
		     iocb_ptr -> iocb.name, dialup_msg_flags.hungup, dialup_msg_channel);
		go to WAIT_FOR_ANSWERING_SERVICE;
	     end;


/* Create the event channel for ring-0:  try using a special channel first */

ASSUME_ATTACHED:
	     channel_info.attached = "1"b;		/* we have the channel from the answering service now */

	     call hcs_$assign_channel (channel_info.event_channel, code);

	     if code ^= 0 then do;			/* couldn't get fast channel: try standard one */
		call ipc_$create_ev_chn (channel_info.event_channel, code);
		if code ^= 0 then call convert_ipc_code_ (code);
		if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel.");
	     end;


/* Attach the channel through the ring-0 HASP multiplexer in MCS, validate the supplied device type, and set it's modes
   to "rawi,rawo" */

	     call hcs_$tty_attach (tty_channel, channel_info.event_channel, channel_info.devx, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then call abort_attachment (code, "Unable to attach to ^a.", tty_channel);

	     call hcs_$tty_order (channel_info.devx, "get_device_type", addr (multiplexer_device_type), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if (code = 0) then
		if (channel_info.device_type = multiplexer_device_type) then
		     ;				/* proper device type for this channel */
		else call abort_attachment (error_table_$incorrect_device_type,
			"Device type of ^a is ""^a""; not ""^a"".", tty_channel,
			HASP_DEVICE_NAMES (multiplexer_device_type), HASP_DEVICE_NAMES (channel_info.device_type));
	     else if (code = error_table_$undefined_order_request) then
		call abort_attachment (0, "^a is not connected to a HASP multiplexer.", tty_channel);
	     else call abort_attachment (code, "Unable to determine device type of ^a.", tty_channel);

	     tty_modes.modes = "rawi,rawo";
	     tty_modes.modes_lth = length (tty_modes.modes);
	     call hcs_$tty_order (channel_info.devx, "modes", addr (tty_modes), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then call abort_attachment (code, "Unable to set initial modes for ^a.", tty_channel);
	end;


/* Mask and complete construction of the IOCB */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (had.attach_description);
	iocb_ptr -> iocb.attach_data_ptr = had_ptr;
	iocb_ptr -> iocb.open = hasp_host_open;
	iocb_ptr -> iocb.detach_iocb = hasp_host_detach;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

RETURN_FROM_ATTACH:
	P_code = code;
	return;
%page;
/* Open an I/O switch connected to a HASP host:  only record oriented openings are supported */

hasp_host_open:
     entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;

	if ^((open_mode = Sequential_input) | (open_mode = Sequential_output) | (open_mode = Sequential_input_output))
	then do;
	     P_code = error_table_$bad_mode;
	     return;
	end;

	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then
	     if (open_mode = Sequential_output) then do;	/* printer/punch opened for output only */
		P_code = error_table_$bad_mode;
		return;
	     end;

	if (channel_info.device_type = HASP_READER) then
	     if (open_mode = Sequential_input) then do;	/* reader opened for input only */
		P_code = error_table_$bad_mode;
		return;
	     end;

	had.open_description = rtrim (iox_modes (open_mode));

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	if ((open_mode = Sequential_input) | (open_mode = Sequential_input_output)) then
	     iocb_ptr -> iocb.read_record = hasp_host_read_record;

	if ((open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then
	     iocb_ptr -> iocb.write_record = hasp_host_write_record;

	iocb_ptr -> iocb.control = hasp_host_control;
	iocb_ptr -> iocb.modes = hasp_host_modes;

	iocb_ptr -> iocb.close = hasp_host_close;
	iocb_ptr -> iocb.detach_iocb = hasp_host_detach;

	iocb_ptr -> iocb.open_descrip_ptr = addr (had.open_description);
						/* it's now open */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;
	return;
%page;
/* Close an I/O switch connected to a HASP host */

hasp_host_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
	     P_code = error_table_$not_open;
	     return;
	end;

	ips_mask = ""b;

	on condition (cleanup) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = hasp_host_open;
	iocb_ptr -> iocb.detach_iocb = hasp_host_detach;

	iocb_ptr -> iocb.control, iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record =
	     iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;

	return;
%page;
/* Detach an I/O switch from a device of a HASP host */

hasp_host_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;

	if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	call cleanup_attachment (code);		/* remove this switch and the channel if necessary */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* it's detached */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;				/* in case trouble freeing the channel */
	return;
%page;
/* Read a record:  read a single record from the device, returning a "standard" terminal_io_record structure */

hasp_host_read_record:
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_lth, P_record_lth, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;
	code = 0;

	if (channel_info.device_type = HASP_READER) then do;
	     P_code = error_table_$invalid_read;	/* can't read from the reader */
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();
	cv_string_buffer_ptr = null ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if cv_string_buffer_ptr ^= null () then
		     if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then
			free cv_string_buffer in (system_area);
	     end;


/* Check if last read_record operation read an EOF record containing some carriage control; if so, indicate the EOF
   condition on this read as previous read just returned the slew control */

	if channel_info.eof_pending then do;
	     channel_info.eof_pending = "0"b;		/* only do this once per EOF */
	     P_code = error_table_$eof_record;
	     return;
	end;


/* Validate that there is room in the buffer to hold some actual data in addition to a terminal_io_record header */

	terminal_io_record_ptr = P_buffer_ptr;

	terminal_io_record_header_lth =		/* # of characters of buffer occupied by record's header */
	     4 * (binary (rel (addr (terminal_io_record.data)), 18, 0) - binary (rel (terminal_io_record_ptr), 18, 0));

	if terminal_io_record_header_lth >= P_buffer_lth then do;
	     P_code = error_table_$smallarg;		/* supplied buffer is just TOO small */
	     return;
	end;

	terminal_io_record_n_elements = P_buffer_lth - terminal_io_record_header_lth;
						/* # of actual characters that will fit into the buffer */


/* Obtain and unpack a record:  a record is constructed from any data obtained in prior calls to read_record in addition
   to whatever data must be read from ring-0 in this call to complete the record.  Unpacking is performed on the data in
   256 character sections until hasp_util_$expand_text detects the end-of-record sequence in the stream */

	cv_string_buffer_ptr = addr (cv_string_buffer_space);
	cv_string_buffer_lth = length (cv_string_buffer_space);
	cv_string_buffer_used_lth = 0;		/* start putting data into automatic */

	previous_data = "";				/* piece left from previous read */

	srcb_ptr = addr (srcb_read);			/* a place to put the SRCB ... */
	have_srcb = "0"b;				/* ... which hasn't been found yet */

	more_data_needed = "1"b;


	do while (more_data_needed);

/* Select source of data for this time around:  if necessary, data will be read from ring-0 */

	     if channel_info.held_input_ptr ^= null () then do;
						/* read ahead: process as much of the block as can be used */
		io_buffer_ptr = addr (channel_info.held_input_ptr -> held_input.data);
		io_buffer_lth = channel_info.held_input_ptr -> held_input.n_elements_allocated;
		io_buffer_read = channel_info.held_input_ptr -> held_input.n_elements_used;
	     end;

	     else do;				/* no more read ahead: obtain more data from ring-0 */
		io_buffer_ptr = addr (io_buffer_space);
		io_buffer_lth = length (io_buffer_space);
		call read_io_buffer ();		/* sets io_buffer_read */
		if code ^= 0 then go to RETURN_FROM_READ_RECORD;
	     end;

	     if length (previous_data) > 0 then do;	/* some data left over from previous junk: merge them */
		held_input_n_elements_allocated = length (previous_data) + io_buffer_read;
		allocate held_input in (system_area) set (held_input_ptr);
		held_input.n_elements_used = held_input.n_elements_allocated;
		substr (held_input.data, 1, length (previous_data)) = previous_data;
		substr (held_input.data, (length (previous_data) + 1), io_buffer_read) =
		     substr (io_buffer, 1, io_buffer_read);
		if io_buffer_ptr ^= addr (io_buffer_space) then
		     free channel_info.held_input_ptr -> held_input in (system_area);
		channel_info.held_input_ptr = held_input_ptr;
		io_buffer_ptr = addr (held_input.data);
		io_buffer_lth, io_buffer_read = held_input.n_elements_used;
		previous_data = "";
	     end;


/* Unpack the data:  stop when an end-of-record indicator is found */

	     if have_srcb then
		io_buffer_used = 0;			/* in middle of record: first character in buffer is SCB */
	     else do;				/* first part of record: first character is SRCB */
		srcb = substr (io_buffer, 1, 1);
		io_buffer_used = 1;
		have_srcb = "1"b;
	     end;

	     do while (more_data_needed & (io_buffer_used < io_buffer_read));

		call hasp_util_$expand_text (substraddr (io_buffer, 1), io_buffer_read, io_buffer_used,
		     substraddr (cv_string_buffer, 1), cv_string_buffer_lth, cv_string_buffer_used_lth,
		     had.translations.space, expand_code);

		if expand_code = 0 then more_data_needed = "0"b;
						/* found end of record indicator */

		else if expand_code = error_table_$short_record then ;
						/* took entire buffer but need more */

		else if expand_code = error_table_$long_record then do;
						/* overflowed the output buffer: grow it and continue */
		     cv_string_buffer_lth = 2 * cv_string_buffer_lth;
		     on condition (area)
			begin;			/* can't get enough room: record is not readable */
			     code = error_table_$noalloc;
			     go to RETURN_FROM_READ_RECORD;
			end;
		     allocate cv_string_buffer in (system_area) set (new_cv_string_buffer_ptr);
		     revert condition (area);
		     new_cv_string_buffer_ptr -> cv_string_buffer_used = cv_string_buffer_used;
		     if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then
			free cv_string_buffer in (system_area);
		     cv_string_buffer_ptr = new_cv_string_buffer_ptr;
		end;

		else if (io_buffer_read - io_buffer_used) <= (HASP_MAX_NOT_COMPRESSED_TEXT_LTH + 1) then do;
						/* possibly need to read more data from ring-0 */
		     previous_data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used));
		     io_buffer_used = io_buffer_read;	/* force to read some more data */
		end;

		else do;				/* data is definitely improperly formatted */
		     code = error_table_$improper_data_format;
		     go to RETURN_FROM_READ_RECORD;
		end;
	     end;

	     if io_buffer_used = io_buffer_read then	/* have exhausted this buffer ... */
		if io_buffer_ptr ^= addr (io_buffer_space) then do;
		     free channel_info.held_input_ptr -> held_input in (system_area);
		     channel_info.held_input_ptr = null ();
		end;				/* ... so get rid of it so we can read some more */
	end;

	if io_buffer_used < io_buffer_read then do;	/* some data left over: save it */
	     held_input_n_elements_allocated = io_buffer_read - io_buffer_used;
	     allocate held_input in (system_area) set (held_input_ptr);
	     held_input.n_elements_used = held_input.n_elements_allocated;
	     held_input.data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used));
	     if io_buffer_ptr ^= addr (io_buffer_space) then free channel_info.held_input_ptr -> held_input;
	     channel_info.held_input_ptr = held_input_ptr;
	end;


/* Check for end of file:  An EOF record is a zero length record.  If an EOF record is found, check if the SRCB contains
   carriage control information (line printer only), delay indicating the EOF until the next call to read_record and
   return a zero length record with appropriate slew control; otherwise, return error_table_$eof_record.  If no EOF is
   present, convert the data in the record to ASCII */

	if (cv_string_buffer_used_lth = 0) then do;
	     if (channel_info.device_type = HASP_PRINTER) then
		if (srcb = substr (TEMPLATE_HASP_EOF_RECORD, 1, 1)) then
		     code = error_table_$eof_record;
		else do;
		     channel_info.eof_pending = "1"b;
		     terminal_io_record.n_elements = 0; /* no data in the record, just slew */
		end;
	     else code = error_table_$eof_record;
	     if (code = error_table_$eof_record) then go to RETURN_FROM_READ_RECORD;
	end;

	else do;					/* data seems OK: convert it */
	     terminal_io_record.n_elements = min (terminal_io_record_n_elements, cv_string_buffer_used_lth);
	     if cv_string_buffer_used_lth > 0 then
		call mvt_ (addr (cv_string_buffer_used), addr (terminal_io_record_data_chars),
		     (terminal_io_record.n_elements), had.translations.input);
	     if cv_string_buffer_used_lth > terminal_io_record_n_elements then code = error_table_$long_record;
	end;					/* ... return as much as will fit */


/* Control reaches here iff the record is read/converted successfully:  complete the terminal_io_record structure */

	terminal_io_record.version = terminal_io_record_version_1;

	if (channel_info.device_type = HASP_CONSOLE) then terminal_io_record.device_type = TELEPRINTER_DEVICE;
	else if (channel_info.device_type = HASP_PRINTER) then terminal_io_record.device_type = PRINTER_DEVICE;
	else if (channel_info.device_type = HASP_PUNCH) then terminal_io_record.device_type = PUNCH_DEVICE;

	string (terminal_io_record.flags) = ""b;

	if (channel_info.device_type = HASP_CONSOLE) | (channel_info.device_type = HASP_PUNCH) then do;
						/* console or punch: slewing is fixed */
	     terminal_io_record.slew_type = SLEW_BY_COUNT;
	     terminal_io_record.slew_count = 1;
	     terminal_io_record.preslew = "0"b;
	end;

	else do;					/* printer: interpret the SRCB */
	     if hasp_printer_srcb.skip_to_channel then
		terminal_io_record.slew_type = SLEW_TO_CHANNEL;
	     else terminal_io_record.slew_type = SLEW_BY_COUNT;
	     terminal_io_record.slew_count = hasp_printer_srcb.number;
	     terminal_io_record.preslew = hasp_printer_srcb.prespace;
	end;

	terminal_io_record.element_size = 9;

	P_record_lth = terminal_io_record_header_lth + terminal_io_record.n_elements;


/* Cleanup */

RETURN_FROM_READ_RECORD:
	if cv_string_buffer_ptr ^= null () then
	     if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area);

	P_code = code;
	return;
%page;
/* Write a record:  write a single record to the device.  This record represents part or all of a single line and should
   be the output of the prt_conv_ module using the remote_conv_ conversion coroutine, presently named hasp_host_conv_ */

hasp_host_write_record:
     entry (P_iocb_ptr, P_record_ptr, P_record_lth, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;
	code = 0;

	if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then do;
	     P_code = error_table_$invalid_write;	/* can't write printer or punch */
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();
	io_buffer_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;				/* free any temporary buffers */
		if io_buffer_ptr ^= null () then
		     if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area);
	     end;


/* Validate input:  insure that the caller has supplied a complete terminal I/O record; insure that the terminal input
   record contains character as opposed to binary data */

	terminal_io_record_ptr = P_record_ptr;

	if terminal_io_record.version ^= terminal_io_record_version_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if mod (P_record_lth, 4) = 0 then		/* X+4-mod(X,4) fails when X is already a multiple of 4 */
	     if (4 * currentsize (terminal_io_record)) = P_record_lth then
		;				/* user supplied length agrees with computed length */
	     else do;
		P_code = error_table_$improper_data_format;
		return;
	     end;
	else					/* supplied length not multiple of 4:  must round it up */
	     if (4 * currentsize (terminal_io_record)) ^= (P_record_lth + 4 - mod (P_record_lth, 4)) then do;
	     P_code = error_table_$improper_data_format;
	     return;
	end;

	if terminal_io_record.binary | terminal_io_record.preslew | (terminal_io_record.element_size ^= 9) then do;
	     P_code = error_table_$improper_data_format;
	     return;
	end;


/* Convert the data to the remote system's character code (in place) */

	call mvt_ (addr (terminal_io_record_data_chars), addr (terminal_io_record_data_chars),
	     (terminal_io_record.n_elements), had.translations.output);


/* Compute size of I/O buffer required assuming no compression can be performed on the record.  If this size is not too
   large, the automatic buffer will be used; otherwise, a buffer will be allocated */

	io_buffer_lth =
	     max (terminal_io_record.n_elements, 1)
	     +
	     divide ((terminal_io_record.n_elements + HASP_MAX_NOT_COMPRESSED_TEXT_LTH - 1),
	     HASP_MAX_NOT_COMPRESSED_TEXT_LTH, 17, 0) +	/* SCBs for the text */
	     2;					/* SRCB and end-of-record SCB */

	if io_buffer_lth <= length (io_buffer_space) then do;
						/* space needed availabe in automatic */
	     io_buffer_ptr = addr (io_buffer_space);
	     io_buffer_lth = length (io_buffer_space);
	end;
	else do;					/* space required larger than automatic buffer */
	     on condition (area)
		begin;
		     code = error_table_$noalloc;	/* just TOO much */
		     go to RETURN_FROM_WRITE_RECORD;
		end;
	     allocate io_buffer in (system_area) set (io_buffer_ptr);
	end;


/* Create the record:  construct the SRCB for the record, compress the record (insuring that some data is present in the
   record), and add the terminating end-of-record SCB */

	io_buffer_used = 0;				/* nothing in the output yet */

	if (channel_info.device_type = HASP_CONSOLE) then call add_character_to_io_buffer (HASP_CONSOLE_SRCB);
	else if (channel_info.device_type = HASP_READER) then call add_character_to_io_buffer (TEMPLATE_HASP_CARD_SRCB);

	if terminal_io_record.n_elements = 0 then	/* no data:  supply some to avoid lossage with RSCS */
	     call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer),
		io_buffer_used, had.translations.space, compress_code);

	else call hasp_util_$compress_text (addr (terminal_io_record.data), (terminal_io_record.n_elements), (0),
		addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code);

	if compress_code ^= 0 then do;		/* failed:  yet above code insured there'd enough room */
WRITE_RECORD_BAD_DATA:
	     code = error_table_$improper_data_format;
	     go to RETURN_FROM_WRITE_RECORD;
	end;

	call add_character_to_io_buffer (HASP_EOR_SCB);


/* Transmit the I/O block and return to the caller */

	call write_io_buffer ();			/* needed in end_write_mode control order */

RETURN_FROM_WRITE_RECORD:
	if io_buffer_ptr ^= null () then
	     if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area);

	P_code = code;
	return;
%page;
/* Perform control operations on an I/O switch connected to a HASP host */

hasp_host_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	order = P_order;
	info_ptr = P_info_ptr;
	code = 0;


	if (order = "io_call") then do;

/* io_call command interface:  translate the supplied info into an ordinary control order */

	     if info_ptr = null () then do;		/* need the order name */
		P_code = error_table_$undefined_order_request;
		return;
	     end;

	     order = info_ptr -> io_call_info.order_name;
	     info_ptr = null ();
	end;


	if (order = "signon_record") then do;

/* Send a SIGNON record to the host system: validate that the user supplied an event-wait channel, convert the SIGNON
   record itself to uppercase and the remote system's character code, and pass the control order to MCS for actual
   processing */

	     if info_ptr = null () then
		code = error_table_$null_info_ptr;

	     else do;
		signon_record_info_ptr = info_ptr;

		if signon_record_info.version ^= SIGNON_RECORD_INFO_VERSION_1 then
		     code = error_table_$unimplemented_version;
						/* FINISH ME: validate IPC channel... */
		else do;				/* proper version */
		     signon_record_info.record = translate (signon_record_info.record, UPPERCASE, LOWERCASE);
		     signon_record_info.record = translate (signon_record_info.record, had.translations.output);
		     call hcs_$tty_order (channel_info.devx, "signon_record", signon_record_info_ptr, state, code);
		     if state ^= 5 then code = error_table_$io_no_permission;
		end;
	     end;
	end;


	else if (order = "runout") then do;

/* Wait for all output to leave the FNP:  for HASP channels, we only wait for the output to leave the TTY channel and
   enter the multiplexer */

	     write_status.output_pending = "1"b;	/* need do until */

	     do while (write_status.output_pending);

		call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
		if code ^= 0 then go to RETURN_FROM_CONTROL;

		if write_status.output_pending then do;
		     event_wait_channel.n_channels = 1;
		     event_wait_channel.channel_id (1) = channel_info.event_channel;
		     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
		     if code ^= 0 then call convert_ipc_code_ (code);
		     if code ^= 0 then go to RETURN_FROM_CONTROL;
		end;
	     end;
	end;


	else if (order = "end_write_mode") then do;

/* End a write operation:  for a card reader write an EOF record.  For all output devices, wait for all output to enter
   the multiplexer */

	     if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then do;
		code = error_table_$invalid_write;
		go to RETURN_FROM_CONTROL;
	     end;

	     if (channel_info.device_type = HASP_CONSOLE) then
		;				/* don't write an EOF record */

	     else do;
		io_buffer_ptr = addr (TEMPLATE_HASP_EOF_RECORD);
		io_buffer_lth, io_buffer_used = length (TEMPLATE_HASP_EOF_RECORD);
		call write_io_buffer ();		/* send it */
		if code ^= 0 then go to RETURN_FROM_CONTROL;
	     end;

	     call hasp_host_control (iocb_ptr, "runout", (null ()), code);
	end;


	else if (order = "read_status") then do;

/* Indicate if input is available:  check local buffers before checking with ring-0 */

	     if (info_ptr = null ()) then
		code = error_table_$null_info_ptr;

	     else do;
		read_status_info.event_channel = channel_info.event_channel;

		if (channel_info.held_input_ptr ^= null ()) | channel_info.eof_pending then
		     read_status_info.input_available = "1"b;
						/* got some here */

		else do;
		     call hcs_$tty_order (channel_info.devx, "read_status", info_ptr, state, code);
		     if state ^= 5 then code = error_table_$io_no_permission;
		end;
	     end;
	end;


	else if (order = "resetread") then do;

/* Flush pending input:  throw out any input being held locally and then perform an appropriate "abort" control on the
   channel */

	     if channel_info.held_input_ptr ^= null () then
		free channel_info.held_input_ptr -> held_input in (system_area);
	     channel_info.held_input_ptr = null ();
	     channel_info.eof_pending = "0"b;

	     call hcs_$tty_abort (channel_info.devx, (1), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	end;


	else if (order = "resetwrite") then do;

/* Flush pending output:  perform the appropriate "abort" control order on the channel */

	     call hcs_$tty_abort (channel_info.devx, (2), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	end;


	else if (order = "hangup_proc") then do;

/* Caller supplies a procedure to be invoked when the channel used by this switch is hungup */

	     if (info_ptr = null ()) then
		code = error_table_$null_info_ptr;

	     else do;
		call ipc_$decl_ev_call_chn (channel_info.attach_event_channel, hangup_proc_info.procedure,
		     hangup_proc_info.data_ptr, hangup_proc_info.priority, code);
		if code ^= 0 then call convert_ipc_code_ (code);
		if code = 0 then channel_info.attach_channel_is_call = "1"b;
	     end;
	end;


	else if (order = "get_channel_info") then do;

/* Return the name and MCS device index of the channel attached via this switch */

	     if (info_ptr = null ()) then code = error_table_$null_info_ptr;

	     else if get_channel_info.version ^= tty_get_channel_info_version then
		code = error_table_$unimplemented_version;

	     else do;
		get_channel_info.devx = channel_info.devx;
		get_channel_info.channel_name = channel_info.name;
	     end;
	end;


	else if (order = "select_device") then ;	/* select a specific output device: ignored */

	else if (order = "reset") then ;		/* reset the switch to a well-known state: ignored */


	else do;

/* Unrecognized control order or "no_signon_record" order: pass it on to MCS */

	     call hcs_$tty_order (channel_info.devx, order, info_ptr, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	end;

RETURN_FROM_CONTROL:
	P_code = code;
	return;
%page;
/* Change modes:  only the "non_edited" and "default" modes are recognized */

hasp_host_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	P_old_modes = "";				/* no modes are reflected to caller */
	code = 0;

	if (P_new_modes = "non_edited") | (P_new_modes = "default") then
	     ;
	else code = error_table_$bad_mode;

	P_code = code;
	return;
%page;
/* Remove an I/O switch which might be attached to the channel:  if this switch is the only one attached to the channel,
   the channel itself is detached */

cleanup_attachment:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* a parameter to allow callers to ignore it */

	P_code = 0;

	if had_ptr ^= null () then do;		/* there is an I/O switch */

	     if had.channel_info_ptr ^= null () then do;	/* there is knowledge of the channel */

		channel_info_ptr = had.channel_info_ptr;

		if (had.chain.previous = null ()) then
		     channel_info.hads.first = had.chain.next;
		else had.chain.previous -> had.chain.next = had.chain.next;

		if (had.chain.next = null ()) then
		     channel_info.hads.last = had.chain.previous;
		else had.chain.next -> had.chain.previous = had.chain.previous;

		if (channel_info.hads.first = null ()) then call release_channel ();
						/* last switch connected to the channel */
	     end;

	     free had in (system_area);
	     had_ptr = null ();			/* just to be sure */
	end;

	return;



/* Internal to cleanup_attachment:  release the knowledge associated with a TTY channel */

release_channel:
	procedure ();

	     if channel_info.devx ^= -1 then call hcs_$tty_detach (channel_info.devx, (0), (0), P_code);

	     if channel_info.event_channel ^= -1 then call ipc_$delete_ev_chn (channel_info.event_channel, (0));

	     if channel_info.attached then do;		/* give the channel back to the answering service */
		if channel_info.attach_channel_is_call then
		     call ipc_$decl_ev_wait_chn (channel_info.attach_event_channel, (0));
		dma.version = dial_manager_arg_version_2;
		dma.dial_channel = channel_info.attach_event_channel;
		dma.channel_name = channel_info.name;
		dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = "";
		call dial_manager_$release_channel (addr (dma), (0));
		channel_info.attached = "0"b;		/* assume success */
	     end;

	     if channel_info.attach_event_channel ^= -1 then
		call ipc_$delete_ev_chn (channel_info.attach_event_channel, (0));

	     if (channel_info.chain.previous = null ()) then
		first_channel_info_ptr = channel_info.chain.next;
	     else channel_info.chain.previous -> channel_info.chain.next = channel_info.chain.next;

	     if (channel_info.chain.next = null ()) then
		last_channel_info_ptr = channel_info.chain.previous;
	     else channel_info.chain.next -> channel_info.chain.previous = channel_info.chain.previous;

	     free channel_info in (system_area);
	     channel_info_ptr = null ();

	     return;

	end release_channel;

     end cleanup_attachment;
%page;
/* Wrapper to protect against errors while IPS interrupts are masked */

any_other_handler:
     procedure () options (non_quick);

	if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	ips_mask = ""b;

	call continue_to_signal_ ((0));		/* not interested, */

	return;

     end any_other_handler;



/* Abort a call to the attach entry:  print an error message if requested */

abort_attachment:
     procedure () options (variable, non_quick);

dcl  the_code fixed binary (35) based (the_code_ptr);
dcl  the_code_ptr pointer;

dcl  caller_message character (256);

	call cu_$arg_ptr (1, the_code_ptr, (0), (0));

	if loud_sw then do;				/* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b);
	     call com_err_ (the_code, NAME, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message);
	end;

	call cleanup_attachment ((0));		/* get rid of anything that was accomplished */

	if the_code = 0 then
	     code = error_table_$action_not_performed;
	else code = the_code;			/* save the error code */

	go to RETURN_FROM_ATTACH;

     end abort_attachment;
%page;
/* Fetch the next argument from the attach options and validate that it is a non-null character string */

get_string_argument:
     procedure () returns (character (*));

dcl  option_name character (32);

	option_name = argument;			/* about to move on to the next one */

	if (argument_idx = hbound (P_attach_options, 1)) then
	     call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name);

	argument_idx = argument_idx + 1;

	argument_ptr = substraddr (P_attach_options (argument_idx), 1);
	argument_lth = length (P_attach_options (argument_idx));

	if (argument = "") then
	     call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name);

	return (argument);

     end get_string_argument;



/* Fetch the next argument from the attach options and verify that it is a number */

get_numeric_argument:
     procedure () returns (fixed binary (35));

dcl  option_name character (32);
dcl  the_value fixed binary (35);

	option_name = argument;			/* about to move on to the next one */

	if (argument_idx = hbound (P_attach_options, 1)) then
	     call abort_attachment (error_table_$noarg, "Number following ""^a"".", option_name);

	argument_idx = argument_idx + 1;

	argument_ptr = substraddr (P_attach_options (argument_idx), 1);
	argument_lth = length (P_attach_options (argument_idx));

	the_value = cv_dec_check_ (argument, code);

	if code ^= 0 then
	     call abort_attachment (error_table_$bad_conversion, """^a"" must be followed by a number; not ""^a"".",
		option_name, argument);

	return (the_value);

     end get_numeric_argument;
%page;
/* Set input/output translation to the given string:  If the string supplied is less than 512 characters, the out of range
   characters are translated to NULs */

set_translation:
     procedure (P_translate_table, P_translate_string_ptr, P_translate_string_lth);

dcl  P_translate_table character (512) aligned parameter;	/* translate table */
dcl  P_translate_string_ptr pointer parameter;		/* -> translation string */
dcl  P_translate_string_lth fixed binary (21) parameter;	/* length of translation string */

dcl  translate_string character (P_translate_string_lth) based (P_translate_string_ptr);

	P_translate_table = translate_string;

	if length (translate_string) < length (P_translate_table) then
	     substr (P_translate_table, (length (translate_string) + 1)) =
		copy (NUL, (length (P_translate_table) - length (translate_string)));

	return;

     end set_translation;
%page;
/* Read an I/O buffer:  block until some data arrives and perform a single read from ring-0 */

read_io_buffer:
     procedure ();

	io_buffer_read = 0;				/* need do until here */

	do while (io_buffer_read = 0);

	     read_status.input_available = "0"b;	/* again, no do until */

	     do while (^read_status.input_available);

		call hcs_$tty_order (channel_info.devx, "read_status", addr (read_status), state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
		if code ^= 0 then return;		/* punt! */

		if ^read_status.input_available then do;/* need to wait for some input */
		     event_wait_channel.n_channels = 1;
		     event_wait_channel.channel_id (1) = channel_info.event_channel;
		     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
		     if code ^= 0 then call convert_ipc_code_ (code);
		     if code ^= 0 then return;
		end;
	     end;

	     call hcs_$tty_read (channel_info.devx, addr (io_buffer), (0), io_buffer_lth, io_buffer_read, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then return;
	end;

	return;

     end read_io_buffer;
%page;
/* Add the specified character to the I/O buffer for later output */

add_character_to_io_buffer:
     procedure (P_character);

dcl  P_character character (1) aligned parameter;

	if io_buffer_used = length (io_buffer) then	/* no room in buffer */
	     go to WRITE_RECORD_BAD_DATA;

	io_buffer_used = io_buffer_used + 1;

	substr (io_buffer, io_buffer_used, 1) = P_character;

	return;

     end add_character_to_io_buffer;
%page;
/* Write an I/O buffer:  blocks until the entire buffer has been taken by ring-0 MCS */

write_io_buffer:
     procedure ();

dcl  (transmitted, sent_on_call) fixed binary (21);


	transmitted = 0;				/* do until needed here */

	do while (transmitted < io_buffer_used);

	     call hcs_$tty_write (channel_info.devx, substraddr (io_buffer, (transmitted + 1)), (0),
		(io_buffer_used - transmitted), sent_on_call, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then return;		/* punt! */

	     transmitted = transmitted + sent_on_call;	/* got some more through */

	     if transmitted < io_buffer_used then do;	/* not done yet: wait 'till we should try again */
		call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
		if code ^= 0 then return;		/* punt! */

		if write_status.output_pending then do; /* must really and truly wait */
		     event_wait_channel.n_channels = 1;
		     event_wait_channel.channel_id (1) = channel_info.event_channel;
		     call timer_manager_$alarm_wakeup (1, "11"b, event_wait_channel.channel_id (1));
		     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
		     if code ^= 0 then call convert_ipc_code_ (code);
		     if code ^= 0 then return;	/* punt! */
		end;
	     end;
	end;

	return;					/* this return taken only on success */

     end write_io_buffer;
%page;
/* substraddr:  Return a pointer to the specified character of a varying or nonvarying string.  When the substraddr
   builtin function is finally implemented, these internal procedures should be removed */

dcl  substraddr
	generic (substraddr_nonvarying when (character (*) nonvarying, fixed binary precision (1:35)),
	substraddr_varying when (character (*) varying, fixed binary precision (1:35)));


substraddr_nonvarying:
     procedure (P_string, P_position) returns (pointer);

dcl  P_string character (*) nonvarying parameter;
dcl  P_position fixed binary (21) parameter;

dcl  string_overlay (length (P_string)) character (1) unaligned based (addr (P_string));

	return (addr (string_overlay (P_position)));

     end substraddr_nonvarying;


substraddr_varying:
     procedure (P_string, P_position) returns (pointer);

dcl  P_string character (*) varying parameter;
dcl  P_position fixed binary (21) parameter;

dcl  1 string_overlay aligned based (addr (P_string)),
       2 lth fixed binary (21),
       2 characters (0 refer (string_overlay.lth)) character (1) unaligned;

	return (addr (string_overlay.characters (P_position)));

     end substraddr_varying;
%page;
%include terminal_io_record;
%page;
%include hasp_device_data;

%include hasp_srcb_scb_bytes;

%include hasp_signon_record_info;
%page;
%include iocb;
%page;
%include iox_modes;
%page;
%include io_call_info;
%page;
%include dial_manager_arg;

%include event_wait_channel;

%include event_wait_info;
%page;
%include terminal_type_data;

%include tty_convert;

%include tty_get_channel_info;

     end hasp_host_;




		    hasp_host_operators_console.pl1 11/18/82  1708.0rew 11/18/82  1629.5      171180



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* Command for a Multics process to communicate with a foreign HASP host as a HASP workstation's operator's console:

      Usage:  hasp_host_operators_console channel {-control_args} {attach_arguments}

      where:
         channel -- is the name of the HASP operator's channel (eg: a.h014.opr),
         control_args -- may be either "-no_signon" or "-signon STR", and
         attach_arguments -- are optional arguments to supply in the attach description */

/* Created:  February 1980 by G. Palter */
/* Modified: 15 October 1980 by G. Palter to establish a hangup handler */
/* Modified: 22 July 1981 by G. Palter to support -signon/-no_signon directly */


hasp_host_operators_console:
hhoc:
     procedure () options (variable);


dcl  n_arguments fixed binary;

dcl  argument character (argument_lth) unaligned based (argument_ptr);
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  tty_channel character (32);			/* MCS channel for the operator's console */

dcl 1 sri aligned like signon_record_info;
dcl  signon_record bit (1) aligned;			/* ON => caller wants a SIGNON record transmitted */
dcl  signon_response fixed binary (71);			/* results of sending the SIGNON record */

dcl  operators_console pointer;			/* -> IOCB for the console */
dcl  switch_name character (32);
dcl  attach_description character (512) varying;		/* attach description for operator's console */

dcl  terminal_io_record_header_lth fixed binary (21);	/* needed to compute size of buffer to read from user_input */

dcl  code fixed binary (35);

dcl  idx fixed binary;

dcl  processing bit (1) aligned;

dcl 1 hangup_info aligned,				/* structure to establish handler for hangups */
    2 entry entry variable,				/* the procedure to call */
    2 data_ptr pointer,				/* -> arbitrary data to pass to the procedure */
    2 priority fixed binary;				/* IPC priority of handler */

dcl 1 ui_status aligned,				/* result of "read_status" on user_input */
    2 event_channel fixed binary (71),
    2 input_available bit (1);			/* ON => something is available to be read from user_input */

dcl 1 oc_status aligned,				/* result of "read_status" on operator's console channel */
    2 event_channel fixed binary (71),
    2 input_available bit (1);			/* ON => foreign system has something to print */

dcl 1 event_wait_list aligned,			/* for waiting for input from either user_input or host */
    2 n_channels fixed binary,
    2 pad bit (36),
    2 channels (2) fixed binary (71);

dcl 1 local_event_wait_info aligned like event_wait_info;

dcl  NO_CONTROL_CHARS character (512) initial (copy (SP, 32) || substr (collate, 33) || copy (SP, 384));

dcl  NAME character (32) static options (constant) initial ("hasp_host_operators_console");
dcl (MAJOR_VERSION	initial (2),
     MINOR_VERSION	initial (0))
	fixed binary static options (constant);

dcl (UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"))
	character (26) static options (constant);

dcl (NL	initial ("
"),
     SP	initial (" "))
	character (1) static options (constant);
    
dcl (iox_$user_input, iox_$user_output) pointer external;

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl (error_table_$bigarg, error_table_$invalid_state, error_table_$noarg, error_table_$out_of_sequence)
	fixed binary (35) external;

dcl (com_err_, com_err_$suppress_name) entry () options (variable);
dcl  convert_ipc_code_ entry (fixed binary (35));
dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl (ioa_, ioa_$nnl) entry () options (variable);
dcl  iox_$attach_name entry (character (*), pointer, character (*), pointer, fixed binary (35));
dcl  iox_$destroy_iocb entry (pointer, fixed binary (35));
dcl  iox_$detach_iocb entry (pointer, fixed binary (35));
dcl  iox_$close entry (pointer, fixed binary (35));
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$get_line entry (pointer, pointer, fixed binary (24), fixed binary (24), fixed binary (35));
dcl  iox_$open entry (pointer, fixed binary, bit (1) aligned, fixed binary (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (24), fixed binary (35));
dcl  iox_$read_record entry (pointer, pointer, fixed binary (24), fixed binary (24), fixed binary (35));
dcl  iox_$write_record entry (pointer, pointer, fixed binary (24), fixed binary (35));
dcl  ipc_$block entry (pointer, pointer, fixed binary (35));
dcl  ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  requote_string_ entry (character (*)) returns (character (*));
dcl  unique_chars_ entry (bit (*)) returns (character (15));

dcl (addr, binary, codeptr, collate, copy, currentsize, length, min, null, rel, rtrim, substr, string, translate, unspec)
	builtin;

dcl (cleanup, hhoc_hangup_, program_interrupt) condition;
%page;
%include terminal_io_record;
%page;
%include hasp_signon_record_info;
%page;
%include iox_modes;
%page;
%include event_wait_info;
%page;
	call cu_$arg_count (n_arguments, code);
	     if code ^= 0 then do;			/* not invoked as command */
		call com_err_ (code, NAME);
		return;
	     end;

	if n_arguments = 0 then do;
	     call com_err_$suppress_name (0, NAME, 
				    "Usage: hasp_host_operators_console tty_channel {-control_args} {attach_arguments}");
	     return;
	end;

	signon_record = "0"b;			/* assume caller doesn't want to send a SIGNON record */

	call cu_$arg_ptr (1, argument_ptr, argument_lth, (0));

	if index (argument, "-") = 1 then do;
	     call com_err_ (0, NAME,
		          "First argument must be a channel name; not the control argument ""^a"".",
			argument);
	     return;
	end;

	if argument_lth > length (tty_channel) then do;
	     call com_err_ (error_table_$bigarg, NAME, "Channel name must be 32 characters or less; not ""^a"".",
		          tty_channel);
	     return;
	end;

	tty_channel = argument;

	attach_description = "hasp_host_ -comm hasp -tty ";
	attach_description = attach_description || requote_string_ (rtrim (tty_channel));
	attach_description = attach_description || " -device teleprinter";


/* Process optional arguments: -signon/-no_signon may be freely intermixed with the attach options (if any) */

	do idx = 2 to n_arguments;

	     call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));

	     if (argument = "-no_signon") then		/* caller doesn't want a SIGNON record sent */
		signon_record = "0"b;

	     else if (argument = "-signon")
	     then do;				/* caller supplies a SIGNON record */
		if idx = n_arguments then do;
		     call com_err_ (error_table_$noarg, NAME, "Character string after ""-signon"".");
		     return;
		end;
		idx = idx + 1;			/* move on to next the argument */
		call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));
		if argument_lth > length (sri.record) then do;
		     call com_err_ (error_table_$bigarg, NAME,
			          "SIGNON record can not be longer than ^d characters; not ""^a"".",
				length (sri.record), argument);
		     return;
		end;
		sri.record = argument;
		signon_record = "1"b;		/* now will send a SIGNON record */
	     end;

	     else do;				/* anything else goes into the attach description */
		attach_description = attach_description || " ";
		attach_description = attach_description || requote_string_ (argument);
	     end;
	end;


/* Attach the operator's console */

	operators_console,				/* for cleanup handler */
	     terminal_io_record_ptr = null ();
	sri.event_channel = -1;

	on condition (cleanup)
	     call release_console ();

	call get_temp_segment_ (NAME, terminal_io_record_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, NAME, "Obtaining buffer space.");
		return;
	     end;

	terminal_io_record_header_lth = 4 * binary (rel (addr (terminal_io_record.data)), 18, 0);

	terminal_io_record.version = terminal_io_record_version_1;
	terminal_io_record.device_type = TELEPRINTER_DEVICE;
	terminal_io_record.slew_type = SLEW_BY_COUNT;
	terminal_io_record.slew_count = 1;
	string (terminal_io_record.flags) = ""b;
	terminal_io_record.element_size = 9;

	switch_name = substr (tty_channel, 1, min (length (rtrim (tty_channel)), 16)) || "." || unique_chars_ (""b);

	call iox_$attach_name (switch_name, operators_console, (attach_description), codeptr (hasp_host_operators_console), code);
	     if code ^= 0 then do;
		call com_err_ (code, NAME, "^/^-Attaching ^a using attach description: ^a", switch_name,
			     attach_description);
		go to RETURN_FROM_COMMAND;
	     end;

	call iox_$open (operators_console, Sequential_input_output, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, NAME, "Opening ^a (channel ^a) for sequential input/output.", switch_name,
			     tty_channel);
		go to RETURN_FROM_COMMAND;
	     end;


/* Validate the caller specified SIGNON processing: transmits the SIGNON record if need be */

	if signon_record
	then do;					/* send the SIGNON */
	     call ioa_ ("Sending the SIGNON record: ^a", translate (sri.record, UPPERCASE, LOWERCASE));
	     sri.version = SIGNON_RECORD_INFO_VERSION_1;
	     call ipc_$create_ev_chn (sri.event_channel, code);
		if code ^= 0 then call convert_ipc_code_ (code);
		if code ^= 0 then do;
		     call com_err_ (code, NAME, "Creating event channel for SIGNON record control order.");
		     go to RETURN_FROM_COMMAND;
		end;
	     sri.pad = ""b;
	     call iox_$control (operators_console, "signon_record", addr (sri), code);
	     if (code = 0)
	     then do;				/* multiplexer accepted the call: wait for response */
		event_wait_list.n_channels = 1;
		event_wait_list.channels (1) = sri.event_channel;
RETRY_WAIT_FOR_RESPONSE:
		call ipc_$block (addr (event_wait_list), addr (local_event_wait_info), code);
		     if code ^= 0 then call convert_ipc_code_ (code);
		     if code ^= 0 then do;
			call com_err_ (code, NAME, "Blocking to await response to SIGNON record control order.");
			go to RETURN_FROM_COMMAND;
		     end;
		if local_event_wait_info.ring ^= 0 then do;
		     call com_err_ (0, NAME,
			          "Ignoring extraneous wakeup while waiting for response to SIGNON record control order.");
		     go to RETRY_WAIT_FOR_RESPONSE;
		end;
		signon_response = local_event_wait_info.message;
		if (signon_response = HASP_SIGNON_OK) then
		     call ioa_$nnl ("SIGNON record accepted... ");
		else if (signon_response = HASP_SIGNON_REJECTED) | (signon_response = HASP_SIGNON_HANGUP)
		then do;				/* foreign system didn't like what we sent */
		     call com_err_ (0, NAME,
				   "Foreign system rejected SIGNON record^; ^[ please retry^;foreign system has disconnected^].",
				   (signon_response = HASP_SIGNON_REJECTED));
		     go to RETURN_FROM_COMMAND;
		end;
		else do;				/* unknown response */
		     call com_err_ (0, NAME, "Unknown reponse to SIGNON control record order: ^d", signon_response);
		     go to RETURN_FROM_COMMAND;
		end;
	     end;
	     else if (code = error_table_$out_of_sequence)
	     then do;				/* SIGNON record was sent once before... */
		call com_err_ (0, NAME,
			     "A SIGNON record was previously transmitted to this remote system.");
		call ioa_$nnl ("SIGNON record ignored... ");
	     end;					/* ... but that's not fatal */
	     else do;				/* multiplexer rejected the control order: explain why */
		if (code = error_table_$invalid_state) then
		     call com_err_ (0, NAME, "Local multiplexer is not configured to transmit a SIGNON record.");
		else call com_err_ (code, NAME, "Requesting SIGNON record transmission.");
		go to RETURN_FROM_COMMAND;
	     end;
	end;

	else do;					/* caller doesn't want a SIGNON record transmitted */
	     call iox_$control (operators_console, "no_signon_record", null (), code);
	     if code ^= 0 then do;			/* ... but the multiplexer doesn't like that */
		if (code = error_table_$invalid_state) then
		     call com_err_ (0, NAME, "Local multiplexer is configured to transmit a SIGNON record.");
		else call com_err_ (code, NAME, "Validating that no SIGNON record need be transmitted.");
		go to RETURN_FROM_COMMAND;
	     end;
	end;


/* Establish a handler for hangup to terminate the command */

	hangup_info.entry = hhoc_hangup_handler_;
	hangup_info.data_ptr = null ();
	hangup_info.priority = 1;

	call iox_$control (operators_console, "hangup_proc", addr (hangup_info), code);
	     if code ^= 0 then do;
		call com_err_ (code, NAME, "Attempting to establish hangup handler for ^a (channel ^a)", switch_name,
			     tty_channel);
		go to RETURN_FROM_COMMAND;
	     end;

	on condition (hhoc_hangup_)
	     begin;				/* signaled when a hangup occurs */
		call com_err_ (0, NAME, "Hangup detected on channel ^a.", tty_channel);
		go to RETURN_FROM_COMMAND;
	     end;


/* Main processing loop */

	call ioa_ ("Input:");

	processing = "1"b;

	on condition (program_interrupt)
	     go to CONTINUE_TO_READ_FROM_SWITCHES;

	do while (processing);

CONTINUE_TO_READ_FROM_SWITCHES:
	     call iox_$control (iox_$user_input, "read_status", addr (ui_status), code);
		if code ^= 0 then do;
		     call com_err_ (code, NAME, "Performing ""read_status"" on user_input.");
		     go to RETURN_FROM_COMMAND;
		end;

	     call iox_$control (operators_console, "read_status", addr (oc_status), code);
		if code ^= 0 then do;
		     call com_err_ (code, NAME, "Performing ""read_status"" on channel ^a.", tty_channel);
		     go to RETURN_FROM_COMMAND;
		end;

	     if ui_status.input_available then do;	/* process input (if any) */
		call iox_$get_line (iox_$user_input, addr (terminal_io_record.data),
			          (4 * sys_info$max_seg_size - terminal_io_record_header_lth),
				terminal_io_record.n_elements, code);
		     if code ^= 0 then do;
			call com_err_ (code, NAME, "Reading from user_input.");
			go to RETURN_FROM_COMMAND;
		     end;
		terminal_io_record.n_elements = terminal_io_record.n_elements - 1;	/* ignore the newline */
		if terminal_io_record.n_elements > 0 then
		     if (substr (terminal_io_record_data_chars, 1, 1) = "!") then
			call interpret_escape_request ();  /* user requests to do something special */
		terminal_io_record_data_chars = translate (terminal_io_record_data_chars, NO_CONTROL_CHARS);
						/* convert control characters and non-ASCII to spaces */
		call iox_$write_record (operators_console, terminal_io_record_ptr,
				    (4 * currentsize (terminal_io_record)), code);
		     if code ^= 0 then do;
			call com_err_ (code, NAME, "Writing to channel ^a.", tty_channel);
			go to RETURN_FROM_COMMAND;
		     end;
	     end;

CHECK_FOR_FOREIGN_MESSAGES:
	     if oc_status.input_available then do;	/* process messages from foreign host */
		call iox_$read_record (operators_console, terminal_io_record_ptr, (4 * sys_info$max_seg_size), (0),
				   code);
		     if code ^= 0 then do;
			call com_err_ (code, NAME, "Reading from channel ^a.", tty_channel);
			go to RETURN_FROM_COMMAND;
		     end;
		call iox_$put_chars (iox_$user_output, addr (terminal_io_record.data), terminal_io_record.n_elements, (0));
		call iox_$put_chars (iox_$user_output, addr (NL), length (NL), (0));
	     end;

	     if ^ui_status.input_available & ^oc_status.input_available
	     then do;				/* no input from anywhere right now: wait for some */
		event_wait_list.n_channels = 2;
		event_wait_list.channels (1) = ui_status.event_channel;
		event_wait_list.channels (2) = oc_status.event_channel;
		call ipc_$block (addr (event_wait_list), addr (local_event_wait_info), code);
		     if code ^= 0 then call convert_ipc_code_ (code);
		     if code ^= 0 then do;
			call com_err_ (code, NAME, "Attempting to wait for input from user_input or ^a.",
				     tty_channel);
			go to RETURN_FROM_COMMAND;
		     end;
	     end;
	end;

RETURN_FROM_COMMAND:
	call release_console ();
	return;



/* Invoked when the operator's console channel hangs up: abort the command */

hhoc_hangup_handler_:
     entry ();

	signal condition (hhoc_hangup_);

	return;					/* shouldn't get here... */
%page;
/* Interpret escape requests:  Currently, the only defined escape requests are --

      !e command_line  -- execute the given Multics command line,
      !..command_line  -- execute the given Multics command line,
      !.               -- identify this program and the channel being used, or
      !quit            -- disconnect the channel and return to Multics command level */

interpret_escape_request:
	procedure ();

	     if terminal_io_record.n_elements < 2 then do;     /* must have more than just "!" */
		call com_err_ (0, NAME, "No request supplied after ""!"".");
		go to CHECK_FOR_FOREIGN_MESSAGES;
	     end;

	     if (substr (terminal_io_record_data_chars, 2, 2) = "e ") |
	        (substr (terminal_io_record_data_chars, 2, 2) = "..")
		then call cu_$cp (addr (terminal_io_record.data.bits (4)), (terminal_io_record.n_elements - 3), (0));

	     else if (terminal_io_record.n_elements = 2) & (terminal_io_record_data_chars = "!.")
		then call ioa_ ("^a version ^d.^d; connected to channel ^a.", NAME, MAJOR_VERSION, MINOR_VERSION,
			      tty_channel);

	     else if (terminal_io_record.n_elements = length ("!quit")) & (terminal_io_record_data_chars = "!quit")
		then go to RETURN_FROM_COMMAND;	/* WARNING: this method can lose messages from host */

	     else call com_err_ (0, NAME, "Unrecognized request line: ^a", terminal_io_record_data_chars);

	     go to CHECK_FOR_FOREIGN_MESSAGES;

	end interpret_escape_request;
%page;
/* Release operator's console (if attached) and perform other necessary cleanup */

release_console:
	procedure ();

	     if terminal_io_record_ptr ^= null () then do;
		call release_temp_segment_ (NAME, terminal_io_record_ptr, (0));
		terminal_io_record_ptr = null ();
	     end;

	     if operators_console ^= null () then do;	/* have the I/O switch */
		call iox_$close (operators_console, (0));
		call iox_$detach_iocb (operators_console, (0));
		call iox_$destroy_iocb (operators_console, (0));
		operators_console = null ();
	     end;

	     if sri.event_channel ^= -1 then do;	/* created an IPC channel for SIGNON records */
		call ipc_$delete_ev_chn (sri.event_channel, (0));
		sri.event_channel = -1;
	     end;

	     return;

	end release_console;

     end hasp_host_operators_console;




		    hasp_stream_.pl1                07/13/88  1141.4r w 07/13/88  0935.7      213030



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: style4,indattr,ifthen,^indproc */

hasp_stream_: proc;

/* I/O module to allow stream I/O over HASP channels. */

/* Written Feb 1985 by Jim Homan. */

/****^  HISTORY COMMENTS:
  1) change(87-03-31,Beattie), approve(87-04-06,MCR7656),
     audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055):
     Add support to allow HASP operator subchannels to be login service.
                                                   END HISTORY COMMENTS */

/* external entries */

dcl  continue_to_signal_    entry (fixed bin (35));
dcl  get_group_id_	        entry () returns (char (32));
dcl  get_pdir_	        entry () returns (char (168));
dcl  get_temp_segment_      entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_  entry (char (*), ptr, fixed bin (35));
dcl  com_err_	        entry () options (variable);
dcl  hcs_$initiate	        entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$set_ips_mask      entry (bit (*) aligned, bit (*) aligned);
dcl  unique_chars_	        entry (bit (*)) returns (char (15));
dcl  iox_$modes	        entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$write_record      entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$read_record       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$detach_iocb       entry (ptr, fixed bin (35));
dcl  iox_$close	        entry (ptr, fixed bin (35));
dcl  iox_$look_iocb	        entry (char (*), ptr, fixed bin (35));
dcl  iox_$open	        entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$attach_name       entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$propagate	        entry (ptr);
dcl  iox_$err_not_open      entry () options (variable);
dcl  iox_$err_not_closed    entry () options (variable);
dcl  iox_$control	        entry (ptr, char (*), ptr, fixed bin (35));
dcl  terminate_process_     entry (char (*), ptr);

/* error codes */

dcl  sys_info$max_seg_size  fixed bin (35) ext static;
dcl  error_table_$long_record fixed bin (35) ext static;
dcl  error_table_$unable_to_do_io fixed bin (35) ext static;
dcl  error_table_$noarg     fixed bin (35) ext;		/* Expected argument missing. */
dcl  error_table_$incompatible_attach fixed bin (35) ext;	/* Attach and open are incompatible. */
dcl  error_table_$not_attached fixed bin (35) ext;	/* I/O switch (or device) is not attached. */
dcl  error_table_$not_detached fixed bin (35) ext;	/* I/O switch is not detached. */
dcl  error_table_$wrong_no_of_args fixed bin (35) ext static;

/* parameters */

dcl  buffer_length	        fixed bin (21) parameter;
dcl  buffer_ptr	        ptr parameter;
dcl  code		        fixed bin (35) parameter;
dcl  com_err_switch	        bit (1) aligned parameter;
dcl  iocb_ptr	        ptr parameter;
dcl  n_read	        fixed bin (21) parameter;
dcl  obsolete	        bit (1) aligned parameter;
dcl  option_array	        (*) char (*) var parameter;
dcl  mode		        fixed bin parameter;
dcl  new_modes	        char (*) parameter;
dcl  old_modes	        char (*) parameter;
dcl  info_ptr	        ptr parameter;
dcl  order	        char (*) parameter;

/* automatic variables */

dcl  terminal_io_header_length fixed bin (21);
dcl  hasp_stream_info_ptr   ptr;
dcl  mask		        bit (36) aligned;
dcl  atd_ptr	        ptr;
dcl  temp_atd	        char (256) var;
dcl  1 local_input_timeout_info aligned like input_timeout_info;
dcl  1 local_output_timeout_info aligned like output_timeout_info;
dcl  stop_time	        fixed bin (71);
dcl  line_start_pos	        fixed bin (21);
dcl  line_start_ptr	        ptr;
dcl  line_length	        fixed bin (21);


/* constants */

dcl  ME		        char (32) int static options (constant) init ("hasp_stream_");
dcl  SP		        char (1) int static options (constant) init (" ");
dcl  NL		        char (1) int static options (constant) init ("
");
dcl  sio_mode	        char (24) var int static options (constant) init ("stream_input_output");
dcl  so_mode	        char (24) var int static options (constant) init ("stream_output");
dcl  si_mode	        char (24) var int static options (constant) init ("stream_input");

/* based variables */


dcl  1 atd	        based (atd_ptr) aligned,
       2 length	        fixed bin,
       2 string	        char (length (temp_atd) refer (atd.length));

dcl  1 open_descrip	        aligned like atd based;

dcl  1 hasp_stream_info     based (hasp_stream_info_ptr) aligned,
       2 temp_seg_ptr       ptr,
       2 target_iocb_ptr    ptr,
       2 mode	        fixed bin,
       2 target_attach_description char (256) var,
       2 target_switch_name char (32) unal,
       2 must_close_target  bit (1),
       2 must_detach_target bit (1);

/* builtins */

dcl  (addr, addcharno, bin, clock, collate, copy, currentsize, hbound, index, length, max, min, null, rel, rtrim,
     string, substr, translate) builtin;

/* conditions */

dcl  any_other	        condition;
dcl  cleanup	        condition;
%page;
%include iocb;
%page;
%include iox_modes;
%page;
%include pit;
%page;
%include terminal_io_record;
%page;
%include user_attributes;
%page;
%include io_timeout_info;
%page;
hasp_stream_attach: entry (iocb_ptr, option_array, com_err_switch, code);

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     code = error_table_$not_detached;
	     if com_err_switch then
		call com_err_ (code, ME, "^a", iocb_ptr -> iocb.name);
	     return;
	end;
	if hbound (option_array, 1) < 1 then do;
	     code = error_table_$noarg;
	     if com_err_switch then
		call com_err_ (code, ME,
		     "^/Attach description must be: ""hasp_stream_ TargetSwitch"" or ""hasp_stream_ -target TargetATD""");
	     return;
	end;

	atd_ptr, hasp_stream_info_ptr = null ();
	on cleanup
	     call attach_err_cleanup;

	allocate hasp_stream_info;
	hasp_stream_info.target_iocb_ptr = null ();
	hasp_stream_info.temp_seg_ptr = null ();
	hasp_stream_info.target_switch_name = "";
	hasp_stream_info.target_attach_description = "";
	hasp_stream_info.must_close_target, hasp_stream_info.must_detach_target = "0"b;
	call get_temp_segment_ (ME, hasp_stream_info.temp_seg_ptr, code);
	if code ^= 0 then do;
	     if com_err_switch then
		call com_err_ (code, ME, "Cannot get temp segment.");
	     return;
	end;

	call process_option_array (code);
	if code ^= 0 then
	     goto ATTACH_ERR_EXIT;

	if hasp_stream_info.target_attach_description ^= "" then
	     call attach_target;
	if code ^= 0 then do;
	     if com_err_switch then
		call com_err_ (code, ME, "Cannot attach target switch with attach description:^/^a",
		     hasp_stream_info.target_attach_description);
	     goto ATTACH_ERR_EXIT;
	end;

	allocate atd;
	atd.string = temp_atd;

	on any_other
	     call any_other_handler ();		/* Can't tolerate inconsistent IOCBs */
	revert cleanup;
	call hcs_$set_ips_mask ("0"b, mask);		/* Mask IPS signals while changing IOCB */
	iocb_ptr -> iocb.attach_descrip_ptr = atd_ptr;
	iocb_ptr -> iocb.attach_data_ptr = hasp_stream_info_ptr;
	iocb_ptr -> iocb.detach_iocb = hasp_stream_detach_iocb;
	iocb_ptr -> iocb.open = hasp_stream_open;
	iocb_ptr -> iocb.modes = hasp_stream_modes;
	iocb_ptr -> iocb.control = hasp_stream_control;
	call iox_$propagate (iocb_ptr);
	call hcs_$set_ips_mask (mask, "0"b);		/* Restore IPS signals */
	revert any_other;
	code = 0;
	return;

ATTACH_ERR_EXIT:
	call attach_err_cleanup ();
	return;


attach_err_cleanup: proc;
	if atd_ptr ^= null () then
	     free atd;
	if hasp_stream_info_ptr ^= null () then do;
	     if hasp_stream_info.temp_seg_ptr ^= null () then
		call release_temp_segment_ (ME, hasp_stream_info.temp_seg_ptr, (0));
	     free hasp_stream_info;
	end;
     end attach_err_cleanup;
%page;
/* procedure to fill in attach_data and temp_atd from arguments passed via option_array */

process_option_array: proc (ec);

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

	ec = 0;

	if option_array (1) = "-target" then do;
	     hasp_stream_info.target_attach_description = "";
	     temp_atd = rtrim (ME) || " " || option_array (1);
	     do argN = 2 to hbound (option_array, 1);
		hasp_stream_info.target_attach_description = hasp_stream_info.target_attach_description ||
		     option_array (argN) || " ";
		temp_atd = temp_atd || " " || option_array (argN);
	     end;
	end;

	else do;
	     if hbound (option_array, 1) ^= 1 then do;
		ec = error_table_$wrong_no_of_args;
		if com_err_switch then
		     call com_err_ (ec, ME,
			"^/Attach description must be: ""hasp_stream_ TargetSwitch"", ""hasp_stream_ -login_channel"" or ""hasp_stream_ -target TargetATD""");
		return;
	     end;

	     if option_array (1) = "-login_channel" then do;
						/* get pointer to the PIT to get login channel */
		call hcs_$initiate (get_pdir_ (), "pit", "pit_", (0), (0), pit_ptr, ec);
		if pit_ptr ^= null ()
		     then ec = 0;
		if ec ^= 0 then do;
		     if com_err_switch then
			call com_err_ (ec, ME, "Unable to get pointer to PIT.");
		     return;
		end;

		hasp_stream_info.target_attach_description
		     = "hasp_workstation_ -device teleprinter -comm hasp -suppress_dial_manager -tty " || rtrim (pit.tty);
		temp_atd = rtrim (ME) || " -login_channel -target " || hasp_stream_info.target_attach_description;
	     end;

	     else do;
		hasp_stream_info.target_switch_name = option_array (1);
		temp_atd = rtrim (ME) || " " || option_array (1);
	     end;

	end;

     end process_option_array;
%page;
hasp_stream_open: entry (iocb_ptr, mode, obsolete, code);

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
	if mode ^= Stream_input & mode ^= Stream_output & mode ^= Stream_input_output then do;
	     code = error_table_$incompatible_attach;
	     return;
	end;
	hasp_stream_info.mode = mode;
	call open_target;
	if code ^= 0 then do;
	     call close_and_detach_target;
	     return;
	end;

	on any_other
	     call any_other_handler ();		/* Can't tolerate inconsistent IOCBs */
	call hcs_$set_ips_mask ("0"b, mask);		/* Mask IPS signals while changing IOCB */
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.close = hasp_stream_close;

	if hasp_stream_info.mode = Stream_input then do;
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (si_mode);
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_line = hasp_stream_get_line;
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_chars = hasp_stream_get_chars;
	end;
	else if hasp_stream_info.mode = Stream_output then do;
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (so_mode);
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.put_chars = hasp_stream_put_chars;
	end;
	else do;
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (sio_mode);
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_line = hasp_stream_get_line;
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_chars = hasp_stream_get_chars;
	     iocb_ptr -> iocb.actual_iocb_ptr -> iocb.put_chars = hasp_stream_put_chars;
	end;
	call iox_$propagate (iocb_ptr);
	call hcs_$set_ips_mask (mask, "0"b);		/* Restore IPS signals */
	revert any_other;

	return;
%page;
attach_target: proc;

	hasp_stream_info.target_switch_name = "hasp_stream_." || unique_chars_ ("0"b);
	call iox_$attach_name (hasp_stream_info.target_switch_name, hasp_stream_info.target_iocb_ptr,
	     (hasp_stream_info.target_attach_description), null (), code);
	if code ^= 0 then
	     return;
	hasp_stream_info.must_detach_target = "1"b;

     end attach_target;
%page;
open_target: proc;
dcl  target_mode	        char (24) var;
dcl  target_mode_number     fixed bin;

/* First get the IOCB for this switch */

	call iox_$look_iocb (hasp_stream_info.target_switch_name, hasp_stream_info.target_iocb_ptr, code);
	if code ^= 0 then
	     return;

/* Make sure the switch is attached */

	if hasp_stream_info.target_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null then do;
	     code = error_table_$not_attached;
	     return;
	end;

/* If the switch is already open, make sure its opening mode is OK */

	if hasp_stream_info.target_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     target_mode = hasp_stream_info.target_iocb_ptr -> iocb.actual_iocb_ptr ->
		iocb.open_descrip_ptr -> open_descrip.string;
	     if hasp_stream_info.mode = Stream_input_output then do;
		if target_mode ^= "sequential_input_output" then
		     code = error_table_$incompatible_attach;
	     end;
	     else if hasp_stream_info.mode = Stream_input then do;
		if target_mode ^= "sequential_input" & target_mode ^= "sequential_input_output" then
		     code = error_table_$incompatible_attach;
	     end;
	     else if hasp_stream_info.mode = Stream_output then do;
		if target_mode ^= "sequential_output" & target_mode ^= "sequential_input_output" then
		     code = error_table_$incompatible_attach;
	     end;
	end;

	else do;					/* If it wasn't already open, open it for appropriate mode */
	     if hasp_stream_info.mode = Stream_input then
		target_mode_number = Sequential_input;
	     else if hasp_stream_info.mode = Stream_output then
		target_mode_number = Sequential_output;
	     else target_mode_number = Sequential_input_output;
	     call iox_$open (hasp_stream_info.target_iocb_ptr, target_mode_number, obsolete, code);
	     if code = 0 then
		hasp_stream_info.must_close_target = "1"b;
	end;

     end open_target;
%page;
hasp_stream_detach_iocb: entry (iocb_ptr, code);

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
	on any_other
	     call any_other_handler ();		/* Can't tolerate inconsistent IOCBs */
	call release_temp_segment_ (ME, hasp_stream_info.temp_seg_ptr, (0));
	free iocb_ptr -> iocb.attach_descrip_ptr -> atd;
	free iocb_ptr -> iocb.attach_data_ptr -> hasp_stream_info;
	call hcs_$set_ips_mask ("0"b, mask);		/* Mask IPS signals while changing IOCB */
	iocb_ptr -> iocb.attach_descrip_ptr = null ();
	call iox_$propagate (iocb_ptr);
	call hcs_$set_ips_mask (mask, "0"b);		/* Restore IPS signals */
	revert any_other;
	code = 0;
	return;
%page;
hasp_stream_close: entry (iocb_ptr, code);

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
	call close_and_detach_target;
	on any_other
	     call any_other_handler ();		/* Can't tolerate inconsistent IOCBs */
	call hcs_$set_ips_mask ("0"b, mask);		/* Mask IPS signals while changing IOCB */
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null ();
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open = hasp_stream_open;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.detach_iocb = hasp_stream_detach_iocb;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.modes = iox_$err_not_open;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.control = iox_$err_not_open;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_chars = iox_$err_not_open;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.put_chars = iox_$err_not_open;
	iocb_ptr -> iocb.actual_iocb_ptr -> iocb.get_line = iox_$err_not_open;

	call iox_$propagate (iocb_ptr);
	call hcs_$set_ips_mask (mask, "0"b);		/* Restore IPS signals */
	revert any_other;
	code = 0;
	return;
%page;
hasp_stream_get_chars: entry (iocb_ptr, buffer_ptr, buffer_length, n_read, code);
hasp_stream_get_line: entry (iocb_ptr, buffer_ptr, buffer_length, n_read, code);

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
	terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr;
	terminal_io_record.n_elements = 0;		/* Might not be set if code ^= 0 */
	n_read = 0;

	call iox_$read_record (hasp_stream_info.target_iocb_ptr, terminal_io_record_ptr, (4 * sys_info$max_seg_size), (0),
	     code);

	if terminal_io_record.n_elements ^= 0 then
	     call convert_input (buffer_ptr, buffer_length, n_read, code);

	return;
%page;
hasp_stream_put_chars: entry (iocb_ptr, buffer_ptr, buffer_length, code);

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
	terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr;

	line_start_pos = 0;
	call get_next_line (buffer_ptr, buffer_length, line_start_ptr, line_start_pos, line_length);
	do while (line_start_ptr ^= null ());
	     call convert_output (line_start_ptr, line_length);
	     call iox_$write_record (hasp_stream_info.target_iocb_ptr, terminal_io_record_ptr,
		(4 * currentsize (terminal_io_record)), code);
	     call get_next_line (buffer_ptr, buffer_length, line_start_ptr, line_start_pos, line_length);
	end;

	return;
%page;
hasp_stream_control: entry (iocb_ptr, order, info_ptr, code);

/* Just pass through all orders except the timeout orders that need to be changed a bit. */

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;

	if order = "get_chars_timeout" | order = "get_line_timeout" then do;
	     terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr;
	     terminal_io_record.n_elements = 0;
	     timeout_info_ptr = info_ptr;
	     local_input_timeout_info.timeout = input_timeout_info.timeout;
	     local_input_timeout_info.buffer_pointer = terminal_io_record_ptr;
	     local_input_timeout_info.buffer_length = 4 * sys_info$max_seg_size;
	     input_timeout_info.characters_read = 0;
	     call iox_$control (hasp_stream_info.target_iocb_ptr,
		"read_record_timeout", addr (local_input_timeout_info), code);
	     if terminal_io_record.n_elements ^= 0 then
		call convert_input (input_timeout_info.buffer_pointer, input_timeout_info.buffer_length,
		     input_timeout_info.characters_read, code);
	end;
	else if order = "put_chars_timeout" then do;
	     terminal_io_record_ptr = hasp_stream_info.temp_seg_ptr;
	     timeout_info_ptr = info_ptr;

	     output_timeout_info.characters_written = 0;
	     stop_time = clock () + input_timeout_info.timeout;
	     terminal_io_header_length = bin (rel (addr (terminal_io_record.data)));
	     line_start_pos = 0;
	     call get_next_line (output_timeout_info.buffer_pointer,
		output_timeout_info.buffer_length, line_start_ptr, line_start_pos, line_length);
	     do while (line_start_ptr ^= null ());
		call convert_output (line_start_ptr, line_length);
		local_output_timeout_info.timeout = max (0, stop_time - clock ());
		local_output_timeout_info.buffer_length = 4 * currentsize (terminal_io_record);
		local_output_timeout_info.buffer_pointer = terminal_io_record_ptr;
		call iox_$control (hasp_stream_info.target_iocb_ptr,
		     "write_record_timeout", addr (local_output_timeout_info), code);
		if code ^= 0 then
		     return;
		output_timeout_info.characters_written =
		     line_start_pos + line_length;	/* write_record_timeout writes all or none */
		call get_next_line (output_timeout_info.buffer_pointer,
		     output_timeout_info.buffer_length, line_start_ptr, line_start_pos, line_length);
	     end;
	     if output_timeout_info.characters_written > output_timeout_info.buffer_length then
		output_timeout_info.characters_written =
		     output_timeout_info.buffer_length; /* Can happen if no NL at end */
	end;
	else call iox_$control (hasp_stream_info.target_iocb_ptr,
		order, info_ptr, code);

	return;
%page;
hasp_stream_modes: entry (iocb_ptr, new_modes, old_modes, code);

	hasp_stream_info_ptr = iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;

	call iox_$modes (hasp_stream_info.target_iocb_ptr, new_modes, old_modes, code);

	return;
%page;
/* procedure to close target switch if opened by hasp_stream_, and detach
   if attached by hasp_stream_ */

close_and_detach_target: proc;

	if hasp_stream_info.must_close_target then
	     call iox_$close (hasp_stream_info.target_iocb_ptr, 0);
	hasp_stream_info.must_close_target = "0"b;
	if hasp_stream_info.must_detach_target then
	     call iox_$detach_iocb (hasp_stream_info.target_iocb_ptr, 0);
	hasp_stream_info.must_detach_target = "0"b;

     end close_and_detach_target;
%page;
any_other_handler: proc;

dcl  1 fatal_error_info     aligned,
       2 version	        fixed bin,
       2 status_code        fixed bin (35);

	if get_group_id_ () = "Initializer.SysDaemon.z"
	then do;

	     if mask then call hcs_$set_ips_mask (mask, "0"b);
	     mask = ""b;

	     call continue_to_signal_ ((0));		/* hope to get an asdump */
	end;
	else do;
	     fatal_error_info.version = 0;
	     fatal_error_info.status_code = error_table_$unable_to_do_io;

	     call terminate_process_ ("fatal_error", addr (fatal_error_info));
	end;

     end any_other_handler;
%page;
convert_output: proc (output_string_ptr, output_string_length);

dcl  output_string_ptr      ptr;
dcl  output_string_length   fixed bin (21);
dcl  output_string	        char (output_string_length) based (output_string_ptr);

dcl  NO_CONTROL_CHARS       character (512) initial (copy (SP, 32) || substr (collate (), 33) || copy (SP, 384));

	terminal_io_record.version = terminal_io_record_version_1;
	terminal_io_record.device_type = TELEPRINTER_DEVICE;
	terminal_io_record.slew_type = SLEW_BY_COUNT;
	terminal_io_record.slew_count = 1;
	string (terminal_io_record.flags) = ""b;
	terminal_io_record.element_size = 9;
	terminal_io_record.n_elements = length (output_string);
	terminal_io_record_data_chars = translate (output_string, NO_CONTROL_CHARS);
						/* convert control characters and non-ASCII to spaces */
     end convert_output;

convert_input: proc (input_buffer_ptr, input_buffer_length, n_read, ec);

dcl  input_buffer_ptr       ptr;
dcl  input_buffer_length    fixed bin (21);
dcl  n_read	        fixed bin (21);
dcl  ec		        fixed bin (35);
dcl  1 input_buffer	        based (input_buffer_ptr),
       2 data	        char (min (n_read - 1, input_buffer_length)),
       2 new_line	        char (1);

	ec = 0;
	n_read = terminal_io_record.n_elements + 1;

	input_buffer.data = terminal_io_record_data_chars;
	if n_read < input_buffer_length then
	     input_buffer.new_line = NL;
	else ec = error_table_$long_record;

     end convert_input;
%page;
get_next_line: proc (buf_ptr, buf_len, line_start_ptr, line_start_pos, line_len);

dcl  buf_ptr	        ptr;
dcl  buf_len	        fixed bin (21);
dcl  line_start_ptr	        ptr;
dcl  line_start_pos	        fixed bin (21);
dcl  line_len	        fixed bin (21);
dcl  next_NL	        fixed bin (21);
dcl  buffer	        char (buf_len) based (buf_ptr);

	if buf_len <= 0 then do;			/* Catch zero-length buffer */
	     line_start_ptr = null ();
	     return;
	end;

	if line_start_pos = 0 then
	     line_start_pos = 1;
	else do;
	     line_start_pos = line_start_pos + line_length; /* Move past prev line */
	     if line_start_pos > buf_len then do;	/* Could be at end if prev line didn't end in NL */
		line_start_ptr = null ();
		return;
	     end;
	     if substr (buffer, line_start_pos, 1) = NL then
		line_start_pos = line_start_pos + 1;	/* Bump past NL at end of prev line */
	     if line_start_pos > buf_len then do;	/* Check again for end */
		line_start_ptr = null ();
		return;
	     end;
	end;

	line_start_ptr = addcharno (buf_ptr, line_start_pos - 1);
	next_NL = index (substr (buffer, line_start_pos), NL);
	if next_NL = 0 then				/* No NL at buffer end */
	     line_length = buf_len - line_start_pos + 1;
	else line_length = next_NL - 1;

     end get_next_line;

     end hasp_stream_;




		    hasp_util_.pl1                  12/20/82  1103.4rew 12/20/82  1052.8      107073



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* format: off */

/* Support functions for use by user-ring HASP I/O modules */

/* Created:  December 1979 by G. Palter */
/* Modified: 13 January 1980 by G. Palter to have the character to be treated as a space for compression/expansion be a
      parameter rather than fixed as the EBCDIC space character */
/* Modified: 22 July 1981 by G. Palter to compress only spaces in order to increase the performance of HASP I/O switches */
/* Modified: 15 December 1982 by G. Palter to return error_table_$short_record if the expand_text entry reaches the end of
      the input buffer normally without finding an end-of-record indicator */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


hasp_util_:
     procedure ();

	return;					/* not an entry */


/* Error returns */

OUTPUT_BUFFER_OVERFLOWS:
	if expand_entry then			/* reflect what part was processed */
	     P_input_text_used = input_text_used - 1;
	else P_input_text_used = input_text_used;
	P_output_buffer_used = output_buffer_used;
	P_code = error_table_$long_record;
	return;

BAD_DATA_FORMAT:
	P_input_text_used = input_text_used - 1;	/* this much processed successfully */
	P_output_buffer_used = output_buffer_used;
	P_code = error_table_$improper_data_format;
	return;


/* Parameters */

dcl  P_input_text_ptr pointer parameter;		/* -> text to be compressed or decompressed (I) */
dcl  P_input_text_lth fixed binary (21) parameter;	/* length of above text (I) */
dcl  P_input_text_used fixed binary (21) parameter;	/* amount of above text processed (I/O) */

dcl  P_output_buffer_ptr pointer parameter;		/* -> buffer to hold resulting text (I) */
dcl  P_output_buffer_lth fixed binary (21) parameter;	/* size of above buffer (I) */
dcl  P_output_buffer_used fixed binary (21) parameter;	/* amount of above buffer used (I/O) */

dcl  P_space character (1) aligned parameter;		/* treated as a space for compression/expansion (I) */

dcl  P_code fixed binary (35) parameter;		/* status code (O) */


/* Local copies of parameters */

dcl  input_text_ptr pointer;
dcl  (input_text_lth, input_text_used) fixed binary (21);

dcl  output_buffer_ptr pointer;
dcl  (output_buffer_lth, output_buffer_used) fixed binary (21);

dcl  space character (1);


/* Remaining declarations */

dcl  input_text character (input_text_lth) unaligned based (input_text_ptr);
dcl  input_text_array (input_text_lth) character (1) unaligned based (input_text_ptr);

dcl  output_buffer character (output_buffer_lth) unaligned based (output_buffer_ptr);
dcl  output_buffer_array (output_buffer_lth) character (1) unaligned based (output_buffer_ptr);

dcl  scb_char character (1) unaligned based (scb_char_ptr);
dcl  1 scb unaligned based (scb_char_ptr) like hasp_scb_byte;
dcl  1 not_compressed_scb unaligned based (scb_char_ptr) like hasp_not_compressed_scb_byte;
dcl  1 compressed_scb unaligned based (scb_char_ptr) like hasp_compressed_scb_byte;
dcl  scb_char_ptr pointer;

dcl  expand_entry bit (1) aligned;			/* ON => expand_text entry; OFF => compress_text entry */

dcl  space_space character (2);

dcl  the_character character (1) unaligned;
dcl  is_space bit (1) aligned;

dcl  (amount_to_scan, first_duplicate_idx, compression_count, count) fixed binary (21);

dcl  found_eor bit (1) aligned;			/* found end-of-record while expanding */

/* format: off */
dcl (error_table_$improper_data_format, error_table_$long_record, error_table_$short_record)
	fixed binary (35) external;
/* format: on */

dcl  (addr, index, min, substr, verify) builtin;
%page;
/* Compress text:  apply HASP compression algorithm on the supplied text, placing result into given output buffer */

compress_text:
     entry (P_input_text_ptr, P_input_text_lth, P_input_text_used, P_output_buffer_ptr, P_output_buffer_lth,
	P_output_buffer_used, P_space, P_code);

	expand_entry = "0"b;

	input_text_ptr = P_input_text_ptr;
	input_text_lth = P_input_text_lth;
	input_text_used = P_input_text_used;

	output_buffer_ptr = P_output_buffer_ptr;
	output_buffer_lth = P_output_buffer_lth;
	output_buffer_used = P_output_buffer_used;

	space = P_space;
	space_space = space || space;


	call add_scb_char ();			/* add an initial SCB for this piece of text */

	do while (input_text_used < input_text_lth);

	     amount_to_scan =
		min ((input_text_lth - input_text_used),
		(HASP_MAX_NOT_COMPRESSED_TEXT_LTH - not_compressed_scb.count));

	     first_duplicate_idx = index (substr (input_text, (input_text_used + 1), amount_to_scan), space_space);

/*	     do first_duplicate_idx = 1 to (amount_to_scan - 1) */
/*		while (substr (input_text, (input_text_used+first_duplicate_idx), 1) */
/*		      ^= substr (input_text, (input_text_used+first_duplicate_idx+1), 1)); */
/*	     end; */
/* search for first duplicated character */


/*	     if first_duplicate_idx = amount_to_scan */
	     if first_duplicate_idx = 0 then do;

/* No duplicates found: in this portion of the text, no duplicate characters were found so this portion will be copied
   directly to the output buffer.  The size of this substring was computed to not overflow the possibly partially-used SCB
   already at the end of the output buffer */

		call copy_for_compression (amount_to_scan);
		if input_text_used < input_text_lth then call add_scb_char ();
	     end;


	     else do;

/* Duplicate characters found: copy any portion of the string before these characters; if more than two of this character
   appears in the string, use the compressed form of the SCB to save space in the output buffer */

		if first_duplicate_idx > 1 then	/* some text appears before the duplicates */
		     call copy_for_compression (first_duplicate_idx - 1);

		the_character = substr (input_text, (input_text_used + 1), 1);
		is_space = (the_character = space);
		compression_count = verify (substr (input_text, (input_text_used + 1)), the_character) - 1;
		if compression_count = -1 then	/* rest of string is the same character */
		     compression_count = input_text_lth - input_text_used;

		if compression_count > 2 then do;	/* compression is possible */
		     if not_compressed_scb.count = 0 then output_buffer_used = output_buffer_used - 1;
		     count = compression_count;
		     do while (count > 0);
			call add_scb_char ();
			scb.not_compressed = "0"b;
			compressed_scb.not_blank = ^is_space;
			compressed_scb.count = min (count, HASP_MAX_COMPRESSED_TEXT_LTH);
			if ^is_space then do;
			     if output_buffer_used = output_buffer_lth then do;
				output_buffer_used = output_buffer_used - 1;
				go to OUTPUT_BUFFER_OVERFLOWS;
			     end;			/* be sure to flush the SCB before returning */
			     output_buffer_used = output_buffer_used + 1;
			     substr (output_buffer, output_buffer_used, 1) = the_character;
			end;
			count = count - compressed_scb.count;
			input_text_used = input_text_used + compressed_scb.count;
		     end;
		     if input_text_used < input_text_lth then call add_scb_char ();
		end;

		else do;				/* duplicate is too short to benifit from compression */
		     call copy_for_compression (compression_count);
		     if (not_compressed_scb.count = HASP_MAX_NOT_COMPRESSED_TEXT_LTH)
			& (input_text_used < input_text_lth) then
			call add_scb_char ();
		end;
	     end;
	end;


	P_input_text_used = input_text_used;		/* reflect what was done to caller */
	P_output_buffer_used = output_buffer_used;
	P_code = 0;

	return;
%page;
/* Expand text:  apply the inverse of the HASP compression algorithm on the supplied text, placing the result into the
   given output buffer.  If the entire input text is successfully processed but an end-of-record string control byte (SCB)
   is not found, error_table_$short_record will be returned */

expand_text:
     entry (P_input_text_ptr, P_input_text_lth, P_input_text_used, P_output_buffer_ptr, P_output_buffer_lth,
	P_output_buffer_used, P_space, P_code);

	expand_entry = "1"b;			/* for output overflow error handling */

	input_text_ptr = P_input_text_ptr;
	input_text_lth = P_input_text_lth;
	input_text_used = P_input_text_used;

	output_buffer_ptr = P_output_buffer_ptr;
	output_buffer_lth = P_output_buffer_lth;
	output_buffer_used = P_output_buffer_used;

	space = P_space;

	found_eor = "0"b;				/* haven't seen EOR yet */


	do while (input_text_used < input_text_lth);

	     input_text_used = input_text_used + 1;	/* have picked up an SCB */
	     scb_char_ptr = addr (input_text_array (input_text_used));

	     if scb_char = HASP_EOR_SCB then do;	/* found the end of a record */
		found_eor = "1"b;
		go to RETURN_FROM_EXPAND_TEXT;
	     end;


	     else if scb.not_compressed then do;

/* A piece of not compressed text:  simply copy it to the output buffer */

		count = not_compressed_scb.count;

		if (input_text_used + count) > input_text_lth then go to BAD_DATA_FORMAT;
						/* not enough text in input stream */
		if (output_buffer_used + count) > output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS;

		substr (output_buffer, (output_buffer_used + 1), count) =
		     substr (input_text, (input_text_used + 1), count);

		input_text_used = input_text_used + count;
		output_buffer_used = output_buffer_used + count;
	     end;


	     else do;

/* A piece of compressed text:  duplicate the requested character in the output buffer */

		count = compressed_scb.count;

		if compressed_scb.not_blank then do;	/* not space: get the character */
		     if (input_text_used + 1) > input_text_lth then go to BAD_DATA_FORMAT;
		     input_text_used = input_text_used + 1;
		     the_character = substr (input_text, input_text_used, 1);
		end;

		else the_character = space;		/* compressed character is a space */

		if (output_buffer_used + count) > output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS;

		substr (output_buffer, (output_buffer_used + 1), count) = copy (the_character, count);

		output_buffer_used = output_buffer_used + count;
	     end;
	end;


RETURN_FROM_EXPAND_TEXT:
	P_input_text_used = input_text_used;
	P_output_buffer_used = output_buffer_used;

	if found_eor then				/* processing terminated at end-of-record */
	     P_code = 0;
	else P_code = error_table_$short_record;	/* processing terminated at end of input text */

	return;
%page;
/* Add an SCB character to the output buffer */

add_scb_char:
     procedure ();

	if output_buffer_used = output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS;

	output_buffer_used = output_buffer_used + 1;

	scb_char_ptr = addr (output_buffer_array (output_buffer_used));

	scb.not_eor = "1"b;
	scb.not_compressed = "1"b;
	not_compressed_scb.count = 0;

	return;

     end add_scb_char;



/* Copy a piece of text from the input string to the output buffer and update the SCB character count */

copy_for_compression:
     procedure (P_n_characters);

dcl  P_n_characters fixed binary (21) parameter;
dcl  n_characters fixed binary (21);

	n_characters = P_n_characters;

	if (output_buffer_used + n_characters) > output_buffer_lth then go to OUTPUT_BUFFER_OVERFLOWS;

	substr (output_buffer, (output_buffer_used + 1), n_characters) =
	     substr (input_text, (input_text_used + 1), n_characters);
	output_buffer_used = output_buffer_used + n_characters;

	not_compressed_scb.count = not_compressed_scb.count + n_characters;

	input_text_used = input_text_used + n_characters; /* advance "pointer" past text already compressed */

	return;

     end copy_for_compression;
%page;
%include hasp_srcb_scb_bytes;

     end hasp_util_;




		    hasp_workstation_.pl1           10/17/88  1109.4r w 10/17/88  1034.1      792657



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/* format: off */

/* I/O Module for communications with a HASP workstation: This I/O module is designed for use by the I/O daemon's RJE
   software (remote_driver_).  It communicates with the HASP workstation through a TTY channel controlled by the ring-0
   HASP demultiplexer.

   As each TTY channel connected through the HASP demultiplexer communicates with only a single device of the physical
   HASP workstation, this I/O module will ensure that all I/O switches attached to a given channel have the same device
   type.  (Multiple I/O switches are allowed to support multiple request types being attached to the same channel.) */

/* Created:  January 1980 by G. Palter */
/* Modified: 1 September 1980 by G. Palter to remove stream mode support */
/* Modified: 2 December 1980 by G. Palter to properly set return code for io_call control order */
/* Modified: 18 December 1980 by G. Palter to support -terminal_type for input/output translations */
/* Modified: 13 January 1981 by G. Palter to pass the representation of a space in the transmission medium's character
      code to hasp_util_ */
/* Modified: 22 July 1981 by G. Palter to convert to version 2 dial_manager_ and invoke release_channel when done with a
      particular channel */
/* Modified: 25 December 1981 by G. Palter to support set_forms control order */
/* Modified: 26 July 1982 by G. Palter to add get_channel_info control order */
/* Modified: October 1982 by G. Palter to drastically improve write_record performance by changing the order of calls to
      hcs_$tty_order, hcs_$tty_write, and ipc_$block and to use mvt_ rather than the PL/I translate builtin where
      appropriate */
/* Modified: 14 December 1982 by G. Palter to support "s0" as a valid carriage control sequence (HASP #008), to fix bugs
      in the read_record entrypoint's handling of partial or very long input records (HASP #001 and HASP #002), and to
      insure proper behavior of the read_record entrypoint when the input record will not fit in the caller's buffer */
/* Modified: 12 February 1985 by Jim Homan to support HASP operator consoles as message coordinator consoles:
      add read_record_timeout, write_record_timeout, set_event_channel and set_term_type control orders;
      add -suppress_dial_manager control arg.
      Also removed calls to convert_ipc_code_, changed substraddr to addcharno,
      created timer_manager_constants include file. */

/****^  HISTORY COMMENTS:
  1) change(87-03-17,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030):
     Changed ttd_version to ttd_version_3.
  2) change(87-04-03,Beattie), approve(87-04-06,MCR7656),
     audit(87-07-30,Parisek), install(87-08-03,MR12.1-1055):
     Add support for control orders necessary to use operator subchannel on
     HASP workstation multiplexer as login channels.
                                                   END HISTORY COMMENTS */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */


hasp_workstation_:
     procedure ();

	return;					/* not an entry */


/* Parameters */

dcl  P_iocb_ptr pointer parameter;			/* *: -> I/O switch being operated upon */
dcl  P_code fixed binary (35) parameter;

dcl  P_attach_options (*) character (*) varying parameter;	/* attach: attachment arguments */
dcl  P_loud_sw bit (1) parameter;			/* attach: ON => attachment errors should call com_err_ */

dcl  P_open_mode fixed binary parameter;		/* open: opening mode */
dcl  P_open_sw bit (1) parameter;			/* open: obsolete parameter */

dcl  P_record_lth fixed binary (21) parameter;		/* read_record: set to size of terminal_io_record read into
						   buffer in characters;
						   get_chars: set to # of characters read into buffer;
						   write_record, put_chars: size of terminal_io_record to be
						   written in characters */

dcl  P_buffer_ptr pointer parameter;			/* read_record, get_chars: -> area to place result of read */
dcl  P_buffer_lth fixed binary (21) parameter;		/* read_record, get_chars: size of area in characters */

dcl  P_record_ptr pointer parameter;			/* write_record, put_chars: -> terminal_io_record
						   to be written */

dcl  P_order character (*) parameter;			/* control: name of control order to be performed */
dcl  P_info_ptr pointer parameter;			/* control: -> additional information required to execute the
						   control order */

dcl  P_new_modes character (*) parameter;		/* modes: new modes to be set */
dcl  P_old_modes character (*) parameter;		/* modes: set to modes in effect before change */
dcl  P_timeout fixed bin (71) parameter;		/* read_record_timed: */
dcl  P_chars_sent fixed bin (21) parameter;		/* write_record_timed: */

/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);

dcl  temp_state fixed bin;
dcl  based_state fixed bin based;

dcl  argument character (argument_lth) based (argument_ptr);/* based on attach options */
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  loud_sw bit (1) aligned;

dcl  open_mode fixed binary;

dcl  order character (32);
dcl  info_ptr pointer;


/* Remaining declarations */

dcl  event_channel fixed bin (71) based;

dcl  system_area area aligned based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  argument_idx fixed binary;			/* # of attach option being processed */

dcl  (tty_channel, device_name) character (32);		/* required components of attach description */
dcl  have_comm bit (1) aligned;			/* ON => -comm option given (required) */
dcl  terminal_type character (32);			/* terminal type specifying translations (optional) */
dcl  block_on_io_sw bit (1) aligned;			/* OFF => -no_block given */
dcl  suppress_dial_manager_sw bit (1) aligned;		/* ON => -suppress_dial_manager given */
dcl  other_attach_options character (256) varying;	/* optional portions supplied by caller */
dcl  timeout fixed bin (71);
dcl  stop_time fixed bin (71);

dcl  device_type fixed binary;			/* local copy used for argument processing */
dcl  idx fixed binary;

dcl  character_value character (32);			/* unused values from argument processing */
dcl  numeric_value fixed binary (35);

dcl  1 ttd aligned like terminal_type_data;		/* used to call ttt_info_$terminal_data */

dcl  1 dma aligned like dial_manager_arg;		/* used to attach the channel */

dcl  1 local_event_wait_info aligned like event_wait_info;	/* for calls to ipc_$block */

dcl  dialup_msg_channel character (32);			/* arguments to convert_dial_message_ */
dcl  1 dialup_msg_flags aligned,
       2 dialed_up bit (1) unaligned,
       2 hungup bit (1) unaligned,
       2 control bit (1) unaligned,
       2 pad bit (33) unaligned;

dcl  state fixed binary;				/* MCS channel state value */

dcl  multiplexer_device_type fixed binary;		/* for "get_device_type" control order */

dcl  1 tty_modes aligned,				/* used to change MCS modes */
       2 modes_lth fixed binary,
       2 modes character (256);

dcl  1 read_status aligned,				/* for "read_status" control order */
       2 event_channel fixed binary (71),		/* channel to block on waiting for input to arrive */
       2 input_available bit (1);			/* ON => data in ring-0 waiting to be read */

dcl  1 write_status aligned,				/* for "write_status" control order */
       2 event_channel fixed binary (71),		/* channel to block on waiting for write to complete */
       2 output_pending bit (1);			/* ON => data in ring-0 waiting to be sent */

dcl  ips_mask bit (36);				/* IPS mask */

dcl  cv_string_buffer character (cv_string_buffer_lth) based (cv_string_buffer_ptr);
dcl  cv_string_buffer_used character (cv_string_buffer_used_lth) based (cv_string_buffer_ptr);
dcl  (cv_string_buffer_lth, cv_string_buffer_used_lth) fixed binary (21);
dcl  (cv_string_buffer_ptr, new_cv_string_buffer_ptr) pointer;

dcl  io_buffer character (io_buffer_lth) unaligned based (io_buffer_ptr);
dcl  (io_buffer_lth, io_buffer_used, io_buffer_read) fixed binary (21);
dcl  io_buffer_ptr pointer;				/* buffer for I/O to/from the channel */

dcl  cv_string_buffer_space character (384);		/* local space large enough for most conversions */
dcl  io_buffer_space character (256) unaligned;		/* local space large enough for most I/O */

dcl  (compress_code, expand_code) fixed binary (35);	/* code from hasp_util_$compress_text/expand_text */

dcl  terminal_io_record_header_lth fixed binary (21);

dcl  previous_data character (64) varying;		/* large enough for an SCB and associated data */

dcl  (have_srcb, more_data_needed) bit (1) aligned;

dcl  srcb_read character (1);				/* SRCB read from the device */

dcl  n_extra_records fixed binary;			/* used to calculate output I/O buffer size */

dcl  srcb character (1) unaligned based (srcb_ptr);	/* SRCB character being constructed/interpreted */
dcl  srcb_ptr pointer;

dcl  1 hasp_printer_srcb unaligned based (srcb_ptr) like hasp_printer_srcb_byte;

dcl  more_srcbs_needed bit (1) aligned;			/* local state used to perform output slewing */
dcl  (n_last_opcode, local_slew_count) fixed binary;

dcl  pid bit (36) aligned based (info_ptr);		/* data used by "assign_to_user_process" control order */
dcl  detachflag fixed bin aligned based (info_ptr);	/* data used by "detach_user_process" control order */
dcl  line_type fixed bin based (info_ptr);		/* data used by "set_line_type" control order */

dcl  1 read_status_info aligned like read_status based (info_ptr);
						/* data used by "read_status" control order */

dcl  1 hangup_proc_info aligned based (info_ptr),		/* data used by "hangup_proc" control order */
       2 procedure entry variable,			/* procedure to invoke when line is hungup */
       2 data_ptr pointer,				/* user's data to be supplied to said procedure */
       2 priority fixed binary;			/* priority of this event call channel */

dcl  1 get_channel_info aligned based (info_ptr) like tty_get_channel_info;

dcl  NAME character (32) static options (constant) initial ("hasp_workstation_");

/* format: off */
dcl (NUL		initial (""),
     ASCII_SPACE	initial (" "),
     EBCDIC_SPACE	initial ("@"))
	character (1) static options (constant);

dcl (UPPERCASE	initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE	initial ("abcdefghijklmnopqrstuvwxyz"))
	character (26) static options (constant);

dcl  ascii_to_ebcdic_$ae_table character (128) external;
dcl  ebcdic_to_ascii_$ea_table character (256) external;

dcl  error_table_$timeout fixed bin(35) ext static;
dcl  error_table_$invalid_device fixed bin(35) ext static;
dcl (error_table_$action_not_performed, error_table_$bad_conversion, error_table_$bad_mode, error_table_$badopt,
     error_table_$bigarg, error_table_$device_type_unknown, error_table_$eof_record, error_table_$improper_data_format,
     error_table_$inconsistent, error_table_$incorrect_device_type, error_table_$invalid_read, error_table_$invalid_write,
     error_table_$io_no_permission, error_table_$long_record, error_table_$noalloc, error_table_$noarg,
     error_table_$not_attached, error_table_$not_closed, error_table_$not_detached, error_table_$not_open,
     error_table_$null_info_ptr, error_table_$short_record, error_table_$smallarg, error_table_$unable_to_do_io,
     error_table_$undefined_order_request, error_table_$unimplemented_version, error_table_$wrong_no_of_args)
	fixed binary (35) external;
/* format: on */

dcl  com_err_ entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  convert_dial_message_
	entry (bit (72) aligned, character (*), character (*), fixed binary, 1 aligned like dialup_msg_flags,
	fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  dial_manager_$privileged_attach entry (pointer, fixed binary (35));
dcl  dial_manager_$release_channel entry (pointer, fixed binary (35));
dcl  get_group_id_ entry () returns (char (32));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hasp_util_$compress_text
	entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21),
	character (1) aligned, fixed binary (35));
dcl  hasp_util_$expand_text
	entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21),
	character (1) aligned, fixed binary (35));
dcl  hcs_$assign_channel entry (fixed binary (71), fixed binary (35));
dcl  hcs_$delete_channel entry (fixed binary (71), fixed binary (35));
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  hcs_$tty_detach_new_proc entry (fixed bin, bit (36) aligned, fixed bin, fixed bin (35));
dcl  hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35));
dcl  hcs_$tty_abort entry (fixed binary, fixed binary, fixed binary, fixed binary (35));
dcl  hcs_$tty_attach entry (character (*), fixed binary (71), fixed binary, fixed binary, fixed binary (35));
dcl  hcs_$tty_detach entry (fixed binary, fixed binary, fixed binary, fixed binary (35));
dcl  hcs_$tty_order entry (fixed binary, character (*), pointer, fixed binary, fixed binary (35));
dcl  hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_read
	entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary,
	fixed binary (35));
dcl  hcs_$tty_write
	entry (fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary,
	fixed binary (35));
dcl  ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1), bit (1));
dcl  iox_$err_no_operation entry ();
dcl  iox_$propagate entry (pointer);
dcl  ipc_$block entry (pointer, pointer, fixed binary (35));
dcl  ipc_$create_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$decl_ev_call_chn entry (fixed binary (71), entry, pointer, fixed binary, fixed binary (35));
dcl  ipc_$decl_ev_wait_chn entry (fixed binary (71), fixed binary (35));
dcl  ipc_$delete_ev_chn entry (fixed binary (71), fixed binary (35));
dcl  mvt_ entry (pointer, pointer, fixed binary (21), character (512) aligned);
dcl  requote_string_ entry (character (*)) returns (character (*));
dcl  terminate_process_ entry (char (*), ptr);
dcl  timer_manager_$alarm_wakeup entry (fixed binary (71), bit (2), fixed binary (71));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35));

dcl  (any_other, area, cleanup) condition;

dcl  (addcharno, addr, binary, clock, copy, currentsize, divide, dimension, hbound, index, lbound, length, ltrim, max,
     maxlength, min, mod, null, rel, rtrim, string, substr, translate, unspec) builtin;
%page;

/* Data describing a single switch attached through this I/O module */

dcl  1 had aligned based (had_ptr),
       2 attach_description character (256) varying,	/* attach description for this I/O switch */
       2 open_description character (24) varying,		/* open description (mode) */
       2 channel_info_ptr pointer,			/* -> description of the channel */
       2 top_of_page_sequence_ptr pointer,		/* -> description of slewing operations to reach next page */
       2 inside_page_sequence_ptr pointer,		/* -> ... next inside page (head sheet) */
       2 outside_page_sequence_ptr pointer,		/* -> ... next outside page (tail sheet) */
       2 default_forms character (32) varying,		/* default type of forms used on this switch (from -forms) */
       2 current_forms character (32) varying,		/* type of forms currently in use (set_forms control order) */
       2 translations,
         3 input character (512),			/* received data -> ASCII translate table */
         3 output character (512),			/* ASCII -> transmittable data translate table */
         3 space character (1),			/* an ASCII space in remote device's character code */
       2 chain,					/* chain of I/O switches attached to this channel */
         3 next pointer,
         3 previous pointer;

dcl  had_ptr pointer;


/* Data describing a single TTY channel attached through this I/O module */

dcl  1 channel_info aligned based (channel_info_ptr),
       2 name character (32),				/* name of channel described by this entry */
       2 device_type fixed binary,			/* type of device attached on this channel */
       2 devx fixed binary,				/* MCS identifier of this channel */
       2 event_channel fixed binary (71),		/* MCS signals events via this ipc_ channel */
       2 attach_event_channel fixed binary (71),		/* used to obtain the channel from the Answering Service */
       2 hads,					/* chain of I/O switches attached to this channel */
         3 first pointer,
         3 last pointer,
       2 held_input_ptr pointer,			/* -> input from this channel waiting for processing */
       2 forms character (32) varying,			/* type of forms last written to this device */
       2 chain,					/* chain of channels attached via this I/O module */
         3 previous pointer,
         3 next pointer,
       2 flags,
         3 attached bit (1) unaligned,			/* ON => channel has been attached from answering service */
         3 attach_channel_is_call bit (1) unaligned,	/* ON => attach channel has been converted to call channel */
         3 event_channel_assigned bit (1) unaligned,
         3 event_channel_created bit (1) unaligned,
         3 output_interrupted bit (1) unaligned,		/* ON => a write_record timed out and a resetwrite
						   must be done before further output */
         3 suppress_dial_manager bit (1) unaligned,
         3 block_on_io bit (1) unaligned,		/* ON => block on read and write IO operations */
         3 pad bit (29) unaligned;

dcl  channel_info_ptr pointer;

dcl  first_channel_info_ptr pointer internal static initial (null ());
dcl  last_channel_info_ptr pointer internal static initial (null ());


/* Slew sequence description:  the types of slewing performed by the I/O daemon (top-of-page/inside-psage/outside-page)
   must be translated into a sequence of operations intepretable by the HASP workstation.  These operations are either
   (1) skip N lines or (2) skip to channel N.  The sequences are specified in the attach description */

dcl  1 slew_sequence aligned based (slew_sequence_ptr),
       2 n_ops fixed binary,				/* # of operations required to do this type of slewing */
       2 ops (slew_sequence_n_ops refer (slew_sequence.n_ops)),
         3 count_or_channel fixed binary,		/* # of lines to skip or channel # */
         3 skip_to_channel bit (1);			/* ON => above value is channel #; OFF => it's a line count */

dcl  slew_sequence_ptr pointer;
dcl  slew_sequence_n_ops fixed binary;			/* used by attach entry to allocate this structure */


/* Held input:  The read_record operation may read more data from ring-0 than necessary; this data is held in this
   structure for later processing */

dcl  1 held_input aligned based (held_input_ptr),
       2 n_elements_used fixed binary (21),		/* # of characters still being held */
       2 n_elements_allocated fixed binary (21),		/* # of characters initially held */
       2 data character (held_input_n_elements_allocated refer (held_input.n_elements_allocated));

dcl  held_input_ptr pointer;
dcl  held_input_n_elements_allocated fixed binary (21);
%page;
/* Attach an I/O switch to a device of a HASP workstation */

hasp_workstation_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code = 0;					/* assume no errors yet */

	had_ptr = null ();				/* avoid freeing garbage if I/O switch already attached */

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_detached;	/* special case this error */
	     if loud_sw then call com_err_ (P_code, NAME, "For switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call cleanup_attachment ((0));


/* Process attachment options */

	if hbound (P_attach_options, 1) < 1 then
	     call abort_attachment (error_table_$noarg,
		"At least ""-comm"", ""-tty"", and  ""-device"" must be supplied.");

	allocate had in (system_area) set (had_ptr);

	have_comm = "0"b;				/* haven't seen -comm yet */
	tty_channel = "";				/* haven't seen -tty yet */
	device_name = "";				/* haven't seen -device yet */
	terminal_type = "";				/* haven't seen -terminal_type yet */

	block_on_io_sw = "1"b;			/* set the default values */
	suppress_dial_manager_sw = "0"b;

	other_attach_options = "";			/* optional stuff goes here */

	had.open_description = "";
	had.top_of_page_sequence_ptr,			/* haven't seen slew control information yet */
	     had.inside_page_sequence_ptr, had.outside_page_sequence_ptr = null ();
	had.default_forms, had.current_forms = "";	/* haven't seen -forms yet */
	call set_translation (had.translations.input,	/* assume input is EBCDIC */
	     addr (ebcdic_to_ascii_$ea_table), length (ebcdic_to_ascii_$ea_table));
	call set_translation (had.translations.output, addr (ascii_to_ebcdic_$ae_table),
	     length (ascii_to_ebcdic_$ae_table));
	had.translations.space = EBCDIC_SPACE;		/* default translations */
	had.channel_info_ptr = null ();		/* prevents abort from prematurely detaching channel */


	do argument_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);

	     argument_ptr = addcharno (addr (P_attach_options (argument_idx)), 4);
	     argument_lth = length (P_attach_options (argument_idx));

	     if substr (argument, 1, 1) ^= "-" then	/* do not allow non-control arguments */
		call abort_attachment (error_table_$wrong_no_of_args, "All options must be control arguments.");

	     if (argument = "-comm") then do;		/* communications module: must be "hasp" */
		character_value = get_string_argument ();
		if (argument ^= "hasp") then call abort_attachment (0, "Communications module must be ""hasp"".");
		have_comm = "1"b;			/* got the right value */
	     end;

	     else if (argument = "-tty") then		/* specification of TTY channel */
		tty_channel = get_string_argument ();

	     else if (argument = "-device") then do;	/* type of device on other end of channel */
		device_name = get_string_argument ();
		device_type = -1;
		do idx = lbound (HASP_DEVICE_NAMES, 1) to hbound (HASP_DEVICE_NAMES, 1) while (device_type = -1);
		     if HASP_DEVICE_NAMES (idx) = device_name then device_type = idx;
		end;
		if device_type = -1 then		/* unknown type */
		     call abort_attachment (error_table_$device_type_unknown,
			"Device type must be one of ^v(""^a"", ^)or ""^a""; not ""^a"".",
			(dimension (HASP_DEVICE_NAMES, 1) - 1), HASP_DEVICE_NAMES, device_name);
	     end;

	     else if (argument = "-terminal_type") | (argument = "-ttp") then do;
						/* terminal type: specifies input/output translations */
		terminal_type = get_string_argument ();
		terminal_type = translate (terminal_type, UPPERCASE, LOWERCASE);
		ttd.version = ttd_version_3;		/* try to get input/output translations */
		call ttt_info_$terminal_data (terminal_type, -1, 0, addr (ttd), code);
		if code ^= 0 then call abort_attachment (code, "-terminal_type ^a", terminal_type);
		if (ttd.tables.input_tr_ptr = null ()) | (ttd.tables.output_tr_ptr = null ()) then
		     call abort_attachment (0, "Terminal type ""^a"" does not specify input and output translations.",
			terminal_type);
		call set_translation (had.translations.input,
		     addr (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value),
		     dimension (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value, 1));
		call set_translation (had.translations.output,
		     addr (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value),
		     dimension (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value, 1));
		had.translations.space = translate (ASCII_SPACE, had.translations.output);
	     end;

	     else if (argument = "-physical_line_length") | (argument = "-pll") then do;
						/* supplied by calling I/O module:  ignored here */
		numeric_value = get_numeric_argument ();
		other_attach_options = other_attach_options || " -physical_line_length ";
		other_attach_options = other_attach_options || argument;
	     end;

	     else if (argument = "-ebcdic") then	/* supplied by calling I/O module:  ignored here */
		other_attach_options = other_attach_options || " -ebcdic";

	     else if (argument = "-ascii") then		/* hasp_workstation_ doesn't support ASCII data */
		call abort_attachment (0, "ASCII is not supported by this I/O module.");

	     else if (argument = "-horizontal_tab") | (argument = "-htab") then
		call abort_attachment (0, "Horizontal tabs are not supported by this I/O module.");

	     else if (argument = "-top_of_page") then do; /* specifies how to get to top of any page */
		call parse_slew_sequence (had.top_of_page_sequence_ptr);
		other_attach_options = other_attach_options || " -top_of_page ";
		other_attach_options = other_attach_options || argument;
	     end;

	     else if (argument = "-inside_page") then do; /* specifies how to get to top of inside page */
		call parse_slew_sequence (had.inside_page_sequence_ptr);
		other_attach_options = other_attach_options || " -inside_page ";
		other_attach_options = other_attach_options || argument;
	     end;

	     else if (argument = "-outside_page") then do;/* specifies how to get to top of outside page */
		call parse_slew_sequence (had.outside_page_sequence_ptr);
		other_attach_options = other_attach_options || " -outside_page ";
		other_attach_options = other_attach_options || argument;
	     end;

	     else if (argument = "-forms") then do;	/* specifies forms to be used for this switch */
		character_value = get_string_argument ();
		if argument_lth > maxlength (had.default_forms) then
		     call abort_attachment (error_table_$bigarg, "Forms name must be ^d characters or less.",
			maxlength (had.default_forms));
		character_value = translate (character_value, UPPERCASE, LOWERCASE);
		other_attach_options = other_attach_options || " -forms ";
		other_attach_options =
		     other_attach_options || requote_string_ (substr (character_value, 1, argument_lth));
		had.default_forms = substr (character_value, 1, argument_lth);
	     end;					/* will translate to proper code later */

	     else if (argument = "-suppress_dial_manager") then do;
		suppress_dial_manager_sw = "1"b;
		other_attach_options = other_attach_options || " -suppress_dial_manager";
	     end;

	     else if (argument = "-no_block") then do;
		block_on_io_sw = "0"b;
		other_attach_options = other_attach_options || " -no_block";
	     end;

	     else call abort_attachment (error_table_$badopt, """^a""", argument);
	end;					/* of argument processing loop */


/* Validate that all required information has been supplied and apply any needed defaults */

	if ^have_comm then				/* must specify -comm */
	     call abort_attachment (error_table_$noarg, """-comm""");

	if (tty_channel = "") then			/* must specify -tty */
	     call abort_attachment (error_table_$noarg, """-tty""");

	if (device_name = "") then			/* must specify -device */
	     call abort_attachment (error_table_$noarg, """-device""");

	if (device_type = HASP_PRINTER) then		/* only printers need slewing sequences */
	     if ((had.top_of_page_sequence_ptr = null ()) | (had.inside_page_sequence_ptr = null ())
		| (had.outside_page_sequence_ptr = null ())) then do;
						/* not all sequences supplied: default to skip to channel 1 */
		slew_sequence_n_ops = 1;
		allocate slew_sequence in (system_area) set (slew_sequence_ptr);
		slew_sequence.ops (1).count_or_channel = 1;
		slew_sequence.ops (1).skip_to_channel = "1"b;
		if (had.top_of_page_sequence_ptr = null ()) then had.top_of_page_sequence_ptr = slew_sequence_ptr;
		if (had.inside_page_sequence_ptr = null ()) then had.inside_page_sequence_ptr = slew_sequence_ptr;
		if (had.outside_page_sequence_ptr = null ()) then had.outside_page_sequence_ptr = slew_sequence_ptr;
	     end;
	     else ;				/* all sequences were specified */

	else					/* not printer: reject any slewing controls */
	     if ((had.top_of_page_sequence_ptr ^= null ()) | (had.inside_page_sequence_ptr ^= null ())
	     | (had.outside_page_sequence_ptr ^= null ())) then do;
	     if (had.outside_page_sequence_ptr ^= null ()) then idx = 3;
	     if (had.inside_page_sequence_ptr ^= null ()) then idx = 2;
	     if (had.top_of_page_sequence_ptr ^= null ()) then idx = 1;
	     call abort_attachment (error_table_$inconsistent,
		"""-^[top_of_page^;inside_page^;outside_page^]"" may not be specified for the ^a device.", idx,
		device_name);
	end;

	if (device_type ^= HASP_PRINTER) then		/* do not allow forms if not a printer */
	     if (had.default_forms ^= "") then
		call abort_attachment (error_table_$inconsistent,
		     """-forms"" may not be specified for the ^a device.", device_name);

	if (had.default_forms ^= "") then do;		/* translate to code used by foreign device */
	     had.default_forms = translate (had.default_forms, had.translations.output);
	     had.current_forms = had.default_forms;	/* start out by using this forms specification */
	end;


/* Build the attach description */

	had.attach_description = rtrim (NAME);
	had.attach_description = had.attach_description || " -comm hasp -tty ";
	had.attach_description = had.attach_description || rtrim (tty_channel);
	had.attach_description = had.attach_description || " -device ";
	had.attach_description = had.attach_description || rtrim (device_name);
	if (terminal_type ^= "") then do;		/* optional -terminal_type was given */
	     had.attach_description = had.attach_description || " -terminal_type ";
	     had.attach_description = had.attach_description || rtrim (terminal_type);
	end;
	had.attach_description = had.attach_description || other_attach_options;


/* Find the description of this channel:  Validate that all I/O switches attached to this channel are of for the same type
   of I/O daemon device (printer, reader, etc.) */

	do channel_info_ptr = first_channel_info_ptr repeat (channel_info.chain.next)
	     while (channel_info_ptr ^= null ());
	     if channel_info.name = tty_channel then go to FOUND_CHANNEL;
	end;

FOUND_CHANNEL:
	if (channel_info_ptr = null ()) then do;	/* first use of the channel */
	     allocate channel_info in (system_area) set (channel_info_ptr);
	     channel_info.name = tty_channel;
	     channel_info.device_type = device_type;
	     channel_info.devx, channel_info.event_channel, channel_info.attach_event_channel = -1;
	     channel_info.hads = null ();		/* no switches connected yet */
	     channel_info.held_input_ptr = null ();	/* no read ahead yet */
	     channel_info.forms = "";			/* no forms used yet */
	     string (channel_info.flags) = ""b;		/* not attached yet */
	     if first_channel_info_ptr = null () then
		first_channel_info_ptr = channel_info_ptr;
	     else last_channel_info_ptr -> channel_info.chain.next = channel_info_ptr;
	     channel_info.chain.previous = last_channel_info_ptr;
	     channel_info.chain.next = null ();
	     last_channel_info_ptr = channel_info_ptr;
	end;

	else					/* channel in use: insure that device type is correct */
	     if channel_info.device_type ^= device_type then
	     call abort_attachment (error_table_$incorrect_device_type, "Device type of ^a is ""^a""; not ""^a"".",
		tty_channel, HASP_DEVICE_NAMES (channel_info.device_type), HASP_DEVICE_NAMES (device_type));

	if channel_info.hads.first = null () then
	     channel_info.hads.first = had_ptr;		/* first switch for this channel */
	else channel_info.hads.last -> had.chain.next = had_ptr;
	had.chain.previous = channel_info.hads.last;
	had.chain.next = null ();
	channel_info.hads.last = had_ptr;

	had.channel_info_ptr = channel_info_ptr;


/* Acquire and attach the channel if necessary */

	if channel_info.devx = -1 then do;

	     channel_info.block_on_io = block_on_io_sw;
	     channel_info.suppress_dial_manager = suppress_dial_manager_sw;
	     if suppress_dial_manager_sw then goto ASSUME_ATTACHED;

/* Request the TTY channel from the Answering Service */

	     call ipc_$create_ev_chn (channel_info.attach_event_channel, code);
	     if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel.");

	     dma.version = dial_manager_arg_version_2;
	     dma.dial_channel = channel_info.attach_event_channel;
	     dma.channel_name = tty_channel;
	     dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = "";

	     call dial_manager_$privileged_attach (addr (dma), code);
	     if code = error_table_$action_not_performed then go to ASSUME_ATTACHED;
	     if code ^= 0 then call abort_attachment (code, "Attempting to attach ^a.", tty_channel);

	     event_wait_channel.n_channels = 1;
	     event_wait_channel.channel_id (1) = channel_info.attach_event_channel;

WAIT_FOR_ANSWERING_SERVICE:
	     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
						/* wait for answering service to give it to us */
	     if code ^= 0 then call abort_attachment (code, "Waiting for attachment to ^a.", tty_channel);

	     call convert_dial_message_ (unspec (local_event_wait_info.message), dialup_msg_channel, ((32)" "), (0),
		dialup_msg_flags, code);
	     if code ^= 0 then call abort_attachment (code, "Interpreting attachment to ^a.", tty_channel);

	     if ^dialup_msg_flags.dialed_up then do;	/* seems to be a wakeup for some other channel */
		call com_err_ (0, NAME,
		     "For switch ^a: Unexpected signal from answering service - ^[hangup^;control^] for channel ^a.",
		     iocb_ptr -> iocb.name, dialup_msg_flags.hungup, dialup_msg_channel);
		go to WAIT_FOR_ANSWERING_SERVICE;
	     end;


/* Create the event channel for ring-0:  try using a special channel first */

ASSUME_ATTACHED:
	     channel_info.attached = "1"b;		/* we have the channel from the answering service now */

	     call hcs_$assign_channel (channel_info.event_channel, code);

	     if code = 0 then
		channel_info.event_channel_assigned = "1"b;
	     else do;				/* couldn't get fast channel: try standard one */
		call ipc_$create_ev_chn (channel_info.event_channel, code);
		if code ^= 0 then call abort_attachment (code, "Creating ipc_ channel.");
		channel_info.event_channel_created = "0"b;
	     end;


/* Attach the channel through the ring-0 HASP multiplexer in MCS, validate
   the supplied device type, and set its modes to "rawi,rawo" */

	     call hcs_$tty_attach (tty_channel, channel_info.event_channel, channel_info.devx, state, code);
	     if ^suppress_dial_manager_sw then
		if state ^= 5 then code = error_table_$io_no_permission;
	     if suppress_dial_manager_sw then
		if code = error_table_$action_not_performed then
						/* This means the mpx is down */
		     call abort_attachment (error_table_$invalid_device,
						/* But the message coordinator likes this error code
						   to mean mpx down. */
			"The parent multiplexer has not been loaded.");
	     if code ^= 0 then call abort_attachment (code, "Unable to attach to ^a.", tty_channel);

	     call hcs_$tty_order (channel_info.devx, "get_device_type", addr (multiplexer_device_type), state, code);
	     if ^suppress_dial_manager_sw then
		if state ^= 5 then code = error_table_$io_no_permission;
	     if (code = 0) then
		if (channel_info.device_type = multiplexer_device_type) then
		     ;				/* proper device type for this channel */
		else call abort_attachment (error_table_$incorrect_device_type,
			"Device type of ^a is ""^a""; not ""^a"".", tty_channel,
			HASP_DEVICE_NAMES (multiplexer_device_type), HASP_DEVICE_NAMES (channel_info.device_type));
	     else if (code = error_table_$undefined_order_request) then
		call abort_attachment (0, "^a is not connected to a HASP multiplexer.", tty_channel);
	     else call abort_attachment (code, "Unable to determine device type of ^a.", tty_channel);

	     tty_modes.modes = "rawi,rawo";
	     tty_modes.modes_lth = length (tty_modes.modes);
	     call hcs_$tty_order (channel_info.devx, "modes", addr (tty_modes), state, code);
	     if ^suppress_dial_manager_sw then
		if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then call abort_attachment (code, "Unable to set initial modes for ^a.", tty_channel);
	end;


/* Mask and complete construction of the IOCB */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (had.attach_description);
	iocb_ptr -> iocb.attach_data_ptr = had_ptr;
	iocb_ptr -> iocb.open = hasp_workstation_open;
	iocb_ptr -> iocb.control = hasp_workstation_control_before_open;
	iocb_ptr -> iocb.detach_iocb = hasp_workstation_detach;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

RETURN_FROM_ATTACH:
	P_code = code;
	return;
%page;
/* Open an I/O switch connected to a HASP workstation:  only record oriented openings are supported */

hasp_workstation_open:
     entry (P_iocb_ptr, P_open_mode, P_open_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;

	if ^((open_mode = Sequential_input) | (open_mode = Sequential_output) | (open_mode = Sequential_input_output))
	then do;
	     P_code = error_table_$bad_mode;
	     return;
	end;

	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	if (channel_info.device_type = HASP_READER) then
	     if (open_mode = Sequential_output) then do;	/* reader opened for output only */
		P_code = error_table_$bad_mode;
		return;
	     end;

	if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then
	     if (open_mode = Sequential_input) then do;	/* printer/punch opened for input only */
		P_code = error_table_$bad_mode;
		return;
	     end;

	had.open_description = rtrim (iox_modes (open_mode));

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	if ((open_mode = Sequential_input) | (open_mode = Sequential_input_output)) then
	     iocb_ptr -> iocb.read_record = hasp_workstation_read_record;

	if ((open_mode = Sequential_output) | (open_mode = Sequential_input_output)) then
	     iocb_ptr -> iocb.write_record = hasp_workstation_write_record;

	iocb_ptr -> iocb.control = hasp_workstation_control;
	iocb_ptr -> iocb.modes = hasp_workstation_modes;

	iocb_ptr -> iocb.close = hasp_workstation_close;

	iocb_ptr -> iocb.detach_iocb = hasp_workstation_detach;

	iocb_ptr -> iocb.open_descrip_ptr = addr (had.open_description);
						/* it's now open */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;
	return;
%page;
/* Close an I/O switch connected to a HASP workstation */

hasp_workstation_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;

	if iocb_ptr -> iocb.open_descrip_ptr = null () then do;
	     P_code = error_table_$not_open;
	     return;
	end;

	ips_mask = ""b;

	on condition (cleanup) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = hasp_workstation_open;
	iocb_ptr -> iocb.detach_iocb = hasp_workstation_detach;
	iocb_ptr -> iocb.control = hasp_workstation_control_before_open;

	iocb_ptr -> iocb.modes, iocb_ptr -> iocb.read_record, iocb_ptr -> iocb.write_record = iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = 0;

	return;
%page;
/* Detach an I/O switch from a device of a HASP workstation */

hasp_workstation_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;

	if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	call cleanup_attachment (code);		/* remove this switch and the channel if necessary */

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask (((36)"0"b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* it's detached */

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	P_code = code;				/* in case trouble freeing the channel */
	return;
%page;
/* Read a record:  read a single record from the device, returning a "standard" terminal_io_record structure */

hasp_workstation_read_record:
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_lth, P_record_lth, P_code);

	call init_read ();

	if ^channel_info.block_on_io then
	     timeout = 0;
	else timeout = -1;
	goto READ_JOIN;

hasp_workstation_read_record_timed:			/* For read_record_timeout control order */
     entry (P_iocb_ptr, P_buffer_ptr, P_buffer_lth, P_record_lth, P_code, P_timeout);

	call init_read ();

	if ^channel_info.block_on_io then do;
	     P_code = error_table_$inconsistent;
	     return;
	end;

	timeout = P_timeout;

READ_JOIN:
	stop_time = clock () + timeout;
	code = 0;

	if (channel_info.device_type = HASP_PRINTER) | (channel_info.device_type = HASP_PUNCH) then do;
	     P_code = error_table_$invalid_read;	/* can't read from printer or punch */
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();
	cv_string_buffer_ptr = null ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
	     if cv_string_buffer_ptr ^= null () then
		if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area);
	end;


/* Validate that there is room in the buffer to hold some actual data in addition to a terminal_io_record header */

	terminal_io_record_ptr = P_buffer_ptr;

	terminal_io_record_header_lth =		/* # of characters of buffer occupied by record's header */
	     4 * (binary (rel (addr (terminal_io_record.data)), 18, 0) - binary (rel (terminal_io_record_ptr), 18, 0));

	if terminal_io_record_header_lth >= P_buffer_lth then do;
	     code = error_table_$smallarg;		/* supplied buffer is just TOO small */
	     return;
	end;

	terminal_io_record_n_elements = P_buffer_lth - terminal_io_record_header_lth;
						/* # of actual characters that will fit into the buffer */


/* Obtain and unpack a record:  a record is constructed from any data obtained in prior calls to read_record in addition
   to whatever data must be read from ring-0 in this call to complete the record.  Unpacking is performed on the data in
   256 character sections until hasp_util_$expand_text detects the end-of-record sequence in the stream */

	cv_string_buffer_ptr = addr (cv_string_buffer_space);
	cv_string_buffer_lth = length (cv_string_buffer_space);
	cv_string_buffer_used_lth = 0;		/* start putting data into automatic */

	previous_data = "";				/* piece left from previous read */

	srcb_ptr = addr (srcb_read);			/* a place to put the SRCB ... */
	have_srcb = "0"b;				/* ... which hasn't been found yet */

	more_data_needed = "1"b;


	do while (more_data_needed);

/* Select source of data for this time around:  if necessary, data will be read from ring-0 */

	     if channel_info.held_input_ptr ^= null () then do;
						/* read ahead: process as much of the block as can be used */
		io_buffer_ptr = addr (channel_info.held_input_ptr -> held_input.data);
		io_buffer_lth = channel_info.held_input_ptr -> held_input.n_elements_allocated;
		io_buffer_read = channel_info.held_input_ptr -> held_input.n_elements_used;
	     end;

	     else do;				/* no more read ahead: obtain more data from ring-0 */
		io_buffer_ptr = addr (io_buffer_space);
		io_buffer_lth = length (io_buffer_space);
		call read_io_buffer ();		/* sets io_buffer_read */
		if code ^= 0 then go to RETURN_FROM_READ_RECORD;
		if io_buffer_read = 0 then do;
		     terminal_io_record.n_elements = 0;
		     P_record_lth = 0;
		     P_code = 0;
		     return;
		end;
	     end;

	     if length (previous_data) > 0 then do;	/* some data left over from previous junk: merge them */
		held_input_n_elements_allocated = length (previous_data) + io_buffer_read;
		allocate held_input in (system_area) set (held_input_ptr);
		held_input.n_elements_used = held_input.n_elements_allocated;
		substr (held_input.data, 1, length (previous_data)) = previous_data;
		substr (held_input.data, (length (previous_data) + 1), io_buffer_read) =
		     substr (io_buffer, 1, io_buffer_read);
		if io_buffer_ptr ^= addr (io_buffer_space) then
		     free channel_info.held_input_ptr -> held_input in (system_area);
		channel_info.held_input_ptr = held_input_ptr;
		io_buffer_ptr = addr (held_input.data);
		io_buffer_lth, io_buffer_read = held_input.n_elements_used;
		previous_data = "";
	     end;


/* Unpack the data:  stop when an end-of-record indicator is found */

	     if have_srcb then
		io_buffer_used = 0;			/* in middle of record: first character in buffer is SCB */
	     else do;				/* first part of record: first character is SRCB */
		srcb = substr (io_buffer, 1, 1);
		io_buffer_used = 1;
		have_srcb = "1"b;
	     end;

	     do while (more_data_needed & (io_buffer_used < io_buffer_read));

		call hasp_util_$expand_text (addr (io_buffer), io_buffer_read, io_buffer_used,
		     addr (cv_string_buffer), cv_string_buffer_lth, cv_string_buffer_used_lth, had.translations.space,
		     expand_code);

		if expand_code = 0 then more_data_needed = "0"b;
						/* found end of record indicator */

		else if expand_code = error_table_$short_record then ;
						/* took entire buffer but need more */

		else if expand_code = error_table_$long_record then do;
						/* overflowed the output buffer: grow it and continue */
		     cv_string_buffer_lth = 2 * cv_string_buffer_lth;
		     on condition (area)
			begin;			/* can't get enough room: record is not readable */
			code = error_table_$noalloc;
			go to RETURN_FROM_READ_RECORD;
		     end;
		     allocate cv_string_buffer in (system_area) set (new_cv_string_buffer_ptr);
		     revert condition (area);
		     new_cv_string_buffer_ptr -> cv_string_buffer_used = cv_string_buffer_used;
		     if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then
			free cv_string_buffer in (system_area);
		     cv_string_buffer_ptr = new_cv_string_buffer_ptr;
		end;

		else if (io_buffer_read - io_buffer_used) <= (HASP_MAX_NOT_COMPRESSED_TEXT_LTH + 1) then do;
						/* possibly need to read more data from ring-0 */
		     previous_data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used));
		     io_buffer_used = io_buffer_read;	/* force to read some more data */
		end;

		else do;				/* data is definitely improperly formatted */
		     code = error_table_$improper_data_format;
		     go to RETURN_FROM_READ_RECORD;
		end;
	     end;

	     if io_buffer_used = io_buffer_read then	/* have exhausted this buffer ... */
		if io_buffer_ptr ^= addr (io_buffer_space) then do;
		     free channel_info.held_input_ptr -> held_input in (system_area);
		     channel_info.held_input_ptr = null ();
		end;				/* ... so get rid of it so we can read some more */
	end;

	if io_buffer_used < io_buffer_read then do;	/* some data left over: save it */
	     held_input_n_elements_allocated = io_buffer_read - io_buffer_used;
	     allocate held_input in (system_area) set (held_input_ptr);
	     held_input.n_elements_used = held_input.n_elements_allocated;
	     held_input.data = substr (io_buffer, (io_buffer_used + 1), (io_buffer_read - io_buffer_used));
	     if io_buffer_ptr ^= addr (io_buffer_space) then free channel_info.held_input_ptr -> held_input;
	     channel_info.held_input_ptr = held_input_ptr;
	end;


/* Check for end of file:  An EOF record is a zero length record.  If an EOF record is found, return
   error_table_$eof_record, otherwise, convert the data in the record to ASCII */

	if (cv_string_buffer_used_lth = 0) then do;
	     code = error_table_$eof_record;
	     go to RETURN_FROM_READ_RECORD;
	end;

	else do;					/* data seems OK: convert it */
	     terminal_io_record.n_elements = min (terminal_io_record_n_elements, cv_string_buffer_used_lth);
	     if cv_string_buffer_used_lth > 0 then
		call mvt_ (addr (cv_string_buffer_used), addr (terminal_io_record_data_chars),
		     (terminal_io_record.n_elements), had.translations.input);
	     if cv_string_buffer_used_lth > terminal_io_record_n_elements then code = error_table_$long_record;
	end;					/* ... return as much as will fit */


/* Control reaches here iff the record is read/converted successfully:  complete the terminal_io_record structure */

	terminal_io_record.version = terminal_io_record_version_1;

	if (channel_info.device_type = HASP_CONSOLE) then terminal_io_record.device_type = TELEPRINTER_DEVICE;
	else if (channel_info.device_type = HASP_READER) then terminal_io_record.device_type = READER_DEVICE;

	terminal_io_record.slew_type = SLEW_BY_COUNT;	/* for console/reader, this is fixed */
	terminal_io_record.slew_count = 1;

	string (terminal_io_record.flags) = ""b;

	terminal_io_record.element_size = 9;

	P_record_lth = terminal_io_record_header_lth + terminal_io_record.n_elements;


/* Cleanup */

RETURN_FROM_READ_RECORD:
	if cv_string_buffer_ptr ^= null () then
	     if cv_string_buffer_ptr ^= addr (cv_string_buffer_space) then free cv_string_buffer in (system_area);

	P_code = code;
	return;
%page;
/* Write a record:  write a single record to the device.  This record represents part or all of a single line and should
   be the output of the prt_conv_ module using the remote_conv_ conversion routine */

hasp_workstation_write_record:
     entry (P_iocb_ptr, P_record_ptr, P_record_lth, P_code);

	timeout = -1;
	goto WRITE_JOIN;

hasp_workstation_write_record_timed:			/* for write_record_timout control order */
     entry (P_iocb_ptr, P_record_ptr, P_record_lth, P_code, P_timeout, P_chars_sent);

	timeout = P_timeout;
	if timeout < 0 then timeout = 0;		/* Make sure that timeout = -1 means non-timeout call */

WRITE_JOIN:
	if timeout >= 0 then stop_time = clock () + timeout;

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;
	code = 0;

	if channel_info.device_type = HASP_READER then do;/* can't write the card reader */
	     P_code = error_table_$invalid_write;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();
	io_buffer_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;				/* free any temporary buffers */
	     if io_buffer_ptr ^= null () then
		if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area);
	end;


/* Validate input:  insure that the caller has supplied a complete terminal I/O record; insure that the terminal input
   record contains character as opposed to binary data */

	terminal_io_record_ptr = P_record_ptr;

	if terminal_io_record.version ^= terminal_io_record_version_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	if mod (P_record_lth, 4) = 0 then		/* X+4-mod(X,4) fails when X is already a multiple of 4 */
	     if (4 * currentsize (terminal_io_record)) = P_record_lth then
		;				/* user supplied length agrees with computed length */
	     else do;
		P_code = error_table_$improper_data_format;
		return;
	     end;
	else					/* supplied length not multiple of 4:  must round it up */
	     if (4 * currentsize (terminal_io_record)) ^= (P_record_lth + 4 - mod (P_record_lth, 4)) then do;
	     P_code = error_table_$improper_data_format;
	     return;
	end;

	if terminal_io_record.binary | terminal_io_record.preslew | (terminal_io_record.element_size ^= 9) then do;
	     P_code = error_table_$improper_data_format;
	     return;
	end;


/* Convert the data to the character code used by the remote system (in place) */

	call mvt_ (addr (terminal_io_record_data_chars), addr (terminal_io_record_data_chars),
	     (terminal_io_record.n_elements), had.translations.output);


/* Compute size of I/O buffer required assuming no compression can be performed on the record.  If this size is not too
   large, the automatic buffer will be used; otherwise, a buffer will be allocated */

	io_buffer_lth =
	     max (terminal_io_record.n_elements, 1)
	     +
	     divide ((terminal_io_record.n_elements + HASP_MAX_NOT_COMPRESSED_TEXT_LTH - 1),
	     HASP_MAX_NOT_COMPRESSED_TEXT_LTH, 17, 0) +	/* SCBs for the text */
	     2;					/* SRCB and end-of-record SCB */

	if (channel_info.device_type = HASP_PRINTER) then do;
						/* line printer: must count extra records for SRCBs and
						   forms change (if necessary) */
	     if (had.current_forms ^= channel_info.forms) then
		io_buffer_lth = io_buffer_lth + 3 + max (length (had.current_forms), 1);
						/* SRCB, SCB, forms-name, EOR-SCB */
	     if (terminal_io_record.slew_type = SLEW_BY_COUNT) then
		n_extra_records = divide (terminal_io_record.slew_count, HASP_MAX_SLEW_COUNT, 17, 0);
	     else if (terminal_io_record.slew_type = SLEW_TO_TOP_OF_PAGE) then
		n_extra_records = had.top_of_page_sequence_ptr -> slew_sequence.n_ops - 1;
	     else if (terminal_io_record.slew_type = SLEW_TO_INSIDE_PAGE) then
		n_extra_records = had.inside_page_sequence_ptr -> slew_sequence.n_ops - 1;
	     else if (terminal_io_record.slew_type = SLEW_TO_OUTSIDE_PAGE) then
		n_extra_records = had.outside_page_sequence_ptr -> slew_sequence.n_ops - 1;
	     else if (terminal_io_record.slew_type = SLEW_TO_CHANNEL) then n_extra_records = 0;
						/* can be specified in the first SRCB */
	     io_buffer_lth = io_buffer_lth + 4 * n_extra_records;
						/* SRCB, SCB, blank, EOR-SCB */
	end;

	if io_buffer_lth <= length (io_buffer_space) then do;
						/* space needed available in automatic */
	     io_buffer_ptr = addr (io_buffer_space);
	     io_buffer_lth = length (io_buffer_space);
	end;
	else do;					/* space required larger than automatic buffer */
	     on condition (area)
		begin;
		code = error_table_$noalloc;		/* just TOO much */
		go to RETURN_FROM_WRITE_RECORD;
	     end;
	     allocate io_buffer in (system_area) set (io_buffer_ptr);
	end;

	io_buffer_used = 0;				/* nothing in the output yet */


/* Forms processing:  for a line printer, issue a HASP forms change record if the forms required for this I/O switch
   differs from the last forms used on the channel */

	if (channel_info.device_type = HASP_PRINTER) then
	     if (had.current_forms ^= channel_info.forms) then do;
		call add_character_to_io_buffer ((HASP_FORMS_CHANGE_SRCB));
		if length (had.current_forms) = 0 then
		     call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer),
			length (io_buffer), io_buffer_used, had.translations.space, compress_code);
		else call hasp_util_$compress_text (addr (had.current_forms), length (had.current_forms), (0),
			addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code)
			;
		if compress_code ^= 0 then go to WRITE_RECORD_BAD_DATA;
		call add_character_to_io_buffer ((HASP_EOR_SCB));
	     end;


/* Create the record:  construct the SRCB for the record, compress the record (insuring that some data is present in the
   record), and add the terminating end-of-record SCB */

	call generate_record_srcb ();			/* does the dirty work */

	if terminal_io_record.n_elements = 0 then	/* no data:  supply some to avoid lossage with RSCS */
	     call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer),
		io_buffer_used, had.translations.space, compress_code);

	else call hasp_util_$compress_text (addr (terminal_io_record.data), (terminal_io_record.n_elements), (0),
		addr (io_buffer), length (io_buffer), io_buffer_used, had.translations.space, compress_code);

	if compress_code ^= 0 then do;		/* failed. yet above code insured there'd be enough room */
WRITE_RECORD_BAD_DATA:
	     code = error_table_$improper_data_format;
	     go to RETURN_FROM_WRITE_RECORD;
	end;

	call add_character_to_io_buffer ((HASP_EOR_SCB));


/* Complete the data block:  for the line printer, the slew control operation requested in the data record may not be
   representable as a single SRCB character.  The call to generate_record_srcb above sets local state to indicate if more
   SRCBs are needed.  In this case, empty records are created containing just the SRCB and a blank */

	do while (more_srcbs_needed);

	     call generate_next_srcb ();		/* create the next SRCB */

	     call hasp_util_$compress_text (addr (had.translations.space), 1, (0), addr (io_buffer), length (io_buffer),
		io_buffer_used, had.translations.space, compress_code);
	     if compress_code ^= 0 then go to WRITE_RECORD_BAD_DATA;

	     call add_character_to_io_buffer ((HASP_EOR_SCB));
	end;


/* Transmit the I/O block and return to the caller */

	if timeout = -1 then
	     call write_io_buffer ((0));
	else call write_io_buffer (P_chars_sent);

	if code = 0 then				/* if write was successfull ... */
	     if (channel_info.device_type = HASP_PRINTER) then
						/* ... forms have changed */
		channel_info.forms = had.current_forms;

RETURN_FROM_WRITE_RECORD:
	if io_buffer_ptr ^= null () then
	     if io_buffer_ptr ^= addr (io_buffer_space) then free io_buffer in (system_area);

	P_code = code;
	return;
%page;
/* Perform control operations on an I/O switch connected to a HASP workstation */

hasp_workstation_control_before_open:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	order = P_order;
	info_ptr = P_info_ptr;
	code = 0;
	if (order = "set_event" | order = "set_event_channel") then
	     call hasp_workstation_control (P_iocb_ptr, P_order, P_info_ptr, P_code);
	else do;
	     call hcs_$tty_order (channel_info.devx, order, info_ptr, state, code);
	     P_code = code;
	end;

	return;

hasp_workstation_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;

	order = P_order;
	info_ptr = P_info_ptr;
	code = 0;


	if (order = "io_call") then do;

/* io_call command interface:  translate the supplied info into an ordinary control order */

	     if info_ptr = null () then do;		/* need the order name */
		P_code = error_table_$undefined_order_request;
		return;
	     end;

	     order = info_ptr -> io_call_info.order_name;
	     info_ptr = null ();
	end;


	if (order = "runout") then do;

/* Wait for all output to leave the FNP:  for HASP channels, we only wait for the output to leave the TTY channel and
   enter the multiplexer */

	     write_status.output_pending = "1"b;	/* need do until */

	     do while (write_status.output_pending);

		call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
		if code ^= 0 then go to RETURN_FROM_CONTROL;

		if write_status.output_pending then do;
		     event_wait_channel.n_channels = 1;
		     event_wait_channel.channel_id (1) = channel_info.event_channel;
		     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
		     if code ^= 0 then go to RETURN_FROM_CONTROL;
		end;
	     end;
	end;


	else if (order = "end_write_mode") then do;

/* End a write operation: waits for all output to enter the multiplexer, then for a line printer or card punch, writes an
   EOF record, and, for a line printer, reset the forms to the default forms given in the attach description */

	     if (channel_info.device_type = HASP_READER) then do;
		code = error_table_$invalid_write;
		go to RETURN_FROM_CONTROL;
	     end;

	     if (channel_info.device_type = HASP_CONSOLE) then
		;				/* don't write an EOF record */

	     else do;
		io_buffer_ptr = addr (TEMPLATE_HASP_EOF_RECORD);
		io_buffer_lth, io_buffer_used = length (TEMPLATE_HASP_EOF_RECORD);
		call write_io_buffer ((0));		/* send it */
		if code ^= 0 then go to RETURN_FROM_CONTROL;
		if channel_info.device_type = HASP_PRINTER then
						/* reset the switch to its default */
		     had.current_forms = had.default_forms;
		channel_info.forms = "";		/* reset to default forms */
	     end;

	     call hasp_workstation_control (iocb_ptr, "runout", (null ()), code);
	end;


	else if (order = "set_forms") then do;

/* Change the forms used for output on this switch until the next "end_write_mode" control order */

	     if (info_ptr = null ()) then
		code = error_table_$null_info_ptr;

	     else do;
		sti_ptr = info_ptr;

		if set_forms_info.version ^= SET_FORMS_INFO_VERSION_1 then
		     code = error_table_$unimplemented_version;

		else do;
		     had.current_forms = rtrim (set_forms_info.forms);
						/* strip trailing whitespace */
		     had.current_forms = translate (had.current_forms, UPPERCASE, LOWERCASE);
		     had.current_forms = translate (had.current_forms, had.translations.output);
		end;				/* convert to uppercase and proper character set */
	     end;
	end;


	else if (order = "read_status") then do;

/* Indicate if input is available:  check local buffers before checking with ring-0 */

	     if (info_ptr = null ()) then
		code = error_table_$null_info_ptr;

	     else do;
		read_status_info.event_channel = channel_info.event_channel;

		if (channel_info.held_input_ptr ^= null ()) then
		     read_status_info.input_available = "1"b;
						/* got some here */

		else do;
		     call hcs_$tty_order (channel_info.devx, "read_status", info_ptr, state, code);
		     if state ^= 5 then code = error_table_$io_no_permission;
		end;
	     end;
	end;


	else if (order = "resetread") then do;

/* Flush pending input:  throw out any input being held locally and then perform an appropriate "abort" control on the
   channel */

	     if channel_info.held_input_ptr ^= null () then
		free channel_info.held_input_ptr -> held_input in (system_area);
	     channel_info.held_input_ptr = null ();

	     call hcs_$tty_abort (channel_info.devx, (1), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	end;


	else if (order = "resetwrite") then do;

/* Flush pending output:  perform the appropriate "abort" control order on the channel */

	     call hcs_$tty_abort (channel_info.devx, (2), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	end;


	else if (order = "hangup_proc") then do;

/* Caller supplies a procedure to be invoked when the channel used by this switch is hungup */

	     if (info_ptr = null ()) then
		code = error_table_$null_info_ptr;

	     else do;
		call ipc_$decl_ev_call_chn (channel_info.attach_event_channel, hangup_proc_info.procedure,
		     hangup_proc_info.data_ptr, hangup_proc_info.priority, code);
		if code = 0 then channel_info.attach_channel_is_call = "1"b;
	     end;
	end;


	else if (order = "get_channel_info") then do;

/* Return the name and MCS device index of the channel attached via this switch */

	     if (info_ptr = null ()) then code = error_table_$null_info_ptr;

	     else if get_channel_info.version ^= tty_get_channel_info_version then
		code = error_table_$unimplemented_version;

	     else do;
		get_channel_info.devx = channel_info.devx;
		get_channel_info.channel_name = channel_info.name;
	     end;
	end;


	else if (order = "select_device") then ;	/* select a specific output device: ignored */

	else if (order = "reset") then ;		/* reset the switch to a well-known state: ignored */

	else if (order = "set_event" | order = "set_event_channel") then do;
	     if channel_info.event_channel_assigned then call hcs_$delete_channel (channel_info.event_channel, code);
	     else if channel_info.event_channel_created then call ipc_$delete_ev_chn (channel_info.event_channel, code);
	     channel_info.event_channel = info_ptr -> event_channel;
	     call hcs_$tty_event (channel_info.devx, channel_info.event_channel, state, code);
	     if code ^= 0 then goto RETURN_FROM_CONTROL;
	     channel_info.event_channel_assigned = "0"b;
	     channel_info.event_channel_created = "0"b;
	end;

	else if (order = "set_term_type") then do;
	     sttip = info_ptr;
	     if set_term_type_info.version ^= stti_version_1 then do;
		code = error_table_$unimplemented_version;
		goto RETURN_FROM_CONTROL;
	     end;

	     ttd.version = ttd_version_3;
	     call ttt_info_$terminal_data (set_term_type_info.name, -1, 0, addr (ttd), code);
	     if code ^= 0 then goto RETURN_FROM_CONTROL;
	     if (ttd.tables.input_tr_ptr ^= null ()) then /* If no translation table, don't change */
		call set_translation (had.translations.input,
		     addr (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value),
		     dimension (ttd.tables.input_tr_ptr -> cv_trans_struc.cv_trans.value, 1));
	     if (ttd.tables.output_tr_ptr ^= null ()) then do;
		call set_translation (had.translations.output,
		     addr (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value),
		     dimension (ttd.tables.output_tr_ptr -> cv_trans_struc.cv_trans.value, 1));
		had.translations.space = translate (ASCII_SPACE, had.translations.output);
	     end;					/* This should not affect operation of channel.  Its only */
						/* effect should be to set up the tcb with terminal type so */
						/* stty can see it. */
	     call hcs_$tty_order (channel_info.devx, "set_terminal_data", addr (ttd), state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	end;

	else if (order = "set_line_type") then do;

	     if (info_ptr = null ()) then code = error_table_$null_info_ptr;

	     else if line_type ^= LINE_HASP_OPR | channel_info.device_type ^= HASP_CONSOLE then
		code = error_table_$incorrect_device_type;
	     else code = 0;				/* basically a nop */
	end;

	else if (order = "read_record_timeout") then do;
	     timeout_info_ptr = info_ptr;
	     input_timeout_info.characters_read = 0;
	     call hasp_workstation_read_record_timed (P_iocb_ptr, input_timeout_info.buffer_pointer,
		input_timeout_info.buffer_length, input_timeout_info.characters_read, code,
		input_timeout_info.timeout);
	end;

	else if (order = "write_record_timeout") then do;
	     timeout_info_ptr = info_ptr;
	     call hasp_workstation_write_record_timed (P_iocb_ptr, output_timeout_info.buffer_pointer,
		output_timeout_info.buffer_length, code, output_timeout_info.timeout,
		output_timeout_info.characters_written);
	end;					/* wouldn't do any good to send password mask */

	else if (order = "assign_to_user_process") then do;
	     if info_ptr = null () then
		code = error_table_$null_info_ptr;
	     else do;
		call hcs_$tty_detach_new_proc (channel_info.devx, pid, state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
	     end;
	end;

	else if (order = "printer_off") then code = 0;
	else if (order = "printer_on") then code = 0;

	else if (order = "state") then do;
	     call hcs_$tty_state (channel_info.devx, temp_state, (0));
	     info_ptr -> based_state = temp_state;
	     code = 0;
	end;

	else if (order = "detach_user_process") then do;
	     call hcs_$tty_detach (channel_info.devx, detachflag, temp_state, code);
	     if temp_state ^= 5 then code = error_table_$io_no_permission;
	end;

	else do;

/* Unrecognized control order:  pass it on to MCS */

	     call hcs_$tty_order (channel_info.devx, order, info_ptr, state, code);
	     if order ^= "listen" then
		if state ^= 5 then code = error_table_$io_no_permission;
	end;

RETURN_FROM_CONTROL:
	P_code = code;
	return;
%page;
/* Change modes:  modes operation a noop */

hasp_workstation_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	P_old_modes = "";				/* no modes are reflected to caller */
	P_code = 0;
	return;
%page;
/* Remove an I/O switch which might be attached to the channel:  if this switch is the only one attached to the channel,
   the channel itself is detached */

cleanup_attachment:
     procedure (P_code);

dcl  P_code fixed binary (35) parameter;		/* a parameter to allow callers to ignore it */

	P_code = 0;

	if had_ptr ^= null () then do;		/* there is an I/O switch */

	     if had.channel_info_ptr ^= null () then do;	/* there is knowledge of the channel */

		channel_info_ptr = had.channel_info_ptr;

		if (had.chain.previous = null ()) then
		     channel_info.hads.first = had.chain.next;
		else had.chain.previous -> had.chain.next = had.chain.next;

		if (had.chain.next = null ()) then
		     channel_info.hads.last = had.chain.previous;
		else had.chain.next -> had.chain.previous = had.chain.previous;

		if (channel_info.hads.first = null ()) then call release_channel ();
						/* last switch connected to the channel */
	     end;

	     if had.top_of_page_sequence_ptr ^= null () then
		free had.top_of_page_sequence_ptr -> slew_sequence in (system_area);

	     if had.inside_page_sequence_ptr ^= null () then
		free had.inside_page_sequence_ptr -> slew_sequence in (system_area);

	     if had.outside_page_sequence_ptr ^= null () then
		free had.outside_page_sequence_ptr -> slew_sequence in (system_area);

	     free had in (system_area);
	     had_ptr = null ();			/* just to be sure */
	end;

	return;



/* Internal to cleanup_attachment:  release the knowledge associated with a TTY channel */

release_channel:
	procedure ();

	     if channel_info.devx ^= -1 then call hcs_$tty_detach (channel_info.devx, (0), (0), P_code);

	     if channel_info.event_channel ^= -1 then
		if channel_info.event_channel_assigned then
		     call hcs_$delete_channel (channel_info.event_channel, (0));
		else if channel_info.event_channel_created then
		     call ipc_$delete_ev_chn (channel_info.event_channel, (0));

	     if channel_info.attached then do;		/* give the channel back to the answering service */
		if channel_info.attach_channel_is_call then
		     call ipc_$decl_ev_wait_chn (channel_info.attach_event_channel, (0));
		if ^channel_info.suppress_dial_manager then do;
		     dma.version = dial_manager_arg_version_2;
		     dma.dial_channel = channel_info.attach_event_channel;
		     dma.channel_name = channel_info.name;
		     dma.dial_qualifier, dma.dial_out_destination, dma.reservation_string = "";
		     call dial_manager_$release_channel (addr (dma), (0));
		end;
		channel_info.attached = "0"b;		/* assume success */
	     end;

	     if channel_info.attach_event_channel ^= -1 then
		call ipc_$delete_ev_chn (channel_info.attach_event_channel, (0));

	     if (channel_info.chain.previous = null ()) then
		first_channel_info_ptr = channel_info.chain.next;
	     else channel_info.chain.previous -> channel_info.chain.next = channel_info.chain.next;

	     if (channel_info.chain.next = null ()) then
		last_channel_info_ptr = channel_info.chain.previous;
	     else channel_info.chain.next -> channel_info.chain.previous = channel_info.chain.previous;

	     free channel_info in (system_area);
	     channel_info_ptr = null ();

	     return;

	end release_channel;

     end cleanup_attachment;
%page;
/* Wrapper to protect against errors while IPS interrupts are masked */

any_other_handler:
     procedure () options (non_quick);

dcl  1 fatal_error_info aligned,
       2 version fixed bin,
       2 status_code fixed bin (35);

	if get_group_id_ () = "Initializer.SysDaemon.z" then do;

	     if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	     ips_mask = ""b;

	     call continue_to_signal_ ((0));		/* hope to get an asdump */
	end;
	else do;
	     fatal_error_info.version = 0;
	     fatal_error_info.status_code = error_table_$unable_to_do_io;

	     call terminate_process_ ("fatal_error", addr (fatal_error_info));
	end;

	return;

     end any_other_handler;



/* Abort a call to the attach entry:  print an error message if requested */

abort_attachment:
     procedure () options (variable, non_quick);

dcl  the_code fixed binary (35) based (the_code_ptr);
dcl  the_code_ptr pointer;

dcl  caller_message character (256);

	call cu_$arg_ptr (1, the_code_ptr, (0), (0));

	if loud_sw then do;				/* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, caller_message, (0), "1"b, "0"b);
	     call com_err_ (the_code, NAME, "For switch ^a: ^a", iocb_ptr -> iocb.name, caller_message);
	end;

	call cleanup_attachment ((0));		/* get rid of anything that was accomplished */

	if the_code = 0 then
	     code = error_table_$action_not_performed;
	else code = the_code;			/* save the error code */

	go to RETURN_FROM_ATTACH;

     end abort_attachment;
%page;
/* Fetch the next argument from the attach options and validate that it is a non-null character string */

get_string_argument:
     procedure () returns (character (*));

dcl  option_name character (32);

	option_name = argument;			/* about to move on to the next one */

	if (argument_idx = hbound (P_attach_options, 1)) then
	     call abort_attachment (error_table_$noarg, "Character string following ""^a"".", option_name);

	argument_idx = argument_idx + 1;

	argument_ptr = addcharno (addr (P_attach_options (argument_idx)), 4);
	argument_lth = length (P_attach_options (argument_idx));

	if (argument = "") then
	     call abort_attachment (0, "Character string following ""^a"" must be non-null.", option_name);

	return (argument);

     end get_string_argument;



/* Fetch the next argument from the attach options and verify that it is a number */

get_numeric_argument:
     procedure () returns (fixed binary (35));

dcl  option_name character (32);
dcl  the_value fixed binary (35);

	option_name = argument;			/* about to move on to the next one */

	if (argument_idx = hbound (P_attach_options, 1)) then
	     call abort_attachment (error_table_$noarg, "Number following ""^a"".", option_name);

	argument_idx = argument_idx + 1;

	argument_ptr = addcharno (addr (P_attach_options (argument_idx)), 4);
	argument_lth = length (P_attach_options (argument_idx));

	the_value = cv_dec_check_ (argument, code);

	if code ^= 0 then
	     call abort_attachment (error_table_$bad_conversion, """^a"" must be followed by a number; not ""^a"".",
		option_name, argument);

	return (the_value);

     end get_numeric_argument;
%page;
init_read:
     procedure;

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	had_ptr = iocb_ptr -> iocb.attach_data_ptr;
	channel_info_ptr = had.channel_info_ptr;
	return;

     end init_read;




/* Set input/output translation to the given string:  If the string supplied is less than 512 characters, the out of range
   characters are translated to NULs */

set_translation:
     procedure (P_translate_table, P_translate_string_ptr, P_translate_string_lth);

dcl  P_translate_table character (512) aligned parameter;	/* translate table */
dcl  P_translate_string_ptr pointer parameter;		/* -> translation string */
dcl  P_translate_string_lth fixed binary (21) parameter;	/* length of translation string */

dcl  translate_string character (P_translate_string_lth) based (P_translate_string_ptr);

	P_translate_table = translate_string;

	if length (translate_string) < length (P_translate_table) then
	     substr (P_translate_table, (length (translate_string) + 1)) =
		copy (NUL, (length (P_translate_table) - length (translate_string)));

	return;

     end set_translation;
%page;
/* Parse a slew control sequence specification:  the specification is of the form
   Tn:Tn:Tn:Tn:...
   where "n" is the numeric value and T represents the type of operation to perform.  T may be either "c" for skip to
   channel "n", or "s" for space "n" lines */

parse_slew_sequence:
     procedure (P_slew_sequence_ptr);

dcl  P_slew_sequence_ptr pointer;			/* set -> slew_sequence constructed */

dcl  (option_name, operation) character (32);
dcl  (start, next_colon) fixed binary (21);
dcl  the_number fixed binary (35);
dcl  next_op fixed binary;


	option_name = argument;			/* remember it for error messages */

	character_value = get_string_argument ();	/* insure specification is present */

	start = 1;
	slew_sequence_n_ops = 0;			/* haven't found any yet */


/* Count and verify syntax of each operation */

	do while (start <= length (argument));

	     next_colon = index (substr (argument, start), ":");
	     if next_colon = 0 then			/* rest of argument is this sequence */
		next_colon = length (argument) - start + 2;

	     operation = ltrim (rtrim (substr (argument, start, (next_colon - 1))));

	     if (operation = "") then
		call abort_attachment (0, "All slewing operations must be non-null: ""^a"" for ""^a"".", argument,
		     option_name);

	     if (substr (operation, 1, 1) ^= "c") & (substr (operation, 1, 1) ^= "s") then
		call abort_attachment (0, "Invalid slewing operation ""^a"" specified in ""^a"" for ""^a"".",
		     substr (operation, 1, 1), argument, option_name);

	     the_number = cv_dec_check_ (substr (operation, 2), code);
	     if code ^= 0 then
		call abort_attachment (error_table_$bad_conversion, """^a"" in ""^a"" for ""^a"".",
		     substr (operation, 2), argument, option_name);

	     if ((substr (operation, 1, 1) = "c") & ((the_number < 1) | (the_number > 12)))
		| ((substr (operation, 1, 1) = "s") & ((the_number > 15) | (the_number < 0))) then
		call abort_attachment (0, "Invalid value for slewing operation ""^a"" in ""^a"" for ""^a"".",
		     operation, argument, option_name);

	     slew_sequence_n_ops = slew_sequence_n_ops + 1;
						/* it's OK */
	     start = start + next_colon;
	end;


/* Specification is valid:  allocate the structure and fill it in */

	on condition (area)
	     call abort_attachment (error_table_$noalloc, "Interpreting ""^a"" for ""^a"".", argument, option_name);

	allocate slew_sequence in (system_area) set (slew_sequence_ptr);

	start = 1;
	next_op = 0;

	do while (start <= length (argument));

	     next_colon = index (substr (argument, start), ":");
	     if next_colon = 0 then			/* rest of argument is this sequence */
		next_colon = length (argument) - start + 2;

	     operation = ltrim (rtrim (substr (argument, start, (next_colon - 1))));
	     next_op = next_op + 1;

	     if (substr (operation, 1, 1) = "c") then
		slew_sequence.ops (next_op).skip_to_channel = "1"b;
	     else slew_sequence.ops (next_op).skip_to_channel = "0"b;

	     the_number = cv_dec_check_ (substr (operation, 2), (0));
	     slew_sequence.ops (next_op).count_or_channel = the_number;

	     start = start + next_colon;
	end;

	P_slew_sequence_ptr = slew_sequence_ptr;	/* return results to caller */

	return;

     end parse_slew_sequence;
%page;
/* Read an I/O buffer:  block until some data arrives and perform a single read from ring-0 */

read_io_buffer:
     procedure ();

	io_buffer_read = 0;				/* need do until here */

	do while (io_buffer_read = 0);

	     read_status.input_available = "0"b;	/* again, no do until */

	     if timeout ^= 0 then			/* timeout of zero means no blocking */
		do while (^read_status.input_available);

		call hcs_$tty_order (channel_info.devx, "read_status", addr (read_status), state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
		if code ^= 0 then return;		/* punt! */

		if ^read_status.input_available then do;/* need to wait for some input */
		     event_wait_channel.n_channels = 1;
		     event_wait_channel.channel_id (1) = channel_info.event_channel;
		     if timeout > 0 then
			call timer_manager_$alarm_wakeup (stop_time, ABSOLUTE_MICROSECONDS,
			     channel_info.event_channel);
		     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
		     if timeout > 0 then call timer_manager_$reset_alarm_wakeup (channel_info.event_channel);
		     if code ^= 0 then return;
		     if timeout > 0 then
			if clock () > stop_time then read_status.input_available = "1"b;
						/* Force drop out of loop */
		end;
	     end;

	     call hcs_$tty_read (channel_info.devx, addr (io_buffer), (0), io_buffer_lth, io_buffer_read, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then return;
	     if io_buffer_read = 0 then
		if timeout >= 0 then do;
		     if (clock () > stop_time) & channel_info.block_on_io then code = error_table_$timeout;
		     return;
		end;
	end;

	return;

     end read_io_buffer;
%page;
/* Generate the SRCB for this record:  for the console or a punch, the contents of the record's SRCB is fixed; for a line
   printer, the contents of the SRCB are determined from the slew_control field of the terminal_io_record.  For the
   printer, the type of slewing requested might not be able to be satisfied by one SRCB; if this occurs, state information
   is saved to allow generation of as many null records with appropriate SRCBs as necessary */

generate_record_srcb:
     procedure ();


	more_srcbs_needed = "0"b;			/* assume that only one SRCB needed for this slew */


	if (channel_info.device_type = HASP_PRINTER) then do;

/* Line printer:  start interpretation of slew_control */

	     if (terminal_io_record.slew_type = SLEW_BY_COUNT) then local_slew_count = terminal_io_record.slew_count;

	     else if (terminal_io_record.slew_type = SLEW_TO_CHANNEL) then ;
						/* given channel stop: only need one SRCB for this type */

	     else do;				/* skip to top of some type of page */
		n_last_opcode = 0;			/* haven't done anything yet */
		if (terminal_io_record.slew_type = SLEW_TO_TOP_OF_PAGE) then
		     slew_sequence_ptr = had.top_of_page_sequence_ptr;
		else if (terminal_io_record.slew_type = SLEW_TO_INSIDE_PAGE) then
		     slew_sequence_ptr = had.inside_page_sequence_ptr;
		else if (terminal_io_record.slew_type = SLEW_TO_OUTSIDE_PAGE) then
		     slew_sequence_ptr = had.outside_page_sequence_ptr;
	     end;

	     call generate_next_srcb ();		/* actually generate the SRCB */
	end;


	else do;

/* The console or a punch:  generate a fixed SRCB */

	     call add_character_to_io_buffer (NUL);
	     srcb_ptr = addcharno (addr (io_buffer), io_buffer_used - 1);

	     if (channel_info.device_type = HASP_CONSOLE) then srcb = HASP_CONSOLE_SRCB;
	     else if (channel_info.device_type = HASP_PUNCH) then srcb = TEMPLATE_HASP_CARD_SRCB;
	end;

	return;

     end generate_record_srcb;
%page;
/* Generate next SRCB:  given the current local state, construct the next SRCB character required to perform the request
   slewing operation; update the local state for the next call (if any) */

generate_next_srcb:
     procedure ();

	call add_character_to_io_buffer (NUL);		/* make the SRCB and initialize it to all zeroes */
	srcb_ptr = addcharno (addr (io_buffer), io_buffer_used - 1);

	hasp_printer_srcb.mbo1 = "1"b;		/* SRCB now specifies space zero lines */

	if (terminal_io_record.slew_type = SLEW_BY_COUNT) then do;
	     hasp_printer_srcb.number = min (local_slew_count, HASP_MAX_SLEW_COUNT);
	     local_slew_count = local_slew_count - hasp_printer_srcb.number;
	     more_srcbs_needed = (local_slew_count > 0);
	end;

	else if (terminal_io_record.slew_type = SLEW_TO_CHANNEL) then do;
						/* skip to specified channel stop */
	     hasp_printer_srcb.skip_to_channel = "1"b;
	     hasp_printer_srcb.number = terminal_io_record.slew_count;
	     more_srcbs_needed = "0"b;		/* only need one SRCB to do the job */
	end;

	else do;					/* special slewing requested: interpret attach description */
	     n_last_opcode = n_last_opcode + 1;
	     hasp_printer_srcb.skip_to_channel = slew_sequence.ops (n_last_opcode).skip_to_channel;
	     hasp_printer_srcb.number = slew_sequence.ops (n_last_opcode).count_or_channel;
	     more_srcbs_needed = (slew_sequence.n_ops > n_last_opcode);
	end;

	return;

     end generate_next_srcb;



/* Add the specified character to the I/O buffer for later output */

add_character_to_io_buffer:
     procedure (P_character);

dcl  P_character character (1) parameter;

	if io_buffer_used = length (io_buffer) then	/* no room in buffer */
	     go to WRITE_RECORD_BAD_DATA;

	io_buffer_used = io_buffer_used + 1;

	substr (io_buffer, io_buffer_used, 1) = P_character;

	return;

     end add_character_to_io_buffer;
%page;
/* Write an I/O buffer:  blocks until the entire buffer has been taken by ring-0 MCS */

write_io_buffer:
     procedure (transmitted);

dcl  (transmitted, sent_on_call) fixed binary (21);

/* First see if any output from an interrupted timed write_record
   is sitting in ring 0 and must be flushed.  The flushing is done at the last
   possible moment (now) to lessen the chance of flushing output that was ahead
   of the interrupted record, but still in ring 0. */

	transmitted = 0;

	if channel_info.output_interrupted then do;
	     call hcs_$tty_abort (channel_info.devx, 2, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then return;
	     channel_info.output_interrupted = "0"b;
	end;

	do while (transmitted < io_buffer_used);

	     call hcs_$tty_write (channel_info.devx, addcharno (addr (io_buffer), transmitted), (0),
		(io_buffer_used - transmitted), sent_on_call, state, code);
	     if state ^= 5 then code = error_table_$io_no_permission;
	     if code ^= 0 then return;		/* punt! */

	     transmitted = transmitted + sent_on_call;	/* got some more through */

	     if transmitted < io_buffer_used then do;	/* not done yet: wait 'till we should try again */
		call hcs_$tty_order (channel_info.devx, "write_status", addr (write_status), state, code);
		if state ^= 5 then code = error_table_$io_no_permission;
		if code ^= 0 then return;		/* punt! */

		if write_status.output_pending then do; /* must really and truly wait */
		     if timeout = 0			/* Zero timeout means never block */
			| (timeout > 0 & clock () > stop_time) then do;
						/* Really timed out */
			if transmitted > 0 then channel_info.output_interrupted = "1"b;
			if channel_info.block_on_io then code = error_table_$timeout;
						/* non-block code is not interested in timeouts */
			return;
		     end;
		     event_wait_channel.n_channels = 1;
		     event_wait_channel.channel_id (1) = channel_info.event_channel;
		     call timer_manager_$alarm_wakeup (1, RELATIVE_SECONDS, event_wait_channel.channel_id (1));
		     if timeout > 0 then
			call timer_manager_$alarm_wakeup (stop_time, ABSOLUTE_MICROSECONDS,
			     channel_info.event_channel);
		     call ipc_$block (addr (event_wait_channel), addr (local_event_wait_info), code);
		     call timer_manager_$reset_alarm_wakeup (channel_info.event_channel);
		     if code ^= 0 then return;	/* punt! */
		end;
	     end;
	end;

	return;					/* this return taken only on success */

     end write_io_buffer;
%page;
%include terminal_io_record;
%page;
%include hasp_device_data;

%include hasp_srcb_scb_bytes;

%include hasp_set_forms_info;
%page;
%include iocb;
%page;
%include iox_modes;
%page;
%include io_call_info;
%page;
%include dial_manager_arg;

%include event_wait_channel;

%include event_wait_info;
%page;
%include line_types;
%page;
%include terminal_type_data;

%include tty_convert;

%include tty_get_channel_info;
%page;
%include io_timeout_info;
%page;
%include set_term_type_info;
%page;
%include timer_manager_constants;

     end hasp_workstation_;




		    hasp_ws_sim_driver_.pl1         10/03/89  1012.1rew 10/03/89  0954.2      345483



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* IO Daemon Driver Module - designed to run as a HASP workstation for one of the devices associated with the station.
   The possible devices are:

   READER - send jobs to the host as if this pgm is a card reader.
   PRINTER - receive print files from the host.
   PUNCH - receive punch files (card decks) from the host.

   The device to be run by the process is specified in the minor_args with the dev= key as follows:
   "reader_out" => READER device, "printer_in" => PRINTER device, "punch_in" => PUNCH device.

   The process can only run one of the possible HASP devices.  There must be a separate process for each active device.
*/

/* format: style4 */

/* Created by J. C. Whitmore, Feb. 1980. */
/* Modified: September 1980 by G. Palter to make auto_queue the default, eliminate ident= minor_args keyword and ident
   command, and add request_type= minor_args keyword and request_type command */
/* Modified: 30 September 1981 by G. Palter to use proper maximum length for the request type name (24 characters) */
/* Modified: 24 November 1981 by G. Palter to implement the auto_receive parameter */
/* Modified: February 23, 1985 by C. Marker to use version 5 message segments */


/****^  HISTORY COMMENTS:
  1) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Update to version 4 dprint_msg.
  2) change(88-08-19,Brunelle), approve(88-08-19,MCR7911),
     audit(88-10-21,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to version 5 iod tables.
  3) change(88-08-25,Farley), approve(88-08-19,MCR7911),
     audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199):
     Updated to allow for version 5 dprint_msg.
  4) change(89-06-15,Brunelle), approve(89-09-18,MCR8129),
     audit(89-09-29,Beattie), install(89-10-03,MR12.3-1083):
     Correct generation of major/minor_args_ptr when using offset into the I/O
     daemon tables string area.
                                                   END HISTORY COMMENTS */


hasp_ws_sim_driver_:
     procedure ();

	return;					/* not an entry */


/* Parameters */

dcl  a_argp ptr parameter;
dcl  a_source fixed bin parameter;			/* 1 = master console, 2 = slave */
dcl  a_state fixed bin parameter;			/* 0 = not quite ready to handle a request */
						/* 1 = drivers are ready */
						/* 2 = command entered after a quit */
dcl  a_stream char (*) parameter;
dcl  a_banner_type fixed bin parameter;			/* type of banner to be written  */
						/* 1 = heading banner            */
						/* 2 = tail banner               */
						/* 3 = error message             */

dcl  a_data_ptr ptr parameter;			/* pointer to output request data or  */
						/* to char(256) varying string error msg */

dcl  a_code fixed bin (35) parameter;			/* error code */


/* Other declarations */

dcl  age fixed bin;
dcl  argp ptr;
dcl  banner_type fixed bin;
dcl  code fixed bin (35);
dcl  date_string char (24);
dcl  device_type char (32);
dcl  element_size fixed bin;
dcl  format_code fixed bin;
dcl  generic_type character (32);
dcl  ignore fixed bin (35);
dcl  last fixed bin;
dcl  local_request_type character (24);
dcl  iocbp ptr;
dcl  major_args char (major_args_length) based (major_args_ptr);
dcl  major_args_ptr ptr;
dcl  major_args_length fixed bin;
dcl  major_args_name char (256) varying;
dcl  minor_args char (minor_args_length) based (minor_args_ptr);
dcl  minor_args_ptr ptr;
dcl  minor_args_length fixed bin;
dcl  minor_args_name char (256) varying;
dcl  omode char (256);
dcl  p ptr;
dcl  p2 ptr;
dcl  save_code fixed bin (35);
dcl  source fixed bin;
dcl  state fixed bin;
dcl  value fixed bin;
dcl  value_string character (256) varying;

dcl  1 term_info aligned like terminal_info;

dcl  1 hangup_info aligned,				/* structure used to set hangup_info proc */
       2 entry entry,
       2 data_ptr ptr,
       2 priority fixed bin;

dcl  1 read_info aligned,
       2 read_ev_chan fixed bin (71),
       2 input_ready bit (1) unal;

dcl  1 ev_chan_list aligned based,
       2 number fixed bin,
       2 channel (12) fixed bin (71);

dcl  1 static_receive_data aligned int static like receive_file_data;
dcl  static_default_request_type character (32) internal static initial (""); /* request type specified in iod_tables */

dcl  sys_dir char (168) based;

dcl  1 arg_list aligned based (argp),			/* parse_command_ structure */
       2 max_tokens fixed bin,			/* space allocated, do not change */
       2 n_tokens fixed bin,				/* number of tokens from command line (including cmd) */
       2 command char (64) var,			/* the first token is the command */
       2 arg (n_tokens - 1) char (64) var;		/* the other tokens are args to the command */

dcl  add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  iod_info_$generic_type entry (character (*), character (32), fixed binary (35));
dcl  initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  iodd_msg_ entry options (variable);
dcl  iodd_parse_$args entry (char (*) var, char (*)) returns (char (256) var);
dcl  iodd_hangup_$iodd_hangup_ entry;
dcl  set_iod_val entry (char (*), char (*));
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  iodd_listen_ entry (ptr);
dcl  output_request_ entry (char (*), fixed bin, ptr, entry, fixed bin (35));
dcl  output_request_$set_single_copy entry ();
dcl  output_request_$error_during_request entry (char (*));
dcl  pool_manager_$init entry (char (*), fixed bin, bit (36) aligned, fixed bin (35));
dcl  pool_manager_$clean_pool entry (char (*), fixed bin, fixed bin, fixed bin (35));
dcl  receive_file_ entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2) aligned);

dcl  space char (1) int static options (constant) init (" ");
dcl  master fixed bin int static options (constant) init (1);
dcl  slave fixed bin int static options (constant) init (2);
dcl  both fixed bin int static options (constant) init (0); /* master and slave for iodd_msg_ */
dcl  log fixed bin int static options (constant) init (0);
dcl  normal fixed bin int static options (constant) init (1);
dcl  error fixed bin int static options (constant) init (2);

dcl  punch_rmcc_mode fixed bin int static options (constant) init (3);

dcl  initial_punch_rate fixed bin int static options (constant) init (500); /* same for the punch */

dcl  head_banner fixed bin int static options (constant) init (1);

dcl  default_request_types (2) character (32) static options (constant) /* default for dprinting received files */
	initial ("printer", "punch");

dcl  myname char (19) int static init ("hasp_ws_sim_driver_") options (constant);

dcl  time fixed bin (71) int static init (10);
dcl  pool_dir char (168) int static init ("");
dcl  station char (32) int static;

dcl  1 static_sw_info aligned int static like sw_info;	/* allocate a copy of this structure */

dcl  (addr, character, clock, convert, divide, length, ltrim, null, rtrim) builtin;

dcl  (cleanup, command_level, re_init, no_coord, daemon_new_device, daemon_logout, daemon_slave_logout, conversion)
	condition;

dcl  (error_table_$action_not_performed, error_table_$bigarg, error_table_$fatal_error, error_table_$io_no_permission,
     error_table_$undefined_order_request, error_table_$ionmat, error_table_$not_detached, error_table_$not_closed)
	fixed binary (35) external;

/**/

/* Initialize the driver */

init:
     entry (a_argp);

	stat_p = a_argp;				/* put the arg into static for easy reference */
	station = "Undefined!";			/* clear station name for any messages */
	text_strings_ptr = iodd_static.text_strings_ptr;	/* get ptr to i/o daemon table text area */

	if iodd_static.attach_type ^= ATTACH_TYPE_TTY then do; /* this driver expects a tty channel */
	     call iodd_msg_ (error, master, error_table_$fatal_error, myname,
		"The HASP workstation simulator driver requires a line: statement in iod_tables.");
	     return;				/* quit now */
	end;

	if iodd_static.assigned_devices > 1 then do;	/* remember, we can only use one device per process */
	     call iodd_msg_ (error, master, error_table_$fatal_error, myname,
		"The HASP workstation simulator driver only supports one minor device per process.");
	     return;
	end;

	iodd_static.dev_io_stream,
	     iodd_static.dev_in_stream = "Undefined_stream!"; /* we don't use these in this proc */

	on daemon_logout call drop_device;
	on daemon_slave_logout go to logout_slave;
	on daemon_new_device call drop_device;
	on no_coord call drop_device;
	on cleanup call detach_device;

/* locate major args for this device in the i/o daemon tables text area */
	major_args_ptr = add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1);
	major_args_length = iodd_static.major_args.total_chars;

/* see if user wants major args to be found in a segment */
	major_args_name = iodd_parse_$args ("indirect=", major_args);
	if major_args_name ^= "" then do;		/* yes, grab that segment */
	     call initiate_the_file (major_args_name, major_args_ptr, major_args_length, "major_args", code);
	     if code ^= 0 then
		go to clean_out;
	end;

	station = iodd_parse_$args ("station=", major_args);	/* station in major must be defined */
	if station = "" then do;			/* station not defined */
	     call iodd_msg_ (error, master, error_table_$fatal_error, myname,
		"No station specified in major args.");
	     go to clean_out;
	end;

	static_receive_data.version = receive_file_data_version_1;
	static_receive_data.flags = "0"b;		/* clear the default operating modes */
	static_receive_data.testing = iodd_static.test_entry; /* copy the testing bit */
	static_receive_data.request_type = "Undefined!";
	static_receive_data.device_type = 0;		/* illegal value */
	term_info.version = terminal_info_version;	/* set version number once for all possible calls */
	term_info.baud_rate = 0;			/* initialize to no-op just in case */

	p = iodd_static.driver_ptr;			/* this was set by iodd_ */

	p -> driver_status.dev_out_iocbp = null ();
	p -> driver_status.dev_ctl_ptr = null ();

	p -> driver_status.bit_rate_est = 0;		/* no output rate defined yet */
	p -> driver_status.defer_time_limit = 0;	/* make operator specify */
	p -> driver_status.dev_out_stream = "null_stream";

/* locate minor args for this minor device in the i/o daemon tables text area */
	minor_args_ptr = add_char_offset_ (addr (text_strings.chars), p -> driver_status.minor_args.first_char -1);
	minor_args_length = p -> driver_status.minor_args.total_chars;

/* see if user wants minor args to be found in a segment */
	minor_args_name = iodd_parse_$args ("indirect=", minor_args);
	if minor_args_name ^= "" then do;		/* yes, grab that segment */
	     call initiate_the_file (minor_args_name, minor_args_ptr, minor_args_length,
		"minor_args", code);
	     if code ^= 0 then
		go to clean_out;
	end;

	device_type = iodd_parse_$args ("dev=", minor_args);	/* copy for easy reference */

	if device_type = "reader_out" then do;
	     p -> driver_status.attached = "1"b;	/* we will get requests from coord for this one */
	     call iodd_msg_ (normal, both, 0, "", "^/Initializing reader output device: ^a", p -> driver_status.device_id);

	     p -> driver_status.generic_type = "punch";	/* we expect user dpunch functions for this one */

	     call minor_attach (device_type);

	     p -> driver_status.elem_size = 9;		/* in this driver, this is just a place holder */
	     p -> driver_status.message_type = 2;	/* type of dprint msg expected */
	     p -> driver_status.ready = "1"b;		/* mark as ready to save operator cmd */

	     call iox_$control (p -> driver_status.dev_out_iocbp, "terminal_info", addr (term_info), code);
	     if code = 0
	     then p -> driver_status.bit_rate_est = term_info.baud_rate;
	     else p -> driver_status.bit_rate_est = initial_punch_rate;

	     if p -> driver_status.rqti_ptr ^= null then
		call iodd_msg_ (normal, master, 0, myname, "This driver cannot decode an rqti seg.");
	end;
	else if device_type = "printer_in" | device_type = "punch_in" then do;
	     p -> driver_status.attached = "0"b;	/* it is never attached as far as coord knows */

	     call iodd_msg_ (normal, both, 0, "", "^/Initializing ^[printer^;punch^] input device: ^a",
		(device_type = "printer_in"), p -> driver_status.device_id);

	     p -> driver_status.generic_type = device_type;

	     call minor_attach (device_type);

	     call iox_$control (p -> driver_status.dev_in_iocbp, "read_status", addr (read_info), code);
	     if code ^= 0 then go to clean_out;

	     sw_info_p = addr (static_sw_info);		/* init the local switch info for receive_file_ */
	     sw_info.version = sw_info_version_1;
	     sw_info.iocbp (1) = iodd_static.master_in;
	     sw_info.ev_chan (1) = iodd_static.chan_list_ptr -> ev_chan_list.channel (1);
	     last = 2;				/* default to 2 channels: master & device */
	     if iodd_static.slave.active then do;	/* 3 channels if there is a slave */
		sw_info.iocbp (last) = iodd_static.slave_in; /* put the salve after the master */
		sw_info.ev_chan (last) = iodd_static.slave_ev_chan; /* for lower priority */
		last = last + 1;			/* bump index of where the last iocbp will go */
	     end;
	     sw_info.iocbp (last) = p -> driver_status.dev_in_iocbp; /* put the device in the last place */
	     sw_info.ev_chan (last) = read_info.read_ev_chan;
	     sw_info.wait_list.n_channels = last;	/* set the list count to the index */
	     sw_info.n_iocb_ptrs = last;		/* also here */

	     value_string = iodd_parse_$args ("auto_queue=", minor_args);
	     if (value_string = "") | (value_string = "yes") then /* defaults to auto_queue if not given */
		static_receive_data.no_ident, static_receive_data.auto_queue = "1"b;
	     else if (value_string = "no") then
		static_receive_data.no_ident, static_receive_data.auto_queue = "0"b;
	     else do;				/* bad value for the keyword */
		call iodd_msg_ (normal, master, 0, myname,
		     "Invalid ""auto_queue="" argument ""^a"" for minor device ^a.",
		     value_string, p -> driver_status.device_id);
		go to clean_out;
	     end;

	     if device_type = "printer_in" then		/* set device_type before checking for request types */
		static_receive_data.device_type = printer_input_device;
	     else static_receive_data.device_type = punch_input_device;

	     value_string = iodd_parse_$args ("request_type=", minor_args);
	     if (value_string = "") then		/* not specified: try rqt keyword */
		value_string = iodd_parse_$args ("rqt=", minor_args);

	     if (value_string = "") then		/* use default request type */
		static_default_request_type,
		     static_receive_data.request_type = default_request_types (static_receive_data.device_type);

	     else do;				/* request type was specified */
		if length (value_string) > length (local_request_type) then do;
		     call iodd_msg_ (normal, master, error_table_$bigarg, myname,
			"For minor device ^a: request type name must be less than ^d characters long; not ""^a"".",
			p -> driver_status.device_id, (length (local_request_type) + 1), value_string);
		     go to clean_out;
		end;
		local_request_type = value_string;
		call iod_info_$generic_type (local_request_type, generic_type, code);
		if code ^= 0 then do;
		     call iodd_msg_ (normal, master, code, myname, """^a"" for minor device ^a.",
			local_request_type, p -> driver_status.device_id);
		     go to clean_out;
		end;
		if ((static_receive_data.device_type = printer_input_device) & (generic_type ^= "printer")) |
		     ((static_receive_data.device_type = punch_input_device) & (generic_type ^= "punch"))
		then do;				/* wrong type of request type for this driver */
		     call iodd_msg_ (normal, master, 0, myname,
			"For minor device ^a: request type ""^a"" must be of generic type ^[printer^;punch^]; not ""^a"".",
			p -> driver_status.device_id, local_request_type,
			static_receive_data.device_type, generic_type);
		     go to clean_out;
		end;
		static_default_request_type,
		     static_receive_data.request_type = local_request_type;
	     end;

	     if iodd_static.test_entry then		/* use a dummy pool root under pool_dir for test */
		pool_dir = rtrim (iodd_static.sys_dir_ptr -> sys_dir) || ">card_pool"; /* the test pool root */
	     else pool_dir = "System_Card_Pool";	/* otherwise use the one coded in */

	     call pool_manager_$init (pool_dir, 10, "1000"b, code); /* use 10 pages of quota initially */
						/* and set s *.*.* on initial acl of access class pool */
	     if code ^= 0 then do;			/* oops! */
		call iodd_msg_ (normal, master, code, myname, "Unable to initialize card pool.");
		go to clean_out;
	     end;
	end;
	else do;					/* someone slipped in a zinger */
	     call iodd_msg_ (normal, master, 0, myname, "Invalid ""dev="" arg ""^a"" for minor device ^a.",
		device_type, p -> driver_status.device_id);
	     go to clean_out;
	end;

	call set_iod_val ("station_id", rtrim (station));

	iodd_static.admin_ec_name = rtrim (station) || "_admin.ec";

	iodd_static.slave_hold = "1"b;		/* we override the rqti on auto_go */


	call date_time_ (clock (), date_string);	/* get set for ready message */
	call iodd_msg_ (normal, both, 0, "", "^/^a driver on channel ^a ready at ^16a^/",
	     iodd_static.major_device, iodd_static.attach_name, date_string);

	if (device_type = "printer_in") | (device_type = "punch_in")
	then do;					/* check for auto_receive */
	     value_string = iodd_parse_$args ("auto_receive=", minor_args);
	     if (value_string = "yes")
	     then do;
		call iodd_msg_ (normal, source, 0, "", "Waiting for file input.");
		on command_level goto abort_auto_receive; /* grab control after record quota overflow */
		call receive_file_ (pool_dir, addr (static_sw_info), station, addr (static_receive_data), code);
		if code ^= 0 then call iodd_msg_ (normal, source, myname, code, "From receive_file_ ");
abort_auto_receive:
	     end;					/* and go to command level afterwards */
	     else if (value_string = "no")
	     then ;				/* nothing special need be done here */
	     else do;
		call iodd_msg_ (normal, master, 0, myname,
		     "Invalid ""auto_receive="" value ""^a"" for minor device ^a.",
		     value_string, p -> driver_status.device_id);
		go to clean_out;
	     end;
	end;
	else do;					/* don't accept auto_receive for readers */
	     if iodd_parse_$args ("auto_receive=", minor_args) ^= ""
	     then do;
		call iodd_msg_ (normal, master, 0, myname,
		     "auto_receive parameter may not be specified for the reader_in minor device ^a.",
		     p -> driver_status.device_id);
		go to clean_out;
	     end;
	end;

	call iodd_listen_ (stat_p);


clean_out:

/*  This is only for error recovery during initialization.  The listener will never return here. */

	call drop_device;

	return;

logout_slave:					/* logout the slave device but not the process */

	iodd_static.re_init_in_progress = "1"b;		/* we do this by re-initializing the driver */

	call date_time_ (clock (), date_string);	/* get set for message */
	iodd_static.slave.log_msg = "1"b;		/* send to log and slave */
	call iodd_msg_ (log, both, 0, "", "Logout for station: ^a at ^a", station, date_string);

	call iox_$control (iodd_static.slave_out, "runout", null, code);

	call iox_$control (iodd_static.slave_out, "end_write_mode", null, code);

	call drop_device;

	call iodd_msg_ (normal, master, 0, "", "Driver starting re-initialization.");

	go to iodd_static.re_init_label;		/* this will do everything */
%page;
/* Issue a hangup to the device before detaching */

drop_device:
     procedure ();

dcl  send_hangup bit (1);
dcl  p ptr;

	send_hangup = "1"b;				/* tell close_and_detach proc to send hangup */
	go to device_common;

detach_device:
     entry ();

          send_hangup = "0"b;				/* tell close_and_detach proc to not send hangup */
device_common:
	p = iodd_static.driver_ptr;

	call close_and_detach (p -> driver_status.dev_out_iocbp, send_hangup);

	call continue_to_signal_ ((0));		/* in case this is called from a handler */

	return;

     end drop_device;
%page;
/* This entry is called by iodd_listen_ when a request has been received from the coordinator for the remote device.  Here
   we just check to be sure that we can understand the request format and the requested punch data format.  Then the
   request is passed on to output_request_ which actually handles processing of the request */

request:
     entry ();

	p = iodd_static.driver_ptr;			/* find the current driver */
	p2 = addr (p -> driver_status.descriptor);	/* find the request descriptor */
	dmp = addr (p -> driver_status.message);	/* get ptr to message */

	if dmp -> queue_msg_hdr.hdr_version ^= queue_msg_hdr_version_1 then do; /* trouble */
	     call iodd_msg_ (log, both, 0, "", "Invalid message header.  Cannot read request ^d.^d.",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q);
	     p2 -> request_descriptor.keep_in_queue = "1"b; /* save for conversion later */
	     go to be_nice;
	end;
	if dmp -> queue_msg_hdr.message_type ^= p -> driver_status.message_type then do;
	     call iodd_msg_ (log, both, 0, "",		/* log the error */
		"Incorrect message type.^/Request ^d.^d for ^a (segment ^a) not processed.",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		dmp -> queue_msg_hdr.ename);
	     p2 -> request_descriptor.cancelled = "1"b;	/* we don't want this one again */
be_nice:	     p2 -> request_descriptor.dont_delete = "1"b; /* save the user's data */
	     p2 -> request_descriptor.finished = "1"b;	/* mark it done */
	     return;				/* it wasn't for us after all */
	end;
	if dprint_msg.version ^= dprint_msg_version_5	/* Current version */
	& dprint_msg.version ^= dprint_msg_version_4	/* Previous version */
	& dprint_msg.version ^= dprint_msg_version_3	/* Previous version */
	then do;					/* other trouble? */
	     call iodd_msg_ (log, both, 0, "",
		"Wrong message version found.^/Request ^d.^d for ^a (segment ^a) not processed",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		dmp -> queue_msg_hdr.ename);
	     p2 -> request_descriptor.keep_in_queue = "1"b;
	     go to be_nice;
	end;
	if dprint_msg.version < dprint_msg_version_4 then /* Disallow line numbers before version 4 */
	     dprint_msg.control.line_nbrs = "0"b;

	format_code = dprint_msg.output_module;		/* get the user defined format */

	if format_code = punch_rmcc_mode then do;	/* for character output */
	     element_size = 9;			/* for output_request_ */
	end;
	else do;					/* be sure it is defined */
	     call iodd_msg_ (log, both, 0, "",
		"Illegal output format in user request.^/Request ^d.^d for ^a (segment ^a) not processed",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		dmp -> queue_msg_hdr.ename);
	     p2 -> request_descriptor.cancelled = "1"b;	/* we don't want this one again */
	     go to be_nice;
	end;

	iodd_static.quit_during_request = "0"b;		/* start clean */
%page;
	on cleanup begin;
	     call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, (0));
	end;

	call output_request_ ((p -> driver_status.dev_out_stream), element_size, stat_p, print_banner, code);
	if code ^= 0 then do;
	     iodd_static.slave_hold = "1"b;		/* on errors go to command level for guidance */
	     if code = error_table_$io_no_permission then do; /* in case of hangup... */
		call iodd_msg_ (error, master, code, myname,
		     "Device in inconsistent state or hungup.  Must re-initialize.");
		signal re_init;
	     end;
	end;

	call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, code);
	if code = 0 then do;			/* we were able to release the line */
	     call timer_manager_$sleep (time, "11"b);	/* sleep a few seconds */
						/* so remote device can send if needed */
	end;
	else if code = error_table_$undefined_order_request then do; /* this is ok also */
	     if iodd_static.test_entry then		/* be able to set a reasonable pace */
		if time > 1 then call timer_manager_$sleep (time, "11"b); /* simulate device */
	end;
	else do;					/* this is a real error */
	     call iodd_msg_ (error, master, code, myname, "From ""end_write_mode"" control");
	     iodd_static.slave_hold = "1"b;
	end;

	if iodd_static.slave.active then		/* flush any messages */
	     call iox_$control (iodd_static.slave_out, "runout", null, code);

	return;
%page;
/* For this driver, this entry is almost a no-op:  we do not send banners around our reader output to the host */

print_banner:
     entry (a_stream, a_banner_type, a_data_ptr, a_code);

	banner_type = a_banner_type;
	a_code, code = 0;

	p = iodd_static.driver_ptr;			/* save driver_ptr in short name variable */
	p2 = addr (p -> driver_status.descriptor);	/* get descriptor ptr just in case */

	if banner_type = head_banner then do;		/* reset the accounting data for each request copy */
	     call iox_$control (p -> driver_status.dev_out_iocbp, "reset", null, code);
	end;


	a_code = code;
	if code ^= 0 then
	     p2 -> request_descriptor.keep_in_queue = "1"b; /* defer the request */

	return;
%page;
/* Process a driver command */

command:
     entry (a_source, a_state, a_argp, a_code);

	argp = a_argp;				/* define the arg_list structure which contains "command" */
	source = a_source;
	state = a_state;

	on conversion begin;			/* handler for conversion errors */
	     call iodd_msg_ (normal, source, 0, "", "Argument conversion error. Try again.");
	     go to cmd_error;
	end;

	save_code = a_code;				/* save the called value */
	a_code, code = 0;				/* say we handled it for now */

	if command = "help" then do;
	     call iodd_msg_ (normal, source, 0, "", "^/** Commands for the HASP workstation simulator driver **^/");
	     if static_receive_data.device_type ^= 0 then do; /* an input device (printer or punch) */
		call iodd_msg_ (normal, source, 0, "", "receive");
		call iodd_msg_ (normal, source, 0, "", "auto_queue  yes | no");
		call iodd_msg_ (normal, source, 0, "", "request_type  rqt_name");
		call iodd_msg_ (normal, source, 0, "", "clean_pool  <days allowed to remain>");
	     end;
	     else do;				/* output device (reader) */
		call iodd_msg_ (normal, source, 0, "", "pause_time [<delay_time_between_requests>]");
		call iodd_msg_ (normal, source, 0, "", "single");
	     end;
	     go to end_cmd;
	end;


	if command = "pause_time" | command = "pausetime" then do;
	     if static_receive_data.device_type ^= 0 then do; /* only valid for output devices */
		call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device.");
		go to cmd_error;
	     end;
	     if arg_list.n_tokens > 1 then do;
		value = convert (value, arg_list.arg (1));
		if value < 0 | value > 30 then do;
		     call iodd_msg_ (normal, source, 0, "", "pause_time range: 0 to 30 seconds ");
		     go to cmd_error;
		end;
		time = value;
		go to end_cmd;
	     end;
	     else do;
		time = 10;			/* return to the default */
		go to end_cmd;
	     end;
	end;


	if command = "single" then do;		/* make a single copy of the current request */
	     if static_receive_data.device_type ^= 0 then do; /* only valid for output devices */
		call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device.");
		go to cmd_error;
	     end;
	     if iodd_static.request_in_progress then do;
		iocbp = iodd_static.driver_ptr -> driver_status.dev_out_iocbp;
		call iox_$modes (iocbp, "single", omode, ignore); /* set single mode */
		call output_request_$set_single_copy ();
	     end;
	     else call iodd_msg_ (normal, source, 0, "", "No current request.");
	     go to end_cmd;
	end;


	if command = "receive" then do;
	     if static_receive_data.device_type = 0 then do; /* only valid for input devices */
		call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device.");
		go to cmd_error;
	     end;

	     call iodd_msg_ (normal, source, 0, "", "Waiting for file input.");

	     on command_level goto abort_read;		/* grab control after record quota overflow */

	     call receive_file_ (pool_dir, addr (static_sw_info), station, addr (static_receive_data), code);
	     if code ^= 0 then call iodd_msg_ (normal, source, myname, code, "From receive_file_ ");

	     go to end_cmd;

abort_read:    call iodd_msg_ (normal, source, 0, "", "Use the ""clean_pool"" command and retry card input.");
	     go to cmd_error;
	end;


	if command = "auto_queue" | command = "autoqueue" then do;
	     if static_receive_data.device_type = 0 then do; /* wrong driver type */
		call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device.");
		go to cmd_error;
	     end;

	     if arg_list.n_tokens < 2 then do;		/* must define what he wants */
		call iodd_msg_ (normal, source, 0, "", "Argument yes or no must be given.");
		go to cmd_error;
	     end;

	     if arg_list.arg (1) = "yes" then
		static_receive_data.no_ident,		/* don't look for ++IDENT */
		     static_receive_data.auto_queue = "1"b; /* queue request to print/punch file */
	     else if arg_list.arg (1) = "no" then
		static_receive_data.no_ident,		/* look gor ++IDENT */
		     static_receive_data.auto_queue = "0"b; /* don't queue request to print/punch file */
	     else do;
		call iodd_msg_ (normal, source, 0, "", "Argument must be either yes or no.");
		go to cmd_error;
	     end;
	     go to end_cmd;
	end;


	if command = "request_type" | command = "requesttype" | command = "rqt" then do;
	     if static_receive_data.device_type = 0 then do; /* wrong type of driver (input only) */
		call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device.");
		go to cmd_error;
	     end;

	     if arg_list.n_tokens < 2 then do;		/* default to the type specified in iod_tables */
		static_receive_data.request_type = static_default_request_type;
		go to end_cmd;
	     end;

	     if length (arg_list.arg (1)) > length (local_request_type) then do;
		call iodd_msg_ (normal, source, error_table_$bigarg, myname,
		     "Request type name must be less than ^d characters long; not ""^a"".",
		     (length (local_request_type) + 1), arg_list.arg (1));
		go to cmd_error;
	     end;

	     local_request_type = arg_list.arg (1);	/* get the request type */
	     call iod_info_$generic_type (local_request_type, generic_type, code);
	     if code ^= 0 then do;
		call iodd_msg_ (normal, source, code, myname, "^a", local_request_type);
		go to cmd_error;
	     end;

	     if ((static_receive_data.device_type = printer_input_device) & (generic_type ^= "printer")) |
		((static_receive_data.device_type = punch_input_device) & (generic_type ^= "punch"))
	     then do;				/* wrong type of request type for this driver */
		call iodd_msg_ (normal, source, 0, "",
		     "Request type ""^a"" must be of generic type ^[printer^;punch^]; not ""^a"".",
		     local_request_type, static_receive_data.device_type, generic_type);
		go to cmd_error;
	     end;

	     static_receive_data.request_type = local_request_type;
	     go to end_cmd;
	end;


	if command = "clean_pool" | command = "cleanpool" then do; /* garbage collect the card pool */
	     if static_receive_data.device_type = 0 then do; /* only valid for input devices */
		call iodd_msg_ (normal, source, 0, "", "Invalid command for this type of device.");
		go to cmd_error;
	     end;
	     if source = slave then do;
		call iodd_msg_ (normal, source, 0, "", "The clean_pool command is restricted to the master terminal.");
		go to cmd_error;
	     end;
	     if arg_list.n_tokens < 2 then do;		/* we must have an age arg */
		call iodd_msg_ (normal, source, 0, "", "Argument missing: days allowed to remain in the pool.");
		go to cmd_error;
	     end;
	     age = convert (age, arg_list.arg (1));	/* convert to binary */
	     if age < 1 then do;			/* be sure the value is right */
		call iodd_msg_ (normal, source, 0, "", "Invalid argument: ^a", arg_list.arg (1));
		go to cmd_error;
	     end;

	     call pool_manager_$clean_pool (pool_dir, age, 10, code); /* let pool_manager_ do the work */
	     if code ^= 0 then
		call iodd_msg_ (normal, source, code, myname, "Unable to clean up pool storage.");
	     go to end_cmd;
	end;


/* When control passes here, the command is unknown: just return and let iodd_command_processor_ handle it */

	a_code = save_code;
	return;

end_cmd:

	a_code = code;				/* pass back any defined errors */
	return;

cmd_error:

	a_code = error_table_$action_not_performed;	/* cause a resetread */
	return;

default_handler: entry (condition_info_ptr);

dcl  condition char (32);				/* fixed string for the call */

	condition = condition_info.condition_name;	/* this will indent funny */
	if iodd_static.request_in_progress then
	     call output_request_$error_during_request (condition); /* take it away */

	return;					/* output_request_ should not return, but.... */

close_and_detach: proc (a_iocbp, send_hangup);

dcl  a_iocbp ptr;
dcl  send_hangup bit (1);
dcl  code fixed bin (35);				/* local error code */

	if a_iocbp = null then return;

	if send_hangup then call iox_$control (a_iocbp, "hangup", null, code);

	call iox_$close (a_iocbp, code);
	call iox_$detach_iocb (a_iocbp, code);

	a_iocbp = null;

	return;

     end close_and_detach;

minor_attach: procedure (Device);

dcl  Device char (*) parameter;
dcl  desc char (256) varying;
dcl  io_module char (32) var;
dcl  dev_opt char (32) var;
dcl  mode fixed bin;

	if Device = "reader_out" then do;		/* for this one we are simulating a reader to the host */
	     io_module = "remote_punch_";		/* use the special feature of the punch io module */
	     dev_opt = "reader_simulator";		/* by the special -device option */
	     mode = Stream_output;			/* open mode is for stream output */
	end;
	else do;					/* otherwise, we are receiving print/punch files */
	     io_module = "remote_input_";		/* so use the other type io module */
	     dev_opt = rtrim (Device);		/* this will be printer_in or punch_in, don't care which */
	     mode = Stream_input;			/* open mode is for stream input */
	end;

	desc = io_module || " -tty " || rtrim (iodd_static.attach_name); /* build the attach description */
	desc = desc || space || iodd_parse_$args ("desc=", major_args);
	desc = desc || space || iodd_parse_$args ("desc=", minor_args);

	desc = desc || " -device " || dev_opt;		/* be sure this is last */

	p -> driver_status.dev_out_stream = get_switch_name (Device);

	call iox_$attach_ioname ((p -> driver_status.dev_out_stream), p -> driver_status.dev_out_iocbp,
	     (desc), code);
	if code ^= 0 & code ^= error_table_$not_detached & code ^= error_table_$ionmat then goto attach_error;

	call iox_$open (p -> driver_status.dev_out_iocbp, mode, ""b, code);
	if code ^= 0 & code ^= error_table_$not_closed then do;
attach_error:  call iodd_msg_ (error, master, code, myname,
		"Attaching minor device:  ^a^/Attach desc:  ^a.", p -> driver_status.device_id, desc);
	     goto clean_out;
	end;

	p -> driver_status.dev_in_iocbp = p -> driver_status.dev_out_iocbp; /* make them the same */

	call set_hangup_proc (p -> driver_status.dev_out_iocbp);

     end minor_attach;



get_switch_name: procedure (Device) returns (character (32));

declare  index fixed bin internal static init (0);
declare  Device char (*);

	index = index + 1;
	if index > 999 then index = 1;		/* keep it reasonable */
	return (Device || "_" || ltrim (character (index)));

     end get_switch_name;

set_hangup_proc: proc (iocbp);

dcl  iocbp ptr;

/* this internal proc will set the device hangup procedure for the specified switch */

	hangup_info.entry = iodd_hangup_$iodd_hangup_;
	hangup_info.data_ptr = stat_p;
	hangup_info.priority = 1;

	call iox_$control (iocbp, "hangup_proc", addr (hangup_info), code);
	if code ^= 0 then do;
	     call iodd_msg_ (error, master, code, myname, "Fatal error.  Unable to set hangup proc.");
	     goto clean_out;
	end;

	return;

     end set_hangup_proc;
%page;

initiate_the_file:
     proc (pathname_string, args_ptr, args_length, message, code);

dcl  pathname_string char (256) varying;
dcl  args_ptr ptr;
dcl  args_length fixed bin;
dcl  message char (*);
dcl  code fixed bin (35);

dcl  dirname char (168);
dcl  entname char (32);
dcl  compname char (32);
dcl  args_bc fixed bin (24);

	call expand_pathname_$component ((pathname_string), dirname, entname, compname, code);
	if code ^= 0 then
	     return;
	call initiate_file_$component (dirname, entname, compname, R_ACCESS, args_ptr, args_bc, code);
	if code ^= 0 then
	     return;
	args_length = divide (args_bc + 8, 9, 17, 0);

     end initiate_the_file;
%page; %include access_mode_values;
%page; %include condition_info;
%page; %include dprint_msg;
%page; %include driver_ptr_list;
%page; %include driver_status;
%page; %include find_input_sw_info;
%page; %include iod_tables_hdr;
%page; %include iod_constants;
%page; %include iodd_static;
%page; %include iox_modes;
%page; %include mseg_message_info;
%page; %include output_request_data;
%page; %include queue_msg_hdr;
%page; %include receive_file_data;
%page; %include request_descriptor;
%page; %include terminal_info;

     end hasp_ws_sim_driver_;




		    receive_file_.pl1               03/15/89  0843.0r w 03/15/89  0800.0      339021



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



/* Procedure to receive a file from a remote host and put it into some pool storage */

/* Created, Feb 1980, by J. C. Whitmore - based on the read_cards_ proc */
/* Modified: September 1980 by G. Palter to add the request_type keyword to ++CONTROL, make processing of ++FORMAT and
	     ++CONTROL never generate fatal errors, and make use of auto_queue when ++IDENT required not delete */
/* Modified: 30 September 1981 by G. Palter to convert to version 6 dprint_arg (longer request type names) and enable I/O
      daemon escape processing (logical channel skips) by default when queueing print files */
/* Modified: 8 October 1981 by G. Palter to bypass the "classic" segment to MSF conversion problem */
/* Modified: 27 December 1984 by Keith Loepere for version 2 create_branch_info. */


/****^  HISTORY COMMENTS:
  1) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Updated to use latest version (9) of dprint_arg.
                                                   END HISTORY COMMENTS */


receive_file_:
     procedure (a_root_dir, a_sw_info_p, a_station, a_data_ptr, a_code);


/* Parameters */

dcl  a_root_dir char (*) parameter;			/* pool root directory */
dcl  a_sw_info_p ptr parameter;			/* pointer to the sw_info structure */
dcl  a_station char (*) parameter;			/* remote_station name for messages */
dcl  a_data_ptr ptr parameter;			/* pointer to receive_file_data structure of caller */
dcl  a_code fixed bin (35) parameter;


/* Remaining declarations */

dcl  aclec fixed bin;
dcl  add_nl bit (1);
dcl  bc fixed bin (24);				/* bit count of seg */
dcl  record_buffer char (1024) aligned;			/* read buffer for character input */
dcl  record char (2000) var;
dcl  record_len fixed bin (24);
dcl  chars_left_in_seg fixed bin (24);
dcl  left fixed bin (24);
dcl  code fixed bin (35);
dcl  component fixed bin;
dcl  contin bit (1);
dcl  file_name char (32) var;				/* user supplied name of file */
dcl  filep ptr ;
dcl  dirname char (168);				/* pathname of personid directory in pool */
dcl  done bit (1);
dcl  default_person char (32);
dcl  default_project char (32);
dcl  default_personid char (32);
dcl  element_size fixed bin;				/* element size for file format */
dcl  fcbp ptr;
dcl  field (40) char (80) var;
dcl  field_cnt fixed bin;
dcl  ignore fixed bin (35);
dcl  input_modes char (256);
dcl  input_mode_bits bit (36);
dcl  control_mode_bits bit (36);
dcl  key char (32) var;
dcl  key_mode char (32);
dcl  len fixed bin (24);
dcl  long char (100);				/* space to expand an error_table_ code */
dcl  lower_case bit (1);
dcl  max_chars fixed bin (24);
dcl  chars_in_last_seg fixed bin (24);			/* number of elements transmitted */
dcl  new_file_name char (32);				/* internal name of file */
dcl  overwrite bit (1);
dcl  person char (32);				/* person part of personid */
dcl  personid char (32);
dcl  pool_open bit (1);
dcl  proc_auth bit (72);				/* access class of the process */
dcl  project char (32);				/* and the project part */
dcl  file_path char (168) var;
dcl  read_done bit (1);
dcl  root_dir char (168);
dcl  source fixed bin;				/* iocbp index in sw_info structure */
dcl  station char (32) var init ("remote-file-input");
dcl  short char (8);				/* dummy for convert_status_code_ */
dcl  tag fixed bin;					/* dupe name counter */
dcl  testing bit (1);				/* our local test mode flag */
dcl  user_defined bit (1);
dcl  user_msg char (136);
dcl  log_msg char (256);
dcl  test_iocbp ptr;
dcl  trim bit (1);
dcl  data_idx fixed bin;
dcl  file_in_progress bit (1) init ("0"b);

dcl  master_iocbp ptr;				/* iocb pointers which we will use */
dcl  slave_iocbp ptr;
dcl  input_iocbp ptr;

dcl (record_quota_overflow, command_level, cleanup) condition;

dcl (addr, null, index, substr, verify, length, multiply, divide, rtrim, before, after, unspec, search, ltrim) builtin;

dcl  string char (string_len) based;
dcl  string_len fixed bin;
dcl  based_chars (2000) char (1) based;

dcl 1 acle (2) aligned,				/* ACL entry */
    2 name char (32),
    2 mode bit (36),
    2 pad bit (36),
    2 code fixed bin (35);

dcl 1 cb_info aligned like create_branch_info auto;

dcl 1 file_data aligned like receive_file_data;		/* our working copy of the running parms */

dcl 1 count_structure aligned,			/* structure used for the get_count control order */
    2 line fixed bin,				/* most fields are pads, because this structure */
    2 page_len fixed bin,				/* is based on the printer defined structure */
    2 lmarg fixed bin,				/* shown in prt_order_info.incl.pl1 */
    2 rmarg fixed bin,
    2 records fixed bin (35),				/* this is the normal line count field */
    2 page_count fixed bin;

dcl  tell_user bit (1) int static init ("1"b) options (constant);
dcl  silent bit (1) int static init ("0"b) options (constant);
dcl  max_record_len fixed bin (24) int static options (constant) init (1024);
dcl  control_modes char (32) int static init ("^add_nl,lower_case,trim.") options (constant);
dcl  ESC_c char (2) int static options (constant) init ("c");
dcl  ETX char (1) int static options (constant) init ("");
dcl  SP char (1) int static options (constant) init (" ");
dcl  NL char (1) int static options (constant) init ("
");
dcl  FF char (1) int static options (constant) init ("");

dcl  sys_info$max_seg_size fixed bin (35) ext static;

dcl (error_table_$bad_arg, error_table_$bigarg, error_table_$short_record, error_table_$end_of_info,
     error_table_$eof_record, error_table_$namedup, error_table_$noarg, error_table_$unimplemented_version)
	fixed binary (35) external;

dcl  card_util_$modes entry (char (*), bit (36), char (*), fixed bin (35));
dcl  card_util_$translate entry (bit (36), char (*) var);
dcl  send_mail_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8), char (100));
dcl  cu_$level_get entry returns (fixed bin);
dcl  delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  dprint_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  find_input_switch_ entry (ptr, bit (1), fixed bin, fixed bin (35));
dcl  get_authorization_ entry returns (bit (72));
dcl  get_group_id_ entry returns (char (32));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$acl_add entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  iod_info_$generic_type entry (character (*), character (32), fixed binary (35));
dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$get_chars entry (ptr, ptr, fixed bin (24), fixed bin (24), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (24), fixed bin (35));
dcl  iox_$control entry (ptr, char (*) aligned, ptr, fixed bin (35));
dcl  pool_manager_$add_quota entry (char (*), fixed bin, fixed bin (35));
dcl  pool_manager_$close_user_pool entry (char (*), char (*), fixed bin, bit (36), fixed bin (35));
dcl  pool_manager_$open_user_pool entry (char (*), char (*), char (*), fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));
%page;
%include find_input_sw_info;

%include receive_file_data;
%page;
%include create_branch_info;
%page;
%include send_mail_info;
%page;
%include dprint_arg;
%page;
/* receive_file_: procedure (a_root_dir, a_sw_info_p, a_station, a_test_mode, a_code);  */

	a_code = 0;
	root_dir = a_root_dir;
	station = a_station;
	receive_file_data_ptr = a_data_ptr;

	if receive_file_data.version ^= receive_file_data_version_1 then do;
bad_version:   code = error_table_$unimplemented_version;
	     return;
	end;

	sw_info_p = a_sw_info_p;			/* setup automatic based references */
	if sw_info.version ^= sw_info_version_1 then go to bad_version;

/*	set up iocb pointers we will use according to the conventions */

	data_idx = sw_info.n_iocb_ptrs;		/* save index of the data iocbp - last one */
	if data_idx < 2 | data_idx > 10 then do;	/* must have what we need */
bad_arg:	     a_code = error_table_$bad_arg;		/* reject immediately, no opr messages */
	     return;
	end;

	master_iocbp = sw_info.iocbp (1);		/* 1 = master console (user_io) required. */
	if data_idx > 2 then
	     slave_iocbp = sw_info.iocbp (2);		/* 2 = slave  console (if any - optional) */
	else slave_iocbp = null;			/*    be sure we mark it as undefined if not given */
						/* 3 = control console (also optional) - not used here */
	input_iocbp = sw_info.iocbp (data_idx);		/* last one is the data input iocbp - required */

	if input_iocbp = null | master_iocbp = null then go to bad_arg; /* check out pointers */

	call INITIALIZE_STUFF;			/* use the internal proc to make this cleaner */

	on record_quota_overflow call overflow_handler;

	on cleanup begin;
	     code = 0;
	     if file_in_progress then			/* should we tell the operator about this */
		call report ("receive_file_: Aborting file input." || NL, silent); /* don't tell user */
	     call clean_up;				/* delete any partial input */
	end;

start:
	call RESET_PARAMETERS;

	key_mode = "IDENT search";			/* this is for log debugging messages */

/*	check for command input or next file start */

read_ident:

	call find_input_switch_ (sw_info_p, "1"b, source, code); /* look for input, block if nothing waiting */
	if code ^= 0 then call abort (code, "Returning to command level.");

	if source ^= data_idx then return;		/* allow commands to have priority */

/* We have some data coming in.  If we don't require ++IDENT record, all must go into a segment */

	if file_data.no_ident then do;
	     call report ("Begin file: " || file_name || NL, silent);
	     go to get_pool_dir;
	end;

	call read_control_record (key, field (*), field_cnt, code); /* parse record into key and arg fields */
	if code = error_table_$eof_record then go to start; /* ignore an unexpected EOF record */

	if key ^= "++ident" then do;			/* flush anything out of sync */
	     key_mode = "IDENT flush";		/* show that we are dumping data */
	     go to read_ident;
	end;

	key_mode = "IDENT found";			/* we matched on something */

	if field_cnt ^= 3 & field_cnt ^= 2 then
	     call abort_read (0, "Invalid ++IDENT record format: " || record, silent);

	file_name = field (1);			/* first field after ++IDENT is the file name */

	if field_cnt = 3 then do;			/* next is person.project or person project */
	     person = field (2);
	     project = field (3);
	end;
	else if field_cnt = 2 then do;
	     person = before (field (2), ".");
	     project = after (field (2), ".");
	end;

	if person = "*" | person = "" then		/* a personid of * is illegal */
	     call abort_read (0, "Invalid person name: " || record, silent);
	if project = "*" | project = "" then
	     call abort_read (0, "Invalid project name: " || record, silent);

	personid = rtrim (person) || "." || project;

	user_defined = "1"b;			/* we now have something we can identify */

	call ioa_$rsnnl ("Station ""^a""  receiving file ""^a"" for ^a." || NL, user_msg, len,
	     station, file_name, personid);

	call report (rtrim (user_msg), silent);		/* this is a log message */


/* Look for any other control records, up to ++INPUT and digest them */

	done = "0"b;
	do while (^done);
read_next_control_record:
	     call read_control_record (key, field (*), field_cnt, code); /* read and split into key + arg fields */
	     if code = error_table_$eof_record then do;
		call report ("Unexpected EOF record among control records." || NL, silent);
		go to start;
	     end;
	     else if code ^= 0 then call abort (code, "Read error. Aborting");
	     else if key = "++input" then done = "1"b;
	     else if key = "++format" then		/* user defined format data */
		call decode_format_args (field (*), field_cnt);
	     else if key = "++control" then call decode_control_args (field (*), field_cnt);
	     else if key = "++ident" then call abort_read (0, "Out of sequence ++IDENT record", tell_user);
	     else call control_record_error (0, "Unrecognized control record ignored: " || record, tell_user);
	end;


/* We now have all the control records for receiving the file.  Get ready to read the file text. */
/* First, we must have a place to write the data.  Create an output file in the pool directory */

get_pool_dir:

	file_in_progress = "1"b;			/* mark our progress for recovery */

	call pool_manager_$open_user_pool (root_dir, person, dirname, code); /* get dir path name for this person */
	if code ^= 0 then				/* pool error is very bad */
	     call abort (code, "Unable to open pool storage.");
	pool_open = "1"b;				/* be sure we close the pool on error */

	unspec (cb_info) = "0"b;
	cb_info.version = create_branch_version_2;
	cb_info.mode = "101"b;
	cb_info.rings (1), cb_info.rings (2), cb_info.rings (3) = cu_$level_get ();
	cb_info.userid = get_group_id_ ();
	cb_info.access_class = proc_auth;

	tag, code = -1;
	do while (code ^= 0);			/* loop on name dup errors */
	     tag = tag + 1;				/* change the name to "name.n" */
	     if tag > 499 then			/* avoid infinite loop, but try hard */
		call abort_read (0, "Aborting file: 500 duplicate files in " || dirname, tell_user);

	     call ioa_$rsnnl ("^a.^d", new_file_name, len, file_name, tag);

	     if len > 32 then
		call abort_read (0, "File name too long: " || substr (new_file_name, 1, len), tell_user);

	     call hcs_$create_branch_ (dirname, new_file_name, addr (cb_info), code);
	     if code = error_table_$namedup & overwrite then code = 0;
	     if code ^= 0 & code ^= error_table_$namedup then /* also very bad */
		call abort_read (code, "Unable to create branch in pool dir: " || rtrim (dirname), silent);
	end;

	file_path = rtrim (dirname) || ">" || rtrim (new_file_name); /* make error msgs easier */

	call msf_manager_$open (dirname, new_file_name, fcbp, code);
	if code ^= 0 then
	     call abort_read (code, "Unable to open new pool entry " || file_path, silent);

	component = 0;				/* start with the first component - 0 */
	call msf_manager_$get_ptr (fcbp, component, "0"b, filep, bc, code);
	if filep = null then
	     call abort_read (code, "Unable to initiate new pool entry " || file_path, silent);

/*	Set up the translation modes for the record text. */

	call ioa_$rsnnl ("^[^^^]trim,^[^^^]lower_case,^[^^^]add_nl,^[^^^]contin.", input_modes, len,
	     ^trim, ^lower_case, ^add_nl, ^contin);

	call card_util_$modes (input_modes, input_mode_bits, "", code);
	if code ^= 0 then call abort_read (code, "Unable to set file input modes", tell_user);

	call iox_$control (input_iocbp, "reset", null, ignore); /* clear any accounting data */

/* This procedure ASSUMES an element size of 9 bits, I.E.  chars */

	element_size = 9;				/* 9 bits per character */
	max_chars = divide ((sys_info$max_seg_size * 36), element_size, 35); /* get number of chars in a segment */
	chars_in_last_seg = 0;			/* set the number of chars used in last MSF component */
	chars_left_in_seg = max_chars;		/* set number of chars remaining in segment */

read_next_record:

	record_len = 0;
	record_buffer = "";

	call iox_$get_chars (input_iocbp, addr (record_buffer), max_record_len, record_len, code);
	if code ^= 0 then do;
	     if code = error_table_$eof_record then goto end_read_loop; /* NORMAL EXIT */

	     else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0;

	     else call abort_read (code, "Error while reading data.  Aborting file.", silent); /* ERROR EXIT */
	end;

	record = substr (record_buffer, 1, record_len);	/* put into var string for translation */

	call card_util_$translate (input_mode_bits, record);

	record_len = length (record);			/* get the new length after translation */
	left = chars_left_in_seg - record_len;		/* must be at least 1 char left to bump ptr */

	if left <= 0 then do;			/* if not enough, put in part and start new component */
	     string_len = chars_left_in_seg;		/* set size of based string */
	     filep -> string = substr (record, 1, chars_left_in_seg);

	     component = component + 1;		/* start the next MSF component */

	     if component = 1 then do;		/* about to force conversion to MSF ... */
		call pool_manager_$add_quota (root_dir, 260, code);    /* ... need extra quota during conversion */
		if code ^= 0 then do;		/* couldn't get it: let the operator try to correct it ... */
		     call report (NL || "Insufficient quota in pool to convert to MSF." || NL, silent);
		     signal command_level;
		     call pool_manager_$add_quota (root_dir, 260, code);	/* ... and try again */
		end;
		if code ^= 0 then
		     call abort_read (code, "Insufficient quota in pool to convert to MSF.", silent);
	     end;

	     call msf_manager_$get_ptr (fcbp, component, "1"b, filep, bc, code);
	     if filep = null then
		call abort_read (code, "Unable to initiate next MSF component", silent);

	     if component = 1 then			/* give back the quota we got temporarily */
		call pool_manager_$add_quota (root_dir, -260, (0));

	     if left = 0 then record = "";		/* if it fit exactly.... */
	     else record = substr (record, chars_left_in_seg + 1); /* set image to last part of record */

	     string_len = length (record);		/* set the based string size */
	     filep -> string = record;		/* write the record into the output file */
	     filep = addr (filep -> based_chars (string_len + 1)); /* move output pointer to where the next char goes */
	     chars_left_in_seg = max_chars - string_len;	/* room left in this component */
	     chars_in_last_seg = string_len;		/* restart last component count */
	end;
	else do;					/* the full record (+ 1 char) will fit this MSF component */
	     string_len = length (record);		/* set the length of the based string */
	     filep -> string = record;		/* and write out the data */
	     filep = addr (filep -> based_chars (string_len + 1)); /* move output pointer to where the next char goes */
	     chars_left_in_seg = left;		/* do the accounting */
	     chars_in_last_seg = chars_in_last_seg + string_len; /* update the number received */
	end;
	go to read_next_record;

/* - - - we don't fall through here - - - - */


end_read_loop:

	read_done = "1"b;				/* tell abort handler not to look for EOF */

	bc = multiply (chars_in_last_seg, element_size, 24, 0);

/*	set bitcount of last component ... all others are max_seg_size * 36 */

	call msf_manager_$adjust (fcbp, component, bc, "111"b, code);
	if code ^= 0 then call abort_read (code, "Error setting bit-count.", silent);

	unspec (acle) = "0"b;			/* get the acl structure ready */
	acle (1).name = rtrim (personid) || ".*";	/* put the file sender on the acl */
	acle (1).mode = "100"b;			/* read access only */
	aclec = 1;

	call msf_manager_$acl_add (fcbp, addr (acle), aclec, code);
	if code ^= 0 then call abort_read (code, "Error setting ACL.", silent);

	if fcbp ^= null then
	     call msf_manager_$close (fcbp);

	fcbp = null;

	if pool_open then do;
	     call pool_manager_$close_user_pool (root_dir, person, 1, "100"b|| (33)"0"b, code); /* close the pool */
	     if code ^= 0 then call abort_read (code, "Error closing user's pool dir.", silent);
	end;
	pool_open = "0"b;				/* all is well */

	unspec (count_structure) = ""b;		/* clear the value in case of non inplemented order */

	call iox_$control (input_iocbp, "get_count", addr (count_structure), ignore); /* get record total */
						/* this can be used for charging in the future */
	call ioa_$rsnnl ("End-of-file for: ^a ^[(^d records)^]^/", user_msg, len, file_name,
	     (count_structure.records > 0), count_structure.records);

	call report (substr (user_msg, 1, len), silent);	/* log the end of file input */

	if file_data.auto_queue then do;
	     substr (dprint_arg.destination, 1, length (dprint_arg.destination)) =
	    	substr (personid, 1, length (dprint_arg.destination));
	     substr (dprint_arg.request_type, 1, length (dprint_arg.request_type)) =
	 	     substr (file_data.request_type, 1, length (dprint_arg.request_type));
	     dprint_arg.bit_count = (component * 36 * sys_info$max_seg_size) + bc;
	     if ^file_data.no_ident then		/* user requested dprint/dpunch on ++CONTROL record ... */
		dprint_arg.delete = 0;		/* ... so don't delete file before they can copy it */

	     call dprint_ (dirname, new_file_name, dpap, code);
	     if code ^= 0 then go to let_it_stay;

	     call ioa_$rsnnl ("File ""^a"" from station ^a queued for ^[dprint^;dpunch^].^/",
		user_msg, len, file_name, station, (file_data.device_type = printer_input_device));

	     call notify_user (substr (user_msg, 1, len)); /* inform the user if defined */
	end;
	else do;
let_it_stay:
	     call ioa_$rsnnl ("File ""^a"" from station ^a stored in ^a^/", user_msg, len, file_name, station, file_path);

	     call notify_user (substr (user_msg, 1, len)); /* inform the user if defined */
	end;

	if testing then do;
	     call iox_$put_chars (test_iocbp, addr (user_msg), len, code);
	     if code ^= 0 then testing = "0"b;
	end;

	goto start;				/* see if there is another file to read */


abort_exit:
	call clean_up;

	a_code = code;
	return;


abort:	proc (code, message);

dcl  message char (*);
dcl  code fixed bin (35);
dcl  abort_msg char (256);
dcl  len fixed bin (24);

	     if code ^= 0 then call convert_status_code_ (code, short, long);
	     else long = "";

	     call ioa_$rsnnl ("receive_file_: Unable to continue input function.^[^/^a^;^s^]^/^a^/",
		abort_msg, len, (code ^= 0), long, message);

	     call report (rtrim (abort_msg), silent);	/* tell just the operator */

	     goto abort_exit;

	end abort;


notify_user: proc (message);
dcl  message char (*);

	     if user_defined then			/* be sure user from ++IDENT is defined */
		call send_mail_ (personid, message, addr (send_mail_info), (0));

	     return;

	end notify_user;
%page;
abort_read: proc (code, message, tell_user);

dcl  code fixed bin (35);
dcl  message char (*);
dcl  tell_user bit (1);
dcl  abort_msg char (256);
dcl  len fixed bin (24);
dcl  count fixed bin (24);

	     if code ^= 0 then call convert_status_code_ (code, short, long);
	     else long = "";

	     call ioa_$rsnnl ("Aborting input of file^[ ""^a"" (for ^a)^;^2s^] from station ^a.^/^[^a^/^;^s^]^a^/",
		abort_msg, len, user_defined, file_name, personid, station, (code ^= 0), long, message);

	     call report (rtrim (abort_msg), tell_user);	/* route the message as requested */

	     call clean_up;

	     if read_done | ^file_in_progress then go to start; /* was the EOF already read? */

	     call report ("Skipping to EOF record." || NL, silent);

	     code = 0;
	     do count = 0 by 1 while (code ^= error_table_$eof_record);
		call iox_$get_chars (input_iocbp, addr (record_buffer), max_record_len, record_len, code);
		if code ^= 0 then do;
		     if code = error_table_$end_of_info | code = error_table_$short_record then code = 0;
		     if code ^= error_table_$eof_record then
			call abort (code, "Read error.");
		end;
	     end;
	     if testing then do;
		call ioa_$rsnnl ("Aborted ^d records before EOF.^/", log_msg, len, count);
		call iox_$put_chars (test_iocbp, addr (log_msg), len, code);
		if code ^= 0 then testing = "0"b;
	     end;
	     go to start;				/* go back and check for commands and next ++IDENT */

	end abort_read;
%page;
/* Report a non-fatal error encountered during control record processing */

control_record_error:
	procedure (code, message, tell_user);

dcl  code fixed binary (35) parameter;
dcl  message character (*) parameter;
dcl  tell_user bit (1) parameter;
dcl  error_message character (256);

	     if code ^= 0 then			/* include system error message in report */
		call convert_status_code_ (code, short, long);
	     else long = "";			/* just to be safe; it won't be in ioa_ string anyway */

	     call ioa_$rsnnl ("During input of file ""^a"" (for ^a) from station ^a.^/^[^a^/^;^s^]^a^/",
			  error_message, (0b),
			  file_name, personid, station, (code ^= 0), long,
			  message);		/* include supplied message */

	     call report (rtrim (error_message), tell_user);   /* issue the complaint */

	     return;				/* and that's all: it's not fatal... */

	end control_record_error;
%page;
report:	proc (message, tell_user);

dcl  code fixed bin (35);
dcl  message char (*);
dcl  tell_user bit (1);
dcl  opr_iocbp ptr;

	     if tell_user then
		call notify_user (message);

	     if slave_iocbp = null then opr_iocbp = master_iocbp;
	     else opr_iocbp = slave_iocbp;
write_msg:
	     call iox_$put_chars (opr_iocbp, addr (message), length (message), code);
	     if code ^= 0 then do;
		if opr_iocbp = slave_iocbp then do;	/* tell the master if slave gets error */
		     opr_iocbp = master_iocbp;
		     go to write_msg;
		end;

/*		For other errors we can't do much, so just return.  */

	     end;

	     if testing then do;
		call iox_$put_chars (test_iocbp, addr (message), length (message), code);
		if code ^= 0 then testing = "0"b;
	     end;

	     return;

	end report;





read_control_record: proc (key, field, field_cnt, code);

dcl  key char (*) var parameter;
dcl  field (40) char (80) var parameter;
dcl  field_cnt fixed bin parameter;
dcl  code fixed bin (35) parameter;

dcl  arg_string char (160) var;
dcl  scan_done bit (1);
dcl  field_begin fixed bin;
dcl  field_len fixed bin;
dcl  i fixed bin;
dcl  len fixed bin (24);

	     key = "";				/* clear the return parameters */
	     field (*) = "";
	     field_cnt = 0;

	     call iox_$get_chars (input_iocbp, addr (record_buffer), max_record_len, record_len, code);
	     if code ^= 0 then do;
		if code = error_table_$eof_record then return;
		else if code = error_table_$end_of_info | code = error_table_$short_record then code = 0;
		else call abort (code, "Read error.");
	     end;

	     if record_len = 0 then do;
		code = error_table_$end_of_info;
		return;
	     end;

	     record = substr (record_buffer, 1, record_len); /* use varying string for translation */

	     if testing then do;			/* keep a log of all control records read */
		call ioa_$rsnnl ("CTL (^a):^21t^a^/", log_msg, len, key_mode, record);
		call iox_$put_chars (test_iocbp, addr (log_msg), len, code);
		if code ^= 0 then testing = "0"b;
		code = 0;				/* just in case, make it quiet */
	     end;

	     i = index (record, ESC_c);		/* check for slew control chars and flush them */

	     if i = 1 then do;			/* this is the pre-slew sequence */
		i = index (record, ETX);		/* find the closing ETX */
						/* if not found, strip nothing */
		record = substr (record, i + 1);
	     end;
	     else if i > 1 then do;			/* this is the post slew sequence */
		record = substr (record, 1, i - 1);	/* take up to the slew, and junk the rest */
	     end;

	     record = ltrim (record, NL || FF || SP);	/* strip any other pad or slew control */
	     record = rtrim (record, NL || FF || SP);

	     call card_util_$translate (control_mode_bits, record);

	     len = search (record, " ");		/* find the first space char */
	     if len = 0 then do;			/* no spaces, maybe ++input */
		key = record;			/* try it */
		return;
	     end;

	     key = substr (record, 1, len - 1);		/* this is the ++<something> keyword */

	     arg_string = ltrim (rtrim (substr (record, len))); /* args are the remainder of the record */

	     field_begin = 1;
	     scan_done = "0"b;

	     do i = 1 to 40 while (^scan_done);		/* 40 args max */
		field_len = search (substr (arg_string, field_begin), " ");
		if field_len = 0 then do;
		     field_len = length (arg_string) - field_begin + 1;
		     scan_done = "1"b;
		end;
		else field_len = field_len - 1;
		field (i) = substr (arg_string, field_begin, field_len);
		field_begin = field_begin + field_len + verify (substr (arg_string, field_begin + field_len), " ") - 1;
		field_cnt = i;
	     end;

	     return;

	end read_control_record;

decode_format_args: proc (field, field_cnt);

dcl  field (40) char (80) var;
dcl  field_cnt fixed bin;
dcl  i fixed bin;

	     if field_cnt < 1 then do;
		call control_record_error (0, "Incorrect ++FORMAT record ignored: " || record, tell_user);
		go to read_next_control_record;
	     end;

	     do i = 1 to field_cnt;
		if field (i) = "trim" then trim = "1"b;
		else if field (i) = "notrim" then trim = "0"b;
		else if field (i) = "lowercase" then lower_case = "1"b;
		else if field (i) = "noconvert" then lower_case = "0"b;
		else if field (i) = "addnl" then add_nl = "1"b;
		else if field (i) = "noaddnl" then add_nl = "0"b;
		else if field (i) = "contin" then contin = "1"b;
		else if field (i) = "nocontin" then contin = "0"b;
		else call control_record_error (0, "Undefined mode ignored on ++FORMAT record: " || field (i), tell_user);
	     end;

	     return;

	end decode_format_args;
%page;
/* Process ++CONTROL record */

decode_control_args:
	procedure (fields, n_fields);

dcl  fields (40) character (80) varying parameter;
dcl  n_fields fixed binary parameter;
dcl  idx fixed binary;
dcl  generic_type character (32);
dcl  local_request_type character (24);


	     if n_fields < 1 then do;
		call control_record_error (0, "Incorrect ++CONTROL record ignored: " || record, tell_user);
		go to read_next_control_record;
	     end;


	     do idx = 1 to n_fields;

		if (fields (idx) = "overwrite") then	/* overwrite previous versions in compiler pool */
			overwrite = "1"b;

		else if (fields (idx) = "auto_queue") then   /* automatically queue file for printing/punching */
			file_data.auto_queue = "1"b;

		else if ((fields (idx) = "request_type") | (fields (idx) = "rqt"))
		     then do;			/* specific request type for automatic queuing */
			if (idx = n_fields) then do;
			     call control_record_error (error_table_$noarg,
						  "Request type name must follow ""request_type"" key on ++CONTROL record; the ""request_type"" key is ignored.",
						  tell_user);
			     return;		/* this was the last field on the record */
			end;
			idx = idx + 1;		/* request type name is next field */
			if length (fields (idx)) > length (local_request_type) then do;
			     call control_record_error (error_table_$bigarg,
						  "Request type name must be less than 25 characters long; not """ || fields (idx) || """; the ""request_type"" key is ignored.",
						  tell_user);
			     go to check_next_control_field;
			end;
			local_request_type = fields (idx);
			call iod_info_$generic_type (local_request_type, generic_type, code);
			if code ^= 0 then do;
			     call control_record_error (code,
						  """" || fields (idx) || """; the ""request_type"" key is ignored.",
						  tell_user);
			     go to check_next_control_field;
			end;
			if ((file_data.device_type = printer_input_device) & (generic_type ^= "printer")) |
			   ((file_data.device_type = punch_input_device) & (generic_type ^= "punch"))
			then do;			/* wrong type of request type */
			     call control_record_error (0,
						  "Request type """ || fields (idx) || """ specified on ++CONTROL record has incorrect generic type; the ""request_type"" key is ignored.",
						  tell_user);
			     go to check_next_control_field;
			end;
			file_data.request_type = local_request_type; /* got a valid one */
		     end;

		else call control_record_error (0, "Unknown key on ++CONTROL record ignored: " || fields (idx),
					  tell_user);

check_next_control_field:
	     end;

	     return;

	end decode_control_args;
%page;
clean_up:	proc;

dcl  ignore fixed bin (35);

	     if fcbp ^= null then do;
		call msf_manager_$close (fcbp);
		fcbp = null;			/* don't repeat this */
		call delete_$path (dirname, new_file_name, "100100"b, "", ignore);
	     end;

	     if pool_open then do;
		call pool_manager_$close_user_pool (root_dir, person, 1, "100"b || (33)"0"b, ignore);
		pool_open = "0"b;
	     end;

	     return;

	end clean_up;



overflow_handler: proc;

dcl  code fixed bin (35);

	     call pool_manager_$add_quota (root_dir, 10, code); /* add 10 pages and keep going */
	     if code ^= 0 then do;
		call report (NL ||"No available quota in pool." || NL, silent);
		signal command_level;		/* allow operator to respond */
	     end;

	     return;				/* restart where we stopped if it returns */

	end overflow_handler;


INITIALIZE_STUFF: proc;

	     file_data = receive_file_data;		/* set up our working copy of the control data */
	     testing = file_data.testing;		/* grab this once, we may need to cancel it */

	     default_personid = get_group_id_ ();	/* get names to be used for no_ident case */
	     default_person = before (default_personid, ".");
	     default_project = before (after (default_personid, "."), ".");
	     default_personid = rtrim (default_person) || "." || default_project; /* omit the instance tag */

	     dpap = addr (dprint_arg_buf);		/* where we build the message for dprint_ */
	     dprint_arg.version = dprint_arg_version_9;
	     dprint_arg.copies = 1;
	     dprint_arg.queue = 0;			/* use the drfault queue at all times */
	     dprint_arg.delete = 1;			/* always delete after print/punch */
	     dprint_arg.pt_pch = file_data.device_type;	/* they just happen to match */
	     dprint_arg.notify = 0;
	     dprint_arg.heading = "";			/* later */
	     if file_data.device_type = printer_input_device then
		dprint_arg.output_module = 1;		/* 1 = print */
	     else dprint_arg.output_module = 3;		/* 3 = MCC or character output */
	     dprint_arg.dest = "";			/* obsolete, but initialize */
	     dprint_arg.carriage_control = ""b;		/* no options ... */
	     if file_data.device_type = printer_input_device then do;    /* (printer only) */
		dprint_arg.nep = "1"b;		/* ... except -no_endpage */
		dprint_arg.esc = "1"b;		/* ... and escape processing (logical channel skips) */
	     end;
	     dprint_arg.forms = "";
	     dprint_arg.lmargin = 0;
	     dprint_arg.line_lth = 0;			/* again use the default */
	     dprint_arg.class = "";			/* obsolete, but initialize */
	     dprint_arg.page_lth = 0;
	     dprint_arg.top_label = "";
	     dprint_arg.bottom_label = "";
	     dprint_arg.bit_count = 0;
	     dprint_arg.form_name = "";
	     dprint_arg.destination = "";		/* later */
	     dprint_arg.chan_stop_path = "";
	     substr (dprint_arg.request_type, 1, length (dprint_arg.request_type)) =
		substr (file_data.request_type, 1, length (dprint_arg.request_type));
	     dprint_arg.defer_until_process_termination = 0;

	     unspec (send_mail_info) = "0"b;
	     send_mail_info.version = send_mail_info_version_2;
	     send_mail_info.sent_from = station;
	     send_mail_info.wakeup = "1"b;
	     send_mail_info.always_add = "1"b;
	     send_mail_info.never_add = "0"b;
	     send_mail_info.notify = "0"b;
	     send_mail_info.acknowledge = "0"b;

	     proc_auth = get_authorization_ ();		/* get caller's authorization to use for create_branch_ */

	     call card_util_$modes (control_modes, control_mode_bits, "", code); /* get a bit string for control records */
	     if code ^= 0 then
		call abort (code, "Unable to set control modes.");

	     test_iocbp = null;			/* no place to write log messages defined yet */

	     if testing then do;			/* see if we have a side file to log control records */

/*	Test mode for this procedure consists of writing control records and messages into a log file. */
/*	We assume that the IO switch "test_output" is attached through vfile_ to the log file. */
/*	Test mode is cancelled if this switch is not found or an error occurs while writing. */

		call iox_$look_iocb ("test_output", test_iocbp, code);
		if code ^= 0 | test_iocbp = null then testing = "0"b; /* if not cancel test mode */
		else do;
		     call ioa_$rsnnl ("^/receive_file_: Entry initialization for station ^a.^2/", log_msg, len, station);
		     call iox_$put_chars (test_iocbp, addr (log_msg), len, code);
		     if code ^= 0 then testing = "0"b;	/* cancel on errors */
		end;
	     end;

	end INITIALIZE_STUFF;


RESET_PARAMETERS: proc;

	     file_data = receive_file_data;		/* reset to caller's defaults */

	     file_name = unique_chars_ (""b);		/* in case of the no_ident option */
	     dirname = "";
	     person = default_person;
	     project = default_project;
	     personid = default_personid;

	     input_mode_bits = "0"b;
	     pool_open = "0"b;			/* the user pool is not yet open */
	     read_done = "0"b;
	     file_in_progress = "0"b;
	     user_defined = "0"b;
	     filep, fcbp = null;

	     add_nl = "0"b;				/* set the default data translation modes */
	     lower_case = "0"b;
	     overwrite = "0"b;
	     contin = "0"b;
	     trim = "0"b;

	     substr (dprint_arg.request_type , 1, length (dprint_arg.request_type )) =
	 	substr (file_data.request_type, 1, length (dprint_arg.request_type));
	     dprint_arg.heading = rtrim (station) || " Output   OPERATOR PLEASE LOOK INSIDE FOR BANNER";
	     dprint_arg.bit_count = 0;

	     return;

	end RESET_PARAMETERS;





     end receive_file_;






		    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
