



		    l6_tran_.pl1                    04/09/85  1708.8r w 04/08/85  1129.1      532854



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/******************************************************************************/
/*							        */
/*   DESCRIPTION:						        */
/*							        */
/*        This subroutine is the NASP (see MTB 538) which implements file     */
/*   transfer to the Level 6 over an X.25 channel.		        */
/*							        */
/*							        */
/*   JOURNALIZATION:					        */
/*							        */
/*   1) Written 3/82 by R.J.C Kissel				        */
/*   2) Modified 7/83 by R.J.C. Kissel to handle passwords for Mod 400        */
/*      Release 21. and 3.0, and also fix an error message to the L6.	        */
/*   3) Modified 9/83 by R.J.C. Kissel to fix a bug in handling L6 pathnames. */
/*							        */
/******************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

l6_tran_:
     proc ();
RETURN:						/* Label for error returns. */
	return;

/* Parameters */

dcl  P_arg_list_ptr		       ptr parameter;
dcl  P_area_ptr		       ptr parameter;	/* Null means use the system free area. */
dcl  P_caller_name		       char (*) parameter;
dcl  P_code		       fixed bin (35) parameter;
dcl  P_complete		       bit (1) parameter;	/* "1"b -- request is complete, "0"b -- not complete */
dcl  P_error_message	       char (*) varying parameter;
dcl  P_first_arg		       fixed bin parameter;
dcl  P_in_iocbp		       ptr parameter;
dcl  P_list_flag		       bit (1) parameter;	/* "1"b -- list this request, "0"b -- don't list it */
dcl  P_nasp_info_ptr	       ptr parameter;
dcl  P_output_lines		       char (*) varying parameter;
dcl  P_out_iocbp		       ptr parameter;
dcl  P_queued_flag		       bit (1) parameter;	/* "1"b -- request from queue, "0"b -- interactive request */
dcl  P_structure_len	       fixed bin (24) parameter;
						/* In bits */
dcl  P_structure_ptr	       ptr parameter;
dcl  P_unhold		       bit (1) parameter;	/* "1"b -- update held requests, "0"b -- don't update them */

/* Automatic */

dcl  1 auto_status_branch	       aligned like status_branch;
dcl  1 auto_transfer_input_args      aligned like transfer_input_args;
dcl  1 auto_transfer_output_args     aligned like transfer_output_args;

dcl  arg			       char (arg_len) based (arg_ptr);
dcl  arg_idx		       fixed bin;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  arg_list_ptr		       ptr;

dcl  based_area		       area (sys_info$max_seg_size) based (area_ptr);
dcl  area_ptr		       ptr;

dcl  caller_name		       char (32);
dcl  Cleanup_Handler	       entry () variable;
dcl  code			       fixed bin (35);

dcl  comm_buffer		       char (comm_buffer_len) based (comm_buffer_ptr);
dcl  comm_buffer_len	       fixed bin (21);
dcl  comm_buffer_ptr	       ptr defined (temp_seg_ptrs (1));

dcl  complete_flag		       bit (1);

dcl  file_buffer		       char (file_buffer_len) based (file_buffer_ptr);
dcl  file_buffer_len	       fixed bin (21);
dcl  file_buffer_ptr	       ptr defined (temp_seg_ptrs (2));

dcl  first_arg		       fixed bin;
dcl  i			       fixed bin;
dcl  ignored_len		       fixed bin (21);	/* Used in calls to ioa_$rsnnl. */
dcl  in_iocbp		       ptr;
dcl  last_file		       bit (1);

dcl  level_6_attach_desc	       char (128) varying;
dcl  level_6_chars_read	       fixed bin (21);
dcl  level_6_chars_to_write	       fixed bin (21);
dcl  level_6_data_type	       fixed bin;
dcl  level_6_dir		       char (168);
dcl  level_6_entry		       char (32);
dcl  level_6_file_type	       fixed bin;
dcl  level_6_iocbp		       ptr;
dcl  level_6_max_record_size	       fixed bin;
dcl  level_6_pathname	       char (168);
dcl  level_6_response_pathname       char (168);

dcl  list_flag		       bit (1);

dcl  multics_chars_read	       fixed bin (21);
dcl  multics_chars_to_write	       fixed bin (21);
dcl  multics_dir		       char (168);
dcl  multics_entry		       char (32);

dcl  multics_file_attach_desc	       char (256) varying;
dcl  multics_file_block_size	       fixed bin (21);
dcl  multics_file_iocbp	       ptr;
dcl  multics_file_l6_type	       fixed bin;
dcl  multics_file_type	       fixed bin;
dcl  multics_file_open_mode	       fixed bin;
dcl  multics_file_size	       fixed bin (34);

dcl  multics_is_sender	       bit (1);
dcl  multics_pathname	       char (168);

dcl  number_of_args		       fixed bin;
dcl  output_lines		       char (256) varying;
dcl  out_iocbp		       ptr;
dcl  queued_flag		       bit (1);
dcl  saved_attributes	       char (256) varying;
dcl  saved_level_6_entry	       char (32);
dcl  saved_multics_entry	       char (32);
dcl  star_area_ptr		       ptr;
dcl  star_entries_index	       fixed bin;
dcl  star_names_generated	       bit (1);
dcl  suffix		       char (32);
dcl  temp_seg_ptrs		       (2) ptr;
dcl  total_time		       fixed bin (71);
dcl  unhold_flag		       bit (1);

dcl  1 info		       aligned like indx_info;/* Use the biggest structure. */

/* The l6_tran_ shared structure */

dcl  l6tip		       ptr;
dcl  l6_tran_info_v1	       fixed bin (35) internal static options (constant) init (1);

dcl  1 l6_tran_info		       aligned based (l6tip),
       2 version		       fixed bin (35),
       2 sender_info	       aligned,
         3 pathname		       char (168) unaligned,
         3 host_name	       char (32) unaligned,
       2 receiver_info	       aligned,
         3 pathname		       char (168) unaligned,
         3 host_name	       char (32) unaligned,
       2 net_name		       char (32) unaligned,	/* Really the channel name. */
       2 net_address	       char (32) unaligned,	/* The call data for an x.25 channel. */
       2 multics_data_type	       fixed bin,		/* 1--ascii, 2--binary, 3--bcd */
       2 user_name		       char (32) unaligned,
       2 password		       char (12) unaligned,
       2 flags		       aligned,
         3 long		       bit (1) unaligned,	/* "1"b--print a transfer message, "0"b--don't print it */
         3 l6_attended	       bit (1) unaligned,	/* "1"b--no login needed, "0"b--login needed */
         3 pad		       bit (34) unaligned;

/* Internal Static */

dcl  debug_flag		       bit (1) internal static init ("0"b);

/* Internal Constants */

%include l6_tran_constants;

/* External Constants */

dcl  error_table_$area_too_small     fixed bin (35) ext static;
dcl  error_table_$bad_arg	       fixed bin (35) ext static;
dcl  error_table_$bad_file	       fixed bin (35) ext static;
dcl  error_table_$badopt	       fixed bin (35) ext static;
dcl  error_table_$badpath	       fixed bin (35) ext static;
dcl  error_table_$badstar	       fixed bin (35) ext static;
dcl  error_table_$dirseg	       fixed bin (35) ext static;
dcl  error_table_$fatal_error	       fixed bin (35) ext static;
dcl  error_table_$incompatible_file_attribute
			       fixed bin (35) ext static;
dcl  error_table_$noarg	       fixed bin (35) ext static;
dcl  error_table_$not_closed	       fixed bin (35) ext static;
dcl  error_table_$not_detached       fixed bin (35) ext static;
dcl  error_table_$too_many_args      fixed bin (35) ext static;
dcl  error_table_$unimplemented_version
			       fixed bin (35) ext static;

dcl  sys_info$max_seg_size	       fixed bin (19) ext static;

/* External Entries */

dcl  add_char_offset_	       entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  check_star_name_$entry	       entry (char (*), fixed bin (35));
dcl  cu_$arg_list_ptr	       entry (ptr);
dcl  cu_$arg_ptr		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_count		       entry (fixed bin, fixed bin (35));
dcl  cu_$arg_count_rel	       entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  expand_pathname_	       entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_equal_name_	       entry (char (*), char (*), char (32), fixed bin (35));
dcl  get_user_free_area_	       entry returns (ptr);
dcl  get_temp_segments_	       entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$append_branch	       entry (char (*), char (*), fixed bin (5), fixed bin (35));
dcl  hcs_$star_		       entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$status_		       entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  ioa_$ioa_switch	       entry () options (variable);
dcl  ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
dcl  ioa_$rsnnl		       entry () options (variable);
dcl  ioa_$rsnpnnl		       entry options (variable);
dcl  l6_tran_util_$get_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$get_line	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$put_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  l6_tran_receive_file_	       entry (ptr, ptr, char (*) var, fixed bin (35));
dcl  l6_tran_send_file_	       entry (ptr, ptr, char (*) var, fixed bin (35));
dcl  match_star_name_	       entry (char (*), char (*), fixed bin (35));
dcl  net_info_table_$get_host_address
			       entry (char (*), char (*), char (*), fixed bin (35));
dcl  pathname_		       entry (char (*), char (*)) returns (char (168));
dcl  read_password_$switch	       entry (ptr, ptr, char (*), char (*), fixed bin (35));
dcl  release_temp_segments_	       entry (char (*), (*) ptr, fixed bin (35));
dcl  suffixed_name_$make	       entry (char (*), char (*), char (32), fixed bin (35));
dcl  vfile_status_		       entry (char (*), char (*), ptr, fixed bin (35));
dcl  user_info_$whoami	       entry (char (*), char (*), char (*));

/* Builtin Functions and Conditions */

dcl  addr			       builtin;
dcl  before		       builtin;
dcl  clock		       builtin;
dcl  float		       builtin;
dcl  hbound		       builtin;
dcl  index		       builtin;
dcl  lbound		       builtin;
dcl  length		       builtin;
dcl  min			       builtin;
dcl  null			       builtin;
dcl  pointer		       builtin;
dcl  reverse		       builtin;
dcl  rtrim		       builtin;
dcl  string		       builtin;
dcl  substr		       builtin;
dcl  sum			       builtin;
dcl  unspec		       builtin;

dcl  area			       condition;
dcl  cleanup		       condition;

/* Include Files */

%include nasp_info;

%include l6_tran_transfer_args;

/* vfs_info.incl.pl1 */

%include vfs_info;

%include access_mode_values;

%include status_structures;

%include iox_entries;

%include iox_modes;

%include star_structures;

/******************************************************************************/
/*							        */
/*   ENTRY: parser						        */
/*							        */
/*        This entry is in charge of taking the user's command line arguments */
/*   and building a structure that describes the work to be done.  This       */
/*   structure is used by the other entries so they know what to do.  This    */
/*   entry may ask the user questions if it needs more information.	        */
/*							        */
/******************************************************************************/

parser:
     entry (P_in_iocbp, P_out_iocbp, P_caller_name, P_arg_list_ptr, P_first_arg, P_queued_flag, P_area_ptr,
	P_structure_ptr, P_structure_len, P_error_message, P_code);

	in_iocbp = P_in_iocbp;
	out_iocbp = P_out_iocbp;
	caller_name = P_caller_name;
	arg_list_ptr = P_arg_list_ptr;
	first_arg = P_first_arg;
	queued_flag = P_queued_flag;
	area_ptr = P_area_ptr;

	Cleanup_Handler = Parser_Cleanup;
	l6tip = null ();
	level_6_iocbp = null ();			/* No messages for the L6 from parser. */

	on cleanup call Cleanup_Handler ();

/* Make a quick check, since we currently only support interactive request. */

	if queued_flag
	     then call ERROR (error_table_$unimplemented_version, "Only interactive requests are currently supported.");

	if area_ptr = null () then call ERROR (error_table_$bad_arg, "An area pointer must be specified.");

/* Allocate the shared structure and parse the command line arguments. */

	on area call ERROR (error_table_$area_too_small, "Attempting to allocate the l6_tran_info structure.");

	allocate l6_tran_info in (based_area);

	revert area;

	l6_tran_info.version = l6_tran_info_v1;
	l6_tran_info.sender_info = "";
	l6_tran_info.receiver_info = "";
	l6_tran_info.net_name = "";			/* Default */
	l6_tran_info.multics_data_type = ASCII;		/* Default */

	call user_info_$whoami (l6_tran_info.user_name, "", "");
						/* Set the default. */

	l6_tran_info.password = "";
	l6_tran_info.flags = "0"b;			/* Reset all of them. */
	l6_tran_info.flags.long = "1"b;		/* Default */

	call cu_$arg_count_rel (number_of_args, arg_list_ptr, code);
	if code ^= 0 then call ERROR (code);

	if number_of_args - first_arg + 1 < 4 then call ERROR (error_table_$noarg, "^/^a.", USAGE);

	if number_of_args - first_arg + 1 > 11 then call ERROR (error_table_$too_many_args, "^/^a.", USAGE);

	do arg_idx = first_arg to number_of_args;	/* Process the arguments. */

	     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
	     if code ^= 0 then call ERROR (code, "Trying to get argument: ^d.", arg_idx);

	     if index (arg, "-") ^= 1
		then call Process_File_Name ();

		else do;				/* Process a control arg. */

		     if arg = "-name" | arg = "-nm"
			then do;
			     arg_idx = arg_idx + 1;

			     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
			     if code ^= 0 then call ERROR (code, "Trying to get the name after a -name argument.");

			     call Process_File_Name ();
			     end;

		     else if arg = "-data_type"
			then do;
			     arg_idx = arg_idx + 1;
			     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
			     if code ^= 0 then call ERROR (code, "Trying to get the data type.");

			     if arg = "ascii" | arg = "ASCII" then l6_tran_info.multics_data_type = ASCII;
			     else if arg = "binary" | arg = "BINARY" then l6_tran_info.multics_data_type = BINARY;
			     else if arg = "bcd" | arg = "BCD" then l6_tran_info.multics_data_type = BCD;
			     else call ERROR (error_table_$bad_arg, "Unrecognized data type: ^a.", arg);
			     end;

		     else if arg = "-long" | arg = "-lg" then l6_tran_info.flags.long = "1"b;

		     else if arg = "-brief" | arg = "-bf" then l6_tran_info.flags.long = "0"b;

		     else if arg = "-attended" | arg = "-att" then l6_tran_info.flags.l6_attended = "1"b;

		     else if arg = "-not_attended" | arg = "-natt" then l6_tran_info.flags.l6_attended = "0"b;

		     else if arg = "-user"
			then do;
			     arg_idx = arg_idx + 1;
			     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
			     if code ^= 0 then call ERROR (code, "Trying to get the user argument.");

			     l6_tran_info.user_name = arg;
			     end;

		     else if arg = "-password" | arg = "-pw"
			then do;
			     arg_idx = arg_idx + 1;
			     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
			     if code ^= 0 then call ERROR (code, "Trying to get the password argument.");

			     l6_tran_info.password = arg;
			     end;

		     else if arg = "-network" | arg = "-net"
			then do;
			     arg_idx = arg_idx + 1;
			     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
			     if code ^= 0 then call ERROR (code, "Trying to get the network (channel) argument.");

			     l6_tran_info.net_name = arg;
			     end;

		     else call ERROR (error_table_$badopt, "Argument: ^a.", arg);
		     end;				/* Process a control arg. */

	end;					/* Process the arguments. */

/* Make some checks to make sure we have everything we need. */

	if l6_tran_info.sender_info.pathname = ""
	     then call ERROR (error_table_$noarg, "A source pathname must be specified.");

	if l6_tran_info.receiver_info.pathname = ""
	     then call ERROR (error_table_$noarg, "A destination pathname must be specified.");

	if l6_tran_info.sender_info.host_name ^= "" & l6_tran_info.receiver_info.host_name ^= ""
	     then call ERROR (error_table_$too_many_args,
		     "Only one file name may have a host specified with the ""-at"" argument.");

	if l6_tran_info.net_name = ""
	     then call ERROR (error_table_$noarg, "A network name (X.25 channel name) must be specified.");

	if l6_tran_info.sender_info.host_name ^= ""
	     then call net_info_table_$get_host_address (l6_tran_info.sender_info.host_name, l6_tran_info.net_name,
		     l6_tran_info.net_address, code);
	     else call net_info_table_$get_host_address (l6_tran_info.receiver_info.host_name, l6_tran_info.net_name,
		     l6_tran_info.net_address, code);

	if code ^= 0
	     then call ERROR (code, "Unrecognized host: ^[^a^;^a^].", l6_tran_info.sender_info.host_name ^= "",
		     l6_tran_info.sender_info.host_name, l6_tran_info.receiver_info.host_name);

	if l6_tran_info.net_address = ""
	     then call ERROR (error_table_$noarg,
		     "Either the source or destination file must specify the ""-at"" argument with a host name (address)."
		     );


	P_structure_ptr = l6tip;
	P_structure_len = length (unspec (l6_tran_info)); /* Length in bits. */
	P_error_message = "";
	P_code = 0;

	return;

/******************************************************************************/
/*							        */
/*   ENTRY: execute						        */
/*							        */
/*        This entry is in charge of doing the actual work for a L6 file      */
/*   transfer.  It uses the structure built by the parser entry to find out   */
/*   what to do.  It may communicate with the user or operator to clarify     */
/*   operations in some cases.				        */
/*							        */
/******************************************************************************/

execute:
     entry (P_in_iocbp, P_out_iocbp, P_caller_name, P_queued_flag, P_structure_ptr, P_structure_len, P_complete, P_unhold,
	P_error_message, P_code);

	in_iocbp = P_in_iocbp;
	out_iocbp = P_out_iocbp;
	caller_name = P_caller_name;
	queued_flag = P_queued_flag;
	l6tip = P_structure_ptr;

/* Set things up for the cleanup handler. */

	Cleanup_Handler = Execute_Cleanup;
	status_area_ptr = null ();
	status_ptr = null ();
	auto_status_branch.nnames = 0;
	auto_status_branch.names_relp = "0"b;
	multics_file_iocbp = null ();
	level_6_iocbp = null ();
	file_buffer_ptr = null ();
	comm_buffer_ptr = null ();

	star_names_generated = "0"b;
	star_entry_ptr = null ();
	star_names_ptr = null ();
	star_area_ptr = null ();
	star_entry_count = 0;
	star_entries_index = 0;

	on cleanup call Cleanup_Handler ();

/* Find out who is sending, and get pathnames. */

	if l6_tran_info.sender_info.host_name = ""	/* A host name means the Level 6. */
	     then do;
		multics_is_sender = "1"b;
		multics_pathname = l6_tran_info.sender_info.pathname;
		level_6_pathname = l6_tran_info.receiver_info.pathname;
		end;

	     else do;
		multics_is_sender = "0"b;
		multics_pathname = l6_tran_info.receiver_info.pathname;
		level_6_pathname = l6_tran_info.sender_info.pathname;
		end;

	call expand_pathname_ (multics_pathname, multics_dir, saved_multics_entry, code);
	if code ^= 0 then call ERROR (code, "Trying to expand multics pathname: ^a.", multics_pathname);

	multics_pathname = pathname_ (multics_dir, saved_multics_entry);
						/* "Canonicalize" the pathname for vfile_. */
	multics_entry = saved_multics_entry;

	saved_level_6_entry = reverse (before (reverse (level_6_pathname), ">"));
	level_6_dir =
	     substr (level_6_pathname, 1, length (rtrim (level_6_pathname)) - length (rtrim (saved_level_6_entry)));
	level_6_entry = saved_level_6_entry;

/* Make some minimal syntax checks on the L6 pathname. */

	if multics_is_sender & (level_6_entry = "**" | index (substr (level_6_pathname, 2), "^") ^= 0)
	     then call ERROR (error_table_$badpath, "Invalid L6 pathname: ^a.", level_6_pathname);

/* Get temp segments for buffers for file IO and Level 6 IO. */

	call get_temp_segments_ ("l6_tran_", temp_seg_ptrs, code);
	if code ^= 0 then call ERROR (code, "Trying to get temp segs for I/O buffers.");

	comm_buffer_len = sys_info$max_seg_size * 4;
	file_buffer_len = sys_info$max_seg_size * 4;

/* Now do the real work.  We are always the initiator and the Level 6 is the acceptor. */

	if multics_is_sender
	     then do;				/* We are sending, and the file must exist. */
		call Open_L6_Connection ();

		if ^l6_tran_info.flags.l6_attended then call Login_Dialogue ();

		call OK_Dialogue ();

		last_file = "0"b;			/* Do the loop at least once. */
		do while (^last_file);

		     call Get_Next_Path (last_file);

		     info.info_version = vfs_version_1;
		     call vfile_status_ (multics_dir, multics_entry, addr (info), code);
		     if code ^= 0
			then call ERROR (code, "Trying to get vfile_status_ on: ^a, for sending.", multics_pathname)
				;

		     call Check_Multics_File ();

		     call Open_Multics_File ();

		     call Get_Saved_Attributes ();

		     call File_Definition_Dialogue ();

		     if l6_tran_info.flags.long
			then do;
			     total_time = clock ();
			     call ioa_$ioa_switch (out_iocbp,
				"Starting transfer of Multics file: ^a to Level 6 file: ^a.", multics_pathname,
				level_6_pathname);
			     end;

		     auto_transfer_input_args.version = transfer_input_args_version_1;
		     auto_transfer_input_args.comm_iocbp = level_6_iocbp;
		     auto_transfer_input_args.comm_buffer_ptr = comm_buffer_ptr;
		     auto_transfer_input_args.comm_buffer_len = comm_buffer_len;
		     auto_transfer_input_args.file_iocbp = multics_file_iocbp;
		     auto_transfer_input_args.file_buffer_ptr = file_buffer_ptr;
		     auto_transfer_input_args.file_buffer_len = file_buffer_len;
		     auto_transfer_input_args.file_type = multics_file_type;
		     auto_transfer_input_args.data_type = multics_data_type;
		     auto_transfer_input_args.tu_size = SEND_TU_SIZE;
		     auto_transfer_input_args.last_file = last_file;

		     auto_transfer_input_args.prompt_read = (level_6_chars_read ^= 0);
						/* Set in File_Definition_Dialogue. */

		     auto_transfer_output_args.version = transfer_output_args_version_1;

		     call l6_tran_send_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args),
			P_error_message, P_code);
		     if P_code ^= 0
			then do;
			     call Cleanup_Handler ();
			     return;
			     end;

		     if l6_tran_info.flags.long
			then do;
			     total_time = clock () - total_time;
			     call ioa_$ioa_switch (out_iocbp,
				"Completed transfer of ^d records (^d bytes) in ^.3f seconds (^.3f bytes/sec).",
				auto_transfer_output_args.record_number + 1,
				auto_transfer_output_args.total_bytes, float (total_time) / 1e6,
				float (auto_transfer_output_args.total_bytes) / (float (total_time) / 1e6));
			     end;

		     call iox_$close (multics_file_iocbp, code);
		     call iox_$detach_iocb (multics_file_iocbp, code);
		     call iox_$destroy_iocb (multics_file_iocbp, code);

		end;				/* The last_file loop. */

/* "E" is not enough for the L6, send this too. */

		level_6_chars_to_write = length (" 005&");
		substr (comm_buffer, 1, level_6_chars_to_write) = " 005&";

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
						/* Ignore the code. */
		end;				/* We are sending, and the file must exist. */

	     else do;				/* We are receiving, and the file may or may not exist. */
		call Open_L6_Connection ();

		if ^l6_tran_info.flags.l6_attended then call Login_Dialogue ();

		call OK_Dialogue ();

		last_file = "0"b;			/* Loop at least once. */
		do while (^last_file);

		     level_6_response_pathname = "";	/* The L6 may tell us differently. */
		     call File_Definition_Dialogue ();

		     call Generate_Multics_Path ();

		     info.info_version = vfs_version_1;
		     call vfile_status_ (multics_dir, multics_entry, addr (info), code);

		     if code = 0
			then do;
			     call Check_Multics_File ();
			     call Verify_File_Attributes ();
			     end;

			else call Create_Multics_File ();

		     call Open_Multics_File ();

		     call Set_Saved_Attributes ();

		     if l6_tran_info.flags.long
			then do;
			     total_time = clock ();
			     call ioa_$ioa_switch (out_iocbp,
				"Starting transfer of Level 6 file: ^[^a^s^;^s^a^] to Multics file: ^a.",
				level_6_response_pathname ^= "", level_6_response_pathname, level_6_pathname,
				multics_pathname);
			     end;

		     auto_transfer_input_args.version = transfer_input_args_version_1;
		     auto_transfer_input_args.comm_iocbp = level_6_iocbp;
		     auto_transfer_input_args.comm_buffer_ptr = comm_buffer_ptr;
		     auto_transfer_input_args.comm_buffer_len = comm_buffer_len;
		     auto_transfer_input_args.file_iocbp = multics_file_iocbp;
		     auto_transfer_input_args.file_buffer_ptr = file_buffer_ptr;
		     auto_transfer_input_args.file_buffer_len = file_buffer_len;
		     auto_transfer_input_args.file_type = multics_file_type;
		     auto_transfer_input_args.data_type = multics_data_type;
		     auto_transfer_input_args.tu_size = RECV_TU_SIZE;

		     auto_transfer_output_args.version = transfer_output_args_version_1;

		     call l6_tran_receive_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args),
			P_error_message, P_code);
		     if P_code ^= 0
			then do;
			     call Cleanup_Handler ();
			     return;
			     end;

		     last_file = auto_transfer_output_args.last_file;

		     if l6_tran_info.flags.long
			then do;
			     total_time = clock () - total_time;
			     call ioa_$ioa_switch (out_iocbp,
				"Completed transfer of ^d records (^d bytes) in ^.3f seconds (^.3f bytes/sec).",
				auto_transfer_output_args.record_number + 1,
				auto_transfer_output_args.total_bytes, float (total_time) / 1e6,
				float (auto_transfer_output_args.total_bytes) / (float (total_time) / 1e6));
			     end;

		     call iox_$close (multics_file_iocbp, code);
		     call iox_$detach_iocb (multics_file_iocbp, code);
		     call iox_$destroy_iocb (multics_file_iocbp, code);

		end;				/* The last_file loop. */
		end;				/* We are receiving, and the file may or may not exist. */

	call Cleanup_Handler ();

	P_complete = "1"b;
	P_unhold = "1"b;
	P_error_message = "";
	P_code = 0;

	return;
%page;
/******************************************************************************/
/*							        */
/*   These entries are not yet implemented.  We just want to document their   */
/*   calling sequences.					        */
/*							        */
/******************************************************************************/

cancel:
     entry (P_structure_ptr, P_structure_len, P_error_message, P_code);

	P_code = error_table_$unimplemented_version;
	return;
%skip (5);
modify:
     entry (P_in_iocbp, P_out_iocbp, P_caller_name, P_arg_list_ptr, P_first_arg, P_structure_ptr, P_structure_len,
	P_error_message, P_code);

	P_code = error_table_$unimplemented_version;
	return;
%skip (5);
list:
     entry (P_arg_list_ptr, P_first_arg, P_structure_ptr, P_structure_len, P_list_flag, P_output_lines, P_error_message,
	P_code);

	P_code = error_table_$unimplemented_version;
	return;
%skip (5);
info:
     entry (P_structure_ptr, P_structure_len, P_nasp_info_ptr, P_error_message, P_code);

	P_code = error_table_$unimplemented_version;
	return;

Check_Multics_File:
     proc ();

	multics_file_type = info.type;

	if multics_file_type > BLOCKED_FILE_TYPE
	     then call ERROR (error_table_$bad_file,
		     "The Multics file must be unstructured, sequential, or blocked.  File ^a is ^a.",
		     multics_pathname, FILE_TYPE_TO_PNAME (multics_file_type));

	if multics_file_type = BLOCKED_FILE_TYPE
	     then do;
		multics_file_block_size = blk_info.max_rec_len;
		multics_file_size = blk_info.end_pos;
		end;

	     else do;
		multics_file_block_size = 0;
		multics_file_size = 0;
		end;

	multics_file_l6_type = L6_S_FILE_TYPE;		/* This is the default. */

/* Now find out if the file is special by looking for the suffix we put on it. */

	status_area_ptr = get_user_free_area_ ();
	status_ptr = addr (auto_status_branch);

	call hcs_$status_ (multics_dir, multics_entry, CHASE, status_ptr, status_area_ptr, code);
	if code ^= 0 then call ERROR (code, "Trying to get status for: ^a.", multics_pathname);

	if status_branch.short.type = Directory then call ERROR (error_table_$dirseg, "^a.", multics_pathname);

	code = 1;					/* Go through the loop at least once. */
	do i = lbound (status_entry_names, 1) to hbound (status_entry_names, 1) while (code ^= 0);
	     call match_star_name_ ((status_entry_names (i)), "**.*.l6*", code);
	     if code = 0
		then do;
		     suffix = reverse (before (reverse (rtrim (status_entry_names (i))), "."));

		     do i = lbound (MULTICS_L6_FILE_SUFFIX, 1) to hbound (MULTICS_L6_FILE_SUFFIX, 1)
			while (suffix ^= MULTICS_L6_FILE_SUFFIX (i));
		     end;

		     if i > hbound (MULTICS_L6_FILE_SUFFIX, 1)
			then code = 1;		/* Keep looking. */
			else multics_file_l6_type = i;
		     end;
	end;

	if status_branch.nnames > 0 & status_branch.names_relp ^= "0"b
	     then free status_entry_names in (status_area_ptr -> based_area);
						/* Cleanup after ourselves. */

	if l6_tran_info.multics_data_type = BINARY & multics_file_type = UNSTRUCTURED_FILE_TYPE
	     then call ERROR (error_table_$incompatible_file_attribute,
		     "A binary file must be a sequential or blocked file: ^a.", multics_pathname);

	return;

     end Check_Multics_File;

Create_Multics_File:
     proc ();

	multics_file_l6_type = level_6_file_type;

	if level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII
	     then multics_file_type = UNSTRUCTURED_FILE_TYPE;

	else if level_6_file_type = L6_S_FILE_TYPE then multics_file_type = SEQUENTIAL_FILE_TYPE;

	else multics_file_type = BLOCKED_FILE_TYPE;

	if multics_file_type = BLOCKED_FILE_TYPE
	     then do;
		if level_6_max_record_size = 0
		     then multics_file_block_size = 256;/* Set default. */
		     else multics_file_block_size = level_6_max_record_size;
		end;

	     else multics_file_block_size = 0;

	multics_file_size = 0;

	if MULTICS_L6_FILE_SUFFIX (multics_file_l6_type) ^= ""
	     then do;
		call suffixed_name_$make (multics_entry, MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_entry,
		     code);
		if code ^= 0
		     then call ERROR (code, "Trying to add the suffix ""^a"" to ^a",
			     MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_pathname);

		multics_pathname = pathname_ (multics_dir, multics_entry);
		end;

	call hcs_$append_branch (multics_dir, multics_entry, RW_ACCESS_BIN, code);
	if code ^= 0 then call ERROR (code, "Trying to create: ^a.", multics_pathname);

	return;

     end Create_Multics_File;

File_Definition_Dialogue:
     proc ();

dcl  acceptor_file_count	       pic "99";
dcl  chars_read		       fixed bin (21);
dcl  ci_size		       pic "99999";
dcl  char_position		       fixed bin;
dcl  data_type		       char (1);
dcl  file_access		       char (1);
dcl  file_name_len		       pic "99";
dcl  file_size		       pic "99999";
dcl  file_type		       char (1);
dcl  fixed_response_len	       fixed bin (21);
dcl  indicator		       char (1);
dcl  initiator_file_count	       pic "99";
dcl  key_length		       pic "999";
dcl  key_offset		       pic "9999";
dcl  key_type		       char (1);

dcl  1 l6_response		       unaligned based (comm_buffer_ptr),
       2 header,
         3 first_char	       char (1),		/* Should be "8". */
         3 response_len	       pic "999",
         3 ack_indicator	       char (1),		/* "$"--yes, "&"--no. */
       2 rest_of_response	       char (rest_of_response_len);

dcl  l6_response_path_len	       pic "99";
dcl  output_message_len	       pic "999";
dcl  percent_fill		       pic "99";
dcl  record_size		       pic "9999";
dcl  rest_of_response_len	       fixed bin;
dcl  starting_record	       pic "99999";

	if multics_is_sender
	     then do;				/*  We must describe the file to the Level 6. */
		file_name_len = length (rtrim (level_6_pathname)) + 1;
						/* The L6 requires a trailing space in the name. */
		record_size = multics_file_block_size;
		starting_record = 0;
		file_size = multics_file_size;
		initiator_file_count = 1;
		acceptor_file_count = 1;

		call ioa_$rsnpnnl (" 000 O!^2a^a ^[#^a^;^s#P^aQ^a^[R^a^;^s^]S^a^[Z^a^;^s^][^a\^a^]", comm_buffer,
		     level_6_chars_to_write, file_name_len, rtrim (level_6_pathname), saved_attributes ^= "",
		     saved_attributes, L6_FILE_TYPE (multics_file_l6_type),
		     L6_DATA_TYPE (l6_tran_info.multics_data_type), multics_file_block_size > 0, record_size,
		     starting_record, multics_file_size > 0, file_size, initiator_file_count, acceptor_file_count);

		output_message_len = level_6_chars_to_write;
						/* Set the message length. */
		substr (comm_buffer, 2, 3) = output_message_len;

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		if code ^= 0 then call ERROR (code, "Trying to send the output file definition to the Level 6.");
		end;				/*  We must describe the file to the Level 6. */

	     else do;				/* The Level 6 will tell us about the file. */
		file_name_len = length (rtrim (level_6_pathname)) + 1;
						/* The L6 requires a trailing space in the name. */

		call ioa_$rsnpnnl (" 000 I!^2a^a ", comm_buffer, level_6_chars_to_write, file_name_len,
		     rtrim (level_6_pathname));

		output_message_len = level_6_chars_to_write;
						/* Set the message length. */
		substr (comm_buffer, 2, 3) = output_message_len;

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		if code ^= 0 then call ERROR (code, "Trying to send the input file definition to the Level 6.");
		end;				/* The Level 6 will tell us about the file. */

/* Get the Level 6 response to our request.  This involves a loop to get everything he says he sent. */

	call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code);
	if code ^= 0 then call ERROR (code, "Trying to read the output file definition ack from the Level 6.");

	fixed_response_len = l6_response.response_len;
	rest_of_response_len = fixed_response_len - length (string (l6_response.header));

	do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read
	     while (chars_read < fixed_response_len);
	     call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read),
		comm_buffer_len - chars_read, level_6_chars_read, code);
	     if code ^= 0 then call ERROR (code, "Trying to read the output file definition ack from the Level 6.");
	end;


/*****************************************************************************/
/*							       */
/*   Do the following strange thing in case the first prompt sent by the L6  */
/*   was combined with the file definition response when we called	       */
/*   get_chars.  The variable level_6_chars_read is declared in our caller,  */
/*   so set it to be any extra characters after the response.  We will       */
/*   assume that this is the prompt and will not try to get the prompt in    */
/*   l6_tran_send_file_.  We have to do a similar thing in		       */
/*   l6_tran_overseer_, but there we use a write_status to guarantee that    */
/*   our response is not combined with our prompt.  This stuff is all a      */
/*   kludge because there is no way to use the "more_data" bit in an X.25    */
/*   packet on Multics.					       */
/*							       */
/*****************************************************************************/

	level_6_chars_read = level_6_chars_read - fixed_response_len;

/*****************************************************************************/

	if l6_response.ack_indicator ^= "$"
	     then do;
		if l6_response.rest_of_response = "'82FF"
		     then call ERROR (0b, "The last file has been received.");
						/* Not really an error. */
		     else call ERROR (error_table_$fatal_error,
			     "The Level 6 rejected the file transfer.  From L6: ^a.", l6_response.rest_of_response);
		end;

/* Set default level 6 file attributes, and then get the real ones, if any. */

	level_6_data_type = ASCII;
	level_6_file_type = L6_S_FILE_TYPE;
	level_6_max_record_size = 0;

	if l6_response.rest_of_response ^= ""
	     then do;				/* Process the file attributes. */
		char_position = 1;
		do while (char_position <= length (l6_response.rest_of_response));
						/* Loop through the file attributes. */
		     indicator = substr (l6_response.rest_of_response, char_position, length (indicator));
		     char_position = char_position + length (indicator);

		     if indicator = "!"
			then do;			/* He is sending us his pathname. */
			     string (l6_response_path_len) =
				substr (l6_response.rest_of_response, char_position,
				length (l6_response_path_len));

			     char_position = char_position + length (l6_response_path_len);

			     level_6_response_pathname =
				substr (l6_response.rest_of_response, char_position, l6_response_path_len);

			     char_position = char_position + l6_response_path_len;
			     end;			/* He is sending us his pathname. */

		     else if indicator = "#"
			then saved_attributes = substr (l6_response.rest_of_response, char_position);

		     else if indicator = "P"
			then do;			/* File type */
			     file_type = substr (l6_response.rest_of_response, char_position, length (file_type));
			     char_position = char_position + length (file_type);

			     level_6_file_type = index (string (L6_FILE_TYPE), file_type);

			     if level_6_file_type = 0
				then call ERROR (error_table_$bad_file,
					"The Level 6 file type: ""^a"", is not supported.", file_type);
			     end;

		     else if indicator = "Q"
			then do;			/* Data type */
			     data_type = substr (l6_response.rest_of_response, char_position, length (data_type));
			     char_position = char_position + length (data_type);

			     level_6_data_type = index (string (L6_DATA_TYPE), data_type);

			     if level_6_data_type = 0
				then call ERROR (error_table_$bad_file,
					"The Level 6 data type: ""^a"", is not supported.", data_type);
			     end;

		     else if indicator = "R"
			then do;			/* Record size */
			     string (record_size) =
				substr (l6_response.rest_of_response, char_position, length (record_size));
			     char_position = char_position + length (record_size);

			     level_6_max_record_size = record_size;
			     end;

		     else if indicator = "S"
			then do;			/* Starting record */
			     string (starting_record) =
				substr (l6_response.rest_of_response, char_position, length (starting_record));
			     char_position = char_position + length (starting_record);
			     end;

		     else if indicator = "T"
			then do;			/* File access code */
			     file_access =
				substr (l6_response.rest_of_response, char_position, length (file_access));
			     char_position = char_position + length (file_access);
			     end;

		     else if indicator = "U"
			then do;			/* Key length */
			     string (key_length) =
				substr (l6_response.rest_of_response, char_position, length (key_length));
			     char_position = char_position + length (key_length);
			     end;

		     else if indicator = "V"
			then do;			/* Key offset */
			     string (key_offset) =
				substr (l6_response.rest_of_response, char_position, length (key_offset));
			     char_position = char_position + length (key_offset);
			     end;

		     else if indicator = "W"
			then do;			/* Percent fill */
			     string (percent_fill) =
				substr (l6_response.rest_of_response, char_position, length (percent_fill));
			     char_position = char_position + length (percent_fill);
			     end;

		     else if indicator = "X"
			then do;			/* Key type */
			     key_type = substr (l6_response.rest_of_response, char_position, length (key_type));
			     char_position = char_position + length (key_type);
			     end;

		     else if indicator = "Y"
			then do;			/* CI size */
			     string (ci_size) =
				substr (l6_response.rest_of_response, char_position, length (ci_size));
			     char_position = char_position + length (ci_size);
			     end;

		     else if indicator = "Z"
			then do;			/* File size (in CI units) */
			     string (file_size) =
				substr (l6_response.rest_of_response, char_position, length (file_size));
			     char_position = char_position + length (file_size);
			     end;

		     else if indicator = "["
			then do;			/* Initiator's file count */
			     string (initiator_file_count) =
				substr (l6_response.rest_of_response, char_position,
				length (initiator_file_count));
			     char_position = char_position + length (initiator_file_count);
			     end;

		     else if indicator = "\"
			then do;			/* Acceptor's file count */
			     string (acceptor_file_count) =
				substr (l6_response.rest_of_response, char_position, length (acceptor_file_count))
				;
			     char_position = char_position + length (acceptor_file_count);
			     end;

		     else ;			/* Not recognized, skip it */

		end;				/* Loop through the attributes. */
		end;				/* Process the file attributes. */

	return;

     end File_Definition_Dialogue;

Generate_Multics_Path:
     proc ();

dcl  code			       fixed bin (35);
dcl  l6_entryname		       char (32);

	if level_6_response_pathname ^= ""
	     then do;				/* We must generate the Multics name. */
		l6_entryname = reverse (before (reverse (level_6_response_pathname), ">"));

		call get_equal_name_ (l6_entryname, saved_multics_entry, multics_entry, code);
		if code ^= 0
		     then call ERROR (code, "Trying to do equal name processing on: ^a, matching: ^a.",
			     saved_multics_entry, l6_entryname);

		multics_pathname = pathname_ (multics_dir, multics_entry);
		end;				/* We must generate the Multics name. */

	return;

     end Generate_Multics_Path;

Get_Next_Path:
     proc (P_last_file);

dcl  P_last_file		       bit (1) parameter;

dcl  code			       fixed bin (35);

	call check_star_name_$entry (saved_multics_entry, code);

	if code = 0 then P_last_file = "1"b;		/* Not a star name, nothing to do. */

	else if code = error_table_$badstar then call ERROR (code, "Multics file name: ^a.", saved_multics_entry);

	else do;					/* We have a star name. */
	     if ^star_names_generated
		then do;				/* Get the star list once. */
		     star_area_ptr = get_user_free_area_ ();

		     call hcs_$star_ (multics_dir, saved_multics_entry, star_ALL_ENTRIES, star_area_ptr,
			star_entry_count, star_entry_ptr, star_names_ptr, code);
		     if code ^= 0
			then call ERROR (code, "Trying to match starname ^a in directory ^a.", saved_multics_entry,
				multics_dir);

/* Set the index to the first non-directory entry. */

		     do star_entries_index = 1 to hbound (star_entries, 1)
			while (star_entries (star_entries_index).type = star_DIRECTORY);
		     end;

		     if star_entries_index > hbound (star_entries, 1)
			then call ERROR (error_table_$dirseg, "Only directories match ^a.", multics_pathname);

		     star_names_generated = "1"b;
		     end;				/* Get the star list once. */

/* Just use the first matching name on an entry. */

	     multics_entry = star_names (star_entries (star_entries_index).nindex);
	     multics_pathname = pathname_ (multics_dir, multics_entry);

/* Now update the star_entries_index and set P_last_file. */

	     do star_entries_index = star_entries_index + 1 to hbound (star_entries, 1)
		while (star_entries (star_entries_index).type = star_DIRECTORY);
	     end;

	     if star_entries_index > hbound (star_entries, 1)
		then P_last_file = "1"b;
		else P_last_file = "0"b;
	     end;					/* We have a star name. */

/* Now generate the L6 pathname. */

	call get_equal_name_ (multics_entry, saved_level_6_entry, level_6_entry, code);
	if code ^= 0
	     then call ERROR (code, "Trying to do equalname matching on L6 name: ^a, against Multics name: ^a.",
		     saved_level_6_entry, multics_entry);

	level_6_pathname = rtrim (level_6_dir) || level_6_entry;

	return;

     end Get_Next_Path;

Get_Saved_Attributes:
     proc ();

	if multics_file_l6_type ^= L6_S_FILE_TYPE
	     then do;
		call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code)
		     ;
		if code ^= 0
		     then call ERROR (code, "Trying to get the file attributes from the multics file: ^a.",
			     multics_pathname);

		saved_attributes = substr (file_buffer, 1, multics_chars_read);
		end;

	     else saved_attributes = "";

	return;

     end Get_Saved_Attributes;

Login_Dialogue:
     proc ();

dcl  chars_read		       fixed bin (21);
dcl  greeting_message_found	       bit (1);

	call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code);
	if code ^= 0 then call ERROR (code, "Trying to read the Level 6 greeting message.");

	greeting_message_found = "0"b;
	do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read while (^greeting_message_found);
						/* Discard extraneous lines. */

	     if index (substr (comm_buffer, 1, chars_read), "LOAD = ") ^= 0
		| index (substr (comm_buffer, 1, chars_read), "Load = ") ^= 0
		| index (substr (comm_buffer, 1, chars_read), "LOGIN") ^= 0
		then do;				/* We have found a greeting message. */
		     greeting_message_found = "1"b;

		     if debug_flag
			then call ioa_$rsnpnnl ("l ^a -bf -create -nw -pf -nosave -po l6_tran_overseer_^/",
				comm_buffer, level_6_chars_to_write, l6_tran_info.user_name);

			else call ioa_$rsnpnnl ("L ^a -PO TRANX -ARG ^[R^;S^]DAU^a", comm_buffer,
				level_6_chars_to_write, l6_tran_info.user_name, multics_is_sender, CR);

		     call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		     if code ^= 0 then call ERROR (code, "Trying to send the login line to the Level 6.");

/* Read characters until we find "HI" or "PASSWORD" as a substring, then assume we got everything since there is no delimiter. */

		     call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len,
			level_6_chars_read, code);
		     if code ^= 0 then call ERROR (code, "Trying to read ""HI"" or ""PASSWORD"" after login.");

		     do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read
			while ((index (substr (comm_buffer, 1, chars_read), "HI") = 0)
			& (index (substr (comm_buffer, 1, chars_read), "PASSWORD") = 0));
			call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read),
			     comm_buffer_len - chars_read, level_6_chars_read, code);
			if code ^= 0 then call ERROR (code, "Trying to read ""HI"" or ""PASSWORD"" after login.");
		     end;

		     if index (substr (comm_buffer, 1, chars_read), "PASSWORD") ^= 0
			then do;			/* L6 wants a password. */
			     if l6_tran_info.password = ""
				then do;		/* Get the password from the user. */
				     call read_password_$switch (out_iocbp, in_iocbp,
					"Level 6 has requested password:", l6_tran_info.password, code);
						/* Forget the code, we won't use it anyway. */
				     end;		/* Get the password from the user. */

			     level_6_chars_to_write = length (rtrim (l6_tran_info.password));

			     if debug_flag
				then substr (comm_buffer, 1, level_6_chars_to_write) =
					rtrim (l6_tran_info.password) || "
";
				else substr (comm_buffer, 1, level_6_chars_to_write) =
					rtrim (l6_tran_info.password);

			     l6_tran_info.password = "";
						/* Erase the password now. */

			     call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write,
				code);
			     if code ^= 0 then call ERROR (code, "Trying to send the password to the Level 6.");

/* Read characters until we find "HI" as a substring, then assume we got everything since there is no delimiter. */

			     call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len,
				level_6_chars_read, code);
			     if code ^= 0 then call ERROR (code, "Trying to read ""HI"" after login.");

			     do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read
				while (index (substr (comm_buffer, 1, chars_read), "HI") = 0);
				call l6_tran_util_$get_chars (level_6_iocbp,
				     add_char_offset_ (comm_buffer_ptr, chars_read), comm_buffer_len - chars_read,
				     level_6_chars_read, code);
				if code ^= 0 then call ERROR (code, "Trying to read ""HI"" after login.");
			     end;

			     end;			/* L6 wants a password. */

			else ;			/* We found the "HI", and that's it. */

		     end;				/* We have found a greeting message. */

		else do;				/* Get some more characters and look again. */
		     greeting_message_found = "0"b;

		     call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read),
			comm_buffer_len - chars_read, level_6_chars_read, code);
		     if code ^= 0 then call ERROR (code, "Trying to read the Level 6 greeting message.");
		     end;

	end;					/* Discard extraneous lines. */

	return;

     end Login_Dialogue;

OK_Dialogue:
     proc ();

	level_6_chars_to_write = length ("OK?");
	substr (comm_buffer, 1, level_6_chars_to_write) = "OK?";

	call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
	if code ^= 0 then call ERROR (code, "Trying to send ""OK?"" to the Level 6.");

	call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code);
	if code ^= 0 then call ERROR (code, "Trying to read ""OK"" from the Level 6.");

	if substr (comm_buffer, 1, level_6_chars_read) ^= "OK" then ;
						/* Something wrong, but keep going anyway. */

	return;

     end OK_Dialogue;

Open_L6_Connection:
     proc ();

	call ioa_$rsnnl ("tty_ ^a -destination ^a", level_6_attach_desc, ignored_len, l6_tran_info.net_name,
	     l6_tran_info.net_address);

	call iox_$attach_name (l6_tran_info.net_name, level_6_iocbp, (level_6_attach_desc), null (), code);
	if code ^= 0 & code ^= error_table_$not_detached
	     then call ERROR (code, "Trying to attach the Level 6 on channel: ^a.", l6_tran_info.net_name);

	call iox_$open (level_6_iocbp, Stream_input_output, "0"b, code);
	if code ^= 0 & code ^= error_table_$not_closed
	     then call ERROR (code, "Trying to open the Level 6 channel: ^a.", l6_tran_info.net_name);

	call iox_$modes (level_6_iocbp, "8bit,rawi,rawo", "", code);
	if code ^= 0
	     then call ERROR (code, "Trying to set modes on switch: ^a to ""8bit,rawi,rawo"".", l6_tran_info.net_name);

	return;

     end Open_L6_Connection;

Open_Multics_File:
     proc ();

	call ioa_$rsnnl ("^[record_stream_ -target ^]vfile_ ^a^[ -blocked ^d^;^s^]", multics_file_attach_desc,
	     ignored_len, multics_file_type = UNSTRUCTURED_FILE_TYPE, multics_pathname,
	     multics_file_type = BLOCKED_FILE_TYPE, multics_file_block_size);

	call iox_$attach_name (multics_entry, multics_file_iocbp, (multics_file_attach_desc), null (), code);
	if code ^= 0 & code ^= error_table_$not_detached
	     then call ERROR (code, "Trying to attach file: ^a through switch: ^a.", multics_pathname, multics_entry);

	if multics_is_sender
	     then multics_file_open_mode = Sequential_input;
	     else multics_file_open_mode = Sequential_output;

	call iox_$open (multics_file_iocbp, multics_file_open_mode, "0"b, code);
	if code ^= 0 & code ^= error_table_$not_closed
	     then call ERROR (code, "Trying to open file: ^a through switch: ^a.", multics_pathname, multics_entry);

	return;

     end Open_Multics_File;

Process_File_Name:
     proc ();

dcl  code			       fixed bin (35);
dcl  sender_file_flag	       bit (1);

	if l6_tran_info.sender_info.pathname = ""
	     then do;				/* From file first. */
		l6_tran_info.sender_info.pathname = arg;
		sender_file_flag = "1"b;
		end;

	     else do;				/* To file second. */
		l6_tran_info.receiver_info.pathname = arg;
		sender_file_flag = "0"b;
		end;

/* Now peek ahead in the arg list to see if there is a host specified for this file. */

	call cu_$arg_ptr_rel (arg_idx + 1, arg_ptr, arg_len, code, arg_list_ptr);

	if code = 0
	     then do;				/* There is a next arg. */
		if arg = "-at"
		     then do;			/* Pick up the host name. */
			arg_idx = arg_idx + 2;	/* Set to host arg number. */

			call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
			if code ^= 0
			     then call ERROR (code, "Trying to get the host name after the ""-at"" argument.");

			if sender_file_flag
			     then l6_tran_info.sender_info.host_name = arg;
			     else l6_tran_info.receiver_info.host_name = arg;

			end;			/* Pick up the host name. */
		end;				/* There is a next arg. */

	return;

     end Process_File_Name;

Set_Saved_Attributes:
     proc ();

	if multics_file_l6_type ^= L6_S_FILE_TYPE
	     then do;
		multics_chars_to_write = length (saved_attributes);
		substr (file_buffer, 1, multics_chars_to_write) = saved_attributes;

		call iox_$write_record (multics_file_iocbp, file_buffer_ptr, multics_chars_to_write, code);
		if code ^= 0 then call ERROR (code, "Trying to save the file attributes in: ^a.", multics_pathname);
		end;

	return;

     end Set_Saved_Attributes;

Verify_File_Attributes:
     proc ();

	if multics_file_l6_type ^= level_6_file_type
	     then call ERROR (error_table_$bad_file,
		     "The Level 6 file type does not match the existing Multics file type.  (M = ^a, L6 = ^a).",
		     L6_FILE_TYPE (multics_file_l6_type), L6_FILE_TYPE (level_6_file_type));

	if multics_file_type = BLOCKED_FILE_TYPE & multics_file_block_size < level_6_max_record_size
	     then call ERROR (error_table_$bad_file,
		     "The Multics file block size is less than the Level 6 record size.  (M = ^d, L6 = ^d).",
		     multics_file_block_size, level_6_max_record_size);

	if multics_file_type = UNSTRUCTURED_FILE_TYPE
	     & ^(level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII)
	     then call ERROR (error_table_$bad_file,
		     "Only a sequential ascii Level 6 file may be transferred to an unstructured Multics file.");

	return;

     end Verify_File_Attributes;

/*****************************************************************************/
/*							       */
/*   PROCEDURE: ERROR					       */
/*							       */
/*   This subroutine expects arguments as follows:		       */
/*							       */
/*         call ERROR (code, ioa_control_string, ioa_arguments, ...)	       */
/*							       */
/*   where: code is fixed bin (35), and ioa_control_string and ioa_arguments */
/*          are optional character strings as defined for ioa_.	       */
/*							       */
/*   Some global variables are used:				       */
/*							       */
/*   	Cleanup_Handler (a procedure that does cleanup)		       */
/*							       */
/*     For commands:					       */
/*   	report_error (an entry variable set to com_err_ or active_fnc_err_)*/
/*   	command_name (the character string name of the command)	       */
/*	return_arg_ptr (used to return "false" for active functions)       */
/*							       */
/*     For subroutines:					       */
/*	depends on the error reporting strategy chosen.		       */
/*							       */
/*   At completion a non-local goto is done to the label RETURN.	       */
/*							       */
/*   Declarations are expected for:				       */
/*							       */
/*   	cu_$arg_list_ptr					       */
/*   	cu_$arg_ptr					       */
/*   	cu_$arg_count					       */
/*   	error_table_$fatal_error				       */
/*   	ioa_$general_rs					       */
/*							       */
/*****************************************************************************/

ERROR:
     proc () options (variable, non_quick);

dcl  arg_list_ptr		       ptr;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  based_code		       fixed bin (35) based;
dcl  caller_code		       fixed bin (35);
dcl  code			       fixed bin (35);
dcl  err_msg		       char (256);
dcl  err_msg_len		       fixed bin (21);
dcl  nargs		       fixed bin;

	call cu_$arg_count (nargs, code);		/* IGNORE CODE */

	if nargs >= 1
	     then do;				/* We were called correctly. */
		arg_ptr = null ();			/* Set this so we know if cu_$arg_ptr worked. */
		call cu_$arg_ptr (1, arg_ptr, arg_len, code);

		if arg_ptr ^= null ()
		     then caller_code = arg_ptr -> based_code;
						/* The normal case. */
		     else caller_code = error_table_$fatal_error;
						/* Some problem with our arg list. */

		if nargs > 1
		     then do;			/* There is a message. */
			call cu_$arg_list_ptr (arg_list_ptr);
			call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b);
			end;

		     else do;			/* No message. */
			err_msg = "";
			err_msg_len = 0;
			end;
		end;				/* We were called correctly. */

	     else do;				/* We were called with no arguments. */
		caller_code = error_table_$fatal_error; /* The best we can do. */
		err_msg = "";
		err_msg_len = 0;
		end;				/* We were called with no arguments. */

/* The following lines must be modified depending on the error reporting strategy used. */

	if level_6_iocbp ^= null () & comm_buffer_ptr ^= null ()
	     then do;				/* Tell the Level 6. */

dcl  pic_err_msg_len	       pic "99";

		pic_err_msg_len = min (99, err_msg_len);

		call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len,
		     substr (err_msg, 1, pic_err_msg_len));

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		end;

	P_error_message = substr (err_msg, 1, err_msg_len);
	P_code = caller_code;

/* Clean up and do a non-local goto back to the outermost block. */

	call Cleanup_Handler ();
	goto RETURN;

     end ERROR;

Parser_Cleanup:
     proc ();

	if l6tip ^= null () then free l6_tran_info in (based_area);

	return;

     end Parser_Cleanup;

Execute_Cleanup:
     proc ();

dcl  code			       fixed bin (35);

	if status_area_ptr ^= null () & status_ptr ^= null ()
	     then do;
		if status_branch.nnames > 1 & status_branch.names_relp ^= "0"b
		     then free status_entry_names in (status_area_ptr -> based_area);
		end;

	if star_area_ptr ^= null ()
	     then do;				/* Order is important here. */
		if star_names_ptr ^= null () & star_entry_ptr ^= null ()
		     then free star_names in (star_area_ptr -> based_area);

		if star_entry_ptr ^= null () then free star_entries in (star_area_ptr -> based_area);
		end;

	if multics_file_iocbp ^= null ()
	     then do;
		call iox_$close (multics_file_iocbp, code);
		call iox_$detach_iocb (multics_file_iocbp, code);
		call iox_$destroy_iocb (multics_file_iocbp, code);
		end;

	if level_6_iocbp ^= null ()
	     then do;
		call iox_$close (level_6_iocbp, code);
		call iox_$detach_iocb (level_6_iocbp, code);
		call iox_$destroy_iocb (level_6_iocbp, code);
		end;

	if file_buffer_ptr ^= null () | comm_buffer_ptr ^= null ()
	     then call release_temp_segments_ ("l6_tran_", temp_seg_ptrs, code);

	return;

     end Execute_Cleanup;

debug_on:
     entry ();
	debug_flag = "1"b;
	return;

debug_off:
     entry ();
	debug_flag = "0"b;
	return;

     end l6_tran_;




		    l6_tran_overseer_.pl1           07/13/88  1242.3r w 07/13/88  0935.4      331515



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*****************************************************************************/
/*							       */
/*   DESCRIPTION:						       */
/*							       */
/*        This subroutine is the server for file transfer to or from the     */
/*   Level 6 over an X.25 connection.  It is implemented as a process	       */
/*   overseer so that the answering service can do all of the hard work of   */
/*   making the connection.  This server corresponds to the NASP, l6_tran_,  */
/*   which does the Multics initiated side of the file transfer.	       */
/*							       */
/*							       */
/*   JOURNALIZATION:					       */
/*							       */
/*   1) Written 5/82 by R.J.C Kissel				       */
/*   2) Modified 7/83 by R.J.C. Kissel to fix an error message sent to the L6*/
/*   3) Modified 7/83 by R.J.C. Kissel to fix an error in terminating the    */
/*      process.						       */
/*							       */
/*****************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

l6_tran_overseer_:
     proc (P_pit_ptr, P_call_listener, P_with_command_line);

/* Parameters */

dcl  P_pit_ptr		       ptr parameter;
dcl  P_call_listener	       bit (1) aligned parameter;
dcl  P_with_command_line	       char (*) varying parameter;

/* Automatic */

dcl  P_error_message	       char (256) varying;	/* Needed by ERROR, but never used. */
dcl  P_code		       fixed bin (35);	/* Needed by ERROR, but never used. */

dcl  1 auto_status_branch	       aligned like status_branch;
dcl  1 auto_transfer_input_args      aligned like transfer_input_args;
dcl  1 auto_transfer_output_args     aligned like transfer_output_args;

dcl  based_area		       area (sys_info$max_seg_size) based (area_ptr);
dcl  area_ptr		       ptr;

dcl  code			       fixed bin (35);

dcl  comm_buffer		       char (comm_buffer_len) based (comm_buffer_ptr);
dcl  comm_buffer_len	       fixed bin (21);
dcl  comm_buffer_ptr	       ptr defined (temp_seg_ptrs (1));

dcl  file_buffer		       char (file_buffer_len) based (file_buffer_ptr);
dcl  file_buffer_len	       fixed bin (21);
dcl  file_buffer_ptr	       ptr defined (temp_seg_ptrs (2));

dcl  i			       fixed bin;
dcl  ignored_len		       fixed bin (21);	/* Used in calls to ioa_$rsnnl. */
dcl  last_file		       bit (1);

dcl  level_6_chars_read	       fixed bin (21);
dcl  level_6_chars_to_write	       fixed bin (21);
dcl  level_6_data_type	       fixed bin;
dcl  level_6_dir		       char (168);
dcl  level_6_entry		       char (32);
dcl  level_6_file_type	       fixed bin;
dcl  level_6_iocbp		       ptr;
dcl  level_6_max_record_size	       fixed bin;
dcl  level_6_pathname	       char (168);

dcl  1 logout_string	       aligned,		/* information about logouts */
       2 version		       fixed bin,		/* this is version 0 */
       2 hold		       bit (1) unaligned,	/* don't hangup line */
       2 brief		       bit (1) unaligned,	/* don't print logout message */
       2 pad		       bit (34) unaligned;	/* must be zero */

dcl  multics_chars_read	       fixed bin (21);
dcl  multics_chars_to_write	       fixed bin (21);
dcl  multics_data_type	       fixed bin;
dcl  multics_dir		       char (168);
dcl  multics_entry		       char (32);

dcl  multics_file_attach_desc	       char (256) varying;
dcl  multics_file_block_size	       fixed bin (21);
dcl  multics_file_exists	       bit (1);
dcl  multics_file_iocbp	       ptr;
dcl  multics_file_l6_type	       fixed bin;
dcl  multics_file_type	       fixed bin;
dcl  multics_file_open_mode	       fixed bin;
dcl  multics_file_size	       fixed bin (34);

dcl  multics_is_sender	       bit (1);
dcl  multics_pathname	       char (168);

dcl  saved_level_6_entry	       char (32);
dcl  saved_multics_entry	       char (32);
dcl  star_area_ptr		       ptr;
dcl  star_entries_index	       fixed bin;
dcl  star_names_generated	       bit (1);
dcl  suffix		       char (32);
dcl  temp_seg_ptrs		       (2) ptr;
dcl  term_structure_ptr	       ptr;

dcl  1 info		       aligned like indx_info;/* Use the biggest structure. */

/* Internal Constants */

dcl  REL_SECONDS		       bit (2) internal static options (constant) init ("11"b);

%include l6_tran_constants;

/* Internal Static */

dcl  debug_flag		       bit (1) internal static init ("0"b);

/* External Constants */

dcl  error_table_$bad_file	       fixed bin (35) ext static;
dcl  error_table_$badstar	       fixed bin (35) ext static;
dcl  error_table_$dirseg	       fixed bin (35) ext static;
dcl  error_table_$fatal_error	       fixed bin (35) ext static;
dcl  error_table_$not_closed	       fixed bin (35) ext static;
dcl  error_table_$not_detached       fixed bin (35) ext static;

dcl  sys_info$max_seg_size	       fixed bin (19) ext static;

/* External Entries */

dcl  add_char_offset_	       entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  check_star_name_$entry	       entry (char (*), fixed bin (35));
dcl  cu_$arg_count		       entry (fixed bin, fixed bin (35));
dcl  cu_$arg_list_ptr	       entry (ptr);
dcl  cu_$arg_ptr		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  expand_pathname_	       entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_equal_name_	       entry (char (*), char (*), char (32), fixed bin (35));
dcl  get_user_free_area_	       entry () returns (ptr);
dcl  get_temp_segments_	       entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$append_branch	       entry (char (*), char (*), fixed bin (5), fixed bin (35));
dcl  hcs_$star_		       entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$status_		       entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
dcl  ioa_$rsnnl		       entry () options (variable);
dcl  ioa_$rsnpnnl		       entry options (variable);
dcl  l6_tran_util_$get_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$put_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  l6_tran_receive_file_	       entry (ptr, ptr, char (*) var, fixed bin (35));
dcl  l6_tran_send_file_	       entry (ptr, ptr, char (*) var, fixed bin (35));
dcl  match_star_name_	       entry (char (*), char (*), fixed bin (35));
dcl  pathname_		       entry (char (*), char (*)) returns (char (168));
dcl  release_temp_segments_	       entry (char (*), (*) ptr, fixed bin (35));
dcl  suffixed_name_$make	       entry (char (*), char (*), char (32), fixed bin (35));
dcl  terminate_process_	       entry (char (*), ptr);
dcl  timer_manager_$sleep	       entry (fixed bin (71), bit (2));
dcl  vfile_status_		       entry (char (*), char (*), ptr, fixed bin (35));

/* Builtin Functions and Conditions */

dcl  addr			       builtin;
dcl  before		       builtin;
dcl  hbound		       builtin;
dcl  index		       builtin;
dcl  lbound		       builtin;
dcl  length		       builtin;
dcl  min			       builtin;
dcl  null			       builtin;
dcl  pointer		       builtin;
dcl  reverse		       builtin;
dcl  rtrim		       builtin;
dcl  string		       builtin;
dcl  substr		       builtin;
dcl  sum			       builtin;

dcl  any_other		       condition;
dcl  finish		       condition;

/* Include Files */

%include l6_tran_transfer_args;

%include star_structures;

/* vfs_info.incl.pl1 */

%include vfs_info;

%include access_mode_values;

%include status_structures;

%include iox_entries;

%include iox_modes;

%include pit;

%include user_attributes;

	pit_ptr = P_pit_ptr;

	P_call_listener = "0"b;			/* We will never return anyway. */
	P_with_command_line = "";

/* Set things up for for an error, in which case we will tell the Level 6 and logout. */

	status_area_ptr = null ();
	status_ptr = null ();
	auto_status_branch.nnames = 0;
	auto_status_branch.names_relp = "0"b;
	multics_file_iocbp = null ();
	level_6_iocbp = iox_$user_io;
	file_buffer_ptr = null ();
	comm_buffer_ptr = null ();

	star_names_generated = "0"b;
	star_entry_ptr = null ();
	star_names_ptr = null ();
	star_area_ptr = null ();
	star_entry_count = 0;
	star_entries_index = 0;

	on finish ;				/* Do nothing. */

	on any_other call ERROR (error_table_$fatal_error, "The file transfer has abnormally terminated.");

/* Get temp segments for buffers for file IO and Level 6 IO. */

	call iox_$modes (level_6_iocbp, "8bit,rawi,rawo", "", code);
	if code ^= 0 then call ERROR (code, "Trying to set modes for Level 6 comm.");

	call get_temp_segments_ ("l6_tran_", temp_seg_ptrs, code);
	if code ^= 0 then call ERROR (code, "Trying to get a temp segs.");

	comm_buffer_len = sys_info$max_seg_size * 4;
	file_buffer_len = sys_info$max_seg_size * 4;

/* Now do the real work.  We are always the acceptor and the Level 6 is the initiator. */

	level_6_chars_to_write = length ("HI");		/* First tell him we are here. */
	substr (comm_buffer, 1, level_6_chars_to_write) = "HI";

	call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
	if code ^= 0 then call ERROR (code, "Could not send ""HI"".");

	call OK_Dialogue ();

/* Loop here to handle possible star name transfers. */

	last_file = "0"b;				/* Loop at least once. */
	do while (^last_file);

	     call File_Definition_Dialogue ();

	     auto_transfer_input_args.version = transfer_input_args_version_1;
	     auto_transfer_input_args.comm_iocbp = level_6_iocbp;
	     auto_transfer_input_args.comm_buffer_ptr = comm_buffer_ptr;
	     auto_transfer_input_args.comm_buffer_len = comm_buffer_len;
	     auto_transfer_input_args.file_iocbp = multics_file_iocbp;
	     auto_transfer_input_args.file_buffer_ptr = file_buffer_ptr;
	     auto_transfer_input_args.file_buffer_len = file_buffer_len;
	     auto_transfer_input_args.file_type = multics_file_type;
	     auto_transfer_input_args.data_type = multics_data_type;

	     auto_transfer_output_args.version = transfer_output_args_version_1;

	     if multics_is_sender
		then do;
		     auto_transfer_input_args.tu_size = SEND_TU_SIZE;
		     auto_transfer_input_args.last_file = last_file;
						/* Set by File_Definition_Dialogue. */

		     call l6_tran_send_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args),
			P_error_message, P_code);
		     end;

		else do;
		     auto_transfer_input_args.tu_size = RECV_TU_SIZE;

		     call l6_tran_receive_file_ (addr (auto_transfer_input_args), addr (auto_transfer_output_args),
			P_error_message, P_code);
		     last_file = auto_transfer_output_args.last_file;
		     end;

/* We are finished with the file, get rid of it. */

	     call iox_$close (multics_file_iocbp, code);
	     call iox_$detach_iocb (multics_file_iocbp, code);
	     call iox_$destroy_iocb (multics_file_iocbp, code);
	end;					/* Loop while ^last_file. */

	if multics_is_sender
	     then do;				/* "E" is not enough, so engage in a final dialogue. */
		call File_Definition_Dialogue ();	/* Last_file = "1"b here. */
		end;

/*****************************************************************************/
/*							       */
/*   We are done, so terminate the process.  Do it in this gross way so no   */
/*   "hangup" message is sent.  Also, wait a minute before we terminate so   */
/*   we avoid confusing the Level 6 if he wanted to do the termination.  (If */
/*   he terminates, this will also kill us.)			       */
/*							       */
/*****************************************************************************/

LAST_FILE_RETURN:					/* Come here from File_Definition_Dialogue since "E" is not set. */
	call Cleanup_Handler ();

RETURN:
	call timer_manager_$sleep (60, REL_SECONDS);	/* Wait in case the L6 wants to terminate. */

/*   How to logout cleanly, if we ever want to.

		logout_string.version = 0;
		logout_string.hold = "0"b;
		logout_string.brief = "1"b;
		logout_string.pad = "0"b;

		term_structure_ptr = addr (logout_string);

		call terminate_process_ ("logout", term_structure_ptr);
*/
	call iox_$control (iox_$user_io, "hangup", null (), code);
	call timer_manager_$sleep (60, REL_SECONDS);	/* Wait for the "hangup" to take. */

	return;					/* We should never get here. */

File_Definition_Dialogue:
     proc ();

dcl  acceptor_file_count	       pic "99";
dcl  chars_read		       fixed bin (21);
dcl  ci_size		       pic "99999";
dcl  char_position		       fixed bin;
dcl  data_type		       char (1);
dcl  file_access		       char (1);
dcl  file_size		       pic "99999";
dcl  file_type		       char (1);
dcl  fixed_definition_len	       fixed bin (21);
dcl  indicator		       char (1);
dcl  initiator_file_count	       pic "99";
dcl  key_length		       pic "999";
dcl  key_offset		       pic "9999";
dcl  key_type		       char (1);
dcl  l6_path_len		       pic "99";

dcl  1 l6_file_definition	       unaligned based (comm_buffer_ptr),
       2 header,
         3 first_char	       char (1) unaligned,	/* Should be " ". */
         3 definition_len	       pic "999" unaligned,
         3 another_char	       char (1) unaligned,	/* Should be " ". */
         3 direction	       char (1) unaligned,	/* Should be "I" or "O". */
         3 file_name_indicator       char (1) unaligned,	/* Should be "!". */
         3 file_name_len	       pic "99" unaligned,
         3 file_name	       char (0 refer (l6_file_definition.file_name_len)) unaligned,
       2 rest_of_definition	       char (rest_of_definition_len) unaligned;

dcl  output_message_len	       pic "999";
dcl  percent_fill		       pic "99";
dcl  record_size		       pic "9999";
dcl  rest_of_definition_len	       fixed bin;
dcl  starting_record	       pic "99999";
dcl  saved_attributes	       char (256) varying;

/* Get the Level 6 file definition record.  This involves a loop to get everything he says he sent. */

	call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code);
	if code ^= 0 then call ERROR (code, "Trying to read the file definition from the Level 6.");

	fixed_definition_len = l6_file_definition.definition_len;
	rest_of_definition_len = fixed_definition_len - length (string (l6_file_definition.header));

	do chars_read = level_6_chars_read repeat chars_read + level_6_chars_read
	     while (chars_read < fixed_definition_len);
	     call l6_tran_util_$get_chars (level_6_iocbp, add_char_offset_ (comm_buffer_ptr, chars_read),
		comm_buffer_len - chars_read, level_6_chars_read, code);
	     if code ^= 0 then call ERROR (code, "Trying to read the file definition from the Level 6.");
	end;

/* Special no file message, instead of "E" on last file, when Multics is receiving. */

	if l6_file_definition.another_char = "&" then goto LAST_FILE_RETURN;

/* Special return for last file dialogue when Multics is sending. */

	if last_file
	     then do;
		level_6_chars_to_write = length ("8010&'82FF");
		substr (comm_buffer, 1, level_6_chars_to_write) = "8010&'82FF";

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
						/* Ignore the code. */

		return;
		end;

	if l6_file_definition.direction = "I"
	     then multics_is_sender = "1"b;
	     else multics_is_sender = "0"b;

	multics_pathname = l6_file_definition.file_name;

	call expand_pathname_ (multics_pathname, multics_dir, saved_multics_entry, code);
	if code ^= 0 then call ERROR (code, "Trying to expand multics pathname: ^a.", multics_pathname);

	multics_pathname = pathname_ (multics_dir, saved_multics_entry);
						/* Turn into absolute pathname. */

	multics_entry = saved_multics_entry;

	level_6_dir = "";				/* We don't know. */
	saved_level_6_entry = "==";			/* Tell him names that match ours. */

/* Set default Level 6 file attributes, and then get the real ones, if any. */

	level_6_data_type = ASCII;
	level_6_file_type = L6_S_FILE_TYPE;
	level_6_max_record_size = 0;

	if l6_file_definition.rest_of_definition ^= ""
	     then do;				/* Process the file attributes. */
		char_position = 1;
		indicator = substr (l6_file_definition.rest_of_definition, char_position, length (indicator));

		if indicator = "#"
		     then do;
			char_position = char_position + length (indicator);

			saved_attributes = substr (l6_file_definition.rest_of_definition, char_position);
			end;

		     else do;			/* Probably something wrong, but keep going. */
			saved_attributes = substr (l6_file_definition.rest_of_definition, char_position);
			end;


		do while (char_position <= length (l6_file_definition.rest_of_definition));
						/* Loop through the file attributes. */
		     indicator = substr (l6_file_definition.rest_of_definition, char_position, length (indicator));
		     char_position = char_position + length (indicator);

		     if indicator = "P"
			then do;			/* File type */
			     file_type =
				substr (l6_file_definition.rest_of_definition, char_position, length (file_type));
			     char_position = char_position + length (file_type);

			     level_6_file_type = index (string (L6_FILE_TYPE), file_type);

			     if level_6_file_type = 0
				then call ERROR (error_table_$bad_file,
					"The Level 6 file type: ""^a"", is not supported.", file_type);
			     end;

		     else if indicator = "Q"
			then do;			/* Data type */
			     data_type =
				substr (l6_file_definition.rest_of_definition, char_position, length (data_type));
			     char_position = char_position + length (data_type);

			     level_6_data_type = index (string (L6_DATA_TYPE), data_type);

			     if level_6_data_type = 0
				then call ERROR (error_table_$bad_file,
					"The Level 6 data type: ""^a"", is not supported.", data_type);
			     end;

		     else if indicator = "R"
			then do;			/* Record size */
			     string (record_size) =
				substr (l6_file_definition.rest_of_definition, char_position,
				length (record_size));
			     char_position = char_position + length (record_size);

			     level_6_max_record_size = record_size;
			     end;

		     else if indicator = "S"
			then do;			/* Starting record */
			     string (starting_record) =
				substr (l6_file_definition.rest_of_definition, char_position,
				length (starting_record));
			     char_position = char_position + length (starting_record);
			     end;

		     else if indicator = "T"
			then do;			/* File access code */
			     file_access =
				substr (l6_file_definition.rest_of_definition, char_position,
				length (file_access));
			     char_position = char_position + length (file_access);
			     end;

		     else if indicator = "U"
			then do;			/* Key length */
			     string (key_length) =
				substr (l6_file_definition.rest_of_definition, char_position, length (key_length))
				;
			     char_position = char_position + length (key_length);
			     end;

		     else if indicator = "V"
			then do;			/* Key offset */
			     string (key_offset) =
				substr (l6_file_definition.rest_of_definition, char_position, length (key_offset))
				;
			     char_position = char_position + length (key_offset);
			     end;

		     else if indicator = "W"
			then do;			/* Percent fill */
			     string (percent_fill) =
				substr (l6_file_definition.rest_of_definition, char_position,
				length (percent_fill));
			     char_position = char_position + length (percent_fill);
			     end;

		     else if indicator = "X"
			then do;			/* Key type */
			     key_type =
				substr (l6_file_definition.rest_of_definition, char_position, length (key_type));
			     char_position = char_position + length (key_type);
			     end;

		     else if indicator = "Y"
			then do;			/* CI size */
			     string (ci_size) =
				substr (l6_file_definition.rest_of_definition, char_position, length (ci_size));
			     char_position = char_position + length (ci_size);
			     end;

		     else if indicator = "Z"
			then do;			/* File size (in CI units) */
			     string (file_size) =
				substr (l6_file_definition.rest_of_definition, char_position, length (file_size));
			     char_position = char_position + length (file_size);
			     end;

		     else if indicator = "["
			then do;			/* Initiator's file count */
			     string (initiator_file_count) =
				substr (l6_file_definition.rest_of_definition, char_position,
				length (initiator_file_count));
			     char_position = char_position + length (initiator_file_count);
			     end;

		     else if indicator = "\"
			then do;			/* Acceptor's file count */
			     string (acceptor_file_count) =
				substr (l6_file_definition.rest_of_definition, char_position,
				length (acceptor_file_count));
			     char_position = char_position + length (acceptor_file_count);
			     end;

		     else ;			/* Not recognized, skip it */

		end;				/* Loop through the attributes. */
		end;				/* Process the file attributes. */

/* Now do the right things to attach and open the Multics file based on everything we have learned. */

	if multics_is_sender
	     then do;				/*  We must describe the file to the Level 6. */
		call Get_Next_Path (last_file);	/* This sets level_6_pathname too. */

		info.info_version = vfs_version_1;
		call vfile_status_ (multics_dir, multics_entry, addr (info), code);
		if code ^= 0
		     then call ERROR (code, "Trying to get vfile_status_ on: ^a, for sending.", multics_pathname);

		call Check_Multics_File ();

		call Open_Multics_File ();

		call Get_Saved_Attributes ();
		end;				/*  We must describe the file to the Level 6. */

	     else do;				/* The Level 6 has told us about the file. */
		level_6_pathname = "";		/* Not needed since we are receiving. */
		star_names_generated = "0"b;		/* We never get starnames when receiving. */

		info.info_version = vfs_version_1;
		call vfile_status_ (multics_dir, multics_entry, addr (info), code);

		if code = 0
		     then do;
			call Check_Multics_File ();
			call Verify_File_Attributes ();
			end;

		     else call Create_Multics_File ();

		call Open_Multics_File ();

		call Set_Saved_Attributes ();
		end;				/* The Level 6 has told us about the file. */

/* Send our response to the Level 6. */

	l6_path_len = length (rtrim (level_6_pathname)) + 1;

	call ioa_$rsnpnnl ("8000$^[^[!^2a^a ^;^2s^]^[#P^aQ^a^s^;^2s#^a^]^;^]", comm_buffer, level_6_chars_to_write,
	     multics_is_sender, star_names_generated, l6_path_len, rtrim (level_6_pathname), saved_attributes = "",
	     L6_FILE_TYPE (multics_file_l6_type), L6_DATA_TYPE (multics_data_type), saved_attributes);

	output_message_len = level_6_chars_to_write;
	substr (comm_buffer, 2, 3) = output_message_len;

	call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
	if code ^= 0 then call ERROR (code, "Trying to send the ack to the Level 6 file definition.");

/* We may have to put a call to write_status here, to prevent our response from being combined with our first prompt. */

	return;

Check_Multics_File:
     proc ();

	multics_file_type = info.type;

	if multics_file_type > BLOCKED_FILE_TYPE
	     then call ERROR (error_table_$bad_file,
		     "The Multics file must be unstructured, sequential, or blocked.  File ^a was ^a.",
		     multics_pathname, FILE_TYPE_TO_PNAME (multics_file_type));

	if multics_file_type = BLOCKED_FILE_TYPE
	     then do;
		multics_file_block_size = blk_info.max_rec_len;
		multics_file_size = blk_info.end_pos;
		end;

	     else do;
		multics_file_block_size = 0;
		multics_file_size = 0;
		end;

	multics_file_l6_type = L6_S_FILE_TYPE;		/* This is the default. */

/* Now find out if the file is special by looking for the suffix we put on it. */

	status_area_ptr = get_user_free_area_ ();
	status_ptr = addr (auto_status_branch);

	call hcs_$status_ (multics_dir, multics_entry, CHASE, status_ptr, status_area_ptr, code);
	if code ^= 0 then call ERROR (code, "Trying to get status for: ^a.", multics_pathname);

	if status_branch.short.type = Directory then call ERROR (error_table_$dirseg, "^a.", multics_pathname);

	code = 1;					/* Go through the loop at least once. */
	do i = lbound (status_entry_names, 1) to hbound (status_entry_names, 1) while (code ^= 0);
	     call match_star_name_ ((status_entry_names (i)), "**.*.l6*", code);
	     if code = 0
		then do;
		     suffix = reverse (before (reverse (rtrim (status_entry_names (i))), "."));

		     do i = lbound (MULTICS_L6_FILE_SUFFIX, 1) to hbound (MULTICS_L6_FILE_SUFFIX, 1)
			while (suffix ^= MULTICS_L6_FILE_SUFFIX (i));
		     end;

		     if i > hbound (MULTICS_L6_FILE_SUFFIX, 1)
			then code = 1;		/* Keep looking. */
			else multics_file_l6_type = i;
		     end;
	end;

	if status_branch.nnames > 0 & status_branch.names_relp ^= "0"b
	     then free status_entry_names in (status_area_ptr -> based_area);
						/* Cleanup after ourselves. */

	if multics_file_type = UNSTRUCTURED_FILE_TYPE
	     then multics_data_type = ASCII;
	     else multics_data_type = BINARY;

	return;

     end Check_Multics_File;

Create_Multics_File:
     proc ();

	multics_file_l6_type = level_6_file_type;
	multics_data_type = level_6_data_type;

	if level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII
	     then multics_file_type = UNSTRUCTURED_FILE_TYPE;

	else if level_6_file_type = L6_S_FILE_TYPE then multics_file_type = SEQUENTIAL_FILE_TYPE;

	else multics_file_type = BLOCKED_FILE_TYPE;

	if multics_file_type = BLOCKED_FILE_TYPE
	     then do;
		if level_6_max_record_size = 0
		     then multics_file_block_size = 256;/*Set default. */
		     else multics_file_block_size = level_6_max_record_size;
		end;

	     else multics_file_block_size = 0;

	multics_file_size = 0;

	if MULTICS_L6_FILE_SUFFIX (multics_file_l6_type) ^= ""
	     then do;
		call suffixed_name_$make (multics_entry, MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_entry,
		     code);
		if code ^= 0
		     then call ERROR (code, "Trying to add the suffix ""^a"" to ^a",
			     MULTICS_L6_FILE_SUFFIX (multics_file_l6_type), multics_pathname);

		multics_pathname = pathname_ (multics_dir, multics_entry);
		end;

	call hcs_$append_branch (multics_dir, multics_entry, RW_ACCESS_BIN, code);
	if code ^= 0 then call ERROR (code, "Trying to create: ^a.", multics_pathname);

	return;

     end Create_Multics_File;

Get_Next_Path:
     proc (P_last_file);

dcl  P_last_file		       bit (1) parameter;

dcl  code			       fixed bin (35);

	call check_star_name_$entry (saved_multics_entry, code);

	if code = 0 then P_last_file = "1"b;		/* Not a star name, nothing to do. */

	else if code = error_table_$badstar then call ERROR (code, "Multics file name: ^a.", saved_multics_entry);

	else do;					/* We have a star name. */
	     if ^star_names_generated
		then do;				/* Get the star list once. */
		     star_area_ptr = get_user_free_area_ ();

		     call hcs_$star_ (multics_dir, saved_multics_entry, star_ALL_ENTRIES, star_area_ptr,
			star_entry_count, star_entry_ptr, star_names_ptr, code);
		     if code ^= 0
			then call ERROR (code, "Trying to match starname ^a in directory ^a.", saved_multics_entry,
				multics_dir);

/* Set the index to the first non-directory entry. */

		     do star_entries_index = 1 to hbound (star_entries, 1)
			while (star_entries (star_entries_index).type = star_DIRECTORY);
		     end;

		     if star_entries_index > hbound (star_entries, 1)
			then call ERROR (error_table_$dirseg, "Only directories match ^a.", multics_pathname);

		     star_names_generated = "1"b;
		     end;				/* Get the star list once. */

/* Just use the first matching name on an entry. */

	     multics_entry = star_names (star_entries (star_entries_index).nindex);
	     multics_pathname = pathname_ (multics_dir, multics_entry);

/* Now update the star_entries_index and set P_last_file. */

	     do star_entries_index = star_entries_index + 1 to hbound (star_entries, 1)
		while (star_entries (star_entries_index).type = star_DIRECTORY);
	     end;

	     if star_entries_index > hbound (star_entries, 1)
		then P_last_file = "1"b;
		else P_last_file = "0"b;
	     end;					/* We have a star name. */

/* Now generate the L6 pathname. */

	call get_equal_name_ (multics_entry, saved_level_6_entry, level_6_entry, code);
	if code ^= 0
	     then call ERROR (code, "Trying to do equalname matching on L6 name ^a, against Multics name ~a.",
		     saved_level_6_entry, multics_entry);

	level_6_pathname = rtrim (level_6_dir) || level_6_entry;

	return;

     end Get_Next_Path;

Get_Saved_Attributes:
     proc ();

	if multics_file_l6_type ^= L6_S_FILE_TYPE
	     then do;
		call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code)
		     ;
		if code ^= 0
		     then call ERROR (code, "Trying to get the file attributes from the multics file: ^a.",
			     multics_pathname);

		saved_attributes = substr (file_buffer, 1, multics_chars_read);
		end;

	     else saved_attributes = "";

	return;

     end Get_Saved_Attributes;

Open_Multics_File:
     proc ();

	call ioa_$rsnnl ("^[record_stream_ -target ^]vfile_ ^a^[ -blocked ^d^;^s^]", multics_file_attach_desc,
	     ignored_len, multics_file_type = UNSTRUCTURED_FILE_TYPE, multics_pathname,
	     multics_file_type = BLOCKED_FILE_TYPE, multics_file_block_size);

	call iox_$attach_name (multics_entry, multics_file_iocbp, (multics_file_attach_desc), null (), code);
	if code ^= 0 & code ^= error_table_$not_detached
	     then call ERROR (code, "Trying to attach file: ^a through switch: ^a.", multics_pathname, multics_entry);

	if multics_is_sender
	     then multics_file_open_mode = Sequential_input;
	     else multics_file_open_mode = Sequential_output;

	call iox_$open (multics_file_iocbp, multics_file_open_mode, "0"b, code);
	if code ^= 0 & code ^= error_table_$not_closed
	     then call ERROR (code, "Trying to open file: ^a through switch: ^a.", multics_pathname, multics_entry);

	return;

     end Open_Multics_File;

Set_Saved_Attributes:
     proc ();

	if multics_file_l6_type ^= L6_S_FILE_TYPE
	     then do;
		multics_chars_to_write = length (saved_attributes);
		substr (file_buffer, 1, multics_chars_to_write) = saved_attributes;

		call iox_$write_record (multics_file_iocbp, file_buffer_ptr, multics_chars_to_write, code);
		if code ^= 0 then call ERROR (code, "Trying to save the file attributes in: ^a.", multics_pathname);
		end;

	return;

     end Set_Saved_Attributes;

Verify_File_Attributes:
     proc ();

	if multics_file_l6_type ^= level_6_file_type
	     then call ERROR (error_table_$bad_file,
		     "The Level 6 file type does not match the existing Multics file type.  (M = ^a, L6 = ^a).",
		     L6_FILE_TYPE (multics_file_l6_type), L6_FILE_TYPE (level_6_file_type));

	if multics_file_type = BLOCKED_FILE_TYPE & multics_file_block_size < level_6_max_record_size
	     then call ERROR (error_table_$bad_file,
		     "The Multics fiel block size is less than the Level 6 record size.  (M = ^d, L6 = ^d).",
		     multics_file_block_size, level_6_max_record_size);

	if multics_file_type = UNSTRUCTURED_FILE_TYPE
	     & ^(level_6_file_type = L6_S_FILE_TYPE & level_6_data_type = ASCII)
	     then call ERROR (error_table_$bad_file,
		     "Only a sequential ascii Level 6 file may be transferred to an unstructured Multics file.");

	return;

     end Verify_File_Attributes;

     end File_Definition_Dialogue;

OK_Dialogue:
     proc ();

	call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code);
	if code ^= 0 then call ERROR (code, "Trying to read ""OK?"" from the Level 6.");

	if substr (comm_buffer, 1, level_6_chars_read) ^= "OK?" then ;
						/* Something wrong, but keep going anyway. */

	level_6_chars_to_write = length ("OK");
	substr (comm_buffer, 1, level_6_chars_to_write) = "OK";

	call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
	if code ^= 0 then call ERROR (code, "Trying to send ""OK"" to the Level 6.");

	return;

     end OK_Dialogue;

/*****************************************************************************/
/*							       */
/*   PROCEDURE: ERROR					       */
/*							       */
/*   This subroutine expects arguments as follows:		       */
/*							       */
/*         call ERROR (code, ioa_control_string, ioa_arguments, ...)	       */
/*							       */
/*   where: code is fixed bin (35), and ioa_control_string and ioa_arguments */
/*          are optional character strings as defined for ioa_.	       */
/*							       */
/*   Some global variables are used:				       */
/*							       */
/*   	Cleanup_Handler (a procedure that does cleanup)		       */
/*							       */
/*     For commands:					       */
/*   	report_error (an entry variable set to com_err_ or active_fnc_err_)*/
/*   	command_name (the character string name of the command)	       */
/*	return_arg_ptr (used to return "false" for active functions)       */
/*							       */
/*     For subroutines:					       */
/*	depends on the error reporting strategy chosen.		       */
/*							       */
/*   At completion a non-local goto is done to the label RETURN.	       */
/*							       */
/*   Declarations are expected for:				       */
/*							       */
/*   	cu_$arg_list_ptr					       */
/*   	cu_$arg_ptr					       */
/*   	cu_$arg_count					       */
/*   	error_table_$fatal_error				       */
/*   	ioa_$general_rs					       */
/*							       */
/*****************************************************************************/

ERROR:
     proc () options (variable, non_quick);

dcl  arg_list_ptr		       ptr;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  based_code		       fixed bin (35) based;
dcl  caller_code		       fixed bin (35);
dcl  code			       fixed bin (35);
dcl  err_msg		       char (256);
dcl  err_msg_len		       fixed bin (21);
dcl  nargs		       fixed bin;

	call cu_$arg_count (nargs, code);		/* IGNORE CODE */

	if nargs >= 1
	     then do;				/* We were called correctly. */
		arg_ptr = null ();			/* Set this so we know if cu_$arg_ptr worked. */
		call cu_$arg_ptr (1, arg_ptr, arg_len, code);

		if arg_ptr ^= null ()
		     then caller_code = arg_ptr -> based_code;
						/* The normal case. */
		     else caller_code = error_table_$fatal_error;
						/* Some problem with our arg list. */

		if nargs > 1
		     then do;			/* There is a message. */
			call cu_$arg_list_ptr (arg_list_ptr);
			call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b);
			end;

		     else do;			/* No message. */
			err_msg = "";
			err_msg_len = 0;
			end;
		end;				/* We were called correctly. */

	     else do;				/* We were called with no arguments. */
		caller_code = error_table_$fatal_error; /* The best we can do. */
		err_msg = "";
		err_msg_len = 0;
		end;				/* We were called with no arguments. */

/* The following lines must be modified depending on the error reporting strategy used. */

	if level_6_iocbp ^= null () & comm_buffer_ptr ^= null ()
	     then do;				/* Tell the Level 6. */

dcl  pic_err_msg_len	       pic "99";

		pic_err_msg_len = min (99, err_msg_len);

		call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len,
		     substr (err_msg, 1, pic_err_msg_len));

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		end;

	P_error_message = substr (err_msg, 1, err_msg_len);
	P_code = caller_code;

/* Clean up and do a non-local goto back to the outermost block. */

	call Cleanup_Handler ();
	goto RETURN;

     end ERROR;

Cleanup_Handler:
     proc ();

dcl  code			       fixed bin (35);

	if status_area_ptr ^= null () & status_ptr ^= null ()
	     then do;
		if status_branch.nnames > 1 & status_branch.names_relp ^= "0"b
		     then free status_entry_names in (status_area_ptr -> based_area);
		end;

	if star_area_ptr ^= null ()
	     then do;				/* Order is important here. */
		if star_names_ptr ^= null () & star_entry_ptr ^= null ()
		     then free star_names in (star_area_ptr -> based_area);

		if star_entry_ptr ^= null () then free star_entries in (star_area_ptr -> based_area);
		end;

	if multics_file_iocbp ^= null ()
	     then do;
		call iox_$close (multics_file_iocbp, code);
		call iox_$detach_iocb (multics_file_iocbp, code);
		call iox_$destroy_iocb (multics_file_iocbp, code);
		end;

	if file_buffer_ptr ^= null () | comm_buffer_ptr ^= null ()
	     then call release_temp_segments_ ("l6_tran_", temp_seg_ptrs, code);

	return;

     end Cleanup_Handler;

debug_on:
     entry ();
	debug_flag = "1"b;
	return;

debug_off:
     entry ();
	debug_flag = "0"b;
	return;

     end l6_tran_overseer_;




		    l6_tran_receive_file_.pl1       07/21/83  1210.3r w 07/21/83  1115.1      156591



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*****************************************************************************/
/*							       */
/*   DESCRIPTION:						       */
/*							       */
/*        This subroutine does all the work necessary to receive a file from */
/*   the Level 6.  It is used by the l6_tran_ NASP and l6_tran_overseer_.    */
/*							       */
/*							       */
/*   JOURNALIZATION:					       */
/*							       */
/*   1) Written 5/82 by R.J.C. Kissel.				       */
/*   2) Modified 7/83 by R.J.C. Kissel to fix an error message sent to the L6*/
/*							       */
/*****************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

l6_tran_receive_file_:
     proc (P_input_args_ptr, P_output_args_ptr, P_error_message, P_code);

/* Parameters */

dcl  P_input_args_ptr	       ptr parameter;
dcl  P_output_args_ptr	       ptr parameter;
dcl  P_error_message	       char (*) varying parameter;
dcl  P_code		       fixed bin (35) parameter;

/* Automatic */

dcl  comm_buffer		       char (comm_buffer_len) based (comm_buffer_ptr);
dcl  comm_buffer_len	       fixed bin (21);
dcl  comm_buffer_ptr	       ptr;
dcl  comm_buffer_position	       fixed bin (21);

dcl  char_position_in_tu	       fixed bin (21);
dcl  code			       fixed bin (35);
dcl  end_of_file		       bit (1);

dcl  file_buffer		       char (file_buffer_len) based (file_buffer_ptr);
dcl  file_buffer_len	       fixed bin (21);
dcl  file_buffer_ptr	       ptr;

dcl  last_file		       bit (1);

dcl  level_6_chars_read	       fixed bin (21);
dcl  level_6_chars_to_write	       fixed bin (21);
dcl  level_6_iocbp		       ptr;

dcl  multics_chars_to_write	       fixed bin (21);
dcl  multics_data_type	       fixed bin;
dcl  multics_file_iocbp	       ptr;
dcl  multics_file_type	       fixed bin;

dcl  next_transmission_unit	       fixed bin;

dcl  1 prompt		       aligned,
       2 prompt_char	       char (1) unaligned init ("P"),
       2 record_number	       pic "99999" unaligned;

dcl  record_number		       fixed bin;
dcl  total_bytes		       fixed bin (35);
dcl  tu_size		       fixed bin (21);

/* Internal Constants */

%include l6_tran_constants;

/* External Constants */

dcl  error_table_$unimplemented_version
			       fixed bin (35) ext static;
dcl  error_table_$fatal_error	       fixed bin (35) ext static;

/* External Entries */

dcl  cu_$arg_count		       entry (fixed bin, fixed bin (35));
dcl  cu_$arg_list_ptr	       entry (ptr);
dcl  cu_$arg_ptr		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_		       entry (char (*)) returns (fixed bin (35));
dcl  cv_dec_check_		       entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
dcl  ioa_$rsnpnnl		       entry options (variable);
dcl  iox_$write_record	       entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$get_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$put_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* Builtin Functions and Conditions */

dcl  copy			       builtin;
dcl  index		       builtin;
dcl  length		       builtin;
dcl  min			       builtin;
dcl  null			       builtin;
dcl  string		       builtin;
dcl  substr		       builtin;
dcl  verify		       builtin;

/* Include Files */

%include l6_tran_transfer_args;

	level_6_iocbp = null ();			/* Initialize these in case of error. */
	comm_buffer_ptr = null ();

	tiap = P_input_args_ptr;
	toap = P_output_args_ptr;

	if transfer_input_args.version ^= transfer_input_args_version_1
	     then call ERROR (error_table_$unimplemented_version, "The input args version was ^a, expected ^a.",
		     transfer_input_args.version, transfer_input_args_version_1);

	if transfer_output_args.version ^= transfer_output_args_version_1
	     then call ERROR (error_table_$unimplemented_version, "The output args version was ^a, expected ^a.",
		     transfer_output_args.version, transfer_output_args_version_1);

	level_6_iocbp = transfer_input_args.comm_iocbp;
	comm_buffer_ptr = transfer_input_args.comm_buffer_ptr;
	comm_buffer_len = transfer_input_args.comm_buffer_len;
	multics_file_iocbp = transfer_input_args.file_iocbp;
	file_buffer_ptr = transfer_input_args.file_buffer_ptr;
	file_buffer_len = transfer_input_args.file_buffer_len;
	multics_file_type = transfer_input_args.file_type;
	multics_data_type = transfer_input_args.data_type;
	tu_size = transfer_input_args.tu_size;
	total_bytes = 0;

	comm_buffer_position = 1;			/* Set this for Receive_L6_Record */
	char_position_in_tu = 1;			/* Set this for Receive_L6_Record */
	level_6_chars_read = 0;			/* Set this for Receive_L6_Record */
	next_transmission_unit = 0;			/* Set this for Receive_L6_Record */

/* Send the initial prompt for record 0. */

	prompt.record_number = 0;
	level_6_chars_to_write = length (string (prompt));
	substr (comm_buffer, 1, level_6_chars_to_write) = string (prompt);

	call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
	if code ^= 0 then call ERROR (code, "Trying to write the first prompt to the Level 6.");

/* Receive records until we find end of file (returned after the last record is read). */

	call Receive_L6_Record (record_number, end_of_file, last_file);

/* A level 6 null line has whitespace in it.  If we get a whitespace record, write a null line to the Multics file. */

	if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII
	     & verify (substr (file_buffer, 1, multics_chars_to_write), SP || HT) = 0
	     then multics_chars_to_write = 0;

	do while (^end_of_file);

	     call iox_$write_record (multics_file_iocbp, file_buffer_ptr, multics_chars_to_write, code);
	     if code ^= 0 then call ERROR (code, "Trying to write record ^d to the multics file.", record_number);

	     total_bytes = total_bytes + multics_chars_to_write;

	     call Receive_L6_Record (record_number, end_of_file, last_file);

/* A level 6 null line has whitespace in it.  If we get a record of just whitespace, write a null line to the Multics file. */

	     if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII
		& verify (substr (file_buffer, 1, multics_chars_to_write), SP || HT) = 0
		then multics_chars_to_write = 0;

	end;

/* Send the final prompt for the last record we got.  The L6 wants the # of records, not the # of the last record. */

	prompt.record_number = min (99999, record_number + 1);
	level_6_chars_to_write = length (string (prompt));
	substr (comm_buffer, 1, level_6_chars_to_write) = string (prompt);

	call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
	if code ^= 0 then call ERROR (code, "Trying to write the final prompt to the Level 6.");

	transfer_output_args.record_number = record_number;
	transfer_output_args.total_bytes = total_bytes;
	transfer_output_args.last_file = last_file;
	P_error_message = "";
	P_code = 0;

RETURN:
	return;

Receive_L6_Record:
     proc (P_record_number, P_end_of_file, P_last_file);

dcl  P_record_number	       fixed bin;
dcl  P_end_of_file		       bit (1) parameter;
dcl  P_last_file		       bit (1) parameter;

dcl  code			       fixed bin (35);
dcl  current_char		       char (1);
dcl  current_digit		       fixed bin;
dcl  data_chars_available	       fixed bin;
dcl  data_field_len		       char (2);
dcl  data_is_packed		       bit (1);
dcl  end_of_file		       bit (1);
dcl  end_of_record		       bit (1);
dcl  file_buffer_position	       fixed bin (21);
dcl  fixed_data_field_len	       fixed bin;
dcl  last_file		       bit (1);

dcl  1 l6_error		       aligned based (comm_buffer_ptr),
       2 first_char		       char (1) unaligned,	/* Should be "C". */
       2 second_char	       char (1) unaligned,	/* Should be "U". */
       2 message_len	       pic "99" unaligned,
       2 message		       char (0 refer (l6_error.message_len)) unaligned;

dcl  media_code		       fixed bin;
dcl  read_record_state	       fixed bin;
dcl  record_number		       char (5);

/* Set initial parser state variables. */

	file_buffer_position = 1;
	read_record_state = 1;
	current_digit = 1;

/* Now parse the record, getting more characters as needed. */

	last_file = "0"b;

	end_of_file = "0"b;
	end_of_record = "0"b;
	do while (^end_of_file & ^end_of_record);

	     if comm_buffer_position > level_6_chars_read
		then do;				/* Get some more characters to process. */
		     call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len,
			level_6_chars_read, code);
		     if code ^= 0 then call ERROR (code, "Trying to get characters for a record.");

		     comm_buffer_position = 1;
		     end;				/* Get some more characters to process. */

	     current_char = substr (comm_buffer, comm_buffer_position, 1);

	     if char_position_in_tu = tu_size + 1 | char_position_in_tu = 1
		then do;				/* Special transmission unit character. */
		     char_position_in_tu = 1;

		     if current_char = "C"
			then call ERROR (error_table_$fatal_error, "Error from the Level 6: ^a.", l6_error.message);

		     if cv_dec_ (current_char) ^= next_transmission_unit then ;
						/* Something wrong, but keep going. */

		     next_transmission_unit = next_transmission_unit + 1;
		     comm_buffer_position = comm_buffer_position + 1;
		     char_position_in_tu = char_position_in_tu + 1;

		     goto NEXT_STATE;
		     end;				/* Special transmission unit character. */

	     goto RECORD_PARSER (read_record_state);

RECORD_PARSER (1):					/* Process the media code or end of file */
	     if current_char = "E"
		then do;
		     end_of_file = "1"b;
		     last_file = "1"b;
		     end;

	     else if current_char = "F"
		then do;
		     end_of_file = "1"b;
		     last_file = "0"b;
		     end;

	     else media_code = index (string (L6_DATA_TYPE), current_char);

	     comm_buffer_position = comm_buffer_position + 1;
						/* Take any media code. */
	     char_position_in_tu = char_position_in_tu + 1;
	     read_record_state = 2;

	     goto NEXT_STATE;

RECORD_PARSER (2):					/* Process the digits of the record number */
	     substr (record_number, current_digit, 1) = current_char;

	     comm_buffer_position = comm_buffer_position + 1;
	     current_digit = current_digit + 1;
	     char_position_in_tu = char_position_in_tu + 1;

	     if current_digit <= length (record_number)
		then read_record_state = 2;
		else do;
		     current_digit = 1;
		     read_record_state = 3;
		     end;

	     goto NEXT_STATE;

RECORD_PARSER (3):					/* Process packed (P), unpacked (U), or end of record (R) */
	     if current_char = "P" then data_is_packed = "1"b;

	     else if current_char = "U" then data_is_packed = "0"b;

	     else if current_char = "R" then end_of_record = "1"b;

	     else do;				/* Assume end of record */
		end_of_record = "1"b;
		goto NEXT_STATE;			/* Don't advance buffer position */
		end;

	     comm_buffer_position = comm_buffer_position + 1;
	     char_position_in_tu = char_position_in_tu + 1;
	     read_record_state = 4;

	     goto NEXT_STATE;

RECORD_PARSER (4):					/* Process the digits of the data field length */
	     substr (data_field_len, current_digit, 1) = current_char;

	     comm_buffer_position = comm_buffer_position + 1;
	     current_digit = current_digit + 1;
	     char_position_in_tu = char_position_in_tu + 1;

	     if current_digit <= length (data_field_len)
		then read_record_state = 4;
		else do;
		     current_digit = 1;

		     fixed_data_field_len = cv_dec_check_ (data_field_len, code);
		     if code ^= 0 then fixed_data_field_len = 0;

		     code = 0;
		     read_record_state = 5;
		     end;

	     goto NEXT_STATE;

RECORD_PARSER (5):					/* Process a data field, we may not have it all. */
	     if data_is_packed
		then do;
		     substr (file_buffer, file_buffer_position, fixed_data_field_len) =
			copy (current_char, fixed_data_field_len);
		     file_buffer_position = file_buffer_position + fixed_data_field_len;
		     comm_buffer_position = comm_buffer_position + 1;
		     char_position_in_tu = char_position_in_tu + 1;

		     read_record_state = 3;
		     end;

		else do;
		     data_chars_available = min (fixed_data_field_len, level_6_chars_read - comm_buffer_position + 1);

		     substr (file_buffer, file_buffer_position, data_chars_available) =
			substr (comm_buffer, comm_buffer_position, data_chars_available);
		     file_buffer_position = file_buffer_position + data_chars_available;
		     comm_buffer_position = comm_buffer_position + data_chars_available;
		     char_position_in_tu = char_position_in_tu + data_chars_available;

		     fixed_data_field_len = fixed_data_field_len - data_chars_available;

		     if fixed_data_field_len <= 0
			then read_record_state = 3;	/* done with the data. */
			else read_record_state = 5;	/* more unpacked data. */
		     end;

	     goto NEXT_STATE;

NEXT_STATE:
	end;					/* Parser loop */

	multics_chars_to_write = file_buffer_position - 1;

	P_last_file = last_file;
	P_end_of_file = end_of_file;			/* Only eof or eor may be set, not both. */
	P_record_number = cv_dec_check_ (record_number, code);
	if code ^= 0 then P_record_number = 0;

	return;

     end Receive_L6_Record;

/*****************************************************************************/
/*							       */
/*   PROCEDURE: ERROR					       */
/*							       */
/*   This subroutine expects arguments as follows:		       */
/*							       */
/*         call ERROR (code, ioa_control_string, ioa_arguments, ...)	       */
/*							       */
/*   where: code is fixed bin (35), and ioa_control_string and ioa_arguments */
/*          are optional character strings as defined for ioa_.	       */
/*							       */
/*   Some global variables are used:				       */
/*							       */
/*   	Cleanup_Handler (a procedure that does cleanup)		       */
/*							       */
/*     For commands:					       */
/*   	report_error (an entry variable set to com_err_ or active_fnc_err_)*/
/*   	command_name (the character string name of the command)	       */
/*	return_arg_ptr (used to return "false" for active functions)       */
/*							       */
/*     For subroutines:					       */
/*	depends on the error reporting strategy chosen.		       */
/*							       */
/*   At completion a non-local goto is done to the label RETURN.	       */
/*							       */
/*   Declarations are expected for:				       */
/*							       */
/*   	cu_$arg_list_ptr					       */
/*   	cu_$arg_ptr					       */
/*   	cu_$arg_count					       */
/*   	error_table_$fatal_error				       */
/*   	ioa_$general_rs					       */
/*							       */
/*****************************************************************************/

ERROR:
     proc () options (variable, non_quick);

dcl  arg_list_ptr		       ptr;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  based_code		       fixed bin (35) based;
dcl  caller_code		       fixed bin (35);
dcl  code			       fixed bin (35);
dcl  err_msg		       char (256);
dcl  err_msg_len		       fixed bin (21);
dcl  nargs		       fixed bin;

	call cu_$arg_count (nargs, code);		/* IGNORE CODE */

	if nargs >= 1
	     then do;				/* We were called correctly. */
		arg_ptr = null ();			/* Set this so we know if cu_$arg_ptr worked. */
		call cu_$arg_ptr (1, arg_ptr, arg_len, code);

		if arg_ptr ^= null ()
		     then caller_code = arg_ptr -> based_code;
						/* The normal case. */
		     else caller_code = error_table_$fatal_error;
						/* Some problem with our arg list. */

		if nargs > 1
		     then do;			/* There is a message. */
			call cu_$arg_list_ptr (arg_list_ptr);
			call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b);
			end;

		     else do;			/* No message. */
			err_msg = "";
			err_msg_len = 0;
			end;
		end;				/* We were called correctly. */

	     else do;				/* We were called with no arguments. */
		caller_code = error_table_$fatal_error; /* The best we can do. */
		err_msg = "";
		err_msg_len = 0;
		end;				/* We were called with no arguments. */

/* The following lines must be modified depending on the error reporting strategy used. */

	if level_6_iocbp ^= null () & comm_buffer_ptr ^= null ()
	     then do;				/* Tell the Level 6. */

dcl  pic_err_msg_len	       pic "99";

		pic_err_msg_len = min (99, err_msg_len);

		call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len,
		     substr (err_msg, 1, pic_err_msg_len));

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		end;

	P_error_message = substr (err_msg, 1, err_msg_len);
	P_code = caller_code;

/* Clean up and do a non-local goto back to the outermost block. */

	call Cleanup_Handler ();
	goto RETURN;

     end ERROR;

Cleanup_Handler:
     proc ();

	return;					/* Nothing to do for now. */

     end Cleanup_Handler;

     end l6_tran_receive_file_;




		    l6_tran_send_file_.pl1          10/05/83  1349.7rew 10/05/83  1332.6      182097



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*****************************************************************************/
/*							       */
/*   DESCRIPTION:						       */
/*							       */
/*        This subroutine does all of the work necessary to send a file to   */
/*   the Level 6.  It is used by the l6_tran_ NASP.		       */
/*							       */
/*							       */
/*   JOURNALIZATION:					       */
/*							       */
/*   1) Written 5/82 by R.J.C. Kissel.				       */
/*   2) Modified 7/83 by R.J.C. Kissel to check for an error message from    */
/*      the L6 after every transmission unit is sent.		       */
/*   3) Modified 9/83 by R.J.C. Kissel to not call the final prompt after a  */
/*      file transfer an error.				       */
/*							       */
/*****************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

l6_tran_send_file_:
     proc (P_input_args_ptr, P_output_args_ptr, P_error_message, P_code);

/* Parameters */

dcl  P_input_args_ptr	       ptr parameter;
dcl  P_output_args_ptr	       ptr parameter;
dcl  P_error_message	       char (*) varying parameter;
dcl  P_code		       fixed bin (35) parameter;

/* Automatic */

dcl  comm_buffer		       char (comm_buffer_len) based (comm_buffer_ptr);
dcl  comm_buffer_len	       fixed bin (21);
dcl  comm_buffer_ptr	       ptr;
dcl  comm_buffer_position	       fixed bin (21);

dcl  code			       fixed bin (35);
dcl  end_of_file		       bit (1);

dcl  file_buffer		       char (file_buffer_len) based (file_buffer_ptr);
dcl  file_buffer_len	       fixed bin (21);
dcl  file_buffer_ptr	       ptr;

dcl  last_file		       bit (1);

dcl  level_6_chars_read	       fixed bin (21);
dcl  level_6_chars_to_write	       fixed bin (21);
dcl  level_6_iocbp		       ptr;

dcl  multics_chars_read	       fixed bin (21);
dcl  multics_data_type	       fixed bin;
dcl  multics_file_type	       fixed bin;
dcl  multics_file_iocbp	       ptr;

dcl  next_transmission_unit	       fixed bin;

dcl  1 prompt		       aligned,
       2 prompt_char	       char (1) unaligned init ("P"),
       2 record_number	       pic "99999" unaligned;

dcl  record_number		       fixed bin;
dcl  total_bytes		       fixed bin (35);
dcl  tu_size		       fixed bin (21);

/* Internal Constants */

%include l6_tran_constants;

/* External Constants */

dcl  error_table_$end_of_info	       fixed bin (35) ext static;
dcl  error_table_$fatal_error	       fixed bin (35) ext static;
dcl  error_table_$short_record       fixed bin (35) ext static;
dcl  error_table_$unimplemented_version
			       fixed bin (35) ext static;

/* External Entries */

dcl  cu_$arg_count		       entry (fixed bin, fixed bin (35));
dcl  cu_$arg_list_ptr	       entry (ptr);
dcl  cu_$arg_ptr		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
dcl  ioa_$rsnpnnl		       entry options (variable);
dcl  iox_$read_record	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$get_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$put_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$read_status       entry (ptr) returns (bit (1));

/* Builtin Functions and Conditions */

dcl  length		       builtin;
dcl  min			       builtin;
dcl  mod			       builtin;
dcl  null			       builtin;
dcl  string		       builtin;
dcl  substr		       builtin;
dcl  verify		       builtin;

/* Include Files */

%include l6_tran_transfer_args;

	level_6_iocbp = null ();			/* Initialize these in case of error. */
	comm_buffer_ptr = null ();

	tiap = P_input_args_ptr;
	toap = P_output_args_ptr;

	if transfer_input_args.version ^= transfer_input_args_version_1
	     then call ERROR (error_table_$unimplemented_version, "The input args version was ^a, expected ^a.",
		     transfer_input_args.version, transfer_input_args_version_1);

	if transfer_output_args.version ^= transfer_output_args_version_1
	     then call ERROR (error_table_$unimplemented_version, "The output args version was ^a, expected ^a.",
		     transfer_output_args.version, transfer_output_args_version_1);

	level_6_iocbp = transfer_input_args.comm_iocbp;
	comm_buffer_ptr = transfer_input_args.comm_buffer_ptr;
	comm_buffer_len = transfer_input_args.comm_buffer_len;
	multics_file_iocbp = transfer_input_args.file_iocbp;
	file_buffer_ptr = transfer_input_args.file_buffer_ptr;
	file_buffer_len = transfer_input_args.file_buffer_len;
	multics_file_type = transfer_input_args.file_type;
	multics_data_type = transfer_input_args.data_type;
	tu_size = transfer_input_args.tu_size;
	last_file = transfer_input_args.last_file;
	total_bytes = 0;

	comm_buffer_position = 1;			/* Set this for Send_L6_Record. */
	next_transmission_unit = 0;			/* Set this for Send_L6_Record. */

/* Get the first prompt from the Level 6, it should be for record 0. */

	if ^transfer_input_args.flags.prompt_read
	     then do;
		call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read,
		     code);
		if code ^= 0 then call ERROR (code, "Trying to read the first prompt from the Level 6.");

		string (prompt) = substr (comm_buffer, 1, level_6_chars_read);

		if prompt.record_number ^= 0 then ;	/* Something wrong, but keep going. */
		end;

/* Send records until end of file.  (et_$short_record means eof but no newline from iox_$get_line). */


	call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code);
	if code ^= 0 & code ^= error_table_$end_of_info & code ^= error_table_$short_record
	     then call ERROR (code, "Trying to read the first record from the multics file.");

/* The level 6 cannot handle a null record, so if we have one put a space in it and send that. */

	if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII & multics_chars_read = 0
	     then do;
		multics_chars_read = 1;
		substr (file_buffer, 1, 1) = " ";
		end;

	total_bytes = total_bytes + multics_chars_read;
	end_of_file = (code = error_table_$end_of_info);

	do record_number = 0 by 1 while (^end_of_file);

/* Send the record if it is non-null, otherwise skip it. */

	     if multics_chars_read > 0
		then call Send_L6_Record (record_number, end_of_file, last_file);
		else record_number = record_number - 1; /* Ignore null record, do loop will increment this. */

/* Read the next Multics record, and check the error code. */

	     call iox_$read_record (multics_file_iocbp, file_buffer_ptr, file_buffer_len, multics_chars_read, code);
	     if code ^= 0 & code ^= error_table_$end_of_info & code ^= error_table_$short_record
		then call ERROR (code, "Trying to read record ^d from the multics file.", record_number + 1);

/* The level 6 cannot handle a null record, so if we have one put a space in it and send that. */

	     if multics_file_type = UNSTRUCTURED_FILE_TYPE & multics_data_type = ASCII & multics_chars_read = 0
		then do;
		     multics_chars_read = 1;
		     substr (file_buffer, 1, 1) = " ";
		     end;

	     total_bytes = total_bytes + multics_chars_read;
	     end_of_file = (code = error_table_$end_of_info);
	end;

	call Send_L6_Record (record_number, end_of_file, last_file);
						/* Write the end of file record. */

/* Get the final prompt from the Level 6, it might be an error message. */

	call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_len, level_6_chars_read, code);
	if code ^= 0 then call ERROR (code, "Trying to read the final prompt from the Level 6.");

	call Check_For_L6_Error ((record_number));

	transfer_output_args.record_number = record_number;
	transfer_output_args.total_bytes = total_bytes;
	P_error_message = "";
	P_code = 0;

RETURN:
	return;

Send_L6_Record:
     proc (P_record_number, P_end_of_file, P_last_file);

dcl  P_record_number	       fixed bin parameter;
dcl  P_end_of_file		       bit (1) parameter;
dcl  P_last_file		       bit (1) parameter;

dcl  chars_left_in_record	       fixed bin (21);
dcl  code			       fixed bin (35);
dcl  current_digit		       fixed bin;
dcl  data_field_len		       pic "99";
dcl  end_of_record		       bit (1);
dcl  file_buffer_position	       fixed bin (21);
dcl  max_unpacked_chars	       fixed bin;
dcl  media_code		       char (1);
dcl  pic_next_tu		       pic "9";
dcl  pack_the_data		       bit (1);
dcl  packable_index		       fixed bin;
dcl  packable_string	       bit (1);
dcl  possible_packed_char	       char (1);
dcl  possible_packed_length	       fixed bin;
dcl  record_number		       pic "99999";
dcl  write_record_state	       fixed bin;

	current_digit = 1;
	file_buffer_position = 1;
	media_code = L6_DATA_TYPE (multics_data_type);
	record_number = min (99999, P_record_number);
	write_record_state = 1;

	end_of_record = "0"b;
	do while (^end_of_record);			/* Output loop. */

	     if comm_buffer_position = tu_size + 1 | comm_buffer_position = 1
		then do;

		     if comm_buffer_position = tu_size + 1
			then do;			/* Normal case, = 1 only the first time. */
			     call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, tu_size, code);
			     if code ^= 0 then call ERROR (code, "Trying to write transmission unit.");

/* Look and see if the L6 has sent us something (usually an error message). */

			     if l6_tran_util_$read_status (level_6_iocbp)
				then do;
				     call l6_tran_util_$get_chars (level_6_iocbp, comm_buffer_ptr,
					comm_buffer_len, level_6_chars_read, code);
				     if code ^= 0
					then call ERROR (code,
						"Trying to read a message from the Level 6 after sending record ^d."
						, record_number);

				     call Check_For_L6_Error ((record_number));
				     end;
			     end;

		     comm_buffer_position = 1;

		     pic_next_tu = next_transmission_unit;
		     substr (comm_buffer, comm_buffer_position, 1) = string (pic_next_tu);

		     comm_buffer_position = comm_buffer_position + 1;
		     next_transmission_unit = mod (next_transmission_unit + 1, 10);

		     goto NEXT_STATE;
		     end;

	     goto WRITE_RECORD (write_record_state);

WRITE_RECORD (1):					/* Put in the media code */
	     if P_end_of_file
		then do;
		     if P_last_file
			then substr (comm_buffer, comm_buffer_position, 1) = "E";
			else substr (comm_buffer, comm_buffer_position, 1) = "F";

		     call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, comm_buffer_position, code);
		     if code ^= 0 then call ERROR (code, "Trying to write the last tu.");

		     end_of_record = "1"b;		/* Exit the loop. */
		     end;

		else substr (comm_buffer, comm_buffer_position, 1) = media_code;

	     comm_buffer_position = comm_buffer_position + 1;
	     write_record_state = 2;

	     goto NEXT_STATE;

WRITE_RECORD (2):					/* Put in the record number, one digit at a time. */
	     substr (comm_buffer, comm_buffer_position, 1) = substr (record_number, current_digit, 1);

	     comm_buffer_position = comm_buffer_position + 1;
	     current_digit = current_digit + 1;

	     if current_digit <= length (record_number)
		then write_record_state = 2;
		else do;
		     current_digit = 1;
		     write_record_state = 3;
		     end;

	     goto NEXT_STATE;

WRITE_RECORD (3):					/* Decide to pack, unpack (and how much), or end record. */
	     chars_left_in_record = multics_chars_read - file_buffer_position + 1;

	     if chars_left_in_record <= 0
		then do;				/* Done with the record data. */
		     substr (comm_buffer, comm_buffer_position, 1) = "R";

		     comm_buffer_position = comm_buffer_position + 1;
		     end_of_record = "1"b;		/* Exit the loop. */

		     goto NEXT_STATE;
		     end;

/* Find the longest unpackable string in what is left.  If one is not found, use what is left. */

	     packable_string = "0"b;

	     do packable_index = 0 to min (99, chars_left_in_record) - 1 while (^packable_string);

		possible_packed_char = substr (file_buffer, file_buffer_position + packable_index, 1);

		possible_packed_length =
		     verify (
		     substr (file_buffer, file_buffer_position + packable_index + 1,
		     min (99, chars_left_in_record) - packable_index - 1), possible_packed_char);

		if possible_packed_length = 0 & min (99, chars_left_in_record) - packable_index - 1 > 0
		     then possible_packed_length = min (99, chars_left_in_record) - packable_index;

		if possible_packed_length >= 5
		     then packable_string = "1"b;
		     else packable_string = "0"b;
	     end;

	     packable_index = packable_index - 1;

	     if packable_string & packable_index = 0 then pack_the_data = "1"b;

	     else if packable_string & packable_index > 0
		then do;
		     pack_the_data = "0"b;

		     max_unpacked_chars = (tu_size - comm_buffer_position + 1) - 3;
		     if max_unpacked_chars <= 0 | max_unpacked_chars >= 99 then max_unpacked_chars = 99;
		     max_unpacked_chars = min (max_unpacked_chars, packable_index);
		     end;

	     else do;
		pack_the_data = "0"b;

		max_unpacked_chars = (tu_size - comm_buffer_position + 1) - 3;
		if max_unpacked_chars <= 0 | max_unpacked_chars >= 99 then max_unpacked_chars = 99;
		max_unpacked_chars = min (max_unpacked_chars, chars_left_in_record);
		end;

/* Now put in "P" or "U" as appropriate, and set the length. */

	     if pack_the_data
		then do;
		     data_field_len = possible_packed_length;
		     substr (comm_buffer, comm_buffer_position, 1) = "P";
		     end;

		else do;
		     data_field_len = max_unpacked_chars;
		     substr (comm_buffer, comm_buffer_position, 1) = "U";
		     end;

	     comm_buffer_position = comm_buffer_position + 1;
	     write_record_state = 4;

	     goto NEXT_STATE;

WRITE_RECORD (4):					/* Put in the data length, one digit at a time. */
	     substr (comm_buffer, comm_buffer_position, 1) = substr (data_field_len, current_digit, 1);

	     comm_buffer_position = comm_buffer_position + 1;
	     current_digit = current_digit + 1;

	     if current_digit <= length (string (data_field_len))
		then write_record_state = 4;
		else do;
		     current_digit = 1;
		     write_record_state = 5;
		     end;

	     goto NEXT_STATE;

WRITE_RECORD (5):					/* Now put in the data, it won't cross the tu boundary. */
	     if pack_the_data
		then do;
		     substr (comm_buffer, comm_buffer_position, 1) = possible_packed_char;
		     comm_buffer_position = comm_buffer_position + 1;
		     file_buffer_position = file_buffer_position + possible_packed_length;
		     end;

		else do;
		     substr (comm_buffer, comm_buffer_position, max_unpacked_chars) =
			substr (file_buffer, file_buffer_position, max_unpacked_chars);
		     comm_buffer_position = comm_buffer_position + max_unpacked_chars;
		     file_buffer_position = file_buffer_position + max_unpacked_chars;
		     end;

	     write_record_state = 3;

	     goto NEXT_STATE;

NEXT_STATE:
	end;					/* Output loop. */

	return;

     end Send_L6_Record;

Check_For_L6_Error:
     proc (current_multics_record);

dcl  current_multics_record	       fixed bin;

dcl  1 l6_error		       aligned based (comm_buffer_ptr),
						/* L6 error message overlay. */
       2 header,
         3 first_char	       char (1) unaligned,	/* Should be "C". */
         3 second_char	       char (1) unaligned,	/* Should be "U". */
         3 message_len	       pic "99" unaligned,
       2 message		       char (0 refer (l6_error.header.message_len)) unaligned;

dcl  strange_error		       char (level_6_chars_read) based (comm_buffer_ptr);

	if level_6_chars_read > 0
	     then do;				/* Something to look at. */
		if l6_error.first_char = "C" & level_6_chars_read >= length (string (l6_error.header))
		     then call ERROR (error_table_$fatal_error, "Error from the Level 6 after sending record ^d: ^a.",
			     current_multics_record, l6_error.message);

		else if l6_error.first_char = "P" & level_6_chars_read = length (string (prompt)) then ;
						/* This is not an error, just a prompt. */

		else call ERROR (error_table_$fatal_error, "Error from the Level 6 after sending record ^d: ^a.",
			current_multics_record, strange_error);
		end;

	return;

     end Check_For_L6_Error;

/*****************************************************************************/
/*							       */
/*   PROCEDURE: ERROR					       */
/*							       */
/*   This subroutine expects arguments as follows:		       */
/*							       */
/*         call ERROR (code, ioa_control_string, ioa_arguments, ...)	       */
/*							       */
/*   where: code is fixed bin (35), and ioa_control_string and ioa_arguments */
/*          are optional character strings as defined for ioa_.	       */
/*							       */
/*   Some global variables are used:				       */
/*							       */
/*   	Cleanup_Handler (a procedure that does cleanup)		       */
/*							       */
/*     For commands:					       */
/*   	report_error (an entry variable set to com_err_ or active_fnc_err_)*/
/*   	command_name (the character string name of the command)	       */
/*	return_arg_ptr (used to return "false" for active functions)       */
/*							       */
/*     For subroutines:					       */
/*	depends on the error reporting strategy chosen.		       */
/*							       */
/*   At completion a non-local goto is done to the label RETURN.	       */
/*							       */
/*   Declarations are expected for:				       */
/*							       */
/*   	cu_$arg_list_ptr					       */
/*   	cu_$arg_ptr					       */
/*   	cu_$arg_count					       */
/*   	error_table_$fatal_error				       */
/*   	ioa_$general_rs					       */
/*							       */
/*****************************************************************************/

ERROR:
     proc () options (variable, non_quick);

dcl  arg_list_ptr		       ptr;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  based_code		       fixed bin (35) based;
dcl  caller_code		       fixed bin (35);
dcl  code			       fixed bin (35);
dcl  err_msg		       char (256);
dcl  err_msg_len		       fixed bin (21);
dcl  nargs		       fixed bin;

	call cu_$arg_count (nargs, code);		/* IGNORE CODE */

	if nargs >= 1
	     then do;				/* We were called correctly. */
		arg_ptr = null ();			/* Set this so we know if cu_$arg_ptr worked. */
		call cu_$arg_ptr (1, arg_ptr, arg_len, code);

		if arg_ptr ^= null ()
		     then caller_code = arg_ptr -> based_code;
						/* The normal case. */
		     else caller_code = error_table_$fatal_error;
						/* Some problem with our arg list. */

		if nargs > 1
		     then do;			/* There is a message. */
			call cu_$arg_list_ptr (arg_list_ptr);
			call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b);
			end;

		     else do;			/* No message. */
			err_msg = "";
			err_msg_len = 0;
			end;
		end;				/* We were called correctly. */

	     else do;				/* We were called with no arguments. */
		caller_code = error_table_$fatal_error; /* The best we can do. */
		err_msg = "";
		err_msg_len = 0;
		end;				/* We were called with no arguments. */

/* The following lines must be modified depending on the error reporting strategy used. */

	if level_6_iocbp ^= null () & comm_buffer_ptr ^= null ()
	     then do;				/* Tell the Level 6. */

dcl  pic_err_msg_len	       pic "99";

		pic_err_msg_len = min (99, err_msg_len);

		call ioa_$rsnpnnl ("CU^a^aR", comm_buffer, level_6_chars_to_write, pic_err_msg_len,
		     substr (err_msg, 1, pic_err_msg_len));

		call l6_tran_util_$put_chars (level_6_iocbp, comm_buffer_ptr, level_6_chars_to_write, code);
		end;

	P_error_message = substr (err_msg, 1, err_msg_len);
	P_code = caller_code;

/* Clean up and do a non-local goto back to the outermost block. */

	call Cleanup_Handler ();
	goto RETURN;

     end ERROR;

Cleanup_Handler:
     proc ();

	return;					/* Nothing to do for now. */

     end Cleanup_Handler;

     end l6_tran_send_file_;




		    l6_tran_util_.pl1               08/08/88  1553.7r w 08/08/88  1410.7       72216



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*****************************************************************************/
/*							       */
/*   DESCRIPTION:						       */
/*							       */
/*        This subroutine handles utility functions for Level 6 file	       */
/*   transfer.  Basically these are reading and writing to or from the Level */
/*   6.							       */
/*							       */
/*							       */
/*   JOURNALIZATION:					       */
/*							       */
/*   1) Written 5/82 by R.J.C. Kissel.				       */
/*   2) Modified 7/83 by R.J.C. Kissel to add an entry to do a read_status,  */
/*      used to check for L6 error messages.			       */
/*							       */
/*****************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

l6_tran_util_:
     proc ();
	return;

/* Parameters */

dcl  P_iocbp		       ptr parameter;
dcl  P_input_chars_ptr	       ptr parameter;
dcl  P_input_buffer_len	       fixed bin (21) parameter;
dcl  P_input_chars_len	       fixed bin (21) parameter;

dcl  P_output_chars_ptr	       ptr parameter;
dcl  P_output_chars_len	       fixed bin (21) parameter;

dcl  P_code		       fixed bin (35) parameter;

/* Automatic */

dcl  code			       fixed bin (35);

dcl  input_chars_ptr	       ptr;
dcl  input_buffer_len	       fixed bin (21);
dcl  input_chars_len	       fixed bin (21);
dcl  input_chars		       char (input_chars_len) based (input_chars_ptr);

dcl  iocbp		       ptr;
dcl  line_status		       bit (72);

dcl  output_chars_ptr	       ptr;
dcl  output_chars_len	       fixed bin (21);
dcl  output_chars		       char (output_chars_len) based (output_chars_ptr);

dcl  1 read_status_info	       aligned like tty_read_status_info;

/* Internal Static */

dcl  debug		       bit (1) internal static init ("0"b);
dcl  debug_iocbp		       ptr internal static init (null ());

/* External Constants */

dcl  error_table_$line_status_pending
			       fixed bin (35) ext static;

/* External Entries */

dcl  ioa_$ioa_switch	       entry () options (variable);
dcl  iox_$control		       entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$get_chars		       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$get_line		       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$put_chars		       entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  ipc_$drain_chn		       entry (fixed bin (71), fixed bin (35));

/* Builtin Functions and Conditions */

dcl  addr			       builtin;

/*****************************************************************************/
/*							       */
/*   ENTRY: get_chars					       */
/*							       */
/*        This entry gets characters from the Level 6 and handles debugging  */
/*   and line status.					       */
/*							       */
/*****************************************************************************/

get_chars:
     entry (P_iocbp, P_input_chars_ptr, P_input_buffer_len, P_input_chars_len, P_code);

	iocbp = P_iocbp;
	input_chars_ptr = P_input_chars_ptr;
	input_buffer_len = P_input_buffer_len;

	call iox_$get_chars (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code);

	do while (code = error_table_$line_status_pending);
	     call iox_$control (iocbp, "line_status", addr (line_status), code);

	     if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status);

	     call iox_$get_chars (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code);
	end;

	if debug
	     then call ioa_$ioa_switch (debug_iocbp, "From L6: ^d characters^/""^a""", input_chars_len, input_chars);

	P_input_chars_len = input_chars_len;
	P_code = code;

	return;

/*****************************************************************************/
/*							       */
/*   ENTRY: get_line					       */
/*							       */
/*        This entry gets a line from the Level 6 and handles debugging      */
/*   and line status.					       */
/*							       */
/*****************************************************************************/

get_line:
     entry (P_iocbp, P_input_chars_ptr, P_input_buffer_len, P_input_chars_len, P_code);

	iocbp = P_iocbp;
	input_chars_ptr = P_input_chars_ptr;
	input_buffer_len = P_input_buffer_len;

	call iox_$get_line (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code);

	do while (code = error_table_$line_status_pending);
	     call iox_$control (iocbp, "line_status", addr (line_status), code);

	     if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status);

	     call iox_$get_line (iocbp, input_chars_ptr, input_buffer_len, input_chars_len, code);
	end;

	if debug
	     then call ioa_$ioa_switch (debug_iocbp, "From L6: ^d characters^/""^a""", input_chars_len, input_chars);

	P_input_chars_len = input_chars_len;
	P_code = code;

	return;


/*****************************************************************************/
/*							       */
/*   ENTRY: put_chars					       */
/*							       */
/*        This entry sends characters to the Level 6 and handles debugging   */
/*   and line status.					       */
/*							       */
/*****************************************************************************/

put_chars:
     entry (P_iocbp, P_output_chars_ptr, P_output_chars_len, P_code);

	iocbp = P_iocbp;
	output_chars_ptr = P_output_chars_ptr;
	output_chars_len = P_output_chars_len;

	if debug
	     then call ioa_$ioa_switch (debug_iocbp, "To L6: ^d characters^/""^a""", output_chars_len, output_chars);

	call iox_$put_chars (iocbp, output_chars_ptr, output_chars_len, code);

	do while (code = error_table_$line_status_pending);
	     call iox_$control (iocbp, "line_status", addr (line_status), code);

	     if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status);

	     call iox_$put_chars (iocbp, output_chars_ptr, output_chars_len, code);
	end;

	P_code = code;

	return;

/*****************************************************************************/
/*							       */
/*   ENTRY: read_status					       */
/*							       */
/*        This entry returns true if there is input pending and false	       */
/*   otherwise.  It handles line_status_pending and any error codes.  Since  */
/*   we don't care about wakeups, it also drains the event channel on every  */
/*   call.						       */
/*							       */
/*****************************************************************************/

read_status:
     entry (P_iocbp) returns (bit (1));

	iocbp = P_iocbp;

	call iox_$control (iocbp, "read_status", addr (read_status_info), code);

	do while (code = error_table_$line_status_pending);
	     call iox_$control (iocbp, "line_status", addr (line_status), code);

	     if debug then call ioa_$ioa_switch (debug_iocbp, "Line status from L6: ^.3b", line_status);

	     call iox_$control (iocbp, "read_status", addr (read_status_info), code);
	end;

	call ipc_$drain_chn (read_status_info.event_channel, code);

	if debug
	     then call ioa_$ioa_switch (debug_iocbp,
		     "Called read_status, ev_chn = ^o, input_pending = ^b, code = ^d.",
		     read_status_info.event_channel, read_status_info.input_pending, code);

	return (read_status_info.input_pending);

debug_on:
     entry ();
	debug = "1"b;
	return;




debug_off:
     entry ();
	debug = "0"b;
	return;




set_debug_iocb:
     entry (diocbp);

dcl  diocbp		       ptr;
dcl  iox_$user_output	       ptr ext static;
dcl  null			       builtin;

	if diocbp = null ()
	     then debug_iocbp = iox_$user_output;
	     else debug_iocbp = diocbp;

	return;

/* Include Files */

%include tty_read_status_info;

     end l6_tran_util_;




		    net_info_table_.pl1             11/12/82  1350.6rew 11/12/82  0953.9       16965



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*****************************************************************************/
/*							       */
/*   This is currently just an internal interface used by the L6 tran	       */
/*   software.  It will be the real thing in the future.		       */
/*							       */
/*****************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

net_info_table_:
     proc ();
	return;

/* Parameters */

dcl  P_code		       fixed bin (35) parameter;
dcl  P_function_name	       char (*) parameter;
dcl  P_host_address		       char (*) parameter;
dcl  P_host_name		       char (*) parameter;
dcl  P_nasp_name		       char (*) parameter;
dcl  P_net_name		       char (*) parameter;

/* Automatic */

dcl  host_name		       char (32);
dcl  function_name		       char (32);
dcl  net_name		       char (32);

/* External Constants */

dcl  error_table_$resource_type_unknown
			       fixed bin (35) ext static;

get_host_address:
     entry (P_host_name, P_net_name, P_host_address, P_code);

	host_name = P_host_name;
	net_name = P_net_name;

	P_host_address = host_name;			/* The name is the address for now. */
	P_code = 0;

	return;

get_nasp_name:
     entry (P_function_name, P_nasp_name, P_code);

	function_name = P_function_name;

	if function_name ^= "l6_ftf"
	     then do;
		P_nasp_name = "";
		P_code = error_table_$resource_type_unknown;
		end;

	     else do;
		P_nasp_name = "l6_tran_";
		P_code = 0;
		end;

	return;

     end net_info_table_;




		    network_request.pl1             11/12/82  1350.6rew 11/12/82  0953.9       98514



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/******************************************************************************/
/*							        */
/*   DESCRIPTION:						        */
/*							        */
/*        This command implements the general interactive network function    */
/*   interface.  The syntax is:				        */
/*							        */
/*   	nr <function> {<function_args>}			        */
/*							        */
/*   The <function> is used to look up the subroutine that implements that    */
/*   function in the Network Information Table, using the net_info_table_     */
/*   entries.  That subroutine is then called to do all the work.  Basically  */
/*   this command is just a framework into which different functions can be   */
/*   plugged.						        */
/*							        */
/*							        */
/*   JOURNALIZATION:					        */
/*							        */
/*   1) Written 3/82 by R.J.C. Kissel				        */
/*							        */
/******************************************************************************/

/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

network_request:
nr:
     proc ();

/* Automatic */

dcl  arg			       char (arg_len) based (arg_ptr);
dcl  arg_idx		       fixed bin;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  arg_list_ptr		       ptr;

dcl  1 auto_area_info	       aligned like area_info;
dcl  based_area		       area (sys_info$max_seg_size) based;
dcl  code			       fixed bin (35);
dcl  command_name		       char (16);
dcl  function_name		       char (32);
dcl  get_argument		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable;
dcl  in_iocbp		       ptr;

dcl  nasp_area_ptr		       ptr defined (auto_area_info.areap);
dcl  nasp_complete		       bit (1);
dcl  nasp_error_message	       char (256) varying;
dcl  nasp_name		       char (32);
dcl  nasp_unhold		       bit (1);

dcl  nasp_structure		       bit (nasp_structure_len) based (nasp_structure_ptr) aligned;
dcl  nasp_structure_len	       fixed bin (24);
dcl  nasp_structure_ptr	       ptr;

dcl  number_of_args		       fixed bin;
dcl  out_iocbp		       ptr;
dcl  queued_flag		       bit (1);
dcl  report_error		       entry () options (variable) variable;

dcl  return_arg		       char (return_arg_len) based (return_arg_ptr);
dcl  return_arg_len		       fixed bin (21);
dcl  return_arg_ptr		       ptr;

dcl  usage		       char (64);

/* Local Constants */

dcl  COM_USAGE		       char (64) internal static options (constant)
			       init ("Usage: nr <function> {<function_args>}");
dcl  AF_USAGE		       char (64) internal static options (constant)
			       init ("Usage: [nr <function> {<function_args>}]");

/* External Constants */

dcl  error_table_$fatal_error	       fixed bin (35) ext static;
dcl  error_table_$noarg	       fixed bin (35) ext static;
dcl  error_table_$not_act_fnc	       fixed bin (35) ext static;

dcl  iox_$user_input	       ptr ext static;
dcl  iox_$user_output	       ptr ext static;

dcl  sys_info$max_seg_size	       fixed bin (35) ext static;

/* External Entries */

dcl  active_fnc_err_	       entry options (variable);
dcl  com_err_		       entry () options (variable);
dcl  cu_$af_return_arg	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$af_arg_ptr		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_list_ptr	       entry (ptr);
dcl  cu_$arg_ptr		       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_count		       entry (fixed bin, fixed bin (35));
dcl  cv_entry_		       entry (char (*), ptr, fixed bin (35)) returns (entry);
dcl  define_area_		       entry (ptr, fixed bin (35));
dcl  ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
dcl  net_info_table_$get_nasp_name   entry (char (*), char (*), fixed bin (35));
dcl  release_area_		       entry (ptr);

/* Builtin Functions and Conditions */

dcl  addr			       builtin;
dcl  null			       builtin;
dcl  rtrim		       builtin;

dcl  cleanup		       condition;

/* Include Files */

%include nasp_entry_dcls;

%include area_info;

	command_name = "network_request";
	in_iocbp = iox_$user_input;
	out_iocbp = iox_$user_output;
	queued_flag = "0"b;				/* This is an interactive request. */

	nasp_area_ptr = null ();			/* This sets auto_area_info.areap too. */
	nasp_structure_ptr = null ();
	nasp_structure_len = 0;

	call cu_$af_return_arg (number_of_args, return_arg_ptr, return_arg_len, code);

	if code = 0
	     then do;				/* An active function call. */
		report_error = active_fnc_err_;
		get_argument = cu_$af_arg_ptr;
		usage = AF_USAGE;
		end;

	else if code = error_table_$not_act_fnc
	     then do;				/* A command call. */
		return_arg_ptr = null ();
		report_error = com_err_;
		get_argument = cu_$arg_ptr;
		usage = COM_USAGE;
		end;

	else do;					/* An error. */
	     return_arg_ptr = null ();
	     report_error = com_err_;
	     call ERROR (code, "Trying to get the command arguments.");
	     end;

	if number_of_args < 1 then call ERROR (error_table_$noarg, "^/^a.", usage);

	arg_idx = 1;				/* Process the function argument. */

	call get_argument (arg_idx, arg_ptr, arg_len, code);
	if code ^= 0 then call ERROR (code, "Trying to get the <function> argument.");

	function_name = arg;

	call net_info_table_$get_nasp_name (function_name, nasp_name, code);
	if code ^= 0 then call ERROR (code, "Trying to get the NASP name for the function: ^a.", function_name);

	NASP_parser = cv_entry_ (rtrim (nasp_name) || "$parser", null (), code);
	if code ^= 0 then call ERROR (code, "Trying to generate the NASP_$parser entry.");

	NASP_execute = cv_entry_ (rtrim (nasp_name) || "$execute", null (), code);
	if code ^= 0 then call ERROR (code, "Trying to generate the NASP_$execute entry.");

/* Set up so the NASP entry can get its arguments from our argument list. */

	arg_idx = arg_idx + 1;

	call cu_$arg_list_ptr (arg_list_ptr);

	on cleanup call Cleanup_Handler ();

/* Get a temporary area */

	auto_area_info.version = area_info_version_1;
	auto_area_info.control = "0"b;
	auto_area_info.control.extend = "1"b;
	auto_area_info.control.zero_on_alloc = "1"b;
	auto_area_info.owner = command_name;
	auto_area_info.size = sys_info$max_seg_size;

	call define_area_ (addr (auto_area_info), code);
	if code ^= 0 then call ERROR (code, "Trying to define a temporary area.");

/* Do the real work by calling the NASP entries. */

	call NASP_parser (in_iocbp, out_iocbp, command_name, arg_list_ptr, arg_idx, queued_flag, nasp_area_ptr,
	     nasp_structure_ptr, nasp_structure_len, nasp_error_message, code);
	if code ^= 0 then call ERROR (code, "From ^a$parser: ^a", nasp_name, nasp_error_message);

	call NASP_execute (in_iocbp, out_iocbp, command_name, queued_flag, nasp_structure_ptr, nasp_structure_len,
	     nasp_complete, nasp_unhold, nasp_error_message, code);
	if code ^= 0 then call ERROR (code, "From ^a$execute: ^a", nasp_name, nasp_error_message);

/* nasp_complete and nasp_unhold are ignored for an interactive request, so we are done. */

	call Cleanup_Handler ();

	if return_arg_ptr ^= null () then return_arg = "true";

RETURN:
	return;

/*****************************************************************************/
/*							       */
/*   PROCEDURE: ERROR					       */
/*							       */
/*   This subroutine expects arguments as follows:		       */
/*							       */
/*         call ERROR (code, ioa_control_string, ioa_arguments, ...)	       */
/*							       */
/*   where: code is fixed bin (35), and ioa_control_string and ioa_arguments */
/*          are optional character strings as defined for ioa_.	       */
/*							       */
/*   Some global variables are used:				       */
/*							       */
/*   	Cleanup_Handler (a procedure that does cleanup)		       */
/*							       */
/*     For commands:					       */
/*   	report_error (an entry variable set to com_err_ or active_fnc_err_)*/
/*   	command_name (the character string name of the command)	       */
/*	return_arg_ptr (used to return "false" for active functions)       */
/*							       */
/*     For subroutines:					       */
/*	depends on the error reporting strategy chosen.		       */
/*							       */
/*   At completion a non-local goto is done to the label RETURN.	       */
/*							       */
/*   Declarations are expected for:				       */
/*							       */
/*   	cu_$arg_list_ptr					       */
/*   	cu_$arg_ptr					       */
/*   	cu_$arg_count					       */
/*   	error_table_$fatal_error				       */
/*   	ioa_$general_rs					       */
/*							       */
/*****************************************************************************/

ERROR:
     proc () options (variable, non_quick);

dcl  arg_list_ptr		       ptr;
dcl  arg_len		       fixed bin (21);
dcl  arg_ptr		       ptr;
dcl  based_code		       fixed bin (35) based;
dcl  caller_code		       fixed bin (35);
dcl  code			       fixed bin (35);
dcl  err_msg		       char (256);
dcl  err_msg_len		       fixed bin (21);
dcl  nargs		       fixed bin;

	call cu_$arg_count (nargs, code);		/* IGNORE CODE */

	if nargs >= 1
	     then do;				/* We were called correctly. */
		arg_ptr = null ();			/* Set this so we know if cu_$arg_ptr worked. */
		call cu_$arg_ptr (1, arg_ptr, arg_len, code);

		if arg_ptr ^= null ()
		     then caller_code = arg_ptr -> based_code;
						/* The normal case. */
		     else caller_code = error_table_$fatal_error;
						/* Some problem with our arg list. */

		if nargs > 1
		     then do;			/* There is a message. */
			call cu_$arg_list_ptr (arg_list_ptr);
			call ioa_$general_rs (arg_list_ptr, 2, 3, err_msg, err_msg_len, "1"b, "0"b);
			end;

		     else do;			/* No message. */
			err_msg = "";
			err_msg_len = 0;
			end;
		end;				/* We were called correctly. */

	     else do;				/* We were called with no arguments. */
		caller_code = error_table_$fatal_error; /* The best we can do. */
		err_msg = "";
		err_msg_len = 0;
		end;				/* We were called with no arguments. */

	call Cleanup_Handler ();

/* The following lines must be modified depending on the error reporting strategy used. */

	call report_error (caller_code, command_name, "^a", err_msg);

	if return_arg_ptr ^= null () then return_arg = "false";

/* Do a non-local goto back to the outermost block. */

	goto RETURN;

     end ERROR;

Cleanup_Handler:
     proc ();

	if nasp_area_ptr ^= null ()
	     then do;
		if nasp_structure_ptr ^= null () then free nasp_structure in (nasp_area_ptr -> based_area);

		call release_area_ (nasp_area_ptr);
		end;

	return;

     end Cleanup_Handler;

     end network_request;




		    rbf_.pl1                        10/17/88  1107.4r w 10/17/88  1033.4      421812



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


/*****************************************************************************/
/*							       */
/*   DESCRIPTION:						       */
/*							       */
/*        This IO module is analogous to g115_.  It handles remote batch to  */
/*   a Level 6M Satellite over an X.25 connection in the same way that g115_ */
/*   does remote batch over an RCI connection.  It uses tty_ to do its IO.   */
/*   The four possible devices which are supported, reader, punch, printer,  */
/*   and teleprinter, all use the same communications channel, therefore,    */
/*   the channel name can not contain stars.			       */
/*							       */
/*****************************************************************************/


/****^  HISTORY COMMENTS:
  1) change(82-06-01,RKissel), approve(), audit(), install():
     Written.
  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: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

rbf_:
     proc ();

ERROR_EXIT:
	return;

/* Parameter */

dcl  a_buffer_len		       fixed bin (21) parameter;
dcl  a_bufferp		       ptr parameter;
dcl  a_code		       fixed bin (35) parameter;
dcl  a_comerr_sw		       bit (1) parameter;
dcl  a_infop		       ptr parameter;
dcl  a_iocbp		       ptr parameter;
dcl  a_new_modes		       char (*) parameter;
dcl  a_old_modes		       char (*) parameter;
dcl  a_open_mode		       fixed bin parameter;
dcl  a_option		       (*) char (*) var parameter;
dcl  a_order		       char (*) parameter;
dcl  a_record_len		       fixed bin (21) parameter;
dcl  a_recordp		       ptr parameter;

/* Automatic */

dcl  1 auto_area_info	       aligned like area_info;
dcl  1 auto_ttd		       aligned like terminal_type_data;

dcl  based_area		       area (sys_info$max_seg_size) based (areap);

dcl  bcd_equiv		       (0:63) char (1) unal defined (bcd_equiv_string);
dcl  code			       fixed bin (35);
dcl  comerr_sw		       bit (1);
dcl  dummy_arg		       char (32);
dcl  i			       fixed bin;
dcl  input_trp		       ptr;
dcl  iocbp		       ptr;
dcl  mask			       bit (36) aligned;
dcl  next_attach_description	       char (256) varying unaligned;
dcl  next_attach_options	       char (256) varying unaligned;
dcl  next_channel		       char (32) varying unaligned;
dcl  next_io_module		       char (32) varying unaligned;
dcl  next_io_switch_name	       char (32) varying unaligned;
dcl  open_mode		       fixed bin;
dcl  output_chars_to_write	       fixed bin (21);
dcl  output_trp		       ptr;
dcl  my_attach_description	       char (256) var;
dcl  slew_by_count_char	       (0:15) char (1) unaligned defined (legal_slew_chars) pos (2);
dcl  temp_ptr		       ptr;

/* Structure to define per-attachment data for each rbf_ switch attachment. */

dcl  radp			       ptr;

dcl  1 rbf_attach_data	       based (radp),
       2 attach_description	       char (256) var,
       2 open_description	       char (256) var,
       2 modes		       char (256) var,
       2 translations,				/* translation tables */
         3 input		       char (512),
         3 output		       char (512),
       2 terminal_type	       char (32),
       2 device		       char (32),		/* name of generic type of remote device */
       2 device_type	       fixed bin,		/* generic device in fixed bin form */
       2 comm_data_ptr	       ptr;		/* common data for this attachment. */

/* Structure for holding communication line specific data for all attachments to this line. */

dcl  cdbp			       ptr;		/* pointer to the comm data block. */

dcl  1 comm_data_block	       aligned based (cdbp),
       2 forward_ptr	       ptr,		/* Forward data block chain. */
       2 backward_ptr	       ptr,		/* Backward data block chain. */
       2 comm_channel	       char (32) unaligned,	/* Name of the channel for this RBF station. */
       2 comm_io_module	       char (32) unaligned,	/* Name of the IO module to use. */
       2 comm_iocbp		       ptr,		/* iocb ptr for this RBF station. */
       2 comm_event_channel	       fixed bin (71),	/* event channel used by the IO module. */
       2 timer_event_channel	       fixed bin (71),	/* event channel for use by runout control. */
       2 temp_seg_ptrs	       (2) ptr,		/* 1 is input buffer, 2 is output buffer */
       2 temp_seg_lens	       (2) fixed bin (21),
       2 number_of_attachments       fixed bin,
       2 input_chars_read	       fixed bin (21),
       2 input_buffer_position       fixed bin (21),
       2 flags		       aligned,
         3 comm_attached	       bit (1) unaligned,
         3 comm_open	       bit (1) unaligned,
         3 we_just_wrote	       bit (1) unaligned,
         3 pad		       bit (33) unaligned;

dcl  input_buffer		       char (input_buffer_len) based (input_buffer_ptr);
dcl  input_buffer_ptr	       ptr defined (comm_data_block.temp_seg_ptrs (1));
dcl  input_buffer_len	       fixed bin (21) defined (comm_data_block.temp_seg_lens (1));

dcl  output_buffer		       char (output_buffer_len) based (output_buffer_ptr);
dcl  output_buffer_ptr	       ptr defined (comm_data_block.temp_seg_ptrs (2));
dcl  output_buffer_len	       fixed bin (21) defined (comm_data_block.temp_seg_lens (2));

/* Builtin Functions and Conditions */

dcl  addr			       builtin;
dcl  bin			       builtin;
dcl  codeptr		       builtin;
dcl  collate9		       builtin;
dcl  copy			       builtin;
dcl  currentsize		       builtin;
dcl  dimension		       builtin;
dcl  divide		       builtin;
dcl  hbound		       builtin;
dcl  index		       builtin;
dcl  lbound		       builtin;
dcl  length		       builtin;
dcl  null			       builtin;
dcl  rtrim		       builtin;
dcl  substr		       builtin;
dcl  translate		       builtin;
dcl  unspec		       builtin;
dcl  verify		       builtin;

dcl  any_other		       condition;
dcl  cleanup		       condition;

/* Internal Static */

dcl  areap		       ptr int static init (null);
dcl  debug_flag		       bit (1) int static init ("0"b);
dcl  first_cdbp		       ptr internal static init (null ());
dcl  last_cdbp		       ptr internal static init (null ());

/* Internal Constants */

dcl  bcd_equiv_string	       char (64) unal int static options (constant)
			       init ("0123456789[#@:>? ABCDEFGHI&.](<\^JKLMNOPQR-$*);'+/STUVWXYZ_,%=""!");
dcl  CR			       char (1) internal static options (constant) init ("");
dcl  default_modes		       char (14) init ("8bit,rawi,rawo") int static options (constant);
dcl  device_names		       (4) char (32) int static options (constant)
			       init ("teleprinter", "reader", "printer", "punch");
dcl  legal_slew_chars	       char (19) int static options (constant) init (" 0123456789[#@:>?AB");
						/* printer slew codes, in order:
						   Top of form - space
						   slew 0 to 15 lines - 0...?
						   VFU_1 - A, VFU_2 - B */
dcl  lowercase		       char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl  MY_NAME		       char (4) int static options (constant) init ("rbf_");
dcl  REL_SECONDS		       bit (2) int static options (constant) init ("11"b);
dcl  space		       char (1) int static options (constant) init (" ");
dcl  uppercase		       char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");

/* The following are RBF specific constants. */

dcl  1 RBF		       aligned internal static options (constant),
						/* This group defines input/output media codes associated with records within the text of a message block */
       2 media_codes	       unal,
         3 bcd_input_mc	       char (1) init ("H"),	/* Input media code for BCD data - 110 octal */
         3 bin_input_mc	       char (1) init ("P"),	/* Input media code for Binary data - 120 octal */
         3 printer_mc	       char (1) init ("L"),	/* printer output media code - 114 octal */
         3 punch_bcd_mc	       char (1) init ("O"),	/* punch output media code (BCD data)  - 117 octal */
         3 punch_bin_mc	       char (1) init ("W"),	/* punch output media code (Binary data)  - 127 octal */
         3 teleprinter_mc	       char (1) init ("N"),	/* teleprinter output media code - 116 octal */
						/* This group defines the message format codes which apply to all records in a single message block */
       2 format_codes	       unal,
         3 info_ns_nc	       bit (9) init ("110"b3),/* information message, no split, no compression */
         3 info_ns_c	       bit (9) init ("111"b3),/* information message, no split, compression */
         3 info_s_nc	       bit (9) init ("112"b3),/* information message, split, no compression */
         3 info_s_c		       bit (9) init ("113"b3),/* information message, split, compression */
         3 special_nc	       bit (9) init ("104"b3),/* Special control record, no compression */
         3 special_c	       bit (9) init ("105"b3),/* Special control record, compression */
						/* This group defines reserved characters which appear in the message block */
       2 char_codes		       unal,
         3 stx_char		       bit (9) init ("002"b3),/* start-of-text (STX) char */
         3 etx_char		       bit (9) init ("003"b3),/* end-of-text (ETX) char */
         3 soh_char		       bit (9) init ("001"b3),/* start-of-header (SOH) char */
         3 addr_code_char	       bit (9) init ("100"b3),/* address code character */
         3 id_code_char	       bit (9) init ("100"b3),/* identification code character */
         3 RS		       char (1) init (""),	/* record separator - 036 octal */
         3 CC		       char (1) init (""),	/* compression character code - 037 octal */
						/* The maximum size of a single rci message from SOH to ETX */
       2 max_msg_len	       fixed bin init (324);	/* max data in a message */

/* External Entries */

dcl  com_err_		       entry () options (variable);
dcl  continue_to_signal_	       entry (fixed bin (35));
dcl  convert_ipc_code_	       entry (fixed bin (35));
dcl  get_system_free_area_	       entry () returns (ptr);
dcl  get_temp_segments_	       entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$set_ips_mask	       entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$reset_ips_mask	       entry (bit (36) aligned, bit (36) aligned);
dcl  ipc_$block		       entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn	       entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn	       entry (fixed bin (71), fixed bin (35));
dcl  ipc_$drain_chn		       entry (fixed bin (71), fixed bin (35));
dcl  l6_tran_util_$get_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  l6_tran_util_$put_chars	       entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  mode_string_$parse	       entry (char (*), ptr, ptr, fixed bin (35));
dcl  release_temp_segments_	       entry (char (*), (*) ptr, fixed bin (35));
dcl  timer_manager_$alarm_wakeup     entry (fixed bin (71), bit (2), fixed bin (71));
dcl  timer_manager_$reset_alarm_wakeup
			       entry (fixed bin (71));
dcl  ttt_info_$terminal_data	       entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  unique_chars_		       entry (bit (*)) returns (char (15));

/* External Constants */

dcl  error_table_$bad_mode	       fixed bin (35) ext static;
dcl  error_table_$bad_mode_value     fixed bin (35) ext static;
dcl  error_table_$badopt	       fixed bin (35) ext static;
dcl  error_table_$eof_record	       fixed bin (35) ext static;
dcl  error_table_$improper_data_format
			       fixed bin (35) ext static;
dcl  error_table_$invalid_read       fixed bin (35) ext static;
dcl  error_table_$long_record	       fixed bin (35) ext static;
dcl  error_table_$noarg	       fixed bin (35) ext static;
dcl  error_table_$not_attached       fixed bin (35) ext static;
dcl  error_table_$not_closed	       fixed bin (35) ext static;
dcl  error_table_$not_detached       fixed bin (35) ext static;
dcl  error_table_$not_open	       fixed bin (35) ext static;
dcl  error_table_$null_info_ptr      fixed bin (35) ext static;
dcl  error_table_$short_record       fixed bin (35) ext static;
dcl  error_table_$smallarg	       fixed bin (35) ext static;
dcl  error_table_$unimplemented_version
			       fixed bin (35) ext static;
dcl  error_table_$wrong_no_of_args   fixed bin (35) ext static;

dcl  sys_info$max_seg_size	       fixed bin (35) ext static;

rbf_attach:
     entry (a_iocbp, a_option, a_comerr_sw, a_code);

	comerr_sw = debug_flag | a_comerr_sw;
	iocbp = a_iocbp;

/* See if we are already attached. */

	if iocbp -> iocb.attach_descrip_ptr ^= null
	     then do;
		a_code = error_table_$not_detached;
		return;
		end;

/* Get an area to work in if we don't already have one. */

	if areap = null () then areap = get_system_free_area_ ();

/* Make a quick consistency check, must have: -tty arg -comm arg -device arg. */

	if hbound (a_option, 1) < 6
	     then call Abort_Attach (error_table_$wrong_no_of_args, MY_NAME, "Invalid attach description", "");

/* Initialize for the cleanup handler. */

	next_io_module = "";
	next_channel = "";
	next_attach_options = "";
	my_attach_description = "";

	cdbp = null ();
	radp = null ();

	on cleanup call Attach_Cleanup ();

/* Allocate a structure to hold our attach data, and initialize it. */

	allocate rbf_attach_data in (based_area) set (radp);

	rbf_attach_data.attach_description = "";
	rbf_attach_data.open_description = "";
	rbf_attach_data.modes = default_modes;
	rbf_attach_data.translations = "";
	rbf_attach_data.terminal_type = "";
	rbf_attach_data.device = "";
	rbf_attach_data.device_type = 0;
	rbf_attach_data.comm_data_ptr = null ();

/* Process the attachment arguments. */

	my_attach_description = MY_NAME;

	do i = 1 to hbound (a_option, 1);

	     my_attach_description = my_attach_description || space || a_option (i);

	     if a_option (i) = "-device" then rbf_attach_data.device = Get_Option_Arg (i);

	     else if a_option (i) = "-tty" then next_channel = Get_Option_Arg (i);

	     else if a_option (i) = "-comm" then next_io_module = Get_Option_Arg (i);

	     else if a_option (i) = "-ascii" then ;

	     else if a_option (i) = "-ebcdic" then ;

	     else if a_option (i) = "-physical_line_length" | a_option (i) = "-pll" then dummy_arg = Get_Option_Arg (i);

	     else if a_option (i) = "-delay" then dummy_arg = Get_Option_Arg (i);

	     else if a_option (i) = "-terminal_type" | a_option (i) = "-ttp"
		then rbf_attach_data.terminal_type = Get_Option_Arg (i);

	     else next_attach_options = next_attach_options || space || a_option (i);
	end;					/* do i = ... */

/* Make some checks on the arguments. */

	if next_io_module ^= "tty_" then call Abort_Attach (0, MY_NAME, "Invalid or missing -comm option", "");

	if next_channel = "" then call Abort_Attach (0, MY_NAME, "No -tty option given", "");

	do i = lbound (device_names, 1) to hbound (device_names, 1) while (rbf_attach_data.device ^= device_names (i));
	end;

	if i > hbound (device_names, 1)
	     then call Abort_Attach (error_table_$badopt, MY_NAME, "Invalid device specified", "");
	     else rbf_attach_data.device_type = i;

/* Get translation information and then set input and output translation. */

	if rbf_attach_data.terminal_type ^= ""
	     then do;
		rbf_attach_data.terminal_type = translate (rbf_attach_data.terminal_type, uppercase, lowercase);

		auto_ttd.version = ttd_version_3;
		call ttt_info_$terminal_data (rbf_attach_data.terminal_type, -1, 0, addr (auto_ttd), code);
		if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unknown terminal type specified", "");

		input_trp = auto_ttd.tables.input_tr_ptr;
		output_trp = auto_ttd.tables.output_tr_ptr;
		end;

	     else do;
		input_trp = null ();
		output_trp = null ();
		end;

	call Set_Translation (rbf_attach_data.translations.input, input_trp);
	call Set_Translation (rbf_attach_data.translations.output, output_trp);

/* Now see if we already know about the target channel. */

	do temp_ptr = first_cdbp repeat (temp_ptr -> comm_data_block.forward_ptr)
	     while (temp_ptr ^= null () & cdbp = null ());
	     if temp_ptr -> comm_data_block.comm_channel = next_channel then cdbp = temp_ptr;
	end;

/* See if we found a comm_data_block, if not create and initialize one. */

	if cdbp = null ()
	     then do;
		allocate comm_data_block in (based_area) set (cdbp);

		comm_data_block.forward_ptr = null ();
		comm_data_block.backward_ptr = last_cdbp;
		comm_data_block.comm_channel = next_channel;
		comm_data_block.comm_io_module = next_io_module;
		comm_data_block.comm_iocbp = null ();
		comm_data_block.comm_event_channel = 0;
		comm_data_block.timer_event_channel = 0;
		comm_data_block.temp_seg_ptrs (*) = null ();
						/* Input and output buffers. */
		comm_data_block.temp_seg_lens (*) = sys_info$max_seg_size;
		comm_data_block.number_of_attachments = 0;
		comm_data_block.input_chars_read = 0;
		comm_data_block.input_buffer_position = 1;
		comm_data_block.flags = "0"b;

		/*** Get temp segments for the input and output buffers. */

		call get_temp_segments_ (MY_NAME, comm_data_block.temp_seg_ptrs, code);
		if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to get input and output buffers", "");

		/*** Get an event channel for use by the timer used by the runout control order. */

		call ipc_$create_ev_chn (comm_data_block.timer_event_channel, code);
		if code ^= 0
		     then do;
			call convert_ipc_code_ (code);
			call Abort_Attach (code, MY_NAME, "Unable to get a timer event channel during attachment.",
			     "");
			end;

		/*** Link it into the chain of comm_data_blocks. */

		if first_cdbp = null ()
		     then first_cdbp = cdbp;
		     else last_cdbp -> comm_data_block.forward_ptr = cdbp;

		last_cdbp = cdbp;
		end;

/* Finish setting up our attach description data. */

	rbf_attach_data.comm_data_ptr = cdbp;

/* If necessary, attach and open the communications IO module we will use. */

	if ^comm_data_block.flags.comm_attached
	     then do;				/* We need to attach. */
		next_io_switch_name = MY_NAME || "." || unique_chars_ (""b);
		next_attach_description = next_io_module || space || next_channel || space || next_attach_options;

		call iox_$attach_name ((next_io_switch_name), comm_data_block.comm_iocbp, (next_attach_description),
		     codeptr (rbf_attach), code);
		if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to attach communications channel", "");

		comm_data_block.flags.comm_attached = "1"b;
		comm_data_block.flags.comm_open = "0"b;
		end;				/* We need to attach. */

	if ^comm_data_block.flags.comm_open
	     then do;				/* We need to open. */
		call iox_$open (comm_data_block.comm_iocbp, Stream_input_output, "0"b, code);
		if code ^= 0 then call Abort_Attach (code, MY_NAME, "Unable to open the communications switch.", "");

		/*** Set initial modes. */

		call iox_$modes (comm_data_block.comm_iocbp, default_modes, (""), code);
		if code ^= 0
		     then call Abort_Attach (code, MY_NAME,
			     "Unable to set initial modes on the communications switch.", "");

		/*** Get the event channel used by the comm module. */

		call iox_$control (comm_data_block.comm_iocbp, "get_event_channel",
		     addr (comm_data_block.comm_event_channel), code);
		if code ^= 0
		     then call Abort_Attach (code, MY_NAME,
			     "Unable to get the event channel for the communications switch.", "");

		comm_data_block.flags.comm_open = "1"b;
		end;				/* We need to open. */

/* Remember that we have attached a device to this channel. */

	comm_data_block.number_of_attachments = comm_data_block.number_of_attachments + 1;

/* Make changes to iocb. */

	mask = "0"b;
	on any_other call Any_Other_Handler ();

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

	iocbp -> iocb.attach_descrip_ptr = addr (rbf_attach_data.attach_description);
	iocbp -> iocb.attach_data_ptr = radp;
	iocbp -> iocb.open = rbf_open;
	iocbp -> iocb.detach_iocb = rbf_detach_iocb;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

rbf_detach_iocb:
     entry (a_iocbp, a_code);

	a_code = 0;
	iocbp = a_iocbp;

/* Make sure that switch is closed and attached. */

	if iocbp -> iocb.attach_descrip_ptr = null
	     then do;
		a_code = error_table_$not_attached;
		return;
		end;

	if iocbp -> iocb.open_descrip_ptr ^= null
	     then do;
		a_code = error_table_$not_closed;
		return;
		end;

	radp = iocbp -> iocb.attach_data_ptr;
	cdbp = rbf_attach_data.comm_data_ptr;

/* Remove this device from the communications data. */

	comm_data_block.number_of_attachments = comm_data_block.number_of_attachments - 1;

	call Attach_Cleanup ();			/* Get rid of everything we should. */

	mask = "0"b;
	on any_other call Any_Other_Handler;

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

	iocbp -> attach_descrip_ptr = null;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

rbf_open:
     entry (a_iocbp, a_open_mode, a_comerr_sw, a_code);

	a_code = 0;
	iocbp = a_iocbp -> iocb.actual_iocb_ptr;

/* Make sure that switch is attached and closed. */

	if iocbp -> iocb.attach_descrip_ptr = null
	     then do;
		a_code = error_table_$not_attached;
		return;
		end;

	if iocbp -> iocb.open_descrip_ptr ^= null
	     then do;
		a_code = error_table_$not_closed;
		return;
		end;

	radp = iocbp -> iocb.attach_data_ptr;

/* Check opening modes. */

	open_mode = a_open_mode;

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

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

	mask = "0"b;
	on any_other call Any_Other_Handler;

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

	if open_mode = Sequential_input | open_mode = Sequential_input_output
	     then iocbp -> iocb.read_record = rbf_read_record;

	if open_mode = Sequential_output | open_mode = Sequential_input_output
	     then iocbp -> iocb.write_record = rbf_write_record;

	iocbp -> iocb.control = rbf_control;
	iocbp -> iocb.modes = rbf_modes;
	iocbp -> iocb.close = rbf_close;
	iocbp -> iocb.detach_iocb = rbf_detach_iocb;
	iocbp -> iocb.open_descrip_ptr = addr (rbf_attach_data.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

rbf_close:
     entry (a_iocbp, a_code);

	a_code = 0;
	iocbp = a_iocbp -> iocb.actual_iocb_ptr;

/* Make sure that switch is attached and open. */

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

	if iocbp -> iocb.open_descrip_ptr = null
	     then do;
		a_code = error_table_$not_open;
		return;
		end;

	mask = "0"b;
	on any_other call Any_Other_Handler;

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

	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = rbf_open;
	iocbp -> iocb.detach_iocb = rbf_detach_iocb;

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

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

rbf_read_record:
     entry (a_iocbp, a_bufferp, a_buffer_len, a_record_len, a_code);

dcl  compression_count	       fixed bin;
dcl  current_char		       char (1);
dcl  end_of_record		       bit (1);
dcl  error_code		       fixed bin (35);
dcl  read_record_state	       fixed bin;
dcl  user_buffer_len	       fixed bin (21);


	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_record_len = 0;
	a_code = 0;

	radp = iocbp -> iocb.attach_data_ptr;
	cdbp = rbf_attach_data.comm_data_ptr;

	if rbf_attach_data.device_type ^= TELEPRINTER_DEVICE & rbf_attach_data.device_type ^= READER_DEVICE
	     then do;				/* can't read from all devices */
		a_code = error_table_$invalid_read;
		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 = a_bufferp;

	user_buffer_len = a_buffer_len - divide (length (unspec (terminal_io_record.header)), 9, 21);

	if user_buffer_len <= 0
	     then do;
		a_code = error_table_$smallarg;
		return;
		end;

	terminal_io_record_data_chars_varying_max_len = user_buffer_len;

/* Initialize the return structure. */

	terminal_io_record.version = terminal_io_record_version_1;
	terminal_io_record.device_type = 0;
	terminal_io_record.slew_type = SLEW_BY_COUNT;
	terminal_io_record.slew_count = 1;
	terminal_io_record.flags = "0"b;
	terminal_io_record.element_size = 9;
	terminal_io_record.n_elements = 0;		/* Initially the null string. */

/* Check to see if we have to tell the L6 that he can send, this is also done in the read_status order. */

	if comm_data_block.flags.we_just_wrote
	     then do;				/* Tell him he can send. */
		call Check_Write_Status (code);
		if code ^= 0 then goto READ_ERROR;

		call Send_EOM (code);
		if code ^= 0 then goto READ_ERROR;

		call Check_Write_Status (code);
		if code ^= 0 then goto READ_ERROR;

		comm_data_block.flags.we_just_wrote = "0"b;
		end;				/* Tell him he can send. */


/* Read in the record, one character at a time since there may be compressed text. */

	read_record_state = 1;
	error_code = 0;
	end_of_record = "0"b;

	do while (^end_of_record);

	     if comm_data_block.input_buffer_position > comm_data_block.input_chars_read
		then do;				/* We need some more data. */
		     call l6_tran_util_$get_chars (comm_data_block.comm_iocbp, input_buffer_ptr, input_buffer_len,
			comm_data_block.input_chars_read, code);
		     if code ^= error_table_$short_record & code ^= 0 then goto READ_ERROR;

		     comm_data_block.input_buffer_position = 1;
		     end;				/* We need some more data. */

	     current_char = substr (input_buffer, comm_data_block.input_buffer_position, 1);

	     goto RECORD_PARSER (read_record_state);

RECORD_PARSER (1):					/* Handle the media code. */
	     if current_char = RBF.media_codes.bcd_input_mc then terminal_io_record.device_type = READER_DEVICE;

	     else if current_char = RBF.media_codes.bin_input_mc
		then do;
		     terminal_io_record.device_type = READER_DEVICE;
		     terminal_io_record.flags.binary = "1"b;
		     end;

	     else if current_char = RBF.media_codes.teleprinter_mc
		then terminal_io_record.device_type = TELEPRINTER_DEVICE;

	     else do;				/* Not an input record but read it anyway. */
		terminal_io_record.device_type = 0;
		error_code = error_table_$improper_data_format;
		end;

	     comm_data_block.input_buffer_position = comm_data_block.input_buffer_position + 1;
	     read_record_state = 2;

	     goto NEXT_STATE;

RECORD_PARSER (2):					/* Handle normal char, compression char, or EOR char. */
	     if current_char = RBF.char_codes.CC then read_record_state = 3;
						/* Decompress the previous char. */

	     else if current_char = RBF.char_codes.RS then end_of_record = "1"b;
						/* We are done. */

	     else do;				/* A normal character. */
		if length (terminal_io_record_data_chars_varying) < user_buffer_len
		     then terminal_io_record_data_chars_varying =
			     terminal_io_record_data_chars_varying || current_char;
		     else error_code = error_table_$long_record;
						/* Must throw it away. */

		read_record_state = 2;
		end;

	     comm_data_block.input_buffer_position = comm_data_block.input_buffer_position + 1;

	     goto NEXT_STATE;

RECORD_PARSER (3):					/* Handle the compression count character. */
	     compression_count = index (bcd_equiv_string, current_char);

	     if compression_count <= 1
		then do;				/* Min is 2, max is 63. */
		     if current_char < substr (bcd_equiv_string, 2, 1)
			then compression_count = 2;
			else compression_count = 63;
		     end;

	     if user_buffer_len - length (terminal_io_record_data_chars_varying) < compression_count
		then do;				/* Not enough room in the user buffer. */
		     error_code = error_table_$long_record;
		     compression_count = user_buffer_len - length (terminal_io_record_data_chars_varying);

		     if compression_count <= 0 then compression_count = 0;
		     end;

	     terminal_io_record_data_chars_varying =
		terminal_io_record_data_chars_varying
		||
		copy (
		substr (terminal_io_record_data_chars_varying, length (terminal_io_record_data_chars_varying), 1),
		compression_count);

	     comm_data_block.input_buffer_position = comm_data_block.input_buffer_position + 1;
	     read_record_state = 2;

	     goto NEXT_STATE;

NEXT_STATE:
	end;					/* Loop through the record. */

/* Finally, do the translation and we are done. */

	terminal_io_record_data_chars_varying =
	     translate (terminal_io_record_data_chars_varying, rbf_attach_data.translations.input, collate9 ());

/* Check for a $*$ card, and if it is one, then give back a zero length record. */

	if length (terminal_io_record_data_chars_varying) >= 3
	     then if substr (terminal_io_record_data_chars_varying, 1, 3) = "$*$"
		     then terminal_io_record.n_elements = 0;

/* Check for an end of file record from the card reader and return the right code. */

	if terminal_io_record_data_chars_varying = "++EOF" | terminal_io_record_data_chars_varying = "++eof"
	     then error_code = error_table_$eof_record;

	a_record_len = 4 * currentsize (terminal_io_record);
	a_code = error_code;

	return;

READ_ERROR:
	a_code = code;

	return;

rbf_write_record:
     entry (a_iocbp, a_recordp, a_record_len, a_code);

dcl  media_code		       char (1);
dcl  rep_count		       fixed bin;
dcl  slew_char		       char (1);
dcl  slew_count		       fixed bin (18);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;

	radp = iocbp -> iocb.attach_data_ptr;
	cdbp = rbf_attach_data.comm_data_ptr;
	terminal_io_record_ptr = a_recordp;

/* Check arguments for inconsistencies. */

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

	if terminal_io_record.preslew
	     then do;
		a_code = error_table_$improper_data_format;
		return;
		end;

/* Set media code and slew character. */

	slew_count = 0;

	if terminal_io_record.device_type = TELEPRINTER_DEVICE
	     then do;
		media_code = RBF.media_codes.teleprinter_mc;
		slew_char = CR;
		end;

	else if terminal_io_record.device_type = PRINTER_DEVICE
	     then do;
		media_code = RBF.media_codes.printer_mc;

		if terminal_io_record.slew_type = SLEW_BY_COUNT
		     then do;
			slew_count = terminal_io_record.slew_count;

			if slew_count < lbound (slew_by_count_char, 1)
			     then do;
				a_code = error_table_$improper_data_format;
				return;
				end;

			if slew_count > hbound (slew_by_count_char, 1)
			     then do;
				slew_char = slew_by_count_char (hbound (slew_by_count_char, 1));
						/* Do the most we can. */
				slew_count = slew_count - hbound (slew_by_count_char, 1);
						/* Figure what is left. */
				end;

			     else do;
				slew_char = slew_by_count_char (slew_count);
				slew_count = 0;	/* Nothing left. */
				end;
			end;

		else if terminal_io_record.slew_type = SLEW_TO_TOP_OF_PAGE then slew_char = space;

		else if terminal_io_record.slew_type = SLEW_TO_INSIDE_PAGE then slew_char = space;

		else if terminal_io_record.slew_type = SLEW_TO_OUTSIDE_PAGE then slew_char = space;

		else if terminal_io_record.slew_type = SLEW_TO_CHANNEL then slew_char = space;

		else slew_char = "1";		/* All undefined slew types default to this */
		end;

	else if terminal_io_record.device_type = PUNCH_DEVICE
	     then do;
		if terminal_io_record.flags.binary
		     then media_code = RBF.media_codes.punch_bin_mc;
		     else media_code = RBF.media_codes.punch_bcd_mc;
		end;

	else media_code = "";

/* If the data is binary, turn it into 6 bit chunks, otherwise, translate it. */

	if (terminal_io_record.binary & terminal_io_record.element_size ^= 1)
	     | (^terminal_io_record.binary & terminal_io_record.element_size ^= 9)
	     then do;
		a_code = error_table_$improper_data_format;
		return;
		end;

	if terminal_io_record.binary
	     then do;
		terminal_io_record.n_elements = divide (terminal_io_record.n_elements + 5, 6, 18);
		terminal_io_record.element_size = 6;

		substr (output_buffer, 1, 1) = media_code;

		do i = 1 to terminal_io_record.n_elements;
		     substr (output_buffer, i + 1, 1) = bcd_equiv (bin (terminal_io_record.data.bits (i), 6));
		end;
		end;

	     else do;
		substr (output_buffer, 1, 1) = media_code;
		substr (output_buffer, 2, terminal_io_record.n_elements) =
		     translate (terminal_io_record_data_chars, rbf_attach_data.translations.output, collate9 ());
		end;

	output_chars_to_write = terminal_io_record.n_elements + 1;
						/* Add the media_code length. */

/* Perform data compression (except on teleprinter output). */

	if rbf_attach_data.device_type ^= TELEPRINTER_DEVICE
	     then do;
		i = 2;

		do while (i <= output_chars_to_write);	/* Do this since we may modify the counters. */

		     rep_count =
			verify (substr (output_buffer, i, output_chars_to_write - i + 1),
			substr (output_buffer, i, 1)) - 1;

		     if rep_count < 0 then rep_count = output_chars_to_write - i + 1;
						/* everything matched. */

		     if rep_count > 64 then rep_count = 64;
						/* This is the limit. */

		     if rep_count <= 3
			then i = i + 1;		/* no compression needed. */

			else do;			/* compress this one. */
			     substr (output_buffer, i + 1, 1) = RBF.char_codes.CC;
			     substr (output_buffer, i + 2, 1) = bcd_equiv (rep_count - 1);

			     i = i + 3;
			     output_chars_to_write = output_chars_to_write - rep_count + 3;

			     substr (output_buffer, i, output_chars_to_write - i + 1) =
				substr (output_buffer, i + rep_count - 3, output_chars_to_write - i + 1);
						/* Shift the end of the data over the compressed chars. */
			     end;
		end;				/* Compression loop. */
		end;				/* Perform data compression. */

/* Now add slew control if necessary, and add the final record separator character. */

	if media_code = RBF.media_codes.printer_mc | media_code = RBF.media_codes.teleprinter_mc
	     then do;				/* Handle devices that slew. */
		substr (output_buffer, output_chars_to_write + 1, 2) = slew_char || RBF.char_codes.RS;
		output_chars_to_write = output_chars_to_write + 2;

		if slew_count > 0
		     then do;			/* Send null records to finish slewing. */
			do while (slew_count > hbound (slew_by_count_char, 1));
			     substr (output_buffer, output_chars_to_write + 1, 3) =
				media_code || slew_by_count_char (hbound (slew_by_count_char, 1))
				|| RBF.char_codes.RS;
			     output_chars_to_write = output_chars_to_write + 3;
			     slew_count = slew_count - hbound (slew_by_count_char, 1);
			end;

			if slew_count > 0
			     then do;		/* Get the last bit. */
				substr (output_buffer, output_chars_to_write + 1, 3) =
				     media_code || slew_by_count_char (slew_count) || RBF.char_codes.RS;
				output_chars_to_write = output_chars_to_write + 3;
				end;
			end;			/* Send null records to finish slewing. */
		end;				/* Handle devices that slew. */

	     else do;
		substr (output_buffer, output_chars_to_write + 1, 1) = RBF.char_codes.RS;
		output_chars_to_write = output_chars_to_write + 1;
		end;

/* Transmit record to comm_io_module io switch. */

	call l6_tran_util_$put_chars (comm_data_block.comm_iocbp, output_buffer_ptr, output_chars_to_write, a_code);

/* Set a flag so the control and read_record entries can send the $*$EOM record. */

	if rbf_attach_data.device_type = TELEPRINTER_DEVICE then comm_data_block.flags.we_just_wrote = "1"b;

	return;

rbf_control:
     entry (a_iocbp, a_order, a_infop, a_code);


	a_code = 0;

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;

/* Make sure the switch is attached and open. */

	if iocbp -> iocb.attach_descrip_ptr = null
	     then do;
		a_code = error_table_$not_attached;
		return;
		end;

	if iocbp -> iocb.open_descrip_ptr = null
	     then do;
		a_code = error_table_$not_open;
		return;
		end;

	radp = iocbp -> iocb.attach_data_ptr;
	cdbp = rbf_attach_data.comm_data_ptr;

	if a_order = "end_write_mode"
	     then do;				/* Handle end_write_mode. */
		call Check_Write_Status (code);
		if code ^= 0 then goto CONTROL_ERROR;

		call Send_EOM (code);
		if code ^= 0 then goto CONTROL_ERROR;

		call Check_Write_Status (code);
		if code ^= 0 then goto CONTROL_ERROR;
		end;				/* Handle end_write_mode. */

	else if a_order = "runout"
	     then do;				/* Handle runout. */
		call Check_Write_Status (code);
		if code ^= 0 then goto CONTROL_ERROR;
		end;				/* Handle runout. */

	else if a_order = "read_status"
	     then do;				/* Handle read_status. */
		tty_read_status_info_ptr = a_infop;

		if tty_read_status_info_ptr = null ()
		     then do;
			a_code = error_table_$null_info_ptr;
			return;
			end;

		if comm_data_block.flags.we_just_wrote
		     then do;			/* Tell him he can send. */
			call Check_Write_Status (code);
			if code ^= 0 then goto CONTROL_ERROR;

			call Send_EOM (code);
			if code ^= 0 then goto CONTROL_ERROR;

			call Check_Write_Status (code);
			if code ^= 0 then goto CONTROL_ERROR;

			comm_data_block.flags.we_just_wrote = "0"b;
			end;			/* Tell him he can send. */

/*
   We will assume that if we have any input then it is at least one record,
   even if it is only a $*$ card.  The same is true if tty_ has some input
   that we have'nt read yet.  Therefore, if we have any input, then our caller
   will not go blocked if he calls read_record.  If we don't then tty_ will
   return the right results.  That is, if it has some input, then we won't go
   blocked when we try to read a complete record, and if it does not have
   input, then it will send a wakeup when it gets some.
*/

		if comm_data_block.input_buffer_position <= comm_data_block.input_chars_read
		     then tty_read_status_info.input_pending = "1"b;
		     else tty_read_status_info.input_pending = "0"b;

		/*** If we have input then just get the event channel else let tty_ do the work. */

		if tty_read_status_info.input_pending
		     then call iox_$control (comm_data_block.comm_iocbp, "get_event_channel",
			     addr (tty_read_status_info.event_channel), a_code);
		     else call iox_$control (comm_data_block.comm_iocbp, "read_status", a_infop, a_code);
		end;				/* Handle read_status. */

	else if a_order = "select_device" | a_order = "reset" | a_order = "binary_punch" then ;
						/* Ignore, done by magic in terminal_io_record. */

/* Pass all other control orders on to the communications switch. */

	else call iox_$control (comm_data_block.comm_iocbp, a_order, a_infop, a_code);

	return;

CONTROL_ERROR:
	a_code = code;

	return;

rbf_modes:
     entry (a_iocbp, a_new_modes, a_old_modes, a_code);

	a_code = 0;
	a_old_modes = "";

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;

/* Make sure the switch is attached and open. */

	if iocbp -> iocb.attach_descrip_ptr = null
	     then do;
		a_code = error_table_$not_attached;
		return;
		end;

	if iocbp -> iocb.open_descrip_ptr = null
	     then do;
		a_code = error_table_$not_open;
		return;
		end;

	radp = iocbp -> iocb.attach_data_ptr;

	call mode_string_$parse (a_new_modes, areap, mode_string_info_ptr, a_code);
	if a_code ^= 0 then return;

	if mode_string_info.version ^= mode_string_info_version_2
	     then do;
		a_code = error_table_$unimplemented_version;
		return;
		end;

	do i = lbound (mode_string_info.modes, 1) to hbound (mode_string_info.modes, 1);
	     if mode_string_info.modes (i).mode_name = "rawi" | mode_string_info.modes (i).mode_name = "rawo"
		| mode_string_info.modes (i).mode_name = "8bit"
		then do;
		     if ^(mode_string_info.modes (i).boolean_valuep & mode_string_info.modes (i).boolean_value)
			then do;
			     a_code = error_table_$bad_mode_value;
			     return;
			     end;
		     end;
		else do;
		     a_code = error_table_$bad_mode;
		     return;
		     end;
	end;

	a_old_modes = rbf_attach_data.modes;
	rbf_attach_data.modes = a_new_modes;

	return;

/* Internal routines */

Get_Option_Arg:
     proc (idx) returns (char (*) var);

dcl  idx			       fixed bin parameter;

	idx = idx + 1;

	if idx > hbound (a_option, 1)
	     then call Abort_Attach (error_table_$noarg, MY_NAME, "No argument after ^a", (a_option (idx - 1)));

	my_attach_description = my_attach_description || space || a_option (idx);

	return (a_option (idx));

     end Get_Option_Arg;

Any_Other_Handler:
     proc ();

	if mask then call hcs_$reset_ips_mask (mask, mask);

	mask = "0"b;

	call continue_to_signal_ ((0));

     end Any_Other_Handler;

Attach_Cleanup:
     proc ();

dcl  code			       fixed bin (35);


	if radp ^= null then free rbf_attach_data in (based_area);

	if cdbp ^= null ()
	     then do;
		if comm_data_block.number_of_attachments = 0
		     then do;
			if input_buffer_ptr ^= null () | output_buffer_ptr ^= null ()
			     then call release_temp_segments_ (MY_NAME, comm_data_block.temp_seg_ptrs, code);

			if comm_data_block.comm_iocbp ^= null ()
			     then do;
				call iox_$close (comm_data_block.comm_iocbp, code);
				call iox_$detach_iocb (comm_data_block.comm_iocbp, code);
				call iox_$destroy_iocb (comm_data_block.comm_iocbp, code);
				end;

			if comm_data_block.timer_event_channel ^= 0
			     then call ipc_$delete_ev_chn (comm_data_block.timer_event_channel, code);

			call Free_Comm_Data_Block ();
			end;
		end;

	return;

     end Attach_Cleanup;

Abort_Attach:
     proc (code, prog_name, control_str, arg_value);

dcl  code			       fixed bin (35) parameter;
dcl  prog_name		       char (*) parameter;
dcl  control_str		       char (*) parameter;
dcl  arg_value		       char (*) parameter;

	call Attach_Cleanup;

	call Abort (code, prog_name, control_str, arg_value);

     end Abort_Attach;

Abort:
     proc (code, prog_name, control_str, arg_value);

dcl  code			       fixed bin (35) parameter;
dcl  prog_name		       char (*) parameter;
dcl  control_str		       char (*) parameter;
dcl  arg_value		       char (*) parameter;


	if comerr_sw then call com_err_ (code, prog_name, control_str, arg_value);
	a_code = code;

	go to ERROR_EXIT;

     end Abort;

Check_Write_Status:
     proc (code);

/*
   This routine checks the write_status and loops until the write is complete.
   The timer is needed since write_status does not guarantee to send a
   wakeup if output_pending is set.
*/

dcl  code			       fixed bin (35) parameter;

dcl  1 event_info		       aligned,
       2 channel_id		       fixed bin (71),
       2 message		       fixed bin (71),
       2 sender		       bit (36),
       2 origin,
         3 dev_signal	       bit (18) unaligned,
         3 ring		       bit (18) unaligned,
       2 channel_index	       fixed bin;

dcl  1 wait_list		       aligned,
       2 nchan		       fixed bin,
       2 pad		       fixed bin,
       2 channel_id		       (2) fixed bin (71);

dcl  1 write_status_info	       aligned,
       2 ev_chan		       fixed bin (71),
       2 output_pending	       bit (1);

/* Set up a wait list for blocking in write_status. */

	wait_list.nchan = 2;
	wait_list.pad = 0;
	wait_list.channel_id (1) = comm_data_block.comm_event_channel;
	wait_list.channel_id (2) = comm_data_block.timer_event_channel;

	call iox_$control (comm_data_block.comm_iocbp, "write_status", addr (write_status_info), code);
	if code ^= 0 then return;

	do while (write_status_info.output_pending & write_status_info.ev_chan ^= 0);

	     call timer_manager_$alarm_wakeup (1, REL_SECONDS, comm_data_block.timer_event_channel);

	     call ipc_$block (addr (wait_list), addr (event_info), code);
	     if code ^= 0
		then do;
		     call convert_ipc_code_ (code);
		     return;
		     end;

	     call timer_manager_$reset_alarm_wakeup (comm_data_block.timer_event_channel);

	     call ipc_$drain_chn (comm_data_block.timer_event_channel, code);
	     if code ^= 0
		then do;
		     call convert_ipc_code_ (code);
		     return;
		     end;

	     call iox_$control (comm_data_block.comm_iocbp, "write_status", addr (write_status_info), code);
	     if code ^= 0 then return;
	end;					/* Write status loop. */

	return;

     end Check_Write_Status;

Free_Comm_Data_Block:
     proc ();

/* Unlinks and frees what cdbp points to. */

	if comm_data_block.backward_ptr = null ()
	     then first_cdbp = comm_data_block.forward_ptr;
						/* It was the head of the chain. */
	     else comm_data_block.backward_ptr -> comm_data_block.forward_ptr = comm_data_block.forward_ptr;

	if comm_data_block.forward_ptr = null ()
	     then last_cdbp = comm_data_block.backward_ptr;
						/* It was the tail of the chain. */
	     else comm_data_block.forward_ptr -> comm_data_block.backward_ptr = comm_data_block.backward_ptr;

	free comm_data_block in (based_area);
	cdbp = null ();

	return;

     end Free_Comm_Data_Block;

Send_EOM:
     proc (P_code);

dcl  P_code		       fixed bin (35) parameter;

	output_chars_to_write = length ("$*$EOM" || RBF.char_codes.RS);
	substr (output_buffer, 1, output_chars_to_write) = "$*$EOM" || RBF.char_codes.RS;

	call l6_tran_util_$put_chars (comm_data_block.comm_iocbp, output_buffer_ptr, output_chars_to_write, P_code);


	return;

     end Send_EOM;

Set_Translation:
     proc (translate_table, trans_strucp);

dcl  translate_table	       char (512) parameter;
dcl  trans_strucp		       ptr parameter;

dcl  translate_string_len	       fixed bin (21);
dcl  translate_stringp	       ptr;
dcl  translate_string	       char (translate_string_len) based (translate_stringp);


	if trans_strucp = null
	     then translate_table = collate9 ();

	     else do;
		translate_stringp = addr (trans_strucp -> cv_trans_struc.cv_trans.value);
		translate_string_len = dimension (trans_strucp -> cv_trans_struc.cv_trans.value, 1);

		translate_table = translate_string;

		if length (translate_table) > translate_string_len
		     then substr (translate_table, translate_string_len + 1) =
			     copy ("", length (translate_table) - translate_string_len);
		end;

	return;

     end Set_Translation;

%include iox_dcls;

%include iocb;

%include iox_modes;

%include mode_string_info;

%include area_info;

%include terminal_type_data;

%include tty_convert;

%include tty_read_status_info;

%include terminal_io_record;

debug_on:
     entry ();

	debug_flag = "1"b;

	return;


debug_off:
     entry ();

	debug_flag = "0"b;

	return;

     end rbf_;



		    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
