


		    close_file.pl1                  04/18/84  1708.3r w 04/18/84  1556.1       32085


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

/* modified 03/21/84 by Melanie Weaver to close pascal files */

/* format: style3,^indnoniterdo */
close_file:
cf:
     proc;
dcl	arg		char (cnt) based (arg_ptr) unal;
dcl	(arg_count, cnt, i) fixed bin (17);
dcl	arg_ptr		ptr;
dcl	code		fixed bin (35);
dcl	com_err_		entry options (variable);
dcl	(convert, substr, verify)
			builtin;
dcl	cu_$arg_count	entry (fixed bin),
	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	(
	error_table_$noarg,
	error_table_$badopt,
	error_table_$no_file
	)		ext static fixed bin (35);
dcl	f_file		fixed bin;
dcl	(fortran_code, pl1_code, pascal_code)
			fixed bin (35);
dcl	fortran_io_$close_file
			entry (fixed bin, fixed bin (35));
dcl	ft_file		char (2);
dcl	linkage_error	condition;
dcl	msg		char (80);
dcl	plio2_$close_all_	entry,
	plio2_$close_by_name_sys_
			entry (char (*) unal, fixed bin (35));
dcl	pascal_io_$close_all
			entry;
dcl	pascal_io_$close_by_name
			entry (char (*), fixed bin (35));

	call cu_$arg_count (arg_count);
	if arg_count = 0
	then do;					/* needs args */
	     code = error_table_$noarg;
	     msg = "argument must be -all, or 1 or more file names.";
	     go to error_return;
	end;

	else do i = 1 to arg_count;
		msg = "";
		fortran_code, pl1_code, pascal_code = 1;
		call cu_$arg_ptr (i, arg_ptr, cnt, code);
		if code ^= 0
		then do;
error_return:
		     call com_err_ (code, "close_file", "^a", msg);
		     return;
		end;
		if substr (arg, 1, 1) = "-"
		then if arg ^= "-all" & arg ^= "-a"
		     then do;			/* bad option */
			code = error_table_$badopt;
			msg = arg || ".";
			go to error_return;
		     end;

		if arg = "-all" | arg = "-a"
		then do;				/* close all of them */
		     on linkage_error
			begin;
			     fortran_code = 1;
			     go to SKIP_FORTRAN_ALL;
			end;
		     call fortran_io_$close_file (-1, fortran_code);
SKIP_FORTRAN_ALL:
		     revert linkage_error;

		     on linkage_error go to SKIP_PASCAL_ALL;
		     call pascal_io_$close_all;
SKIP_PASCAL_ALL:
		     revert linkage_error;

		     call plio2_$close_all_;		/* close all pl1 files */
		     return;			/* all done */
		end;
		else do;
		     if substr (arg, 1, 4) = "file"
		     then do;			/* might be a fortran file */
			ft_file = substr (arg, 5, 2);
			if ft_file ^= "00"
			then if verify (ft_file, "1234567890") = 0
			     then do;
				f_file = convert (f_file, ft_file);
				on linkage_error
				     begin;
					fortran_code = 1;
					go to SKIP_FORTRAN_ONE_FILE;
				     end;
				call fortran_io_$close_file (f_file, fortran_code);
SKIP_FORTRAN_ONE_FILE:
				revert linkage_error;
			     end;
			     else ;
			else ;
		     end;

		     on linkage_error
			begin;
			     pascal_code = 1;
			     go to SKIP_PASCAL_ONE_FILE;
			end;
		     call pascal_io_$close_by_name ((arg), pascal_code);
SKIP_PASCAL_ONE_FILE:
		     revert linkage_error;

		     call plio2_$close_by_name_sys_ ((arg), pl1_code);
		end;
		if pl1_code + fortran_code + pascal_code > 2
		then call com_err_ (error_table_$no_file, "close_file", "^a", arg);
	     end;
	return;
     end close_file;
   



		    copy_cards.pl1                  11/04/82  2006.8rew 11/04/82  1631.3       69111


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

copy_cards: ccd: proc;
						/* Written by S. Vestal */
						/* modified by J. Stern 7/9/75 */
dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_authorization_ entry returns (bit (72) aligned);
dcl  get_group_id_ entry returns (char (32));
dcl  pool_manager_$find_pool entry (char (*), bit (72) aligned, char (*), char (*), fixed bin (35));
dcl  check_star_name_$entry entry (char (*), fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin,
     ptr, ptr, fixed bin (35));
dcl (ioa_, com_err_) entry options (variable);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35));
dcl  copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
dcl  error_table_$noentry fixed bin (35) ext;
dcl  error_table_$nomatch fixed bin (35) ext;
dcl  error_table_$entlong fixed bin (35) ext;
dcl  error_table_$bad_equal_name fixed bin (35) ext;
dcl  error_table_$longeql fixed bin (35) ext;
dcl (addr, substr, before, null, fixed, index, verify, reverse) builtin;
dcl  id char (10) int static init ("copy_cards");
dcl  latest bit (1);
dcl  warn_flag bit (1) init ("0"b);
dcl  code fixed bin (35);				/*  error return code */
dcl  equal bit (1) init ("0"b);			/*  on if equal(=) in path */
dcl  star bit (1) init ("0"b);			/*  on if stars in path */
dcl  arg char (argl) based (argp);
dcl  argp ptr;
dcl  argl fixed bin;
dcl  ename char (32);
dcl  deck_name char (32);				/*  search name for card decks */
dcl  caller char (22);				/*  Person name of the caller */
dcl  sysdir char (168) int static init ("System_Card_Pool");
dcl  caller_auth bit (72) aligned;			/*  callers authorization */
dcl  pool_path char (168);				/*  pathname of the card pool */
dcl  areap ptr;					/*  area pointer */
dcl  system_area area (65560) based (areap);		/*  area overlay */
dcl  ecount fixed bin;				/* entry count */
dcl  eptr ptr init (null);				/*  pointer to entry structure */
dcl  nptr ptr init (null);				/*  pointer to name array */
dcl  names (200) char (32) based (nptr);		/*  name array */
dcl  new_deck_dirname char (168);			/*  directory portion of pathname for new_deck */
dcl  new_deck_ename char (32);			/*  name of new deck */
dcl  dir char (168);				/* directory name used in error message */
dcl  ent char (32);					/* entry name used in error message */
dcl  nind fixed bin;				/*  name index */
dcl  new_ename char (32);				/*  entry name */
dcl  suffix char (4) ;				/* suffix of ename */
dcl  prefix char (32);
dcl  errsw bit (1) ;				/*  error switch */
dcl (i, j) fixed bin;				/*  loop index */
dcl 1 entries (100) based (eptr) aligned,
    2 type bit (2) unal,
    2 nname bit (16) unal,
    2 nindex bit (18) unal;
dcl  cleanup condition;


	if cu_$arg_count () = 0 then do;
	     call ioa_ ("^a: Usage: ^a deck_name [newdeck_name] ", id, id);
	     return;
	end;
	new_deck_ename = "==";
	new_deck_dirname = get_wdir_ ();
	latest = "0"b;
	i = 1;
	do while (i <= cu_$arg_count ());
	     call cu_$arg_ptr (i, argp, argl, code);
	     if code ^= 0 then goto error;
	     if i = 1 then deck_name = arg;
	     else if arg = "-latest" then latest = "1"b;
	     else do;
		call expand_pathname_ (arg, new_deck_dirname, new_deck_ename, code);
		if code ^= 0 then goto error;
	     end;
	     i = i + 1;
	end;
	call check_star_name_$entry (deck_name, code);	/* check legality of starname */
	if code > 2 then do;			/*  illegal */
	     call com_err_ (code, id, deck_name);
	     return;
	end;
	if code > 0 then				/* deck_name contains stars */
	     if length (rtrim (deck_name)) >= 2 then
		if substr (deck_name, length (rtrim (deck_name))-1, 2) = "**" then /* deck_name ends in "**" */
		     go to get_auth;
	substr (deck_name, length (rtrim (deck_name)) + 1, 2) = ".*";
get_auth:
	caller = before (get_group_id_ (), ".");	/*  get the callers name and level */
	caller_auth = get_authorization_ ();
	call pool_manager_$find_pool (sysdir, caller_auth, caller, pool_path, code);
	if code ^= 0 then
	     if code = error_table_$noentry then	/* no pool, cards probably not read yet */
		go to not_found;			/* treat like pool exists but deck missing */
	     else do;				/* uh oh */
		call com_err_ (code, id, "Cannot find user card pool.");
		return;
	     end;
	areap = get_system_free_area_ ();
	on cleanup call clean_up;
	call hcs_$star_ ((pool_path), (deck_name), 2, areap, ecount, eptr, nptr, code);
	if code ^= 0 then				/*  anything in the caller's pool */
	     if code = error_table_$nomatch then do;
not_found:	call com_err_ (0, id, "^a not found in card pool.", substr (deck_name, 1, argl));
		return;
	     end;
	     else do;
		call com_err_ (code, id, "^a>^a", pool_path, deck_name);
		return;
	     end;
	j = 0;
	do i = 1 to ecount;				/*  look at every entry */
	     nind = fixed (eptr -> entries (i).nindex, 18); /*  build the name */
	     ename = nptr -> names (nind);
	     suffix = reverse (before (reverse (ename), "."));
	     prefix = reverse (after (reverse (ename), ".")); /* erase suffix to compute equal reverse(ename) */
	     call get_equal_name_ (prefix, new_deck_ename, new_ename, code); /*  build an equal name for it */
	     if code ^= 0 then
		if code = error_table_$bad_equal_name then do;
		     call com_err_ (code, id, new_deck_ename);
		     go to finish;
		end;
		else do;
long_equal:	     call com_err_ (code, id, "converting ^a to ^a", ename, new_deck_ename);
		     go to end_loop;
		end;
	     if suffix ^= "0" then do;		/* must have been a namedup during card input */
		if length (rtrim (new_ename)) + length (rtrim (suffix)) + 1 > 32 then goto long_equal;
		new_ename = substr (new_ename, 1, length (rtrim (new_ename))) || "." || suffix;
		warn_flag = "1"b;
	     end;
	     call copy_seg_ (pool_path, ename, new_deck_dirname, new_ename, "copy_cards", errsw, code); /*  copy the segment */
	     if code ^= 0 then do;
		if ^errsw then do;			/* problem with source seg */
		     dir = pool_path;
		     ent = ename;
		end;
		else do;				/* problem with target seg */
		     dir = new_deck_dirname;
		     ent = new_ename;
		end;
		call com_err_ (code, id, "^a>^a", dir, ent);
		go to end_loop;
	     end;
	     j = j+1;				/*  increment the copy count */
end_loop:	end;
	if warn_flag then
	     call com_err_ (0, id, "Multiple decks of the same name may have been entered. Check for numbered copies.");
	call ioa_ ("^d card decks copied.", j);		/*  inform the caller and exit */
finish:	call clean_up;
	return;
test:	entry (dirname);				/*  test entry point for defining pool pathname */
dcl  dirname char (*);
	sysdir = dirname;				/*  should be the only argument */
	return;

clean_up:	proc;					/*  trap to cleanup */
	     if eptr ^= null then free entries in (system_area); /*  free system storage */
	     if nptr ^= null then free names in (system_area);
	     return;				/*  and return */
	end;
error:	if code ^= 0 then call com_err_ (code, id);
	call clean_up;
	return;
     end copy_cards;
 



		    copy_file.pl1                   02/06/84  1105.5r   02/06/84  1101.5      266841


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


cpf: copy_file: procedure;

/*
   This command copies records from a structured input file to
   a structured output file.  If the input file is keyed, the
   keys may or may not be copied.  The input file may be copied
   either partially, or in its entirety.

   0) Created 01/13/76 by Ross E. Klinger
   1) Modified 10/4/83 by Charles Spitzer: let it copy keyed files with invalid descriptors
*/
	

/* DECLARATIONS */


/* control argument variables */
dcl  arg char (argL) based (argP),			/* argument string */
     argL fixed bin,				/* length of an argument string */
     argN fixed bin,				/* number of arguments */
     argP ptr,					/* ptr to an argument string */
     argX fixed bin,				/* index of argument currently being processed */
     max_argL fixed bin,				/* maximum length of an argument descriptor */
     numeric_arg fixed bin (35);			/* holds numeric value of an argument descriptor */


/* control argument validation variables */
dcl  input_type fixed bin,				/* -1 - undefined; 0 - I/O switch;  1 - attach description */
     output_type fixed bin,				/* -1 - undefined; 0 - I/O switch;  1 - attach description */
     copy_keys bit (1) aligned,			/* "0"b - no;  "1"b - yes */
     begin_cntl fixed bin,				/* -1 - undefined; 0 - from_idx;  1 - start */
     end_cntl fixed bin,				/* -1 - undefined; 0 - to;  1 - stop;  2 - count;  3 - all */
     msg_cntl fixed bin;				/* -1 - undefined; 0 - brief;  1 - long */


/* control argument validation types */
dcl  undefined fixed bin internal static options (constant) init (-1),
     isw fixed bin internal static options (constant) init (0),
    (osw, from_idx, to_idx, brief) fixed bin defined (isw),
     ids fixed bin internal static options (constant) init (1),
    (ods, start, stop, long) fixed bin defined (ids),
     count fixed bin internal static options (constant) init (2),
     all fixed bin internal static options (constant) init (3),
     yes bit (1) aligned internal static options (constant) init ("1"b),
     no bit (1) aligned internal static options (constant) init ("0"b);


/* control argument descriptor values */
dcl  input_switchname char (32),			/* input switch name */
     input_description char (256),			/* input attach description */
     output_switchname char (32),			/* output switch name */
     output_description char (256),			/* output attach description */
     from_idx_position fixed bin (35),			/* record position at which to begin copy */
     start_key char (256) varying,			/* record key at which to begin copying */
     to_idx_position fixed bin (35),			/* record position after which to stop copy */
     stop_key char (256) varying,			/* record key after which to stop copy */
     count_value fixed bin (35);			/* record count after which to stop copy */
	

/* I/O system variables */
dcl  input_iocbP ptr,				/* pointer to input I/O control block */
     input_open_mode fixed bin,			/* 4 - sequential_input :: 8 - keyed_sequential_input */
     output_iocbP ptr,				/* pointer to output I/O control block */
     output_open_mode fixed bin;			/* 5 - sequential_output :: 9 - keyed_sequential_output */


/* opening mode constants */
dcl  sequential_input fixed bin internal static options (constant) init (4),
     sequential_output fixed bin internal static options (constant) init (5),
     keyed_sequential_input fixed bin internal static options (constant) init (8),
     keyed_sequential_output fixed bin internal static options (constant) init (9);


/* I/O cleanup switches */
dcl  close_input bit (1) aligned,			/* close input switch before exiting */
     detach_input bit (1) aligned,			/* detach input switch before exiting */
     close_output bit (1) aligned,			/* close output switch before exiting */
     detach_output bit (1) aligned;			/* detach output switch before exiting */


/* record copying variables */
dcl  recordL fixed bin (21),				/* record length */
     recordP (1) ptr,				/* pointer to record buffer segment */
     record_count fixed bin (35),			/* number of records copied */
     record_key char (256) varying,			/* key of record being copied */
     max_recordL fixed bin (21) init (sys_info$max_seg_size * 4), /* in characters */
     sys_info$max_seg_size fixed bin (35) external static,
     can_rewrite bit (1) aligned,			/* "0"b - no  :: "1"b - yes */
     read_keys bit (1) aligned;			/* "0"b - no :: "1"b - yes */


/* Error message text variables */
dcl  name char (9) internal static options (constant) init ("copy_file"),
     error_text char (256) varying,			/* holds message for output via com_err_ */
     end_argument (0:3) char (6) internal static options (constant)
     init ("-to", "-stop", "-count", "-all"),
     input_open_string char (24) varying,
     output_open_string char (24) varying;


/*  Miscellaneous storage */
dcl  code fixed bin (35),				/* error code */
     unique_string char (15);				/* holds value returned by unique_string_ */


/*  Conditions and builtin functions */
dcl  cleanup condition,
    (addr, before, binary, null, substr, unspec, verify) builtin;
	

/*  Error codes */
dcl (error_table_$action_not_performed,
     error_table_$bad_arg,
     error_table_$badopt,
     error_table_$end_of_info,
     error_table_$fatal_error,
     error_table_$inconsistent,
     error_table_$key_order,
     error_table_$no_key,
     error_table_$no_record,
     error_table_$noarg,
     error_table_$nodescr,
     error_table_$not_attached,
     error_table_$not_closed,
     error_table_$wrong_no_of_args) fixed bin (35) external static;


/*  External procedures */
dcl  com_err_ ext entry options (variable),
     cu_$arg_count ext entry (fixed bin),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     get_system_free_area_ entry() returns(ptr),
     get_temp_segments_ ext entry (char (*), (*) ptr, fixed bin (35)),
     ioa_ ext entry options (variable),
     iox_$attach_ioname ext entry (char (*), ptr, char (*), fixed bin (35)),
     iox_$close ext entry (ptr, fixed bin (35)),
     iox_$control entry (ptr, char(*), ptr, fixed bin(35)),
     iox_$detach_iocb ext entry (ptr, fixed bin (35)),
     iox_$destroy_iocb entry (ptr, fixed bin(35)),
     iox_$look_iocb ext entry (char (*), ptr, fixed bin (35)),
     iox_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
     iox_$position ext entry (ptr, fixed bin, fixed bin, fixed bin (35)),
     iox_$read_key ext entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)),
     iox_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$rewrite_record ext entry (ptr, ptr, fixed bin (21), fixed bin (35)),
     iox_$seek_key ext entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)),
     iox_$write_record ext entry (ptr, ptr, fixed bin (21), fixed bin (35)),
     release_temp_segments_ ext entry (char (*), (*) ptr, fixed bin (35)),
     unique_chars_ ext entry (bit (*)) returns (char (15));
	

/* iocb attach description variable */
dcl 1 input_attach_desc based (input_iocbP -> iocb.attach_descrip_ptr),
    2 len fixed bin (17),
    2 string char (0 refer (input_attach_desc.len));
dcl io_module char (32);

/* iocb open description variables */
dcl 1 input_open_desc based (input_iocbP -> iocb.open_descrip_ptr),
    2 len fixed bin (17),
    2 string char (0 refer (input_open_desc.len));
dcl 1 output_open_desc based (output_iocbP -> iocb.open_descrip_ptr),
    2 len fixed bin (17),
    2 string char (0 refer (output_open_desc.len));
dcl  open_mode char (32) varying;			/* hold open mode from an open description */

/* Key copying variables */
dcl  areap ptr,					/* pointer to my_area to allocate in */
     my_area area based (areap),			/* where structures are allocated in */
     only_keys bit (1) aligned,			/* we only copy keys and no records */
    1 info like indx_info;				/* place to put file_status info */

%include ak_info;
%include vfs_info;
%include iocb;
	

/* PREPARATORY CONTROL ARGUMENT PROCESSING */

	input_type, output_type, begin_cntl, end_cntl, msg_cntl = undefined;
	copy_keys = no;


/* PROCESS AND VALIDATE CONTROL ARGUMENTS */

	call cu_$arg_count (argN);			/* get number of arguments */
	if argN < 4 then do;
	     call com_err_ (error_table_$wrong_no_of_args, name,
		"^/Type ""help copy_file -section Syntax"" for details of use.");
	     return;
	end;

	do argX = 1 to argN;			/* look at each argument */
	     call cu_$arg_ptr (argX, argP, argL, code);
	     if code ^= 0 then do;
		call com_err_ (code, name);
		return;
	     end;

	     if arg = "-input_switch" | arg = "-isw" then do;
		if input_type ^= undefined then do;
MULTIPLE_INPUT:	     error_text = "Multiple input file specifications.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
		else input_type = isw;
		call get_string_arg_32;
		input_switchname = arg;
	     end;

	     else if arg = "-input_description" | arg = "-ids" then do;
		if input_type ^= undefined then go to MULTIPLE_INPUT;
		else input_type = ids;
		call get_string_arg_256;
		input_description = arg;
	     end;

	     else if arg = "-output_switch" | arg = "-osw" then do;
		if output_type ^= undefined then do;
MULTIPLE_OUTPUT:	     error_text = "Multiple output file specifications.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
		else output_type = osw;
		call get_string_arg_32;
		output_switchname = arg;
	     end;

	     else if arg = "-output_description" | arg = "-ods" then do;
		if output_type ^= undefined then go to MULTIPLE_OUTPUT;
		else output_type = ods;
		call get_string_arg_256;
		output_description = arg;
	     end;
	     
	     else if arg = "-keyed" then do;
		if copy_keys then do;
		     error_text = "Multiple ""-keyed"" arguments.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
		else copy_keys = yes;
	     end;

	     else if arg = "-from" | arg = "-fm" then do;
		if begin_cntl ^= undefined then do;
MULTIPLE_BEGIN:	     error_text = "Multiple initial record specifications.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
		else begin_cntl = from_idx;
		call get_numeric_arg;
		from_idx_position = numeric_arg;
	     end;

	     else if arg = "-start" | arg = "-sr" then do;
		if begin_cntl ^= undefined then go to MULTIPLE_BEGIN;
		else begin_cntl = start;
		call get_string_arg_256;
		start_key = arg;
	     end;

	     else if arg = "-to" then do;
		if end_cntl ^= undefined then do;
MULTIPLE_END:	     error_text = "Multiple terminal record specifications.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
		else end_cntl = to_idx;
		call get_numeric_arg;
		to_idx_position = numeric_arg;
	     end;

	     else if arg = "-stop" | arg = "-sp" then do;
		if end_cntl ^= undefined then go to MULTIPLE_END;
		else end_cntl = stop;
		call get_string_arg_256;
		stop_key = arg;
	     end;

	     else if arg = "-count" | arg = "-ct" then do;
		if end_cntl ^= undefined then go to MULTIPLE_END;
		else end_cntl = count;
		call get_numeric_arg;
		count_value = numeric_arg;
	     end;

	     else if arg = "-all" | arg = "-a" then do;
		if end_cntl ^= undefined then go to MULTIPLE_END;
		else end_cntl = all;
	     end;
	     
	     else if arg = "-brief" | arg = "-bf" then do;
		if msg_cntl ^= undefined then do;
MULTIPLE_MSG:	     error_text = "Multiple message length specifications.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
		else msg_cntl = brief;
	     end;

	     else if arg = "-long" | arg = "-lg" then do;
		if msg_cntl ^= undefined then go to MULTIPLE_MSG;
		else msg_cntl = long;
	     end;

	     else do;
		call com_err_ (error_table_$badopt, name, "^a", arg);
		return;
	     end;
	end;
	

/* CHECK REQUIREMENTS AND APPLY DEFAULTS */

	if input_type = undefined then do;
	     error_text = "Either ""-input_switch"" or ""-input_description"" is required.";
	     go to NO_ARGUMENT_ERROR;
	end;

	if output_type = undefined then do;
	     error_text = "Either ""-output_switch"" or ""-output_description"" is required.";
	     go to NO_ARGUMENT_ERROR;
	end;


	if msg_cntl = undefined then msg_cntl = long;	/* default is -LONG */

	if end_cntl = undefined then end_cntl = all;	/* default is -ALL */
	else if end_cntl = to_idx then do;		/* -to was specified */
	     if begin_cntl ^= from_idx then do;		/* -from was not specified */
		error_text = """-from"" must be used with ""-to"".";
		go to NO_ARGUMENT_ERROR;
	     end;
	     else do;				/* -from was specified */
		if to_idx_position < from_idx_position then do;
		     error_text = """-to"" position must be greater then or equal to ""-from"" position.";
		     go to INCONSISTENT_ARGUMENT_ERROR;
		end;
	     end;
	end;

	if begin_cntl = start & end_cntl = stop then do;	/* -start and -stop */
	     if stop_key < start_key then do;
		error_text = """-stop"" key must be greater than or equal to ""-start"" key.";
		go to INCONSISTENT_ARGUMENT_ERROR;
	     end;
	end;


	if begin_cntl = start | end_cntl = stop | copy_keys then do;
	     input_open_mode = keyed_sequential_input;
	     input_open_string = "keyed_sequential_input";
	     read_keys = yes;
	end;
	else do;
	     input_open_mode = sequential_input;
	     input_open_string = "sequential_input";
	     read_keys = no;
	end;

	if copy_keys then do;
	     output_open_mode = keyed_sequential_output;
	     output_open_string = "keyed_sequential_output";
	end;
	else do;
	     output_open_mode = sequential_output;
	     output_open_string = "sequential_output";
	end;
	

/*  PREPARATORY I/O PROCESSING */

	can_rewrite, close_input, detach_input, close_output, detach_output = no;
	recordP, gk_info_ptr, ak_info_ptr = null;
	unique_string = "";
	on cleanup call cleaner;			/* tidy up I/O switches and buffer segment */

/* INPUT FILE PROCESSING - I/O SWITCH ALREADY ATTACHED */

	if input_type = isw then do;
	     call iox_$look_iocb (input_switchname, input_iocbP, code); /* get the iocb pointer */
	     if code ^= 0 then do;
BAD_INPUT_ATTACH:	call com_err_ (code, name, """^a""", input_switchname);
		return;
	     end;

	     call iox_$open (input_iocbP, input_open_mode, "0"b, code);

	     if code = 0 then close_input = yes;	/* we opened, so we close */

	     else if code = error_table_$not_attached then go to BAD_INPUT_ATTACH;

	     else if code = error_table_$not_closed then do; /* NOT AN ERROR - switch can be open */

		open_mode = before (input_open_desc.string, " ");
		if read_keys then do;
		     if open_mode = "keyed_sequential_input" then;
		     else if open_mode = "keyed_sequential_update" then;
		     else do;
			error_text = "keyed sequential";
BAD_INPUT_OPEN:		call com_err_ (error_table_$action_not_performed, name,
			     "^/Input switch ""^a"" must be closed^/and re-opened for ^a access.",
			     input_switchname, error_text);
			return;
		     end;
		end;
		else do;
		     if open_mode = "sequential_input" then;
		     else if open_mode = "sequential_input_output" then;
		     else if open_mode = "keyed_sequential_input" then;
		     else if open_mode = "keyed_sequential_update" then;
		     else do;
			error_text = "sequential";
			go to BAD_INPUT_OPEN;
		     end;
		end;

	     end;

	     else do;				/* some other error code */
		call com_err_ (code, name, "^/Unable to open input switch ""^a"" for ^a.",
		     input_switchname, input_open_string);
		return;
	     end;
	end;
	

/*  INPUT FILE PROCESSING - I/O SWITCH NOT ALREADY ATTACHED */

	else do;

	     unique_string = unique_chars_ ("0"b);

	     call iox_$attach_ioname (unique_string || ".copy_file.input", input_iocbP, input_description, code);

	     if code = 0 then detach_input = yes;	/* we attached, so we detach */

	     else do;
		call com_err_ (code, name,
		     "^/Unable to attach input file using attach description^/""^a"".", input_description);
		return;
	     end;

	     call iox_$open (input_iocbP, input_open_mode, "0"b, code);

	     if code = 0 then close_input = yes;	/* we opened, so we close */

	     else do;
		call com_err_ (code, name, "^/Unable to open input file for ^a.", input_open_string);
		go to CLEANUP_AND_RETURN;
	     end;

	end;


/*  INPUT FILE POSITIONING */

	if begin_cntl = from_idx then do;		/* must be able to position to a specific record */

	     if ^close_input then do;			/* input switch was open, position unknown */
		call iox_$position (input_iocbP, -1, 0, code); /* move to 1st record */
		if code ^= 0 then do;
BAD_INPUT_POSITION:	     call com_err_ (error_table_$no_record, name,
			"^/Unable to position input file to record ^d.", from_idx_position);
		     go to CLEANUP_AND_RETURN;
		end;
	     end;

	     call iox_$position (input_iocbP, 0, from_idx_position - 1, code); /* skips from_idx_position - 1 records */
	     if code ^= 0 then go to BAD_INPUT_POSITION;

	end;

	else if begin_cntl = start then do;		/* must seek to a specific key */
	     call iox_$seek_key (input_iocbP, start_key, 0, code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "^/Starting key ""^a"" not found in input file.", start_key);
		go to CLEANUP_AND_RETURN;
	     end;

	end;
	

/*  OUTPUT FILE PROCESSING - I/O SWITCH ALREADY ATTACHED */

	if output_type = osw then do;
	     call iox_$look_iocb (output_switchname, output_iocbP, code);
	     if code ^= 0 then do;
BAD_OUTPUT_ATTACH:	call com_err_ (code, name, """^a""", output_switchname);
		go to CLEANUP_AND_RETURN;
	     end;

	     call iox_$open (output_iocbP, output_open_mode, "0"b, code);
	     if code = 0 then close_output = yes;	/* we opened, so we close */
	     else if code = error_table_$not_attached then go to BAD_OUTPUT_ATTACH;
	     else if code = error_table_$not_closed then do; /* NOT AN ERROR - switch can be open */
		open_mode = before (output_open_desc.string, " ");
		if copy_keys then do;
		     if open_mode = "keyed_sequential_output" then;
		     else if open_mode = "direct_output" then;
		     else if open_mode = "keyed_sequential_update" then can_rewrite = yes;
		     else if open_mode = "direct_update" then can_rewrite = yes;
		     else do;
			error_text = "keyed sequential or direct";
BAD_OUTPUT_OPEN:		call com_err_ (error_table_$action_not_performed, name,
			     "Output switch ""^a"" must be closed^/and re-opened for ^a access.",
			     output_switchname, error_text);
			go to CLEANUP_AND_RETURN;
		     end;
		end;
		else do;
		     if open_mode = "sequential_output" then;
		     else if open_mode = "sequential_input_output" then;
		     else do;
			error_text = "sequential";
			go to BAD_OUTPUT_OPEN;
		     end;
		end;
	     end;
	     else do;
		call com_err_ (code, name, "^/Unable to open output switch ""^a"" for ^a.",
		     output_switchname, output_open_string);
		go to CLEANUP_AND_RETURN;
	     end;
	end;
	

/* OUTPUT FILE PROCESSING - I/O SWITCH NOT ALREADY ATTACHED */

	else do;
	     if unique_string = "" then unique_string = unique_chars_ ("0"b);

	     call iox_$attach_ioname (unique_string || ".copy_file.output", output_iocbP, output_description, code);
	     if code = 0 then detach_output = yes;	/* we attached, we detach */
	     else do;
		call com_err_ (code, name,
		     "^/Unable to attach output file using attach description^/""^a"".", output_description);
		go to CLEANUP_AND_RETURN;
	     end;

	     call iox_$open (output_iocbP, output_open_mode, "0"b, code);
	     if code = 0 then close_output = yes;	/* we opened, so we close */
	     else do;
		call com_err_ (code, name, "^/Unable to open output file for ^a.", output_open_string);
		go to CLEANUP_AND_RETURN;
	     end;
	end;


/* BUFFER SEGMENT PROCESSING */

	call get_temp_segments_ (name, recordP, code);
	if recordP (1) = null then do;
	     call com_err_ (code, name, "^/Unable to create temporary buffer segment in process directory.");
	     go to CLEANUP_AND_RETURN;
	end;
	

	if end_cntl = to_idx then count_value = to_idx_position - from_idx_position + 1;
	record_count = 0;

	if copy_keys then do;
	     io_module = before (input_attach_desc.string, " ");
	     if io_module ^= "vfile_ " then do;
		call com_err_ (0, name, "Attempt to copy keyed file that is not open through the vfile_ I/O module.");
		goto CLEANUP_AND_RETURN;
		end;
	     info.info_version = vfs_version_1;
	     call iox_$control (input_iocbP, "file_status", addr (info), code);
	     if code ^= 0 then do;
		call com_err_ (code, name, "Attempting to get the input file status.");
		goto CLEANUP_AND_RETURN;
		end;
	     if info.type ^= 4 then do;
		call com_err_ (0, name, "The input ^[switch ^a^;attach description ^s^a^] must point to a keyed file.",
		     input_type=isw, input_switchname, input_description);
		goto CLEANUP_AND_RETURN;
		end;
	     if info.records = 0 then do;		/* copy only keys */
		code = 0;
		only_keys = yes;

KEY_CNTL (3):
KEY_LOOP:
		call get_key_descriptor;
		if code = error_table_$no_key | code = error_table_$no_record | code = error_table_$end_of_info
		then goto END_OF_FILE;
		else if code = 0 then do;
			call add_key;
			if code ^= 0 then goto ADD_KEY_ERROR;
			end;
		     else goto GET_KEY_ERROR;

		record_count = record_count + 1;
		call iox_$position (input_iocbP, 0, 1, code);
		if code = error_table_$end_of_info
		then goto END_OF_FILE;
		else if code ^= 0 then goto IO_ERROR;

		goto KEY_CNTL (end_cntl);

KEY_CNTL (1):
		if record_key = stop_key then goto DONE;
		else goto KEY_LOOP;

KEY_CNTL (2):
KEY_CNTL (0):
		if record_count = count_value then goto DONE;
		else goto KEY_LOOP;
		end;
	     end;
	

/* Copy the records and associated keys from the input file */

RECORD_CNTL (3):
RECORD_LOOP:
	if read_keys then do;
	     call iox_$read_key (input_iocbP, record_key, 0, code);
	     if code = 0 then;
	     else if code = error_table_$end_of_info then go to END_OF_FILE;
	     else go to READ_ERROR;
	     end;

	call iox_$read_record (input_iocbP, recordP (1), max_recordL, recordL, code);
	if code = 0 then;
	else if code = error_table_$end_of_info then go to END_OF_FILE;
	else go to READ_ERROR;

	if copy_keys then do;
	     call iox_$seek_key (output_iocbP, record_key, 0, code);
	     if code = error_table_$no_record then;	/* THIS IS CORRECT - means key not in file */
	     else if code = error_table_$key_order then go to OUTPUT_KEY_ERROR;
	     else if code = 0 then do;		/* duplicate key */
		if can_rewrite then do;
		     call iox_$rewrite_record (output_iocbP, recordP (1), recordL, code);
		     if code = 0 then go to COUNT_IT;
		     else go to WRITE_ERROR;
		end;
		else go to DUPLICATE_KEY_ERROR;
	     end;
	     else go to WRITE_ERROR;
	end;

	call iox_$write_record (output_iocbP, recordP (1), recordL, code);
	if code ^= 0 then go to WRITE_ERROR;

COUNT_IT:	record_count = record_count + 1;
	go to RECORD_CNTL (end_cntl);

RECORD_CNTL (1): if record_key = stop_key then go to DONE;
	else go to RECORD_LOOP;

RECORD_CNTL (0):
RECORD_CNTL (2): if record_count = count_value then go to DONE;
	else go to RECORD_LOOP;

/* NOTE -- RECORD_CNTL (3) is at beginning of RECORD_LOOP */
	

/* END CASE PROCESSING */

END_OF_FILE: if end_cntl = all then go to DONE;		/* this is to be expected */

	else do;					/* otherwise, copying was prematurely terminated */
	     call com_err_ (error_table_$end_of_info, name, "While reading input file.
""^a"" condition not satisfied.  ^d records copied.",
		end_argument (end_cntl), record_count);
	     go to CLEANUP_AND_RETURN;
	end;


DONE:	if msg_cntl = long then call ioa_ ("^d ^[keys^;records^] copied.", record_count, only_keys);


CLEANUP_AND_RETURN: call cleaner;


RETURN_TO_CL: return;
	

/* ERROR PROCESSING */

INCONSISTENT_ARGUMENT_ERROR: code = error_table_$inconsistent;
	go to ARGUMENT_ERROR;


NO_ARGUMENT_ERROR: code = error_table_$noarg;


ARGUMENT_ERROR: call com_err_ (code, name, "^/^a", error_text);
	return;


ADD_KEY_ERROR:
	call com_err_ (code, name, "Adding key ""^a"" to output file.", record_key);
	goto CLEANUP_AND_RETURN;


GET_KEY_ERROR:
	call com_err_ (code, name, "Error getting next key after ""^a"" from input file.", record_key);
	goto CLEANUP_AND_RETURN;


READ_ERROR: error_text = "reading input";
	go to IO_ERROR;


WRITE_ERROR: error_text = "writing output";


IO_ERROR:	call com_err_ (code, name,
	     "^/Error while ^a file.  ^d records successfully copied.", error_text, record_count);
	go to CLEANUP_AND_RETURN;


OUTPUT_KEY_ERROR: call com_err_ (error_table_$action_not_performed, name,
	     "^/Unable to perform requested copy.
Key of last output file record is greater than or
equal to key of first input file record: ""^a"".", record_key);
	go to CLEANUP_AND_RETURN;


DUPLICATE_KEY_ERROR: call com_err_ (error_table_$fatal_error, name,
	     "^/Unable to copy input file record with key ""^a"".
A record with this key already exists in the output file.
The output switch must be closed and re-opened in an update mode
to copy this record.  ^d records successfully copied.",
	     record_count);
	go to CLEANUP_AND_RETURN;
	

/* INTERNAL PROCEDURES */
/*   Note:  none of the following three internal procedures should be modified so that they would no longer run
   in the stack frame of the main procedure.  This restriction is imposed by the use of cu_$arg_ptr, which
   would then operate on the argument list of the internal procedure instead of the command's argument list.     */

get_string_arg_256: procedure;			/* obtains next argument, a string ^> 256 chars */
	     max_argL = 256;
	     go to GET_ARGUMENT;

get_string_arg_32: entry;				/* obtains next argument, a string ^> 32 chars */
	     max_argL = 32;

GET_ARGUMENT:  call get_arg;				/* get next argument, if any */
	     if argL > max_argL then do;
		call com_err_ (error_table_$bad_arg, name,
		     "^/Argument descriptor length exceeds ^d characters.^/^a", max_argL, arg);
		go to RETURN_TO_CL;
	     end;
	     return;

	end get_string_arg_256;


get_numeric_arg: procedure;				/* obtains next argument, a number */

	     call get_arg;				/* get the argument, if any */
	     if argL > 10 then do;
BAD_NUMERIC_ARG:	call com_err_ (error_table_$bad_arg, name,
		     "^/Argument descriptor must be positive integer < 10000000000.^/""^a""", arg);
		go to RETURN_TO_CL;
	     end;
	     if verify (arg, "0123456789") ^= 0 then go to BAD_NUMERIC_ARG;
	     numeric_arg = binary (arg);
	     if numeric_arg <= 0 then go to BAD_NUMERIC_ARG;
	     return;

	end get_numeric_arg;


get_arg:	procedure;				/* obtains next argument, if any */

	     argX = argX + 1;			/* increment to next argument */
	     if argX > argN then do;
		call com_err_ (error_table_$nodescr, name, "^a", arg);
		go to RETURN_TO_CL;
	     end;
	     call cu_$arg_ptr (argX, argP, argL, code);
	     if code ^= 0 then do;
		call com_err_ (code, name);
		go to RETURN_TO_CL;
	     end;
	     return;

	end get_arg;
%page;

get_key_descriptor:
     proc;

	if gk_info_ptr = null then do;
	     areap = get_system_free_area_ ();
	     gk_key_len = 256;
	     allocate gk_info in (my_area) set (gk_info_ptr);
	     unspec (gk_info_ptr -> gk_info) = "0"b;
	     gk_info_ptr -> gk_info.current = "1"b;
	     gk_info_ptr -> gk_info.version = gk_info_version_0;
	     end;

	call iox_$control (input_iocbP, "get_key", gk_info_ptr, code);
	if code = error_table_$no_key then code = error_table_$end_of_info;
	return;

	end get_key_descriptor;

%page;

add_key:
     proc;

	if ak_info_ptr = null then do;
	     areap = get_system_free_area_ ();
	     ak_key_len = 256;
	     allocate ak_info in (my_area) set (ak_info_ptr);
	     unspec (ak_info_ptr -> ak_info) = "0"b;
	     ak_info_ptr -> ak_info.flags.input_desc = "1"b;
	     ak_info_ptr -> ak_info.flags.input_key = "1"b;
	     end;
	ak_info_ptr -> ak_info.descrip = gk_info_ptr -> gk_info.descrip;
	ak_info_ptr -> ak_info.key_len = gk_info_ptr -> gk_info.key_len;
	record_key, ak_info_ptr -> ak_info.key = substr (gk_info_ptr -> gk_info.key, 1, gk_info_ptr -> gk_info.key_len);

	call iox_$control (output_iocbP, "add_key", ak_info_ptr, code);
	return;
	end add_key;
	

/* CLEANUP PROCEDURE */

cleaner:	procedure;

	     if recordP (1) ^= null then do;
		call release_temp_segments_ (name, recordP, 0);
		recordP (1) = null;
	     end;

	     if close_input then do;
		call iox_$close (input_iocbP, code);
		if code = 0 then close_input = no;
		else call com_err_ (code, name, "^/Unable to close input file.");
	     end;

	     if detach_input then do;
		call iox_$detach_iocb (input_iocbP, code);
		if code = 0 then call iox_$destroy_iocb (input_iocbP, code);
		if code = 0 then detach_input = no;
		else call com_err_ (code, name, "^/Unable to detach input file.");
	     end;

	     if close_output then do;
		call iox_$close (output_iocbP, code);
		if code = 0 then close_output = no;
		else call com_err_ (code, name, "^/Unable to close output file.");
	     end;

	     if detach_output then do;
		call iox_$detach_iocb (output_iocbP, code);
		if code = 0 then call iox_$destroy_iocb (output_iocbP, code);
		if code = 0 then detach_output = no;
		else call com_err_ (code, name, "^/Unable to detach output file.");
	     end;

	     if ak_info_ptr ^= null then do;
		free ak_info_ptr -> ak_info in (my_area);
		ak_info_ptr = null;
		end;

	     if gk_info_ptr ^= null then do;
		free gk_info_ptr -> gk_info in (my_area);
		gk_info_ptr = null;
		end;

	end cleaner;


     end copy_file;
   



		    discard_output.pl1              11/04/82  2006.8rew 11/04/82  1631.3       77013


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


discard_output:
dco:
     procedure options (variable);

/* This module implements the discard_output command, which discards the
   output from specified I/O switches for the duration of a command line.

   Usage:
	discard_output {-osw switch_name}... command_line

   */

/* Steve Herbst 4/19/77 */


dcl  arg char (arg_len) based (arg_ptr);
dcl  command_line char (cl_len) aligned based (cl_ptr);
dcl  old_command_line char (old_cl_len) aligned based (old_cl_ptr);
dcl  cl_space char (512) aligned init ("");

dcl  command char (14) int static options (constant) init ("discard_output");
dcl  NL char (1) int static options (constant) init ("
");

dcl  area area based (area_ptr);

dcl  cl_allocated bit (1);

dcl (area_ptr, discard_ptr) ptr init (null ());
dcl (arg_list_ptr, arg_ptr, cl_ptr, iocb_ptr, old_cl_ptr) ptr;

dcl (arg_len, cl_len, command_len, old_cl_len) fixed bin (21);
dcl (arg_count, arg_index, iocb_limit, iocb_count, n_saved_iocbs, i) fixed bin;
dcl (code, cp_code) fixed bin (35);

dcl  switch_name char (32);
dcl  syn_attach_desc char (37);

dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$not_attached fixed bin (35) ext static;

dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$error_output ptr ext;
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$move_attach entry (ptr, ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35));
dcl  iox_$user_output ptr ext;
dcl  unique_chars_ entry (bit (*)) returns (char (15));

dcl (addr, divide, length, null, substr) builtin;

dcl  cleanup condition;

%include iox_modes;

	call cu_$arg_count (arg_count);
	if arg_count = 0 then do;
USAGE:	     call com_err_ (0, command,
		"Usage:  discard_output {-osw switchname}... command_line");
	     return;
	end;

	iocb_count, command_len = 0;
	iocb_limit = divide (arg_count, 2, 17, 0)+1;
	cl_ptr = addr (cl_space);
	cl_len = length (cl_space);
	cl_allocated = "0"b;
	call cu_$arg_list_ptr (arg_list_ptr);
	arg_index = 1;

	begin;

dcl  iocbp (iocb_limit) pointer;			/* IOCB's to discard */
dcl  iocb_name (iocb_limit) char (32);			/* names of the switches */
dcl  saved_iocb (iocb_limit) pointer;			/* IOCB's of saved attachments */
dcl  was_detached (iocb_limit) bit (1) aligned;		/* ON if switch was not attached to begin with */


	     n_saved_iocbs = 0;			/* haven't saved anything yet */
	     on condition (cleanup) call clean_up;

NEXT_OS:	     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, code, arg_list_ptr);
	     if code ^= 0 then go to USAGE;
	     if substr (arg, 1, 1) = "-" then
		if arg = "-osw" | arg = "-output_switch" then do;
		     call cu_$arg_ptr_rel (arg_index+1, arg_ptr, arg_len, code, arg_list_ptr);
		     if code ^= 0 then go to USAGE;
		     call iox_$look_iocb (arg, iocb_ptr, code);
		     if iocb_ptr = null () then do;
			call com_err_ (code, command, "^a", arg);
			return;
		     end;
		     iocb_count = iocb_count+1;
		     iocbp (iocb_count) = iocb_ptr;
		     iocb_name (iocb_count) = arg;
		     arg_index = arg_index+2;
		     go to NEXT_OS;
		end;
		else do;				/* no other control args allowed */
		     call com_err_ (error_table_$badopt, command, "^a", arg);
		     return;
		end;
	     else call grow_command_line ();		/* start of command line arguments */

	     do arg_index = arg_index+1 to arg_count;	/* pick up rest of command line */
		call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, code, arg_list_ptr);
		call grow_command_line ();
	     end;

	     if iocb_count = 0 then do;
		iocb_count = 1;
		iocbp (iocb_count) = iox_$user_output;	/* default I/O switch */
		iocb_name (iocb_count) = "user_output";
	     end;


/* Create a switch to use to discard output of specified switches */

	     switch_name = "dco_" || unique_chars_ ("0"b); /* create name of switch */
	     syn_attach_desc = "syn_ " || switch_name;	/* and attach description for discarded switches */

	     call iox_$attach_name (switch_name, discard_ptr, "discard_", null (), code); /* attempt to attach it */
	     if code ^= 0 then do;
		call com_err_ (code, command, "Attempting to attach ^a.", switch_name);
		call clean_up;
		return;
	     end;

	     call iox_$open (discard_ptr, Stream_output, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, command, "Attempting to open ^a.", switch_name);
		call clean_up ();
		return;
	     end;


/* Save attachments of switches to be discarded and attach them to discard_
   switch */

	     do i = 1 to iocb_count;
		switch_name = "dco_save_" || unique_chars_ ("0"b);
		call iox_$find_iocb (switch_name, saved_iocb (i), code);
		if code ^= 0 then do;
		     call clean_up ();		/* insure error_output is alright */
		     call com_err_ (code, command, "^a", switch_name);
		     return;
		end;
		call iox_$move_attach (iocbp (i), saved_iocb (i), code);
		if code = 0
		then was_detached (i) = "0"b;		/* have saved something */
		else if code = error_table_$not_attached
		then was_detached (i) = "1"b;		/* not attached */
		else do;
		     call clean_up ();
		     call com_err_ (code, command, "Saving attachment of ^a.", iocb_name (i));
		     return;
		end;
		n_saved_iocbs = n_saved_iocbs + 1;	/* have now saved the attachment */
		call iox_$attach_ptr (iocbp (i), syn_attach_desc, null (), code); /* attach to discard_ */
		if code ^= 0 then do;
		     call clean_up ();
		     call com_err_ (code, command, "Attaching ^a.", switch_name);
		     return;
		end;
	     end;


/* Call the command processor */

	     substr (command_line, command_len, 1) = NL;

	     call cu_$cp (addr (command_line), command_len, cp_code);

	     call clean_up ();
	     revert cleanup;

	     if (cp_code ^= 0) & (cp_code ^= 100) then do; /* have to print message? */
		do i = iocb_count by -1 to 1 while (iocbp (i) ^= iox_$error_output); end;
		if i ^= 0 then call com_err_ (cp_code, command, "Returned by command_processor_.");
	     end;


grow_command_line:
	     procedure ();

/* This internal procedure adds arg to the end of command_line */

		if command_len + arg_len + 1 > cl_len then do; /* need more space */
		     old_cl_ptr = cl_ptr;
		     old_cl_len = cl_len;
		     cl_len = 2 * cl_len;
		     if area_ptr = null () then area_ptr = get_system_free_area_ ();
		     allocate command_line in (area) set (cl_ptr);
		     command_line = old_command_line;
		     if cl_allocated then free old_cl_ptr -> command_line in (area);
		     else cl_allocated = "1"b;
		end;

		substr (command_line, command_len + 1) = arg;
		command_len = command_len + arg_len + 1;

	     end grow_command_line;


clean_up:
	     procedure ();

/* This internal procedure restores attachments to their previous state */

		do i = 1 to n_saved_iocbs;		/* restore each saved attachment */
		     call iox_$detach_iocb (iocbp (i), code); /* detach it from discard_ */
		     if was_detached (i) then;	/* it was detached to start with */
		     else call iox_$move_attach (saved_iocb (i), iocbp (i), code);
		     call iox_$destroy_iocb (saved_iocb (i), code); /* get rid of temp IOCB */
		end;

		if discard_ptr ^= null () then do;	/* get rid of discard_ IOCB */
		     call iox_$close (discard_ptr, code);
		     call iox_$detach_iocb (discard_ptr, code);
		     call iox_$destroy_iocb (discard_ptr, code);
		end;

		if cl_allocated			/* free copy of command line */
		then free command_line in (area);

	     end clean_up;

	end;					/* of begin block */

     end discard_output;
   



		    display_forms_info.pl1          10/05/90  1350.0rew 10/05/90  1333.0       61704


/****^  *********************************************************
        *                                                       *
        * Copyright, (C) BULL HN Information Systems Inc., 1990 *
        *                                                       *
        * Copyright, (C) Honeywell Bull Inc., 1988              *
        *                                                       *
        ********************************************************* */


/****^  HISTORY COMMENTS:
  1) change(88-06-09,Brunelle), approve(88-06-09,MCR7911),
     audit(88-10-26,Wallman), install(88-10-28,MR12.2-1199):
     Created.
  2) change(88-11-11,Brunelle), approve(88-11-11,MCR7911),
     audit(88-11-14,Wallman), install(88-11-14,MR12.2-1212):
     Allow -rqt argument; call enter_output_request$request_type to allow user
     defined request type evaluation.
  3) change(90-09-10,Itani), approve(90-09-10,MCR8197), audit(90-09-25,Bubric),
     install(90-10-05,MR12.4-1038):
     Display a usage message if no arguments are entered.
                                                   END HISTORY COMMENTS */

/* format: style4 */

display_forms_info: dfi: proc;

/*  This command displays a list of all forms options available for a given
   request type */

/* External Procedures & Variables */

dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  enter_output_request$request_type entry (char (*), char (*), char (*), fixed bin, fixed bin, fixed bin (35));
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$no_forms_table_defined fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  ioa_ entry () options (variable);
dcl  iod_info_$forms_info entry (char (*), ptr, ptr, fixed bin (35));

dcl  cleanup condition;

dcl  (index, length, null, rtrim) builtin;

/* Internal Static */

dcl  myname char (32) int static options (constant) init ("display_forms_info");

/* Automatic */

dcl  arg char (argl) based (argp);
dcl  argc fixed bin;
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  error fixed bin (35);
dcl  first fixed bin;
dcl  (i, j, k) fixed bin;
dcl  last fixed bin;
dcl  max_name_length fixed bin;
dcl  need_header bit (1);
dcl  request_type_name char (32);
dcl  (queue_default, queue_max) fixed bin;
%page;

/* actual program begins here */

	call cu_$arg_count (argc, error);
	if error ^= 0 then do;
	     call com_err_ (error, myname, "Getting arg count");
	     return;
	end;

          if argc = 0 then do;
               call com_err_ (error_table_$noarg, myname, "^/^6xUsage: ^a {-rqt} rqt_name ", myname);
               return;
	end;

/* get name of request type to process */
	do i = 1 to argc;
	     call cu_$arg_ptr (i, argp, argl, error);
	     if error ^= 0 then do;
get_arg_error:	call com_err_ (error, myname, "Getting argument ^d", i);
		return;
	     end;
	     if index (arg, "-") = 1 then do;		/* have control arg of some type */
		if arg = "-request_type" | arg = "-rqt" then do;
		     if i + 1 > argc then do;
missing_arg:		call com_err_ (error_table_$noarg, myname);
			return;
		     end;
		     i = i + 1;
		     call cu_$arg_ptr (i, argp, argl, error);
		     if error ^= 0 then go to get_arg_error;
		     if index (arg, "-") = 1 then go to missing_arg;
		end;
		else do;
		     call com_err_ (error_table_$bad_arg, myname, "^a", arg);
		     return;
		end;
	     end;
	     call display_the_info (arg);
	end;
	return;

clean_up: proc;
	if forms_info_ptr ^= null () then
	     free forms_info;
     end clean_up;
%page;
display_the_info: proc (arg_name);

/* internal procedure to call out and display all return forms info */

dcl  arg_name char (*);				/* user supplied name of the request type */

	call enter_output_request$request_type (arg_name, "printer", request_type_name, queue_default, queue_max, error);
	if error ^= 0 then do;
	     call com_err_ (error, myname, "Processing ^a.", arg);
	     return;
	end;

	forms_info_ptr = null ();

	on cleanup call clean_up;

	call iod_info_$forms_info (request_type_name, null (), forms_info_ptr, error);
	if error ^= 0 then do;
	     if error = error_table_$no_forms_table_defined then
		if arg_name = request_type_name then
		     call ioa_ ("Request type ^a has no forms defined.", request_type_name);
		else call ioa_ ("Request type ^a (-rqt ^a) has no forms defined.", arg_name, request_type_name);
	     else do;
		if arg_name = request_type_name then
		     call com_err_ (error, myname, "Getting forms info for ^a", request_type_name);
		else call com_err_ (error, myname, "Getting forms info for ^a (-rqt ^a)", arg_name, request_type_name);
	     end;
	     go to get_out;
	end;

	max_name_length = 0;
	do i = 1 to forms_info.no_entries;
	     do j = forms_info.entry (i).first_name_index to forms_info.entry (i).last_name_index;
		if length (rtrim (forms_info.names (j))) > max_name_length then
		     max_name_length = length (rtrim (forms_info.names (j)));
	     end;
	end;

/* display the header information */
	if arg_name = request_type_name then
	     call ioa_ ("Request type ^a", request_type_name);
	else call ioa_ ("Request type ^a (-rqt ^a)", arg_name, request_type_name);
	call ioa_ ("Default form: ^[^a^;None Supplied^]",
	     forms_info.default_forms_length ^= 0, forms_info.default_form);

	do i = TYPE_USES, TYPE_ORIENTATION, TYPE_FONT_DESC, TYPE_FONT_NAME,
	     TYPE_FONT_SIZE, TYPE_LINE_DESC, TYPE_SPECIAL, TYPE_HOLES,
	     TYPE_PREAMBLE, TYPE_POSTAMBLE;
	     need_header = "1"b;
	     do j = 1 to forms_info.no_entries;
		if forms_info.types (forms_info.entry (j).type_index) = i then do;
		     first = forms_info.entry (j).first_name_index;
		     last = forms_info.entry (j).last_name_index;
		     if need_header then do;
			if i = TYPE_USES then
			     call ioa_ ("^/Forms - combinations");
			else call ioa_ ("^/Forms - ^a", FORMS_TYPE_STRINGS (i));
			need_header = "0"b;
		     end;
		     do k = first to last;
			if k = first then do;
			     call ioa_ ("  ^va  ^[No description supplied.^s^;^a^]",
				max_name_length, forms_info.names (k),
				forms_info.entry (j).comment_index = 0,
				forms_info.comments (forms_info.entry (j).comment_index));
			     if first = last then
				if i = TYPE_USES then
				     call ioa_ ("  ^vx    Uses: ^a",
					max_name_length, forms_info.uses (forms_info.entry (j).uses_index));
			end;
			else do;
			     call ioa_ ("    ^va^[  Uses: ^a",
				max_name_length, forms_info.names (k),
				((k = first + 1) & (i = TYPE_USES)), forms_info.uses (forms_info.entry (j).uses_index));
			end;
		     end;
		end;
	     end;
	end;
get_out:	call clean_up;

     end display_the_info;
%page; %include iod_tables_hdr;
%page; %include iod_forms_info_tab;
%page; %include user_forms_info;

     end display_forms_info;



		    display_ttt.pl1                 10/20/88  1452.0rew 10/20/88  1422.8      445536


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

/* format: style4 */

/* this command displays the contents of the TTT on user_output (or writes it
   into a file) in the form of a TTF that will retranslate back into the same
   TTT.

   Usage:  display_ttt {-pn path} {-nhe | -no_header} {-type type_name}
   {-output_file | -of path}
*/

/****^  HISTORY COMMENTS:
  1) change(77-05-27,RCoren), approve(), audit(), install():
     Written Modified 4/25/78 by Robert S. Coren to add framing_chars Modified
     05/03/78 by Robert Coren & Dave Vinograd to increase length of
        conversion/translation tables to 256 characters Modified 05/29/81 by
     Suzanne Krupp to add function key information
        and also to make display_ttt reject noncurrent version of ttt.
     Modified: 9 June 1981 by G. Palter to convert from X/Y to LINE/COLUMN
  2) change(86-07-10,Parisek), approve(86-08-27,MCR7522),
     audit(86-09-02,GDixon), install(86-09-03,MR12.0-1145):
     Enabled the addition of a ".ttf" suffix to a user created ttf via the
     "-of" ctl argument.  Also corrected the use of the "-pn" ctl argument to
     assume a ".ttt" suffix on the input ttf pathname if user doesn't supply
     it.
  3) change(87-03-10,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030):
     Add code to display the protocol field if present.
  4) change(87-06-15,LJAdams), approve(87-06-15,MCR7646),
     audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055):
     Changed name of include file from terminal_type_protocols.incl.pl1 which
     was to long to term_type_protocols.incl.pl1.
  5) change(87-06-25,LJAdams), approve(87-06-25,MCR7646),
     audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055):
     Add display of DSA extended table.
  6) change(88-01-15,Brunelle), approve(88-01-15,MCR7804),
     audit(88-02-09,Lippard), install(88-02-16,MR12.2-1023):
     Allow expansion of LIKE terminal types.  Accept starname in NAME field of
     -terminal_type (-ttp) or -table (-tb) options. Allow
     printer_terminal_types to accept starname for terminal type and make
     terminal_type  default argument with -pathname (-pn) used to define which
     TTT to use.
  7) change(88-01-22,Brunelle), approve(88-01-22,MCR7813),
     audit(88-10-13,Blair), install(88-10-17,MR12.2-1171):
     Allow processing of version 4 TTT which has 15 char special_chars
     sequences.  Also changed the format of the unexpanded initial_string to
     have fixed bin (18) unsigned delimiters instead of fixed bin (9) unsigned.
  8) change(88-10-20,Brunelle), approve(88-10-20,PBF7813),
     audit(88-10-20,Farley), install(88-10-20,MR12.2-1175):
     Correct "ptr referenced but never set" error.
                                                   END HISTORY COMMENTS */


display_ttt: proc;

/* ENTRIES */

dcl  absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35));
dcl  check_star_name_ entry (char (*), bit (36), fixed bin (2), fixed bin (35));
dcl  clock_ entry returns (fixed bin (71));
dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$ioa_switch_nnl entry options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (*), fixed bin (35));
dcl  match_star_name_ entry (char (*), char (*), fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  ttt_info_$ttt_path entry (char (*), char (*));

/* EXT STATIC */

dcl  iox_$user_output ext static ptr;
dcl  (error_table_$noarg,
     error_table_$badopt,
     error_table_$nomatch,
     error_table_$unimplemented_version,
     error_table_$wrong_no_of_args) ext static fixed bin (35);


/* INT STATIC */

dcl  SHOW_ALL fixed bin init (2) int static options (constant);
dcl  SHOW_MATCH fixed bin init (1) int static options (constant);
dcl  SHOW_NONE fixed bin init (0) int static options (constant);
dcl  prog_name char (11) int static options (constant) init ("display_ttt");
dcl  com_name char (20) int static options (constant) init ("print_terminal_types");
dcl  SYS_DIR char (17) int static options (constant) init (">system_control_1");
dcl  all_caps char (26) int static options (constant) init
	("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  all_lowercase char (26) int static options (constant) init
	("abcdefghijklmnopqrstuvwxyz");
dcl  NUL char (1) int static options (constant) init (" "); /* \000 */
dcl  table_name (6) char (18) int static options (constant) init (
	"input_translation",
	"output_translation",
	"input_conversion",
	"output_conversion",
	"special",
	"function_keys");

dcl  spec_field (11) char (15) int static options (constant) init (
	"new_line",
	"carriage_return",
	"backspace",
	"tab",
	"vertical_tab",
	"form_feed",
	"printer_on",
	"printer_off",
	"red_shift",
	"black_shift",
	"end_of_page");

dcl  delay_name (6) char (9) int static options (constant) init (
	"vert_nl",
	"horz_nl",
	"const_tab",
	"var_tab",
	"backspace",
	"vt_ff");

dcl  video_seq_names (14) char (20) int static options (constant) init (
	"abs_pos",
	"clear_screen",
	"clear_to_eos",
	"home",
	"clear_to_eol",
	"cursor_up",
	"cursor_right",
	"cursor_down",
	"cursor_left",
	"insert_chars",
	"end_insert_chars",
	"delete_chars",
	"insert_lines",
	"delete_lines");

dcl  fkey_seq_names (5) char (5) int static options (constant) init (
	"home",
	"left",
	"right",
	"up",
	"down");

/* AUTOMATIC */

dcl  nargs fixed bin;
dcl  iarg fixed bin;
dcl  argp ptr;
dcl  argl fixed bin;
dcl  arg char (argl) based (argp);

dcl  ttt_dir char (168);
dcl  ttt_ent char (32);
dcl  only_type char (32);
dcl  only_table char (32);
dcl  (type_starname_type, table_starname_type) fixed bin (2);
dcl  (show_types, show_tables) fixed bin;		/* 0 = none, 1 = specified one, 2 = all */
dcl  dft_header bit (1);
dcl  header_spec bit (1);				/* on if -he or -nhe specified */
dcl  header bit (1);
dcl  general_tables bit (1);
dcl  output_file char (168);
dcl  found bit (1);
dcl  found_one bit (1);
dcl  (attached, opened) bit (1);
dcl  iocbp ptr;
dcl  debug_sw bit (1);
dcl  using_default_ttt_path bit (1);
dcl  expand_like bit (1);
dcl  display_all_tables bit (1);
dcl  keep_looping bit (1);

dcl  code fixed bin (35);
dcl  date_str char (24);
dcl  ttx fixed bin;
dcl  (i, j) fixed bin;
dcl  temp_ttep ptr;
dcl  delayx fixed bin;
dcl  special_tablep ptr;
dcl  specialp ptr;
dcl  copy_offset_ptr ptr;
dcl  offset_array_ptr ptr;
dcl  p ptr;
dcl  n fixed bin;
dcl  charx fixed bin;
dcl  ans_spec char (1);
dcl  file_err bit (1);
dcl  key char (12);
dcl  table_len fixed bin;
dcl  c_chars_length fixed bin;

dcl  1 copy_of_tte like tte;

dcl  print_extended_table (3) entry (fixed bin (18)) variable init (
	print_video_table, print_function_key_table, print_dsa_table);
dcl  fkey_seqs_ptr (5) ptr;
dcl  sourcep ptr;

/* BASED */

dcl  based_bit9 bit (9) based unal;
dcl  based_bit18 bit (18) based unal;
dcl  based_fb8 fixed bin (8) based unal;
dcl  based_fb17 fixed bin (17) based unal;
dcl  based_seq (n) fixed bin (8) unal based;
dcl  table_array (8) bit (9) unal based;
dcl  table_offset (6) fixed bin (18) based (offset_array_ptr); /* overlay for table offsets in tte */

dcl  1 float_delays aligned based (delay_tablep),
       2 x fixed bin,				/* holds n_bauds */
       2 array (n refer (float_delays.x)),
         3 stuff (3) fixed bin,			/* header */
         3 delays (6) float bin;			/* delay values as floating-point numbers */

dcl  1 seq (11) based aligned,
       2 count fixed bin (8) unal,
       2 entries (c_chars_length) fixed bin (8) unal; /* like c_chars, but for numeric printing */

dcl  cleanup condition;

dcl  (addr, addrel, byte, divide, hbound, index, lbound, length, low, null, ptr, rank, rel, rtrim, string,
     substr, translate, unspec, char, currentsize, ltrim, min, mod) builtin;

	only_table,
	     only_type = "";
	type_starname_type,
	     table_starname_type = 0;
	dft_header = "1"b;
	general_tables = "1"b;
	header_spec = "0"b;
	output_file = "";
	debug_sw = "0"b;
	expand_like = "0"b;
	display_all_tables = "0"b;

	call ttt_info_$ttt_path (ttt_dir, ttt_ent);	/* default if no pathname specified */

	call cu_$arg_count (nargs);

	if nargs > 0				/* process arguments if any */
	then do iarg = 1 to nargs;
	     call cu_$arg_ptr (iarg, argp, argl, code);
	     if arg = "-pn" | arg = "-pathname"		/* not installed ttt */
	     then do;
		call get_next_arg;			/* updates iarg */
		if code ^= 0 then return;		/* get_next_arg prints error message */
		call expand_pathname_$add_suffix (arg, "ttt", ttt_dir, ttt_ent, code);
						/* append suffix if missing */
		if code ^= 0 then go to argerr;
	     end;

	     else
		if arg = "-type" | arg = "-tp" | arg = "-ttp" | arg = "-terminal_type" /* one type entry only */
	     then do;
		call get_next_arg;
		if code ^= 0 then return;

		only_type = translate (arg, all_caps, all_lowercase);
		call check_star_name_ (only_type, CHECK_STAR_IGNORE_ALL, type_starname_type, code);
		if code ^= 0 then go to argerr;
		general_tables,
		     dft_header = "0"b;
	     end;

	     else
		if arg = "-tb" | arg = "-table"	/* specific table wanted */
	     then do;
		call get_next_arg;
		if code ^= 0 then return;

		only_table = arg;
		call check_star_name_ (only_table, CHECK_STAR_IGNORE_ALL, table_starname_type, code);
		if code ^= 0 then go to argerr;
		general_tables,
		     dft_header = "0"b;
	     end;

	     else
		if arg = "-of" | arg = "-output_file"
	     then do;
		call get_next_arg;
		if code ^= 0 then return;
		call absolute_pathname_$add_suffix (arg, "ttf", output_file, code);
		if code ^= 0 then go to argerr;
	     end;

	     else
		if arg = "-nhe" | arg = "-no_header"
	     then do;
		header_spec = "1"b;
		header = "0"b;
	     end;

	     else
		if arg = "-he" | arg = "-header"
	     then do;
		header_spec = "1"b;
		header = "1"b;
	     end;
	     else if arg = "-debug" | arg = "-db" then debug_sw = "1"b;
	     else if arg = "-expand" | arg = "-exp" then expand_like = "1"b;

	     else do;
		code = error_table_$badopt;
argerr:		call com_err_ (code, prog_name, arg);
		return;
	     end;
	end;

	if expand_like & output_file ^= "" then do;
	     call com_err_ (0, prog_name, "-output_file and -expand are incompatible options.");
	     return;
	end;

	if ^header_spec then header = dft_header;
	if only_type = ""
	then if only_table = ""
	     then show_tables, show_types = SHOW_ALL;	/* nothing specified, show them all */
	     else do;
		show_types = SHOW_NONE;		/* no type entries */
		show_tables = SHOW_MATCH;		/* specified table */
	     end;

	else if only_table = ""			/* type specified, table not */
	then do;
	     show_types = SHOW_MATCH;
	     show_tables = SHOW_NONE;
	end;
	else show_types, show_tables = SHOW_MATCH;	/* show one of each */

	tttp = null;
	attached, opened = "0"b;
	on cleanup call clean_up;

	if output_file = ""				/* default to user_output */
	then iocbp = iox_$user_output;

	else do;
	     call iox_$attach_name ("ttt_output", iocbp, "vfile_ " || output_file, null, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, prog_name, "Could not attach to ^a", output_file);
		return;
	     end;

	     attached = "1"b;
	     call iox_$open (iocbp, 2, ""b, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, prog_name, "Could not open file ^a", output_file);
		call iox_$detach_iocb (iocbp, code);
		return;
	     end;
	     opened = "1"b;
	end;

	call hcs_$initiate (ttt_dir, ttt_ent, "", 0, 1, tttp, code);
	if tttp = null
	then do;
	     call com_err_ (code, prog_name, "Could not initiate ^a>^a", ttt_dir, ttt_ent);
	     call clean_up;
	     return;
	end;

	if ttt.version ^= TTT_version_4
	then do;
	     call com_err_ (error_table_$unimplemented_version, prog_name, "^/^a>^a is version ^d; the current version is ^d.^/Please recompile your ttf.^/", ttt_dir, ttt_ent, ttt.version, TTT_version_4);
	     return;
	end;

/* now start printing stuff */

	if header
	then do;
	     call date_time_ (clock_ (), date_str);
	     call ioa_$ioa_switch (iocbp, "^-/* terminal type file derived from ^a>^a at ^a
^-^3xTTT version ^d, created by ^a^/	*/",
		ttt_dir, ttt_ent, date_str, ttt.version, ttt.author.proc_group_id);
	end;

	if show_types ^= SHOW_NONE
	then do;
	     keep_looping = "1"b;
	     found_one = "0"b;
	     do ttx = 1 to ttt.n_tt_entries while (keep_looping);
		ttep = addr (ttt.tt_entries (ttx));
		if show_types = SHOW_MATCH then do;
		     found = check_for_match_name (tte.name, only_type, type_starname_type);
		     if ^found then goto end_of_tte;
		     if found & type_starname_type = STAR_TYPE_USE_PL1_COMPARE then
			keep_looping = "0"b;
		     found_one = "1"b;
		end;

		if debug_sw then call ioa_ ("^a at ^p", tte.name, ttep);
		if tte.like_type = 0		/* no like to refer back to */
		     | (tte.like_type ^= 0 & expand_like) /* or there is a like but expansion wanted */
		then do;				/* so print all fields that don't have default values */
		     if tte.like_type ^= 0 then do;
			call ioa_$ioa_switch_nnl (iocbp, "/* ");
			call trace_like_tte_chain (ttep); /* recurse to see who is liked together */
			call ioa_$ioa_switch_nnl (iocbp, " */");
		     end;
		     call ioa_$ioa_switch (iocbp, "^/^/^-terminal_type:  ^a;", tte.name);
		     call print_modes;
		     call print_protocol ("0"b);
		     call print_str ("initial_string", tte.initial_string, "0"b);
		     call print_str ("additional_info", tte.additional_info, "0"b);
		     call print_all_delays;

		     offset_array_ptr = addr (tte.input_translation_rp);
		     do i = 1 to 6;
			call print_table (i, "0"b);
		     end;

		     call print_line_types ("0"b);
		     call print_erase ("0"b);
		     call print_kill ("0"b);
		     call print_frame ("0"b);
		     call print_ifc ("0"b);
		     call print_ofc ("0"b);
		     call print_line_delimiter ("0"b);
		     call print_all_flags;
		     call print_old_type ("0"b);
		     call print_extended_tables ("0"b);
		end;
		else do;				/* like, get copy of original */
		     temp_ttep = addr (ttt.tt_entries (tte.like_type));
		     copy_of_tte = temp_ttep -> tte;

		     call ioa_$ioa_switch (iocbp, "^/^/^-terminal_type:  ^a like ^a;", tte.name, copy_of_tte.name);

		     copy_of_tte.name = tte.name;	/* so we can compare */
		     copy_of_tte.like_type = tte.like_type;
		     if unspec (copy_of_tte) ^= unspec (tte) /* see if anything overridden */
		     then do;			/* if so, find out what */
			if tte.modes ^= copy_of_tte.modes
			then call print_modes;

			if tte.protocol ^= copy_of_tte.protocol
			then call print_protocol ("1"b);

			if tte.initial_string.offset ^= copy_of_tte.initial_string.offset
			then call print_str ("initial_string", tte.initial_string, "1"b);

			if tte.additional_info.offset ^= copy_of_tte.additional_info.offset
			then call print_str ("additional_info", tte.additional_info, "1"b);

			if tte.bauds_overridden	/* entirely fresh delay table */
			then call print_all_delays;
			else do;
			     delay_tablep = ptr (tttp, tte.delay_rp);
			     do delayx = 1 to 6;
				if tte.delay_overridden (delayx)
				then call print_delay (delayx);
			     end;
			end;

			copy_offset_ptr = addr (copy_of_tte.input_translation_rp);
			offset_array_ptr = addr (tte.input_translation_rp);
			do i = 1 to 6;
			     if table_offset (i) ^= copy_offset_ptr -> table_offset (i)
			     then call print_table (i, "1"b);
			end;

			if tte.line_types ^= copy_of_tte.line_types
			then call print_line_types ("1"b);

			if tte.erase ^= copy_of_tte.erase
			then call print_erase ("1"b);

			if tte.kill ^= copy_of_tte.kill
			then call print_kill ("1"b);

			if string (tte.framing_chars) ^= string (copy_of_tte.framing_chars)
			then call print_frame ("1"b);

			if tte.input_suspend ^= copy_of_tte.input_suspend |
			     tte.input_resume ^= copy_of_tte.input_resume |
			     tte.input_timeout ^= copy_of_tte.input_timeout
			then call print_ifc ("1"b);

			if tte.output_suspend_etb ^= copy_of_tte.output_suspend_etb |
			     tte.output_resume_ack ^= copy_of_tte.output_resume_ack |
			     tte.output_buffer_size ^= copy_of_tte.output_buffer_size |
			     tte.output_block_acknowledge ^= copy_of_tte.output_block_acknowledge
			then call print_ofc ("1"b);

			if tte.line_delimiter ^= copy_of_tte.line_delimiter
			then call print_line_delimiter ("1"b);
			if tte.keyboard_addressing ^= copy_of_tte.keyboard_addressing
			then call print_kybd_addr;

			if tte.print_preaccess_message ^= copy_of_tte.print_preaccess_message
			then call print_ppm;

			if tte.conditional_printer_off ^= copy_of_tte.conditional_printer_off
			then call print_cpo;
			if tte.old_type ^= copy_of_tte.old_type
			then call print_old_type ("1"b);
			call print_extended_tables ("1"b);
		     end;
		end;

end_of_tte:
	     end;
	end;

	if show_types = SHOW_MATCH & ^found_one		/* we were looking for a specific one and didn't find it */
	then call com_err_ (0, prog_name, "No entry found for type ^a", only_type);

	if show_tables ^= SHOW_NONE			/* not just asking for single type entry, print tables */
	then do;
	     keep_looping = "1"b;
	     found_one = "0"b;
						/* conversion & translation tables */
	     do i = 1 to ttt.n_tables while (keep_looping);
		tablep = addr (ttt.tables (i));

		if show_tables = SHOW_MATCH then do;
		     found = check_for_match_name (table_entry.name, only_table, table_starname_type);
		     if ^found then goto next_ct_table;
		     if found & table_starname_type = STAR_TYPE_USE_PL1_COMPARE then
			keep_looping = "0"b;
		     found_one = "1"b;
		end;

		call ioa_$ioa_switch (iocbp, "^/^-^a_table:  ^a;",
		     table_types (table_entry.type), table_entry.name);
		table_len = CV_TRANS_SIZE (table_entry.version);
		do j = 0 to table_len by 8;
		     call ioa_$ioa_switch (iocbp, "^-^8(^x^3.3b^)^[;^;^]",
			addr (table_entry.value (j)) -> table_array, j = table_len - 7);
		end;
next_ct_table:
	     end;

	     special_tablep = addr (ttt.rest_of_ttt);	/* special_chars tables now */
	     keep_looping = "1"b;
	     do i = 1 to ttt.n_special_tables while (keep_looping);
		specialp = addr (special_tablep -> special_table.special_chars);

		if show_tables = SHOW_MATCH then do;
		     found = check_for_match_name (special_tablep -> special_table.name, only_table, table_starname_type);
		     if ^found then goto next_special;
		     if found & table_starname_type = STAR_TYPE_USE_PL1_COMPARE then
			keep_looping = "0"b;
		     found_one = "1"b;
		end;

		call ioa_$ioa_switch (iocbp, "^/^-special_table:  ^a;", special_tablep -> special_table.name);

		c_chars_length = hbound (specialp -> c_chars.chars, 1);
		do j = 1 to 11;			/* do the standard sequences */
		     call ioa_$ioa_switch (iocbp, "^-^x^a:^[^-^;^2-^]^v(^x^3o^);",
			spec_field (j), j ^= 4, specialp -> seq (j).count,
			specialp -> seq (j).entries (*));
		end;

		sc_escape_len = specialp -> special_chars.escape_length;
		if sc_escape_len > 0
		then do;
		     call ioa_$ioa_switch (iocbp, "^-^xoutput_escapes:");
		     p = addr (specialp -> special_chars.not_edited_escapes);

		     do j = 1 to sc_escape_len;
			n = p -> seq (j).count;
			if n = 0
			then call ioa_$ioa_switch (iocbp, "^-^2x^o^[,^;;^]", j + 16, j < sc_escape_len);
			else call ioa_$ioa_switch (iocbp, "^-^2x^o^v(^x^3o^)^[,^;;^]", j + 16, n,
				addr (p -> seq (j).entries (1)) -> based_seq, j < sc_escape_len);
		     end;

		     call ioa_$ioa_switch (iocbp, "^-^xedited_output_escapes:");
		     p = addr (specialp -> special_chars.edited_escapes);

		     do j = 1 to sc_escape_len;
			n = p -> seq (j).count;
			if n = 0
			then call ioa_$ioa_switch (iocbp, "^-^2x^o^[,^;;^]", j + 16, j < sc_escape_len);
			else call ioa_$ioa_switch (iocbp, "^-^2x^o^v(^x^3o^)^[,^;;^]", j + 16, n,
				addr (p -> seq (j).entries (1)) -> based_seq, j < sc_escape_len);
		     end;

		end;

		sc_input_escape_len = specialp -> special_chars.input_escapes.len;

		if sc_input_escape_len > 0
		then do;
		     call ioa_$ioa_switch (iocbp, "^-^xinput_escapes:");

		     do j = 1 to sc_input_escape_len;
			call ioa_$ioa_switch (iocbp, "^-^2x^3o^x^3o^[,^;;^]",
			     addr (substr (specialp -> special_chars.input_escapes.str, j, 1)) -> based_fb8,
			     addr (substr (specialp -> special_chars.input_results.str, j, 1)) -> based_fb8,
			     j < sc_input_escape_len);
		     end;
		end;

next_special:
		special_tablep = addrel (specialp, divide (length (unspec (specialp -> special_chars)) + 35,
		     36, 18, 0));
	     end;

/* now function key tables */

	     fkey_tablep = ptr (tttp, ttt.fkey_offset);
	     function_key_data_ptr = addr (fkey_table.fkey_data);
	     sourcep = ptr (tttp, fkey_table.seq_offset); /* ptr to sequences */

	     do i = 1 to ttt.n_fkey_tables;

		if show_tables = SHOW_MATCH then do;
		     found = check_for_match_name (fkey_table.name, only_table, table_starname_type);
		     if ^found then go to next_fkey;
		     if found & table_starname_type = STAR_TYPE_USE_PL1_COMPARE then
			keep_looping = "0"b;
		     found_one = "1"b;
		end;

		call ioa_$ioa_switch (iocbp, "^/^-function_key_table:  ^a;", fkey_table.name);
		fkey_seqs_ptr (1) = addr (function_key_data.home (0));
		fkey_seqs_ptr (2) = addr (function_key_data.left (0));
		fkey_seqs_ptr (3) = addr (function_key_data.right (0));
		fkey_seqs_ptr (4) = addr (function_key_data.up (0));
		fkey_seqs_ptr (5) = addr (function_key_data.down (0));

		do j = 1 to 5;			/* go thru home, left, ... */
		     call print_fkey_seqs (sourcep -> function_key_seqs, fkey_seq_names (j), fkey_seqs_ptr (j));
		end;

		do j = 0 to function_key_data.highest;
		     call print_fkey_seqs (sourcep -> function_key_seqs, "key (" || ltrim (char (j)) || ")", addr (function_key_data.function_keys (j, 0)));
		end;

next_fkey:
		fkey_tablep = addrel (fkey_tablep, currentsize (fkey_table) + currentsize (sourcep -> function_key_seqs));
		function_key_data_ptr = addr (fkey_table.fkey_data);
		sourcep = ptr (tttp, fkey_table.seq_offset);
	     end;

	     if show_tables = SHOW_MATCH & ^found_one
	     then call com_err_ (0, prog_name, "table ^a not found.", only_table);
	end;

	if general_tables
	then do;

/* now default_types table */

	     if ttt.default_type_offset ^= 0
	     then do;
		dfttp = ptr (tttp, ttt.default_type_offset);

		if dftt.dft_count > 0
		then do;
		     call ioa_$ioa_switch (iocbp, "^/^/^-default_types:");
		     do i = 1 to dftt.dft_count;
			call ioa_$ioa_switch (iocbp, "^-^x^[any^s^;^d^] ^[any^s^;^a^] ^a^[,^;;^]",
			     dftt.dftte (i).baud = 0, dftt.dftte (i).baud,
			     dftt.dftte (i).line_type = 0, line_types (dftt.dftte (i).line_type),
			     addr (ttt.tt_entries (dftt.dftte (i).term_type_index)) -> tte.name,
			     i < dftt.dft_count);
		     end;
		end;
	     end;

/* now answerback table */

	     answerback_entry_ptr = ptr (tttp, ttt.answerback_offset);

	     do while (rel (answerback_entry_ptr));
		call ioa_$ioa_switch_nnl (iocbp, "^/^-answerback:^3x");
		charx = 1;

		do while (charx <= answerback_entry.def_string.length);
		     if charx > 1
		     then call ioa_$ioa_switch_nnl (iocbp, ", ");

		     ans_spec = answerback_entry.chars (charx);
		     n = addr (answerback_entry.chars (charx + 1)) -> based_fb8;
		     if ans_spec = "m" | ans_spec = "s"
		     then if n < 0
			then do;
			     call ioa_$ioa_switch_nnl (iocbp, "^[match^;^search^] ^[letter^;digit^]",
				ans_spec = "m", -n);
			     charx = charx + 2;
			end;

			else do;
			     call ioa_$ioa_switch_nnl (iocbp, "^[match^;search^] ^a",
				ans_spec = "m",
				requote_string_ (substr (answerback_entry.chars (1), charx + 2, n)));
			     charx = charx + n + 2;
			end;

		     else do;
			n = addr (answerback_entry.chars (charx + 1)) -> based_fb8;
			if ans_spec = "k"
			then call ioa_$ioa_switch_nnl (iocbp, "skip ^d", n);

			else
			     if ans_spec = "i"
			then call ioa_$ioa_switch_nnl (iocbp, "id ^[rest^;^d^]", n = 0, n);

			else call com_err_ (0, prog_name, "Unrecognized answerback specification ^a", ans_spec);

			charx = charx + 2;
		     end;
		end;

		if answerback_entry.term_type_index ^= 0
		then call ioa_$ioa_switch (iocbp, ";^/^-^xtype:  ^a;",
			addr (ttt.tt_entries (answerback_entry.term_type_index)) -> tte.name);

		else call ioa_$ioa_switch (iocbp, ";");

		answerback_entry_ptr = ptr (tttp, answerback_entry.next);
	     end;

	     call print_preaccess_type ("MAP", ttt.type_map);
	     call print_preaccess_type ("963", ttt.type_963);
	     call print_preaccess_type ("029", ttt.type_029);

	     call ioa_$ioa_switch (iocbp, "^/^/^-end;");
	end;

	call clean_up;
	return;
%page;
check_for_match_name: proc (name_to_check, name_to_match, type_match) returns (bit (1));

/* see if this entry matches the name desired by the user */

dcl  name_to_check char (*);				/* name to check for match */
dcl  name_to_match char (*);				/* possible starname to match for */
dcl  type_match fixed bin (2);			/* type of equal match to be made */

dcl  my_code fixed bin (35);

	if type_match = STAR_TYPE_MATCHES_EVERYTHING then
	     my_code = 0;
	else if type_match = STAR_TYPE_USE_MATCH_PROCEDURE then
	     call match_star_name_ (name_to_check, name_to_match, my_code);
	else if type_match = STAR_TYPE_USE_PL1_COMPARE then do;
	     if name_to_check = name_to_match then
		my_code = 0;
	     else my_code = error_table_$nomatch;
	end;

	if my_code = 0 then
	     return ("1"b);
	else return ("0"b);

     end check_for_match_name;
%page;
trace_like_tte_chain: proc (my_ttep);

/* recurse down through all LIKE table entries so we can name who is in the chain */

dcl  my_ttep ptr;

	call ioa_$ioa_switch_nnl (iocbp, "^a", my_ttep -> tte.name);

/* recurse to the next level if this isn't the last one */
	if my_ttep -> tte.like_type ^= 0 then do;
	     call ioa_$ioa_switch_nnl (iocbp, " -> ");
	     call trace_like_tte_chain (addr (ttt.tt_entries (my_ttep -> tte.like_type)));
	end;

     end trace_like_tte_chain;

get_next_arg: proc;

/* gets value of a keyword-value option */

	iarg = iarg + 1;
	key = substr (arg, 2);
	call cu_$arg_ptr (iarg, argp, argl, code);
	if code ^= 0 then
complain:	     call com_err_ (code, prog_name, key);
	else if substr (arg, 1, 1) = "-" then do;
	     code = error_table_$noarg;
	     goto complain;
	end;
	return;

     end /* get_next_arg */;

clean_up: proc;

/* clenup handler and final wrapup */

	file_err = "0"b;
	if opened
	then do;
	     call iox_$close (iocbp, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, prog_name, "Could not close file ^a", output_file);
		file_err = "1"b;
	     end;

	     opened = "0"b;
	end;
	if attached
	then do;
	     call iox_$detach_iocb (iocbp, code);
	     if code ^= 0
	     then if ^file_err
		then call com_err_ (code, prog_name, "Could not detach file ^a", output_file);
	     attached = "0"b;
	end;

	if tttp ^= null
	then call hcs_$terminate_noname (tttp, code);
	return;

     end /* clean_up */;

print_terminal_types: ptt: entry;

/* user command to print names of all terminal types defined in TTT */

dcl  match_name char (32);
dcl  pn_given bit (1);
dcl  ttp_given bit (1);

	ttp_given, pn_given = "0"b;
	using_default_ttt_path = "0"b;
	call cu_$arg_count (nargs);
	do iarg = 1 to nargs;
	     call cu_$arg_ptr (iarg, argp, argl, code);
	     if arg = "-pn" | arg = "-pathname" then do;
		if pn_given then do;
		     call com_err_ (error_table_$wrong_no_of_args, com_name, "Only one ttt pathname allowed");
		     return;
		end;
		call expand_pathname_$add_suffix (arg, "ttt", ttt_dir, ttt_ent, code);
		if code ^= 0 then do;
		     call com_err_ (code, com_name, arg);
		     return;
		end;
		pn_given = "1"b;
	     end;
	     else if arg = "-ttp" | arg = "-terminal_type" then do;
		if ttp_given then do;
		     call com_err_ (error_table_$wrong_no_of_args, com_name, "Only one -match name allowed");
		     return;
		end;
		call get_next_arg;
		if code ^= 0 then return;
		match_name = translate (arg, all_caps, all_lowercase);
		ttp_given = "1"b;
	     end;
	     else do;
		if ttp_given then do;
		     call com_err_ (error_table_$wrong_no_of_args, com_name, "Only one -match name allowed");
		     return;
		end;
		match_name = translate (arg, all_caps, all_lowercase);
		ttp_given = "1"b;
	     end;
	end;

	if ^pn_given then do;
	     using_default_ttt_path = "1"b;
	     call ttt_info_$ttt_path (ttt_dir, ttt_ent);
	end;

	call hcs_$initiate (ttt_dir, ttt_ent, "", 0, 1, tttp, code);
	if tttp = null then do;
	     call com_err_ (code, com_name, "Could not initiate ^a>^a", ttt_dir, ttt_ent);
	     return;
	end;

	if using_default_ttt_path then
	     if ttt_dir ^= SYS_DIR | ttt_ent ^= "ttt" then
		call ioa_ ("Using ^a>^a", ttt_dir, ttt_ent);

	do i = 1 to ttt.n_tt_entries;
	     if ^ttp_given then
		code = 0;
	     else call match_star_name_ (ttt.tt_entries (i).name, match_name, code);
	     if code = 0 then
		call ioa_ ("^-^a", ttt.tt_entries (i).name);
	end;

	return;

/* various internal procedures for outputting parts of a terminal type entry
   *
   *  many of these take a bit(1) argument indicating whether or not the entry being processed
   *  is "like" another entry. If this bit is on, the field is always printed out;
   *  otherwise, it is only printed if it has a non-default value
*/


print_modes: proc;

	if tte.modes ^= "" then
	     call ioa_$ioa_switch (iocbp, "^-^xmodes:  ^a;", tte.modes);
	return;
     end /* print_modes */;


print_str: proc (title, source, like);

dcl  title char (*);
dcl  1 source aligned,
       2 offset fixed bin (18),
       2 len fixed bin;

dcl  like bit (1);

dcl  code_len fixed bin;
dcl  stringp ptr;
dcl  stringl fixed bin;
dcl  cur fixed bin;
dcl  lb bit (1);
dcl  (i, j) fixed bin;
dcl  work char (2500) var;
dcl  temp char (16) var;
dcl  str char (stringl) based (stringp);

/* there is no string defined or it is LIKEd to another string */
	if source.offset = 0 then
	     if like then
		call ioa_$ioa_switch (iocbp, "^-^x^a:  ;", title);
	     else ;

/* string is defined */
	else do;
	     stringp = ptr (tttp, source.offset);
	     stringl = source.len;
	     code_len = addr (substr (str, source.len + 1, 2)) -> based_fb17;

/* all chars in string are printable chars */
	     if code_len = 0 then
		call ioa_$ioa_switch (iocbp, "^-^x^a:  ^a;", title, requote_string_ (str));

/* some of chars in string are no printable but there are no replication factors */
	     else if code_len = -1 then do;
		work = "";
		do i = 1 to source.len;
		     call count_text;		/* scan for printable chars */
		     if j > 1 then do;		/* if any, print them as they are */
			work = work || requote_string_ (substr (str, i, j));
			i = i + j - 1;
		     end;

/* else convert to printable value */
		     else work = work || tchar (substr (str, i, 1));
		     work = work || " ";
		end;
		call ioa_$ioa_switch (iocbp, "^-^x^a:  ^a;", title, work);
	     end;

/* there are replication factors defined in the encoded string */
	     else do;
		work = "";
		stringp = addr (substr (str, source.len + 2));

		lb = "0"b;
		do i = 1 to code_len;
		     cur = rank (substr (str, i, 1));
		     if cur > 255 then do;		/* coded value */
			cur = addr (substr (str, i, 1)) -> based_fb17;
/*			cur = cur - 512;		/* use negative for coded values */
			i=i+1;
		     end;
		     if cur >= 0 then do;		/* real octal char value */
			if ^lb then
			     work = work || " ";
			call count_text;
			if j > 1 then do;
			     work = work || requote_string_ (substr (str, i, j));
			     i = i + j - 1;
			end;
			else work = work || tchar (byte (cur));
		     end;

		     else if cur = -1 then
			work = work || ">";

		     else do;
			if ^lb then
			     work = work || " ";
			call ioa_$rsnnl ("(^d) <", temp, (0), -cur);
			work = work || temp;
		     end;

		     lb = (cur < -1);
		end;

		call ioa_$ioa_switch (iocbp, "^-^x^a:  ^a;", title, work);
	     end;
	end;

	return;

count_text: proc;

	     do j = i to source.len
		while (rank (substr (str, j, 1)) >= 32 & rank (substr (str, j, 1)) <= 126);
	     end;
	     j = j - i;
	     return;

	end count_text;

     end /* print_str */;


print_all_delays: proc;

	if tte.delay_rp = 0
	then return;

	delay_tablep = ptr (tttp, tte.delay_rp);

	call ioa_$ioa_switch_nnl (iocbp, "^-^xbauds:^2-");
	do i = 1 to delay_table.n_bauds;
	     call ioa_$ioa_switch_nnl (iocbp, "^[ other^;^6d^]", delay_table.baud_rate (i) = 0,
		delay_table.baud_rate (i));
	end;
	call ioa_$ioa_switch (iocbp, ";");

	do delayx = 1 to 6;
	     call print_delay (delayx);
	end;

	return;
     end /* print_all_delays */;


print_delay: proc (delayx);

dcl  delayx fixed bin;

	n = delay_table.n_bauds;
	if delayx = 2 | delayx = 4			/* floating-point type */
	then call ioa_$ioa_switch (iocbp, "^-^x^a_delays:^-^v(^6.3f^);", delay_name (delayx), n,
		float_delays.array (*).delays (delayx));

	else call ioa_$ioa_switch (iocbp, "^-^x^a_delays:^-^v(^6d^);", delay_name (delayx), n,
		delay_table.delay_array (*).delays (delayx));

	return;
     end /* print_delay */;


print_table: proc (tablex, like);

dcl  tablex fixed bin;
dcl  like bit (1);

	if table_offset (tablex) = 0
	then if like
	     then call ioa_$ioa_switch (iocbp, "^-^x^a:  ;", table_name (tablex));
	     else ;

	else call ioa_$ioa_switch (iocbp, "^-^x^a:  ^a;", table_name (tablex),
		ptr (tttp, table_offset (tablex)) -> table_entry.name);
	return;
     end /* print_table */;


print_line_types: proc (like);

dcl  like bit (1);
dcl  line_type_str char (168);

	if tte.line_types = (72)"1"b & ^like
	then return;

	line_type_str = "";
	do i = 1 to max_line_type;
	     if substr (tte.line_types, i, 1)
	     then call ioa_$rsnnl ("^a, ^a", line_type_str, n, line_type_str, line_types (i));
	end;

	substr (line_type_str, 1, 1) = " ";		/* get rid of first comma */
	call ioa_$ioa_switch (iocbp, "^-^xline_types:  ^a;", line_type_str);
	return;
     end /* print_line_type */;


print_protocol: proc (like);

dcl  like bit (1);

	if tte.protocol = NO_PROTOCOL & ^like
	then return;

	call ioa_$ioa_switch (iocbp, "^-^xprotocol:  ^a;", protocol_names (tte.protocol));
	return;

     end /* print_protocol */;

print_erase: proc (like);

dcl  like bit (1);

	if tte.erase = "#" & ^like
	then return;

	call ioa_$ioa_switch (iocbp, "^-^xerase: ^a;", tchar (tte.erase));
	return;
     end /* print_erase */;


print_kill: proc (like);

dcl  like bit (1);

	if tte.kill = "@" & ^like
	then return;

	call ioa_$ioa_switch (iocbp, "^-^xkill: ^a;", tchar (tte.kill));
	return;
     end /* print_kill */;


print_frame: proc (like);

dcl  like bit (1);

	if addr (tte.framing_chars) -> based_bit18 = "0"b & ^like /* default */
	then return;

	call ioa_$ioa_switch (iocbp, "^-^xframing_chars: ^a ^a;",
	     tchar (tte.frame_begin), tchar (tte.frame_end));
	return;
     end /* print_frame */;

print_ifc:
     proc (like);

dcl  like bit (1);

	if tte.input_suspend ^= NUL | like
	then call ioa_$ioa_switch (iocbp, "^-^xinput_suspend: ^3.3b;",
		addr (tte.input_suspend) -> based_bit9);

	if tte.input_resume ^= NUL | like
	then call ioa_$ioa_switch (iocbp, "^-^xinput_resume: ^3.3b^[, timeout^;^];",
		addr (tte.input_resume) -> based_bit9, tte.input_timeout);

	return;
     end /* print_ifc */;


print_ofc:
     proc (like);

dcl  like bit (1);

	if addr (tte.output_suspend_etb) -> based_bit18 = "0"b & ^like
	then return;

	call ioa_$ioa_switch (iocbp, "^-^xoutput_^[end_of_block^;suspend^]: ^3.3b;",
	     tte.output_block_acknowledge, addr (tte.output_suspend_etb) -> based_bit9);

	call ioa_$ioa_switch (iocbp, "^-^xoutput_^[acknowledge^;resume^]: ^3.3b;",
	     tte.output_block_acknowledge, addr (tte.output_resume_ack) -> based_bit9);

	if tte.output_buffer_size > 0 & tte.output_block_acknowledge
	then call ioa_$ioa_switch (iocbp, "^-^xbuffer_size: ^d;",
		tte.output_buffer_size);

     end /* print_ofc */;


print_line_delimiter:
     proc (like);

dcl  like bit (1);

	if tte.line_delimiter = low (1) & ^like then return;
	call ioa_$ioa_switch (iocbp, "^-^xline_delimiter: ^3.3b;",
	     addr (tte.line_delimiter) -> based_bit9);
     end;

print_all_flags: proc;

	if tte.keyboard_addressing
	then call ioa_$ioa_switch (iocbp, "^-^xkeyboard_addressing: yes;");

	if tte.print_preaccess_message
	then call ioa_$ioa_switch (iocbp, "^-^xprint_preaccess_message: yes;");

	if tte.conditional_printer_off
	then call ioa_$ioa_switch (iocbp, "^-^xconditional_printer_off: yes;");

	return;
     end /* print_all_flags */;


print_old_type: proc (like);

dcl  like bit (1);

	if tte.old_type <= 0 & ^like
	then return;

	call ioa_$ioa_switch (iocbp, "^-^xold_type: ^d;", tte.old_type);
	return;
     end /* print_old_type */;


print_kybd_addr: proc;

	call ioa_$ioa_switch (iocbp, "^-^xkeyboard_addressing: ^[yes^;no^];", tte.keyboard_addressing);
	return;
     end /* print_kybd_addr */;


print_ppm: proc;

	call ioa_$ioa_switch (iocbp, "^-^xprint_preaccess_message: ^[yes^;no^];", tte.print_preaccess_message);
	return;
     end /* print_ppm */;


print_cpo: proc;

	call ioa_$ioa_switch (iocbp, "^-^xconditional_printer_off: ^[yes^;no^];", tte.conditional_printer_off);
	return;
     end /* print_cpo */;


print_preaccess_type: proc (name, idx);

dcl  name char (*);
dcl  idx fixed bin;

	if idx > 0 then do;
	     ttep = addr (ttt.tt_entries (idx));
	     call ioa_$ioa_switch (iocbp, "^/^-preaccess_command: ^a;^/^-^xtype: ^a;",
		name, tte.name);
	end;

	return;

     end /* print_preaccess_type */;

/* procedures for printing various extended tables */

print_extended_tables: proc (like);

dcl  like bit (1);
dcl  like_extended_tablesp ptr;
dcl  ntables fixed bin;
dcl  i fixed bin;

	ntables = min (hbound (print_extended_table, 1), extended_tables_ntables);
	if tte.extended_tables_rp = 0 then extended_tablesp = null ();
	else extended_tablesp = ptr (tttp, tte.extended_tables_rp);

	if like then
	     if copy_of_tte.extended_tables_rp = 0 then like_extended_tablesp = null ();
	     else like_extended_tablesp = ptr (tttp, copy_of_tte.extended_tables_rp);
	else like_extended_tablesp = null ();

	if extended_tablesp = null () then do;		/* this type has no extended tables */
	     if like_extended_tablesp = null () then return;
	     do i = 1 to min (ntables, like_extended_tablesp -> extended_tables.ntables);
		if like_extended_tablesp -> extended_tables.tables_rp (i) ^= 0 then
		     call print_extended_table (i) (0);
	     end;
	     return;
	end;

	if like_extended_tablesp = null then do;	/* not like a terminal type with tables */
	     do i = 1 to min (ntables, extended_tables.ntables);
		if extended_tables.tables_rp (i) ^= 0 then
		     call print_extended_table (i) (extended_tables.tables_rp (i));
	     end;
	     return;
	end;

/* both this type and the like type have tables.  Print only differences */

	do i = 1 to min (ntables, extended_tables.ntables);
	     if extended_tables.tables_rp (i) ^= like_extended_tablesp -> extended_tables.tables_rp (i) then
		call print_extended_table (i) (extended_tables.tables_rp (i));
	end;
	return;

     end print_extended_tables;

print_dsa_table: proc (dsa_rp);

dcl  dsa_rp fixed bin (18);
dcl  i fixed bin;
dcl  j fixed bin;

	call ioa_$ioa_switch (iocbp, "^-^xdsatm_device:^[ ;^]", (dsa_rp = 0));
	if dsa_rp = 0 then return;
	dsatmdevp = ptr (tttp, dsa_rp);

	do i = lbound (dsatm_device.dpp, 1) to hbound (dsatm_device.dpp, 1);
	     if dsatm_device.dpp (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tdata_presentation: ^a;", DPP_NAME (dsatm_device.dpp (i)));
	end;

	do i = lbound (dsatm_device.sdp_dpp.sdp_class, 1) to
	     hbound (dsatm_device.sdp_dpp.sdp_class, 1);
	     if dsatm_device.sdp_dpp.sdp_class (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tsdp_class: ^a;", SC_NAME (dsatm_device.sdp_dpp.sdp_class (i)));
	end;

	do i = lbound (dsatm_device.real_dpp.real_class, 1) to
	     hbound (dsatm_device.real_dpp.real_class, 1);
	     if dsatm_device.real_dpp.real_class (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13treal_class: ^a;", RC_NAME (dsatm_device.real_dpp.real_class (i)));
	end;

	if dsatm_device.dev_id > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tdevice_id: ^d;", dsatm_device.dev_id);

	if dsatm_device.dev_type > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tdevice_type: ^a;", DT_NAME (dsatm_device.dev_type));

	if dsatm_device.shareability > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tshareability: ^a;", SH_NAME (dsatm_device.shareability));

	j = 0;
	do i = 0 to 9 while (j = 0);
	     if substr (string (dsatm_device.alloc_unit), i) = "1"b then
		j = i;
	end;
	if j > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tallocation_unit: ^a;", AU_NAME (j));

	if dsatm_device.line_overflow > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tline_overflow: ^a;", LO_NAME (dsatm_device.line_overflow));

	if dsatm_device.page_overflow > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tpage_overflow: ^a;", PO_NAME (dsatm_device.page_overflow));

	do i = lbound (dsatm_device.char_encoding, 1) to
	     hbound (dsatm_device.char_encoding, 1);
	     if dsatm_device.char_encoding (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tcharacter_encoding: ^a;", CE_NAME (dsatm_device.char_encoding (i)));
	end;

	do i = lbound (dsatm_device.char_set, 1) to
	     hbound (dsatm_device.char_set, 1);
	     if dsatm_device.char_set (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tcharacter_set: ^a;", CS_NAME (dsatm_device.char_set (i)));
	end;

	do i = lbound (dsatm_device.char_subset, 1) to
	     hbound (dsatm_device.char_subset, 1);
	     if dsatm_device.char_subset (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tcharacter_subset: ^a;", CSS_NAME (dsatm_device.char_subset (i)));
	end;

	do i = lbound (dsatm_device.nat_lang, 1) to
	     hbound (dsatm_device.nat_lang, 1);
	     if dsatm_device.nat_lang (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tnational_language: ^a;", NL_NAME (dsatm_device.nat_lang (i)));
	end;

	do i = lbound (dsatm_device.compression, 1) to
	     hbound (dsatm_device.compression, 1);
	     if dsatm_device.compression (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tcompression_algorithm: ^a;", CA_NAME (dsatm_device.compression (i)));
	end;

	do i = lbound (dsatm_device.char_font, 1) to
	     hbound (dsatm_device.char_font, 1);
	     if dsatm_device.char_font (i) > 0 then
		call ioa_$ioa_switch (iocbp, "^13tcharacter_font: ^a;", CF_NAME (dsatm_device.char_font (i)));
	end;

	if dsatm_device.max_rec_size > 0 then
	     call ioa_$ioa_switch (iocbp, "^13tmax_record_size: ^d;", dsatm_device.max_rec_size);


	i = 1;					/* get attention keys			*/
	do while (i <= 2);
	     if dsatm_device.attentions.attn (i).invocation.break then
		call ioa_$ioa_switch (iocbp, "^13t^[attd;att1^]: BREAK;", (i = 1));
	     if dsatm_device.attentions.attn (i).invocation.sec_dialog then
		call ioa_$ioa_switch (iocbp, "^13t^[attd;att1^]: SEC_DIALOG;", (i = 1));
	     if dsatm_device.attentions.attn (i).invocation.string then
		call ioa_$ioa_switch (iocbp, "^13t^[attd;att1^]: ^a;", dsatm_device.attentions.attn (i).string_value (1));
	     i = i + 1;
	end;

	if dsatm_device.stc_available then
	     call ioa_$ioa_switch (iocbp, "^13tstc_available: YES;");

	return;

     end print_dsa_table;

print_video_table: proc (video_rp);

dcl  video_rp fixed bin (18);
dcl  i fixed bin;

	call ioa_$ioa_switch (iocbp, "^-^xvideo_info:^[ ;^]", (video_rp = 0));
	if video_rp = 0 then return;
	ttyvtblp = ptr (tttp, video_rp);
	video_chars_ptr = addr (tty_video_table.video_chars);

	if tty_video_table.screen_height ^= 0 then
	     call ioa_$ioa_switch (iocbp, "^13tscreen_height: ^d;", tty_video_table.screen_height);
	if tty_video_table.screen_line_length ^= 0 then
	     call ioa_$ioa_switch (iocbp, "^13tscreen_line_length: ^d;", tty_video_table.screen_line_length);
	if tty_video_table.scroll_count ^= 0 then
	     call ioa_$ioa_switch (iocbp, "^13tscroll_count: ^d;", tty_video_table.scroll_count);

	do i = 1 to min (hbound (video_seq_names, 1), tty_video_table.nseq);
	     call print_seq (i);
	end;

	return;

     end print_video_table;

print_seq: proc (seqx);

dcl  seqx fixed bin;

dcl  i fixed bin;
dcl  p ptr;
dcl  cpad_to_print fixed bin (35);
dcl  cpad_units char (3);
dcl  1 test_numeric_encoding like tty_numeric_encoding automatic;

	ttyvseqp = addr (tty_video_table.sequences (seqx));
	if ^tty_video_seq.present then return;
	call ioa_$ioa_switch_nnl (iocbp, "^13t^a:^29t", video_seq_names (seqx));
	p = addr (test_numeric_encoding);
	do i = tty_video_seq.seq_index to tty_video_seq.seq_index + tty_video_seq.len - 1;
	     unspec (test_numeric_encoding) = unspec (substr (video_chars, i, min (2, length (video_chars) - i + 1)));
	     if p -> tty_numeric_encoding.must_be_on then do;
		call ioa_$ioa_switch_nnl (iocbp, " (^[decimal ^]^[octal ^]^[^d ^;^s^]^[LINE^;COLUMN^;N^]",
		     p -> tty_numeric_encoding.express_in_decimal,
		     p -> tty_numeric_encoding.express_in_octal,
		     (p -> tty_numeric_encoding.num_digits ^= 0),
		     p -> tty_numeric_encoding.num_digits,
		     p -> tty_numeric_encoding.l_c_or_n + 1);
		if ^p -> tty_numeric_encoding.offset_is_0 then
		     if p -> tty_numeric_encoding.offset < 0 then
			call ioa_$ioa_switch_nnl (iocbp, " - ^a", tchar (byte (-p -> tty_numeric_encoding.offset)));
		     else call ioa_$ioa_switch_nnl (iocbp, " + ^a", tchar (byte (+p -> tty_numeric_encoding.offset)));
		call ioa_$ioa_switch_nnl (iocbp, ")");
		if ^p -> tty_numeric_encoding.offset_is_0 then
		     i = i + 1;
	     end;
	     else call ioa_$ioa_switch_nnl (iocbp, " ^a", tchar (substr (video_chars, i, 1)));
	end;
	if tty_video_seq.cpad_present then do;
	     if tty_video_seq.cpad_in_chars then do;
		cpad_to_print = tty_video_seq.cpad;
		cpad_units = "";
	     end;
	     else if mod (tty_video_seq.cpad, 10) = 0 then do;
		cpad_to_print = divide (tty_video_seq.cpad, 10, 17, 0);
		cpad_units = " ms";
	     end;
	     else do;
		cpad_to_print = tty_video_seq.cpad * 100;
		cpad_units = " us";
	     end;
	     call ioa_$ioa_switch_nnl (iocbp, ", pad ^d^a", cpad_to_print, cpad_units);
	end;

	call ioa_$ioa_switch (iocbp, ";");
	return;

     end print_seq;

print_function_key_table: proc (function_key_rp);

dcl  function_key_rp fixed bin (18);

	return;

     end print_function_key_table;

print_fkey_seqs: proc (seqs, seqs_name, temp_key_infop);

dcl  seqs char (*);
dcl  seqs_name char (*);
dcl  (i, j, highest) fixed bin;

dcl  temp_key_index fixed bin;
dcl  temp_key_infop ptr;
dcl  1 temp_key_info (0:3) aligned based (temp_key_infop) like key_info;

	highest = highest_defined ();
	if highest < 0 then return;			/* no seqs defined for this fcn key */
	call ioa_$ioa_switch_nnl (iocbp, "^2-^a:  ", seqs_name);
	do temp_key_index = 0 to highest;

	     do i = 0 to temp_key_info (temp_key_index).sequence_length - 1;
		j = temp_key_info (temp_key_index).sequence_index + i;
		call ioa_$ioa_switch_nnl (iocbp, "^[ ^]^a", i ^= 0, tchar (substr (seqs, j, 1)));
	     end;

	     if temp_key_index < highest
	     then call ioa_$ioa_switch_nnl (iocbp, ", ");

	end;

	call ioa_$ioa_switch (iocbp, ";");
	return;

highest_defined: proc returns (fixed bin);

	     do temp_key_index = 3 to 0 by -1;
		if temp_key_info (temp_key_index).sequence_length > 0
		then return (temp_key_index);
	     end;
	     return (-1);

	end highest_defined;

     end print_fkey_seqs;

/* return prettyest representation of a character */

tchar: proc (c) returns (char (4) var);

dcl  c char (1);
dcl  i fixed bin;
dcl  temp char (4);

dcl  asc_value (0:32) char (3) static options (constant) init
	("NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
	"BS ", "TAB", "LF ", "VT ", "FF ", "CR ", "SO ", "SI ",
	"DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
	"CAN", "EM ", "SUB", "ESC", "FS ", "GS ", "RS ", "US ", "SP ");

	i = rank (c);
	if i <= hbound (asc_value, 1) then return (rtrim (asc_value (i)));
	if i > 126 then do;
	     call ioa_$rsnnl ("^o", temp, (0), i);
	     return (temp);
	end;
	if index ("0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ", c) > 0 then return (c);
	if c = """" then return ("""""""""");
	else return ("""" || c || """");

     end tchar;

%include ttt;

%include term_type_protocols;

%include author_dcl;

%include line_types;

%include tty_video_tables;

%include function_key_data;
%page;
%include dsatm_negotiate_info;
%include dsatm_attn_fcn_info;
%include check_star_name;

     end /* display_ttt */;



		    dprint.pl1                      10/28/88  1348.6rew 10/28/88  1257.4      227790


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


/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to call object_lib_$initiate to check if a file is an object
     segment or MSF instead of calling object_info_.
  2) change(88-10-24,Brunelle), approve(88-10-24,MCR7911),
     audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199):
     Dprint_arg_version_7 removed from declaration in program because now
     defined in dprint_arg include file.
                                                   END HISTORY COMMENTS */


/* dprint and dpunch commands: request the I/O daemon to print or punch a segment */

/* Initially coded in April 1969 by V. Voydock */
/* Modified on February 12, 1970 at 5:50 P. M. by V. Voydock */
/* Modified by Nate Adleman on December 20, 1969 at 1123 to add the no_questions entry which does not ask the user
	any questions */
/* Modified for punching by M A Padlipsky April 1970 */
/* Modified by M. Weaver 22 April 1970--added  test_init1 entry for on-line testing */
/* Modified by E. Stone 10/21/70 to add the call to com_query_ */
/* Modified by Dennis Capps 11/02/71 to change the call to com_query_ to a call to command_query_ */
/* Modified by M. Weaver 15 January 1971 22:30 */
/* Modified by Paul Green on January 23, l971 to clean up the incredible mess, and to add the number_of_copies feature */
/* Modified April 1973 by R. S. Coren to interface through dprint_ using message segments, and to add the -destination
	and -queue control arguments */
/* Modified October 1973 by Robert S. Coren to accept -device_class control argument and handle submission errors more
	cleanly */
/* Modified by J. Stern 3/11/75 to add -request_type control arg */
/* Bug with -bf at end of line fixed 12/8/75 Steve Herbst */
/* Changed not to query in most error cases 10/18/76 S. Herbst */
/* Modified by J. C. Whitmore, 5/78, for new dprint_arg structure during Daemon upgrade, bug fixes and removal of -dvc */
/* Modified to reject object segments by S. Herbst, 10/25/78 */
/* Modified to allow object segments to be punched, but not printed 02/03/79 W. Olin Sibert */
/* Modified: 8 March 1981 by G. Palter to ignore error_table_$no_s_permission, accept "-ind" for "-indent" and do some
	minor cleanup of the code */
/* Modified: 10 April 1981 by G. Palter to allow request type names longer than 8 characters */
/* Modified: 8 September 1981 by G. Palter to accept -forms control argument */
/* Modified: June 1982 by R. Kovalcik to accept -defer_until_process_termination */
/* Modified: 84-11-01 by EJ Sharpe for new mdc_$get_lv_access arglist, also
     		create internal dprint_arg_version_7 constant since include
		file has been upgraded to version 8 */

dprint:
dp:  procedure () options (variable);


	dcl     count		 fixed bin;	/* number of segs already queued by this invocation */
	dcl     indx		 fixed bin;
	dcl     lng		 fixed bin;
	dcl     lcnt		 fixed bin;	/* number of realready quests already queued */
	dcl     nargs		 fixed bin;
	dcl     i			 fixed bin;
	dcl     queue		 fixed bin;
	dcl     mode		 bit (36) aligned;
	dcl     pub_bit		 bit (1) aligned;	/* Public flag returned from mdc_$get_lv_access */
	dcl     code		 fixed bin (35);
	dcl     bc		 fixed bin (24);	/* for bit count of MSF component */
	dcl     fcbp		 ptr;
	dcl     dum		 ptr;		/* dummy pointer arg */

	dcl     max_queues		 fixed bin int static options (constant) init (4);
	dcl     MAX_PAGE_WIDTH	 fixed bin int static options (constant) init (136); /* For prt300, etc. */
	dcl     io_coord		 char (16) int static options (constant) init ("IO.SysDaemon");

	dcl     (addr, index, length, max, null, substr, fixed, rtrim, string) builtin;

	dcl     cleanup		 condition;

	dcl     punching		 initial ("0"b) bit (1); /* punch or print? */
	dcl     no_questions	 initial ("0"b) bit (1); /* mainly for use by daemons */

	dcl     control_arg		 bit (1);		/* last arg was a control arg */
	dcl     some_path		 bit (1);		/* some pathname in command line */
	dcl     brief		 bit (1);		/* for brief option */
	dcl     top_lbl_sw		 bit (1);
	dcl     bottom_lbl_sw	 bit (1);
	dcl     access_lbl_sw	 bit (1);

	dcl     (del_acc, r_acc)	 bit (1) aligned;
	dcl     s_acc		 bit (1) aligned;

	dcl     access_class	 bit (72) aligned;
	dcl     access_label	 char (136);

	dcl     accname		 character (32);
	dcl     generic_type	 char (32);
	dcl     rqt_gen_type	 char (32);
	dcl     last_arg		 char (32);

	dcl     argptr		 ptr;
	dcl     seg_ptr		 ptr;
	dcl     based_arg		 char (lng) based (argptr) unaligned;
	dcl     arg		 char (32) aligned;
	dcl     ans		 char (12) varying;

	dcl     question		 char (132);
	dcl     quest_len		 fixed bin;

	dcl     dname		 char (168);	/* directory in which segment to be printed lies */
	dcl     ename		 char (32);	/* entry name of segment to be printed */
	dcl     lvname		 char (32);
	dcl     suf		 char (1) aligned;
	dcl     id		 char (6) aligned;

	dcl     (error_table_$lock_wait_time_exceeded, error_table_$dirseg, error_table_$no_s_permission, error_table_$noentry,
	        error_table_$nostars, error_table_$moderr, error_table_$badopt, error_table_$notalloc, error_table_$id_not_found,
	        error_table_$zero_length_seg)
				 fixed binary (35) external;

	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin);
	dcl     dprint_		 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     dprint_$check_daemon_access entry (character (*), character (*), character (*), bit (1) aligned, bit (1) aligned,
				 bit (1) aligned, character (*), fixed binary (35));
	dcl     dprint_$queue_contents entry (character (*), fixed binary, fixed binary, fixed binary (35));
	dcl     check_star_name_$entry entry (char (*), fixed bin (35));
	dcl     cu_$arg_ptr		 ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_count	 entry (fixed bin, fixed binary (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     (com_err_, com_err_$suppress_name) entry options (variable);
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$ioa_stream	 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     command_query_	 entry options (variable);
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     hcs_$get_access_class	 entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     mdc_$find_lvname	 entry (bit (36), char (*), fixed bin (35));
	dcl     mdc_$get_lv_access	 entry (char (*), fixed bin (3), bit (36) aligned, bit (1) aligned, fixed bin (35));
	dcl     iod_info_$generic_type entry (char (*), char (32), fixed bin (35));
	dcl     msf_manager_$open	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     msf_manager_$close	 entry (ptr);
	dcl     msf_manager_$get_ptr	 entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));

	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	dcl     object_lib_$initiate	 entry (char (*), char (*), char (*), bit (1), ptr, fixed bin (24), bit (1), fixed bin (35));

%include dprint_arg;

%include query_info;

%include branch_status;

/* dprint: dp: procedure () options (variable); */

	queue = 0;				/* we want the default queue */
	go to start_1;


no_questions:
     entry () options (variable);
	no_questions = "1"b;
	queue = 0;				/* want the default queue */
	go to start_1;


dp1: entry () options (variable);
	queue = 1;
	go to start_1;

dp2: entry () options (variable);
	queue = 2;
	go to start_1;

dpunch:
dpn: entry () options (variable);
	punching = "1"b;
	queue = 0;				/* again the default queue */
	go to start_1;

dpn1: entry () options (variable);
	punching = "1"b;
	queue = 1;
	go to start_1;

dpn2: entry () options (variable);
	punching = "1"b;
	queue = 2;


start_1:	call init_variables;			/* get everything set up */

	if punching then do;
		dprint_arg.pt_pch = 2;		/* indicate to dprint_ that its a punch request */
		dprint_arg.output_module = 3;		/* assume mcc format as a default */
		generic_type,
		     dprint_arg.request_type = "punch";
		id = "dpunch";
	     end;
	else do;
		dprint_arg.pt_pch = 1;		/* otherwise this is a print request */
		dprint_arg.output_module = 1;
		generic_type,
		     dprint_arg.request_type = "printer";
		id = "dprint";
	     end;


	on cleanup begin;
		if fcbp ^= null then call msf_manager_$close (fcbp);
	     end;

	call cu_$arg_count (nargs, code);		/* check if called as a command also */
	if code ^= 0 then do;
		call com_err_ (code, id);
		return;
	     end;

	do indx = 1 to nargs;
	     call cu_$arg_ptr (indx, argptr, lng, code);	/* get args, one at a time */
	     arg = based_arg;			/* copy into temp for option testing */

	     if index (based_arg, "-") = 1 then call process_control_arg;
	     else do;				/* Process path name */
		     some_path = "1"b;
		     control_arg = "0"b;		/* seen a pathname since last control arg */
		     call expand_pathname_ (based_arg, dname, ename, code);
		     if code ^= 0 then do;
			     call com_err_ (code, id, "^a", based_arg);
			     go to no_request;
			end;
		     else do;
			     call check_star_name_$entry (ename, code);
			     if code ^= 0 then do;
				     if code <= 2 then /* a legal star name */
					code = error_table_$nostars;
				     call com_err_ (code, id, "^a^[>^]^a", dname, (dname ^= ">"), ename);
				     go to no_request;
				end;
			     else do;
						/* See if file to be printed exists */
				     call hcs_$status_long (dname, ename, 1, addr (branch_status), null, code);
				     if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
					     call com_err_ (code, id, "^a^[>^]^a", dname, (dname ^= ">"), ename);
no_request:				     call com_err_$suppress_name (0, id, "Request not submitted.");
					end;
				     else do;

/* Make sure it's not an object segment. */

					     if ^punching then do;
						     call object_lib_$initiate (dname, ename, "", "1"b, seg_ptr, (0), (""b), code);
						     if seg_ptr ^= null then do;
							     call hcs_$terminate_noname (seg_ptr, (0)); /* we're done with it */
							     call com_err_ (0, id, "^a^[>^]^a is an object segment.",
								dname, (dname ^= ">"), ename);
							     go to no_request;
							end;
						end;

/* Check that user has access, length nonzero, public volume */

					     if ^substr (branch_status.mode, 2, 1) then do; /* check "r" access */
						     code = error_table_$moderr;
CALL_COM:						     call com_err_ (code, id, "^a^[>^]^a", dname, (dname ^= ">"), ename);
						     go to no_request;
						end;

					     dprint_arg.bit_count = 0; /* start with no length */

					     if branch_status.type = directory_type then do; /* directory or MSF */
						     if branch_status.bit_count = "0"b then do; /* a directory */
							     code = error_table_$dirseg;
							     go to CALL_COM;
							end;

/*				For the MSF case, get the total bit count of the file */

						     call msf_manager_$open (dname, ename, fcbp, code);
						     if code ^= 0 then go to CALL_COM;

						     do i = 0 to fixed (branch_status.bit_count, 17, 0) - 1;
							bc = 0;
							call msf_manager_$get_ptr (fcbp, i, "0"b, dum, bc, code);
							if code ^= 0 then go to CALL_COM;
							dprint_arg.bit_count = dprint_arg.bit_count + bc; /* add the bit count */
						     end;

						     call msf_manager_$close (fcbp);
						     fcbp = null;
						end;
					     else dprint_arg.bit_count = fixed (branch_status.bit_count, 24);

					     if dprint_arg.bit_count = 0 then do;
						     code = error_table_$zero_length_seg;
						     go to CALL_COM;
						end;

/* Check that the volume is public. */
					     call mdc_$find_lvname (branch_status.lvid, lvname, code);
					     if code ^= 0 then go to CALL_COM;
					     call mdc_$get_lv_access (lvname, 1, mode, pub_bit, code);
					     if code ^= 0 then go to CALL_COM; /* The daemon driver won't mount it */
					     if ^pub_bit then do;
						     call com_err_ (0, id, "^a^[>^]^a is not on a public volume.",
							dname, (dname ^= ">"), ename);
						     go to no_request;
						end;

/* find out if daemon has access to the segment. If not, warn the user */

					     call dprint_$check_daemon_access (dname, ename, dprint_arg.request_type, del_acc,
						r_acc, s_acc, accname, code);
					     if code ^= 0 then /* We couldn't figure it out. */
						call com_err_ (0, id, "Warning: Unable to check IO daemon access to ^a^[>^]^a",
						     dname, (dname ^= ">"), ename);
					     else do;
						     if ^r_acc then do;
							     call com_err_ (0, id, "^a requires r access to ^a^[>^]^a",
								accname, dname, (dname ^= ">"), ename);
							     go to no_request;
							end;
						     if ^s_acc then
							call ask ("^a does not have status access on ^a^s");
						     if ^del_acc & (dprint_arg.delete ^= 0) then
							call com_err_ (0, "Warning", "^a has insufficient access to delete ^a^[>^]^a",
							     io_coord, dname, (dname ^= ">"), ename); /* this is info only */
						end;

QUEUE_IT:					     if access_lbl_sw then call make_access_lbl;
					     dprint_arg.queue = queue; /* want default or from -q arg */
					     code = 0;
					     call dprint_ (dname, ename, dpap, code);
					     if code ^= 0 then do;
						     call com_err_ (code, id, "Queue ^d for request type ^a",
							dprint_arg.queue, dprint_arg.request_type);
						     if code = error_table_$lock_wait_time_exceeded then do; /* Queue locked */
							     if no_questions then go to next_arg; /* If he won't answer questions, skip it. */
							     query_info.status_code = code;
							     call command_query_ (addr (query_info), ans, id, "Do you wish to try again?");
							     if ans = "yes" then go to QUEUE_IT;
							end;

						     else if code = error_table_$noentry then
							call ioa_$ioa_stream ("error_output",
							     "Request type or queue argument is probably invalid.");

						     else if code = error_table_$notalloc then
							call ioa_$ioa_stream ("error_output", "Queue is full at present.");
						     go to no_request;
						end;

					     else count = count + 1;
					end;
				end;
			end;
		end;
next_arg: end;

	if count > 0 | ^some_path then call print_counts;
	if some_path then if control_arg then call com_err_ (0, id,
		     "Warning: Control arguments following last pathname are ignored.");

RETURN:	return;

/* ===================================================== */

process_control_arg: proc;

	if arg = "-bf" | arg = "-brief" then do;	/* Check for brief option */
		brief = "1"b;
		return;				/* allow -bf at end of line */
	     end;

	control_arg = "1"b;				/* must be an option if it has "-" */

	if arg = "-dl" | arg = "-delete" | arg = "-d" then /* Check for "print and delete" */
	     dprint_arg.delete = 1;
	else if arg = "-he" | arg = "-header" | arg = "-h" then do; /* Check for heading option */
		call get_parameter;
		dprint_arg.heading = " for " || based_arg;
	     end;
	else if arg = "-ds" | arg = "-destination" then do; /* Check for destination */
		call get_parameter;
		dprint_arg.destination = based_arg;
	     end;
	else if arg = "-rqt" | arg = "-request_type" then do;
		if count > 0 then call print_counts;
		call get_parameter;
		call iod_info_$generic_type (based_arg, rqt_gen_type, code);
		if code ^= 0 then
		     if code = error_table_$id_not_found then do;
			     call com_err_ (0, id, "Unknown request type.  ^a", based_arg);
			     go to RETURN;
			end;
		     else call com_err_ (0, id, "Warning -- Unable to check request type ^a.", based_arg);
		else if rqt_gen_type ^= generic_type then do;
			call com_err_ (0, id, "Request type ^a is not of generic type ^a.", based_arg, generic_type);
			go to RETURN;
		     end;
		else if length (rtrim (based_arg)) > length (dprint_arg.request_type) then do;
			call com_err_ (0, id, "Request type name ""^a"" must be ^d characters or less in length.",
			     based_arg, length (dprint_arg.request_type));
			go to RETURN;
		     end;
		else dprint_arg.request_type = based_arg;
	     end;
	else if arg = "-cp" | arg = "-copy" then do;	/* Check for number of copies */
		call get_parameter;
		dprint_arg.copies = cv_dec_check_ (based_arg, code);
		if code ^= 0 | dprint_arg.copies < 1 then do;
			call com_err_ (0, id, "Invalid copy request ^a", based_arg);
			go to RETURN;
		     end;
		else if dprint_arg.copies > 4 then do;
			dprint_arg.copies = 4;
			call com_err_ (0, id, "Too many copies specified; 4 will be supplied.");
		     end;
	     end;
	else if arg = "-nt" | arg = "-notify" then /* Check for "notify me when printed" */
	     dprint_arg.notify = 1;
	else if arg = "-q" | arg = "-queue" then do;	/* Check for queue number */
		if count > 0 then call print_counts;
		call get_parameter;
		queue = cv_dec_check_ (based_arg, code);
		if code ^= 0 | queue < 1 | queue > max_queues then do; /* dprint_ makes the real check */
			call com_err_ (0, id, "Invalid queue number ^a", based_arg);
			go to RETURN;
		     end;
	     end;
	else if arg = "-dupt" | arg = "-defer_until_process_termination" then /* Check for "don't process request until requesting process terminates" */
	     dprint_arg.defer_until_process_termination = 1;
	else if ^punching then do;			/* If printing, lots of new interesting args. */
		if arg = "-nep" | arg = "-no_endpage" then do;
			dprint_arg.nep = "1"b;
			go to NL_OPT;		/* no_label implied */
		     end;
		else if arg = "-ned" | arg = "-non_edited" then
		     dprint_arg.non_edited = "1"b;
		else if arg = "-tc" | arg = "-truncate" then
		     dprint_arg.truncate = "1"b;
		else if arg = "-ll" | arg = "-line_length" then do;
			call get_parameter;
			dprint_arg.line_lth = cv_dec_check_ (based_arg, code);
			if code ^= 0 | dprint_arg.line_lth < 1 then do;
				call com_err_ (0, id, "Invalid line length ^a", based_arg);
				go to RETURN;
			     end;
			if dprint_arg.line_lth > MAX_PAGE_WIDTH then
			     call com_err_ (0, "Warning", "Specified line length is greater then normal printer maximum.");
		     end;
		else if arg = "-in" | arg = "-ind" | arg = "-indent" then do;
			call get_parameter;
			dprint_arg.lmargin = cv_dec_check_ (based_arg, code);
			if code ^= 0 | dprint_arg.lmargin < 0 | dprint_arg.lmargin > MAX_PAGE_WIDTH then do;
				call com_err_ (0, id, "Invalid indentation ^a", based_arg);
				go to RETURN;
			     end;
		     end;
		else if arg = "-sg" | arg = "-single" then
		     dprint_arg.single = "1"b;
		else if arg = "-pl" | arg = "-page_length" then do;
			call get_parameter;
			dprint_arg.page_lth = cv_dec_check_ (based_arg, code);
			if code ^= 0 | dprint_arg.page_lth < 1 then do;
				call com_err_ (0, id, "Invalid page length ^a", based_arg);
				go to RETURN;
			     end;
		     end;
		else if arg = "-lbl" | arg = "-label" then do;
			call get_parameter;
			if dprint_arg.nep then do;
skip_labels:			call com_err_ (0, id, "Warning: Labels are ignored with -no_endpage.");
				return;
			     end;
			dprint_arg.top_label,
			     dprint_arg.bottom_label = based_arg;
			access_lbl_sw = "0"b;	/* don't try to add access labels */
			top_lbl_sw, bottom_lbl_sw = "1"b; /* this is like giving both */
			dprint_arg.center_top_label,
			     dprint_arg.center_bottom_label = "0"b; /* only center access labels */
		     end;
		else if arg = "-tlbl" | arg = "-top_label" then do;
			call get_parameter;
			if dprint_arg.nep then go to skip_labels;
			dprint_arg.top_label = based_arg;
			if bottom_lbl_sw then access_lbl_sw = "0"b; /* when both cancel access labels */
			top_lbl_sw = "1"b;
			dprint_arg.center_top_label = "0"b; /* in case this was set from last path */
		     end;
		else if arg = "-blbl" | arg = "-bottom_label" then do;
			call get_parameter;
			if dprint_arg.nep then go to skip_labels;
			dprint_arg.bottom_label = based_arg;
			if top_lbl_sw then access_lbl_sw = "0"b; /* when both cancel access labels */
			bottom_lbl_sw = "1"b;
			dprint_arg.center_bottom_label = "0"b; /* only for access labels */
		     end;
		else if arg = "-albl" | arg = "-access_label" then do;
			if dprint_arg.nep then go to skip_labels;
			access_lbl_sw = "1"b;
			top_lbl_sw, bottom_lbl_sw = "0"b;
		     end;
		else if arg = "-nlbl" | arg = "-no_label" then do;
NL_OPT:			access_lbl_sw = "0"b;
			top_lbl_sw, bottom_lbl_sw = "0"b;
			dprint_arg.center_top_label, dprint_arg.center_bottom_label = "0"b;
			dprint_arg.top_label, dprint_arg.bottom_label = "";
		     end;
		else if arg = "-forms" then do;
			call get_parameter;
			if length (rtrim (based_arg)) > length (dprint_arg.form_name) then do;
				call com_err_ (0, id, "Forms specification ""^a"" must be ^d characters or less in length.",
				     based_arg, length (dprint_arg.form_name));
				go to RETURN;
			     end;
			dprint_arg.form_name = based_arg;
		     end;
		else do;				/* Bad dprint option */
BAD_OPT:			call com_err_ (error_table_$badopt, id, " ^a ", based_arg);
			go to RETURN;
		     end;
	     end;					/* of print-only */
	else if punching then do;			/* punch args only for dpunch */
		if arg = "-mcc" then
		     dprint_arg.output_module = 3;
		else if arg = "-raw" then
		     dprint_arg.output_module = 4;
		else if arg = "-7p" | arg = "-7punch" then
		     dprint_arg.output_module = 2;
		else go to BAD_OPT;			/* Bad dpunch option */
	     end;

     end process_control_arg;

print_counts: proc;

	if ^brief then do;
		dprint_arg.queue = queue;		/* use the queue we would have requested */
						/* find out how many requests have already been queued */
		call dprint_$queue_contents (dprint_arg.request_type, dprint_arg.queue, lcnt, code);
		if code ^= 0 then
		     call com_err_ (code, id, "Cannot get count for request type ^a, queue ^d",
			dprint_arg.request_type, dprint_arg.queue);

		else if count = 0 then do;
			if lcnt = 1 then suf = ""; else suf = "s";
			call ioa_ ("^d request^a in ^a queue ^d", lcnt, suf, dprint_arg.request_type, dprint_arg.queue);
		     end;
		else do;
			if count = 1 then suf = ""; else suf = "s";
			call ioa_ ("^d request^a signalled, ^d already in ^a queue ^d", count, suf, max (0, lcnt - count),
			     dprint_arg.request_type, dprint_arg.queue);
			count = 0;
		     end;

	     end;

     end print_counts;

ask: proc (format);

	dcl     format		 char (*);

	if no_questions then go to next_arg;
	call ioa_$rsnnl (format, question, quest_len, accname, dname, ename);
	query_info.status_code = code;
	call command_query_ (addr (query_info), ans, id, "^a.  Do you still wish request?  ", question);
	if substr (ans, 1, 3) ^= "yes" then go to next_arg;
	go to QUEUE_IT;				/* User wants request anyway */

     end ask;

make_access_lbl: proc;

	access_label = "";
	call hcs_$get_access_class (dname, ename, access_class, code);
	if code ^= 0 then go to CALL_COM;
	call convert_authorization_$to_string (access_class, access_label, code);
	if ^top_lbl_sw then do;
		dprint_arg.top_label = access_label;
		dprint_arg.center_top_label = "1"b;
	     end;
	if ^bottom_lbl_sw then do;
		dprint_arg.bottom_label = access_label;
		dprint_arg.center_bottom_label = "1"b;
	     end;
     end make_access_lbl;


get_parameter: proc;

	last_arg = arg;
	indx = indx + 1;
	call cu_$arg_ptr (indx, argptr, lng, code);
	if code ^= 0 then do;
		call com_err_ (0, id, "No value specified for ^a.", last_arg);
		go to RETURN;
	     end;

     end get_parameter;

init_variables: proc;

	fcbp = null;				/* no MSF's open yet */
	count = 0;				/* number of requests already signalled */

	query_info.yes_or_no_sw = "1"b;		/* only want yes or no on queries */

	control_arg = "0"b;
	some_path = "0"b;
	brief = "0"b;
	top_lbl_sw = "0"b;
	bottom_lbl_sw = "0"b;
	access_lbl_sw = "1"b;			/* we want access labels by default if not blank */

	dpap = addr (dprint_arg_buf);			/* initialize template dprint args */
	dprint_arg.version = dprint_arg_version_7;
	dprint_arg.queue = queue;			/* initialize the queue as requested */
	dprint_arg.notify = 0;			/* establish some default values */
	dprint_arg.copies = 1;
	dprint_arg.delete = 0;
	dprint_arg.dest = "";			/* be sure the old fields are set */
	dprint_arg.forms = "";
	dprint_arg.heading = "";
	string (dprint_arg.carriage_control) = "0"b;
	dprint_arg.lmargin = 0;
	dprint_arg.line_lth = 0;
	dprint_arg.page_lth = 0;
	dprint_arg.top_label = "";
	dprint_arg.bottom_label = "";
	dprint_arg.chan_stop_path = "";
	dprint_arg.destination = "";			/* just be sure this is clear */
	dprint_arg.form_name = "";			/* and this too */
	dprint_arg.defer_until_process_termination = 0;

     end init_variables;

     end dprint;
  



		    dprint_.pl1                     10/28/88  1348.6rew 10/28/88  1230.1      150831


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


/* format: style4,delnl,insnl,^ifthendo */

/* format: off */

dprint_: proc (dirname, ename, dpap, ec);

/*  The dprint_ subroutine accepts a segment name and an argument structure and formats a message for
   the IO.SysDaemon.  The message is placed in the specified queue of the specified request type.

   THVV 7/72   */


/****^  HISTORY COMMENTS:
  1) change(73-04-01,Coren), approve(), audit(), install():
     (Polished by R. S. Coren 4/73)
     Modified for use with I/O daemon coordinator and device classes, October 1973,
     *  by Robert S. Coren
     Modified by J. Stern, 2/14/75
     Modified by J. C. Whitmore, 4/78, for new dprint_msg structure and enhancements
     Modified: 10 April 1981 by G. Palter to accept request type names > 8 characters in length
     Modified: by G. C. Dixon, 1/82, remove limit on max copies allowed.
     Modified: by R. Kovalcik, 6/82, to add defer_until_process_termination (version 7).
     Modified+ by C. Marker November 1983 to add no_separator
  2) change(86-01-17,Gilcrease), approve(86-01-17,MCR7319),
     audit(86-01-24,RBarstad), install(86-02-03,MR12.0-1012):
               Added the request_id entry point to return the message identifier
               of the request being enqueued SCP 6296.
  3) change(87-02-15,Gilcrease), approve(87-03-26,MCR7645),
     audit(87-03-26,Blair), install(87-04-03,MR12.1-1021):
               Initialize queue-entry count in queue_contents entry.
  4) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Implement line-numbered printouts.
  5) change(88-08-25,Farley), approve(88-09-16,MCR7911),
     audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199):
     Updated to use version 5 dprint_msg and version 10 dprint_arg.
                                                   END HISTORY COMMENTS */

/* format: on */

dcl  dirname char (*),				/* directory where segment resides */
     ename char (*),				/* entry name of segment */
     requestid fixed bin (71),			/* output, message identifier, request_id entry */
     ec fixed bin (35);				/* status code */

dcl  sysdir char (168) aligned int static init (">daemon_dir_dir>io_daemon_dir"),
     sys_msg_seg char (32) aligned,
     mess_id bit (72) aligned based (addr (mess_idx)),
     mess_idx fixed bin (71);

dcl  return_request_id bit (1);
dcl  rqt_name char (24);
dcl  generic_type char (32);
dcl  rqt_generic_type char (32);
dcl  default_q fixed bin;
dcl  max_q fixed bin;

dcl  area_space area (1000) based (areap);
dcl  areap ptr int static init (null);

dcl  queue_pic pic "9";				/* for converting queue number to char */

dcl  error_table_$request_not_recognized ext fixed bin (35);
dcl  error_table_$invalid_lock_reset ext fixed bin (35);
dcl  error_table_$locked_by_this_process ext fixed bin (35);

dcl  clock_ entry returns (fixed bin (71));
dcl  get_system_free_area_ entry (ptr);
dcl  iod_info_$generic_type entry (char (*), char (*), fixed bin (35));
dcl  iod_info_$queue_data entry (char (*), fixed bin, fixed bin, fixed bin (35));
dcl  message_segment_$add_file
	entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (*) aligned, fixed bin (35));
dcl  message_segment_$get_message_count_file entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (35));
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));

dcl  (null, addr, bit, substr, string, length, rtrim, currentsize) builtin;

dcl  cleanup condition;

%include queue_msg_hdr;
%include dprint_msg;
%include dprint_arg;

	return_request_id = "0"b;			/* main entry */
	go to dprint_join;

request_id:
     entry (dirname, ename, dpap, requestid, ec);

	return_request_id = "1"b;

dprint_join:
	if areap = null
	then call get_system_free_area_ (areap);	/* get an area for the dprint message */

	allocate dprint_msg in (area_space) set (dmp);
	on cleanup free dmp -> dprint_msg in (area_space);

	dprint_msg.dirname = dirname;			/* make up the default message */
	dprint_msg.ename = ename;
	dprint_msg.hdr_version = queue_msg_hdr_version_1;
	dprint_msg.version = dprint_msg_version_5;
	dprint_msg.msg_time = clock_ ();
	if return_request_id
	then requestid = dprint_msg.msg_time;
	dprint_msg.message_type = 1;
	dprint_msg.copies = 1;
	string (dprint_msg.bit_flags) = "0"b;
	dprint_msg.state = 0;			/* Daemon has not seen this yet */
	dprint_msg.dupt_lock = "0"b;
	string (dprint_msg.control) = "0"b;
	dprint_msg.output_module = 1;
	dprint_msg.lmargin = 0;
	dprint_msg.line_lth = 0;
	dprint_msg.page_lth = 0;
	dprint_msg.forms = "";
	dprint_msg.destination = "";
	dprint_msg.heading_lth = 0;
	dprint_msg.top_label_lth = 0;
	dprint_msg.bottom_label_lth = 0;
	dprint_msg.chan_stop_path_lth = 0;
	dprint_msg.orig_queue = 0;			/* no queue yet, request the default */
	rqt_name = "printer";			/* assume the default request type for now */
	generic_type = "printer";			/* assume the default generic type for the request type */

	if dpap = null
	then go to send;				/* if no args, send the default message */

	if dprint_arg.pt_pch = DP_PRINT
	then do;					/* this is a print request, make sure */
	     if dprint_arg.output_module ^= 1
	     then do;
		ec = error_table_$request_not_recognized;
		go to free;
	     end;
	end;

	else if dprint_arg.pt_pch = DP_PUNCH
	then do;					/* this is a punch request, check format code */
	     rqt_name = "punch";			/* the default request type is punch */
	     generic_type = "punch";			/* the generic type is punch */
	     if dprint_arg.output_module < 2 | dprint_arg.output_module > 4
	     then do;				/* known format? */
		ec = error_table_$request_not_recognized;
		go to free;
	     end;
	end;

	else if dprint_arg.pt_pch = DP_PLOT
	then do;					/* this is a plotter request.  Make sure the 	*/
	     rqt_name = "plotter";			/* default request type and generic type are set	*/
	     generic_type = "plotter";		/* to plotter.  Only one output mode is supported. */
	     if dprint_arg.output_module ^= 5
	     then do;
		ec = error_table_$request_not_recognized;
		go to free;
	     end;
	end;

	else do;					/* this is bad news */
	     ec = error_table_$request_not_recognized;
	     go to free;
	end;
	dprint_msg.orig_queue = dprint_arg.queue;
	dprint_msg.message_type = dprint_arg.pt_pch;
	dprint_msg.heading_lth = length (rtrim (dprint_arg.heading));
						/* make the string the right length */
	dprint_msg.heading = dprint_arg.heading;
	dprint_msg.output_module = dprint_arg.output_module;
	dprint_msg.delete_sw = (dprint_arg.delete = 1);
	dprint_msg.copies = dprint_arg.copies;
	if dprint_arg.version < dprint_arg_version_5
	then					/* use a different variable after version 5 */
	     dprint_msg.destination = dprint_arg.dest;
	else dprint_msg.destination = dprint_arg.destination;

	if dprint_arg.version = dprint_arg_version_1
	then go to send;				/* limit of version 1 data */
	dprint_msg.nep = dprint_arg.nep;
	dprint_msg.single = dprint_arg.single;
	dprint_msg.non_edited = dprint_arg.non_edited;
	dprint_msg.truncate = dprint_arg.truncate;
	dprint_msg.center_top_label = dprint_arg.center_top_label;
	dprint_msg.center_bottom_label = dprint_arg.center_bottom_label;
	if dprint_arg.version < dprint_arg_version_5
	then dprint_msg.forms_name = dprint_arg.forms;	/* forms location changed with version 5 */
	else if dprint_arg.version < dprint_arg_version_10
	then dprint_msg.forms_name = dprint_arg.form_name;/* forms location changed with version 10 */
	else dprint_msg.forms_name = dprint_arg.forms_name;
						/* new forms location */
	dprint_msg.forms_name_lth = length (rtrim (dprint_msg.forms_name));
						/* make the string the right length */
	dprint_msg.lmargin = dprint_arg.lmargin;
	dprint_msg.line_lth = dprint_arg.line_lth;
	dprint_msg.notify = (dprint_arg.notify = 1);

	if dprint_arg.version = dprint_arg_version_2
	then go to send;				/* limit of version 2 data */
	dprint_msg.page_lth = dprint_arg.page_lth;

	if (dprint_arg.version < dprint_arg_version_6)
	then					/* before version 6: use 8 character request type */
	     if dprint_arg.class ^= ""
	     then rqt_name = dprint_arg.class;
	     else ;
	else if (dprint_arg.request_type ^= "")
	then					/* version 6 and beyond: use long request type name */
	     rqt_name = dprint_arg.request_type;

	if dprint_arg.version = dprint_arg_version_3
	then go to send;				/* limit of version 3 data */
	dprint_msg.top_label_lth = length (rtrim (dprint_arg.top_label));
	dprint_msg.bottom_label_lth = length (rtrim (dprint_arg.bottom_label));
	dprint_msg.top_label = dprint_arg.top_label;
	dprint_msg.bottom_label = dprint_arg.bottom_label;

	if dprint_arg.version = dprint_arg_version_4
	then go to send;				/* limit of version 4 data */
	dprint_msg.bit_count = dprint_arg.bit_count;
	dprint_msg.esc = dprint_arg.esc;
	dprint_msg.chan_stop_path_lth = length (rtrim (dprint_arg.chan_stop_path));
	dprint_msg.chan_stop_path = dprint_arg.chan_stop_path;

	if dprint_arg.version < dprint_arg_version_7
	then go to send;				/* limit of version 6 data */
	dprint_msg.defer_until_process_termination = (dprint_arg.defer_until_process_termination = 1);
						/* see if we want "defer_until_process_termination */
	if dprint_msg.defer_until_process_termination
	then do;					/* if we request deferal until process termination,
						   then we must set up a lock */
	     call set_lock_$lock (dprint_msg.dupt_lock, 1, ec);
	     if ec ^= 0
	     then if (ec = error_table_$invalid_lock_reset) | (ec = error_table_$locked_by_this_process)
		then ec = 0;			/* if it's an OK error, zero it */
		else go to free;			/* else, go barf */
	     else ;
	end;
	if dprint_arg.version = dprint_arg_version_7
	then go to send;				/* limit version 7 data */
	dprint_msg.no_separator = dprint_arg.no_separator;

	if dprint_arg.version = dprint_arg_version_8
	then go to send;				/* limit version 8 */
	dprint_msg.line_nbrs = dprint_arg.line_nbrs;

send:
	call iod_info_$generic_type (rqt_name, rqt_generic_type, ec);
	if ec ^= 0
	then go to free;

	if rqt_generic_type ^= generic_type
	then do;					/* be sure we have the right type of request */
	     ec = error_table_$request_not_recognized;
	     go to free;
	end;

	if dprint_msg.copies < 1
	then dprint_msg.copies = 1;			/* check for consistency */

	if dprint_msg.orig_queue < 1
	then do;					/* do we want the default queue? */
	     call iod_info_$queue_data (rqt_name, default_q, max_q, ec);
	     if ec ^= 0
	     then go to free;
	     dprint_msg.orig_queue = default_q;
	     if dpap ^= null
	     then dprint_arg.queue = default_q;		/* tell caller number of default queue */
	end;

	queue_pic = dprint_msg.orig_queue;		/* convert to a character string */
	sys_msg_seg = rtrim (rqt_name) || "_" || queue_pic || ".ms";
						/* make message seg name */

	call message_segment_$add_file (sysdir, sys_msg_seg, dmp, currentsize (dprint_msg) * 36, mess_id, ec);
free:
	free dmp -> dprint_msg in (area_space);
	return;

/**/

qfull:
     entry (qq, count, ec1, a_rqt_name);

dcl  a_rqt_name char (8);
dcl  (qq, count) fixed bin,
     ec1 fixed bin (35);

	call queue_contents (a_rqt_name, qq, count, ec1); /* invoke the new, modern entry */
	return;


/* Returns number of request already present in a particular queue of the specified request type */

queue_contents:
     entry (a_request_type, a_queue, a_count, ec2);

dcl  a_request_type character (*);
dcl  (a_queue, a_count) fixed binary;
dcl  ec2 fixed binary (35);

	if a_request_type = ""
	then rqt_name = "printer";
	else rqt_name = a_request_type;
	a_count = 0;				/* Initialize queue entries count */

	if a_queue < 1
	then do;					/* if the default queue is requested, find it */
	     call iod_info_$queue_data (rqt_name, default_q, max_q, ec2);
	     if ec2 ^= 0
	     then return;
	     a_queue = default_q;
	end;
	else if a_queue > 4
	then do;					/* illegal value? */
	     ec2 = error_table_$request_not_recognized;
	     return;
	end;

	queue_pic = a_queue;			/* convert queue number to char */
	sys_msg_seg = rtrim (rqt_name) || "_" || queue_pic || ".ms";

	call message_segment_$get_message_count_file (sysdir, sys_msg_seg, a_count, ec2);
	return;

/**/

access_check:
     entry (dirname, ename, a_rqt_name, del_acc, read_acc, stat_acc, ret_accname, ec3);

dcl  del_acc bit (1) aligned;
dcl  read_acc bit (1) aligned;
dcl  stat_acc bit (1) aligned;
dcl  ret_accname char (*);
dcl  ec3 fixed binary (35);

	call check_daemon_access (dirname, ename, a_rqt_name, del_acc, read_acc, stat_acc, ret_accname, ec3);
						/* invoke the new, modern entry */
	return;


/* This entry is used to find out if the I/O daemon
   *  process that will perform this request will have sufficient access to do so.
   *  del_acc will be set to "0"b if the segment cannot be deleted. read_acc
   *  will be set to "0"b if the driver for the specified request_type does not have
   * "r" access on the segment. stat_acc will be set to "0"b if the driver does
   *  not have "s" access on the containing directory.
*/

/* Entry added Dec. 28, 1973 by Robert S. Coren */
/* Modified: 10 April 1981 by G. Palter */

check_daemon_access:
     entry (dirname, ename, a_request_type2, del_acc, read_acc, stat_acc, ret_accname, ec3);

dcl  a_request_type2 character (*);
dcl  cu_$level_get entry returns (fixed bin);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl  iod_info_$driver_access_name entry (char (*), char (32), fixed bin (35));
dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));

dcl  dir char (168);
dcl  ent char (168);
dcl  dirdir char (168);
dcl  dirent char (32);
dcl  accname char (32);
dcl  level fixed bin;
dcl  mode fixed bin (5);
dcl  bit5 bit (5);					/* Inserted to avoid compiler error. */

dcl  df_print_name char (32) int static init ("");	/* driver access name for default print request type */
dcl  df_punch_name char (32) int static init ("");	/* driver access name for default punch request type */

	stat_acc, read_acc, del_acc = "0"b;
	ec3 = 0;
	rqt_name = a_request_type2;

	if rqt_name = "printer"
	then do;
	     if df_print_name = ""
	     then do;
		call iod_info_$driver_access_name ("printer", df_print_name, ec3);
		if ec3 ^= 0
		then return;
	     end;
	     accname = df_print_name;
	end;

	else if rqt_name = "punch"
	then do;
	     if df_punch_name = ""
	     then do;
		call iod_info_$driver_access_name ("punch", df_punch_name, ec3);
		if ec3 ^= 0
		then return;
	     end;
	     accname = df_punch_name;
	end;

	else do;
	     call iod_info_$driver_access_name (rqt_name, accname, ec3);
	     if ec3 ^= 0
	     then return;
	end;

	ret_accname = accname;			/* group id of driver process reading segment */

	level = cu_$level_get ();

/* Determine true pathname of target segment */

	call hcs_$get_link_target (dirname, ename, dir, ent, ec3);
	if ec3 ^= 0
	then return;

	call hcs_$get_user_effmode (dir, ent, accname, level, mode, ec3);
						/* get driver's access to seg */
	if ec3 ^= 0
	then return;

/* read access is second bit */

	read_acc = substr (bit (mode, 5), 2, 1);

/* separate off directory name to check for modify (also status) */

	call expand_pathname_ (dir, dirdir, dirent, ec3);
	if ec3 ^= 0
	then return;

	call hcs_$get_user_effmode (dirdir, dirent, accname, level, mode, ec3);
						/* get driver's access to directory */
	if ec3 ^= 0
	then return;

	stat_acc = substr (bit (mode, 5), 2, 1);

	call hcs_$get_user_effmode (dirdir, dirent, "IO.SysDaemon.*",
						/* see if IO Coord can delete the seg */
	     level, mode, ec3);
	if ec3 ^= 0
	then return;

	bit5 = bit (mode, 5);
	del_acc = substr (bit5, 2, 1) & substr (bit5, 4, 1);
	return;

/**/

/* Set the system directory used to find the queues to permit testing of new version of I/O daemon tables and software */

test:
     entry (test_dir);

dcl  test_dir char (*);
dcl  iod_info_$test entry (char (*));

	sysdir = test_dir;
	df_print_name, df_punch_name = "";
	call iod_info_$test (test_dir);
	return;

     end dprint_;
 



		    enter_output_request.pl1        10/28/88  1348.6rew 10/28/88  1229.4      979200


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


/* format: style4,delnl,insnl,^ifthendo */

/* format: off */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*  NAMES:  enter_output_request, eor						*/
/*									*/
/*      This command submits requests to print or punch files via calls to dprint_.	*/
/*									*/
/*  STATUS								*/
/*									*/
/* 1) Created:  May, 1973 by G. C. Dixon					*/
/* 2) Modified: July, 1974 by G. C. Dixon					*/
/*    a) added -device_class control argument.					*/
/*    b) call dprint_$access_check to check IO Daemon's access to output segments.	*/
/* 3) Modified: September, 1974 by G. C. Dixon					*/
/*    a) support the new control arguments:  -endpage (-ep), -no_endpage (-nep),	*/
/*       -line_length (-ll), -page_length (-pl), -indent (-in).			*/
/* 4) Modified: August, 1978 by Thomas McGary					*/
/*    a) add -label, -top_label, -bottom_label, & check vs -nep.			*/
/*    b) rename -dvc to -rqt.							*/
/*    c) convert to version 5 of dprint_arg struc.				*/
/* 5) Modified: October 12, 1981 by Roger Roach					*/
/*    a) modified to accept 24 character request types and convert to version 6		*/
/*       dprint_arg structure.						*/
/* 6) Modified: October, 21, 1981 by Gary Dixon					*/
/*    a) Major upgrade, including new argument parsing scheme,			*/
/*    b) named, user-settable defaults on a per-request_type basis			*/
/*    c) elimination of (print change)_daemon_defaults entry points in favor of		*/
/*       -print_defaults and -set_defaults					*/
/*    d) implementation of the -forms and -plot control arguments.			*/
/*    e) store default values in Person_id.value seg in [home_dir].			*/
/* 7) Modified: December 12, 1981 by Gary Dixon					*/
/*    a) implement -active_string as operand for -he -ds -lbl -tlbl -blbl.  De-implement	*/
/*       -ehe								*/
/* 8) Modified: June 1, 1982 by Gary Dixon - fix minor bugs, warn when using request	*/
/*	      types for which no user defaults are defined.			*/
/* 9) Modified: June, 1982 by Rick Kovalcik to add support for -dupt			*/
/* 10) Modified: November 1983 by C. Marker to add support for -nsep		          */
/* 11) Modified: January 1984 by C. Marker to make it possible to have a default request  */
/*               type which has no user defined defaults but instead uses the system      */
/*               defaults.							*/
/* 12) Modified: May 1984 by C. Marker to make the system defaults for the heading and    */
/*	       destination be null strings.  This will allow the IO Daemon drivers      */
/*               to take care of the defaults. 
             */
/* 13) Modified: Nov 1, 1984 by EJ Sharpe to change mdc_$get_lv_access arg list		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to call object_lib_$initiate to check if a file is an object
     segment or MSF instead of calling object_info_.
  2) change(87-05-10,Gilcrease), approve(87-05-15,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Implement -nb for line-numbered printouts.
  3) change(88-08-25,Farley), approve(88-09-16,MCR7911),
     audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199):
     Modified to use new version 10 dprint_arg and to call the new iod_info
     forms validation routine.
                                                   END HISTORY COMMENTS */


/* format: on */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


enter_output_request:
eor:
     procedure;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This is the entry point used for submission of print and punch requests and to	*/
/* set/reset/delete/print user-defined groups of defaults.				*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


dcl  Idft fixed bin,
     Nargs fixed bin,				/* number of input arguments.			*/
     Nqueued fixed bin,				/* number of entries submitted for operation.	*/
     Ntype fixed bin,				/* type of operation: 			*/
						/*   0 = UNDEFINED				*/
						/*   1 = DP_PRINT				*/
						/*   2 = DP_PUNCH				*/
						/*   3 = DP_PLOT				*/
     Ntypes_set fixed bin,				/* if >1, then conflicting control args were given */
     Parg_list ptr,
     Pdefault_temp ptr,
     Pfcb ptr,					/* ptr to MSF opening info.			*/
     Pseg ptr,					/* ptr to segment being submitted.		*/
     Sdefault_is_stored bit (1),			/* on if user default is stored in value seg.	*/
     Sgive_label_warning bit (1),			/* on if user should be warned about -nep/-label	*/
     Sgive_nep_warning bit (1),			/* on if user should be warned about -label/-nep	*/
     Sdefault bit (1),				/* use default values for -he and -ds */
     code fixed bin (35),				/* a status code.				*/
     gen_type char (32),
     (line_length_error, line_length_query) fixed bin init (0),
     max_q fixed bin,
     value_seg_path char (168),
     warn_count fixed bin;

dcl  area area based (Parea);

dcl  (after, addr, bit, convert, currentsize, index, length, null, rtrim, search, string, substr, sum, unspec) builtin;

dcl  (cleanup, conversion) condition;

dcl  adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35)),
     check_star_name_$entry entry (char (*), fixed bin (35)),
     com_err_ entry () options (variable),
     command_query_$yes_no entry () options (variable),
     convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35)),
     cu_$arg_count entry (fixed bin, fixed bin (35)),
     cu_$arg_list_ptr entry returns (ptr),
     cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
     cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)),
     dprint_ entry (char (*), char (*), ptr, fixed bin (35)),
     dprint_$check_daemon_access
	entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, bit (1) aligned, char (*),
	fixed bin (35)),
     dprint_$queue_contents entry (char (*), fixed bin, fixed bin, fixed bin (35)),
     eor_cv5_6_ entry (ptr, fixed bin (35)),
     eor_cv6_7_ entry (ptr, fixed bin (35)),
     eor_cv7_8_ entry (ptr, fixed bin (35)),
     eor_cv8_9_ entry (ptr, fixed bin (35)),
     eor_cv9_10_ entry (ptr, fixed bin (35)),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)),
     get_group_id_$tag_star entry () returns (char (32)),
     get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin),
     get_system_free_area_ entry () returns (ptr),
     hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
     hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
     hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35)),
     hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ entry () options (variable),
     iod_info_$generic_type entry (char (*), char (32), fixed bin (35)),
     iod_info_$queue_data entry (char (*), fixed bin, fixed bin, fixed bin (35)),
     iod_info_$validate_forms_info entry (ptr, ptr, fixed bin (35)),
     mdc_$find_lvname entry (bit (36), char (*), fixed bin (35)),
     mdc_$get_lv_access entry (char (*), fixed bin (3), bit (36) aligned, bit (1) aligned, fixed bin (35)),
     msf_manager_$acl_add entry (ptr, ptr, fixed bin, fixed bin (35)),
     msf_manager_$close entry (ptr),
     msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)),
     msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)),
     object_lib_$initiate entry (char (*), char (*), char (*), bit (1), ptr, fixed bin (24), bit (1), fixed bin (35)),
     requote_string_ entry (char (*)) returns (char (*)),
     user_info_ entry (char (*), char (*), char (*)),
     value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35)),
     value_$get_path entry (char (*), fixed bin (35)),
     value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35)),
     value_$set_data
	entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35)),
     value_$set_path entry (char (*), bit (1), fixed bin (35));

dcl  DEFAULT_RQT (3) char (24) int static options (constant) init ("printer", "punch", "plotter"),
     DEFAULT_VALUE_SEG ptr int static options (constant) init (null),
     (
     FALSE init ("0"b),
     TRUE init ("1"b)
     ) bit (1) int static options (constant),
     PERM bit (36) aligned int static options (constant) init ("01"b),
     Parea ptr int static,				/* ptr to an allocation area.			*/
     MAX_COPIES fixed bin int static options (constant) init (30),
     MAX_LINE_LENGTH fixed bin int static options (constant) init (250),
     NL char (1) int static options (constant) init ("
"),
     (
     PRINT init (1),
     PUNCH init (2),
     MCC init (3),
     RAW init (4),
     PLOT init (5)
     ) fixed bin int static options (constant),
     UNDEFINED fixed bin int static options (constant) init (0),
     (
     error_table_$bad_arg,
     error_table_$bad_segment,
     error_table_$badopt,
     error_table_$badstar,
     error_table_$bigarg,
     error_table_$command_line_overflow,
     error_table_$dirseg,
     error_table_$improper_data_format,
     error_table_$inconsistent,
     error_table_$inconsistent_msf,
     error_table_$lock_wait_time_exceeded,
     error_table_$moderr,
     error_table_$no_s_permission,
     error_table_$noarg,
     error_table_$noentry,
     error_table_$nomatch,
     error_table_$nostars,
     error_table_$notalloc,
     error_table_$oldnamerr,
     error_table_$out_of_bounds,
     error_table_$private_volume,
     error_table_$too_many_names,
     error_table_$typename_not_found,
     error_table_$unimplemented_version,
     error_table_$zero_length_seg,
     error_table_$bad_forms_option,
     error_table_$no_forms_table_defined
     ) fixed bin (35) ext static,
     iox_$error_output ptr ext static,
     iox_$user_io ptr ext static,
     person char (22) int static init (""),
     proc char (24) aligned int static options (constant) init ("enter_output_request"),
     proj char (9) int static;


dcl  1 S aligned,					/* The structures on this page hold all of the	*/
       2 processing_control,				/*   information supplied by the user via	*/
         3 brief bit (1),				/*   control arguments.  The S structure holds	*/
         3 force bit (1),				/*   binary switches.			*/
       2 carriage_control,
         3 nep bit (1),
         3 single bit (1),
         3 non_edited bit (1),
         3 truncate bit (1),
         3 no_separator bit (1),
         3 line_nbrs bit (1),
       2 default_control,
         3 set_default bit (1),
         3 print_default bit (1),
         3 all bit (1),
         3 delete_default bit (1),
         3 replace_default bit (1),
         3 list_defaults bit (1),
       2 label,
         3 top bit (1),
         3 bottom bit (1),
         3 access bit (1),
       2 arg_type,
         3 pathnames bit (1),
         3 non_path_ctl_args bit (1),
         3 error bit (1),
         3 dnm_or_rqt_omitted bit (1),
     1 N aligned,					/* The N structure holds numeric switches, 	*/
       2 pt_pch fixed bin,				/* lengths, and other numeric selectors.	*/
       2 delete fixed bin,
       2 notify fixed bin,
       2 copies fixed bin,
       2 queue fixed bin,
       2 output_module fixed bin,
       2 lmargin fixed bin,
       2 line_lth fixed bin,
       2 page_lth fixed bin,
       2 defer_until_process_termination fixed bin,
     1 O aligned,					/* The O structure holds character operands for	*/
       2 request_type char (24) unal,			/*   various control arguments.		*/
       2 default_request_type char (24) unal,
       2 name_of_default char (24) unal,
       2 forms_name char (128) unal,
     1 PLS_struc aligned,
       2 heading like PLS,
       2 destination like PLS,
       2 top_label like PLS,
       2 bottom_label like PLS,
     1 PLS (4) aligned based (addr (PLS_struc)),		/* The PLS array of structures holds user-supplied */
       2 P ptr,					/*   arguments, stored as ptr/length with	*/
       2 L fixed bin (21),				/*   modifying switches.			*/
       2 S,					/*   The 4 array elements contain:		*/
         3 equal_name bit (1) unal,			/*       (1) heading			*/
         3 active_string bit (1) unal,			/*       (2) destination			*/
         3 center bit (1) unal,			/*       (3) top_label			*/
         3 pad bit (33) unal,				/*       (4) bottom_label			*/
     (
     HEADING init (1),
     DESTINATION init (2),
     TOP_LABEL init (3),
     BOTTOM_LABEL init (4)
     ) fixed bin int static options (constant),
     PLS_heading char (PLS.L (HEADING)) based (PLS.P (HEADING)),
     PLS_destination char (PLS.L (DESTINATION)) based (PLS.P (DESTINATION)),
     PLS_top_label char (PLS.L (TOP_LABEL)) based (PLS.P (TOP_LABEL)),
     PLS_bottom_label char (PLS.L (BOTTOM_LABEL)) based (PLS.P (BOTTOM_LABEL)),
     switch_array (21) bit (1) aligned based (addr (S)),
     number_array (10) fixed bin aligned based (addr (N));

dcl  1 default_print aligned based (Pdefault),
       2 header,
         3 Ntype fixed bin,				/* This structure holds information corresponding */
         3 name char (24) unal,			/*   to the O, S, N and PLS structures above, in	*/
         3 size fixed bin (18),			/*   the form in which it is stored as 		*/
       2 Odft,					/*   user-defined groups of default control	*/
         3 request_type char (24) unal init (""),		/*   argument settings for PRINTING.		*/
         3 forms_name char (64) unal init (""),
       2 Sdft,
         3 processing_control,
	 4 brief bit (1) init ("0"b),
	 4 force bit (1) init ("0"b),
         3 carriage_control,
	 4 nep bit (1) init ("0"b),
	 4 single bit (1) init ("0"b),
	 4 non_edited bit (1) init ("0"b),
	 4 truncate bit (1) init ("0"b),
	 4 no_separator bit (1) init ("0"b),
	 4 line_nbrs bit (1) init ("0"b),
         3 label,
	 4 top bit (1) init ("0"b),
	 4 bottom bit (1) init ("0"b),
	 4 access bit (1) init ("1"b),
       2 Ndft,
         3 pt_pch fixed bin init (0),
         3 delete fixed bin init (0),
         3 notify fixed bin init (0),
         3 copies fixed bin init (1),
         3 queue fixed bin init (0),
         3 output_module fixed bin init (PRINT),
         3 lmargin fixed bin init (0),
         3 line_lth fixed bin init (-1),
         3 page_lth fixed bin init (-1),
         3 defer_until_process_termination fixed bin init (0),
       2 LSV,					/* info from PLS converted to form storable	*/
         3 fixed_part,				/*   across process boundaries.		*/
	 4 heading,
	   5 L fixed bin (21),
	   5 S like PLS.S,
	 4 destination like default_print.LSV.fixed_part.heading,
	 4 top_label like default_print.LSV.fixed_part.heading,
	 4 bottom_label like default_print.LSV.fixed_part.heading,
         3 V,
	 4 heading char (PLS_struc.heading.L refer (default_print.LSV.heading.L)) unal,
	 4 destination char (PLS_struc.destination.L refer (default_print.LSV.destination.L)) unal,
	 4 top_label char (PLS_struc.top_label.L refer (default_print.LSV.top_label.L)) unal,
	 4 bottom_label char (PLS_struc.bottom_label.L refer (default_print.LSV.bottom_label.L)) unal,
     1 auto_default aligned,
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 LSV,
         3 fixed_part like default_print.LSV.fixed_part,
         3 V,
	 4 heading char (59),
	 4 destination char (24),
	 4 top_label char (136),
	 4 bottom_label char (136);


dcl  1 default_punch aligned based (Pdefault),
       2 header,
         3 Ntype fixed bin,				/* PUNCH and PLOT DEFAULTS			*/
         3 name char (24) unal,
         3 size fixed bin (18),
       2 Odft,
         3 request_type char (24) unal init (""),
       2 Sdft,
         3 processing_control,
	 4 equal_header bit (1) init ("0"b),
	 4 brief bit (1) init ("0"b),
	 4 force bit (1) init ("0"b),
       2 Ndft,
         3 pt_pch fixed bin init (0),
         3 delete fixed bin init (0),
         3 notify fixed bin init (0),
         3 copies fixed bin init (1),
         3 queue fixed bin init (0),
         3 output_module fixed bin init (MCC),
         3 defer_until_process_termination fixed bin init (0),
       2 LSV,					/* info from PLS converted to form storable	*/
         3 fixed_part,				/*   across process boundaries.		*/
	 4 heading like default_print.LSV.fixed_part.heading,
	 4 destination like default_print.LSV.fixed_part.heading,
         3 V,
	 4 heading char (PLS_struc.heading.L refer (default_punch.LSV.heading.L)) unal,
	 4 destination char (PLS_struc.destination.L refer (default_punch.LSV.destination.L)) unal,
     Pdefault ptr,
     Pnew_default ptr;


dcl  1 default_header aligned based (Pdefault_header),
       2 version fixed bin,				/* structure containing default request types and */
       2 default_request_type (3) char (24) unal,		/* defining version of default_(print punch)	*/
						/* structures above.  The default_request_type	*/
						/* array elements are for printing, punching and	*/
     Pdefault_header ptr,				/* plotting, respectively.			*/
     Vdefault_header_5 fixed bin int static options (constant) init (5),
						/* Version 5 supports -astr in -he, -ds, -lbl	*/
     Vdefault_header_6 fixed bin int static options (constant) init (6),
						/* Version 6 de-supports default names beginning	*/
						/*   with hyphen or including ? or * chars.	*/
     Vdefault_header_7 fixed bin int static options (constant) init (7),
						/* Version 7 supports -dupt			*/
     Vdefault_header_8 fixed bin int static options (constant) init (8),
						/* Version 8 supports -nsep */
     Vdefault_header_9 fixed bin int static options (constant) init (9),
						/* Version 9, -nb */
     Vdefault_header_10 fixed bin int static options (constant) init (10),
						/* Version 10, larger forms_name */
     1 auto_default_header aligned like default_header;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The following table describes the control arguments accepted by eor.  Each		*/
/* argument is preceded by a descriptor (eg, S^ 04) which describes the type of argument	*/
/* [char(2)] (eg, switch or arg with numeric operand, etc), argument value [pic"9"]	*/
/* field, and argument number [pic "99"] within each type.				*/
/*									*/
/* Types are:								*/
/* 	S+ = switch argument, value of switch is on				*/
/*	S^ = switch argument, value of switch is off				*/
/* 	Nb = argument which is followed by a numeric operand			*/
/*	N  = numeric switch argument.  The switch is set to the desc.arg_val.		*/
/*	Ch = argument which is followed by a character operand			*/
/*	Sp = special argument which is not followed by an operand (ie, which is a	*/
/*	     switch), but which requires special processing in addition to setting the	*/
/*	     switch.							*/
/*	PL = argument which is followed by an arbitrarily long character string	*/
/*	     operand.  The operand is stored in the PLS structure as a ptr/length pair. */
/*									*/
/* For switches (S^ or S+) and args with numeric operands (Nb),			*/
/*   the argument number (desc.arg_no) is an index into an array of switches		*/
/*   (switch_array) or numeric operands (number_array).  These arrays overlay structures	*/
/*   (S and N) which identify the switches or numeric operand values by name.		*/
/* For numeric switches (N ),							*/
/*   the argument number (desc.arg_no) is an index into number_array, and desc.arg_val	*/
/*   is the value to be stored in the array element.				*/
/* For special args (Sp) or args with character operands (Ch),			*/
/*   the desc.arg_no identifies a label value to which control is transferred in 	*/
/*   order to process the argument (and its operand).				*/
/* For ptr/length args (PL),							*/
/*   the desc.arg_val identifies which element of the PLS structure should be set, and	*/
/*   desc.arg_no identifies a label value to which control is transferred for further	*/
/*   processing after the structure element is set.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  1 desc unal based (Pdesc),			/* This is the descriptor referred to above.	*/
       2 type char (2),
       2 arg_val pic "9",
       2 arg_no pic "99",
     Pdesc ptr;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 		The table itself is on the next 2 pages.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  arg_tbl (8) char (250) int static options (constant) init ("
S+ 01-brief
S+ 01-bf
S^ 01-long
S^ 01-lg
S+ 02-force
S+ 02-fc
S^ 02-no_force
S^ 02-nfc
S^ 03-end_page
S^ 03-ep
S+ 04-no_vertical_space
S+ 04-nvertsp
S^ 04-vertical_space
S^ 04-vertsp
                ", "
S+ 05-non_edited
S+ 05-ned
S^ 05-edited
S^ 05-ed
S+ 06-truncate
S+ 06-tc
S^ 06-fold
S+ 07-no_separator
S+ 07-nsep
S^ 07-separator
S^ 07-sep
S^ 08-no_number
S^ 08-nnb
S+ 08-number
S+ 08-nb
S+ 09-set_defaults
S+ 09-set_default
S+ 09-sdft
           ", "
S+ 10-print_defaults
S+ 10-print_default
S+ 10-prdft
S+ 10-pdft
S+ 12-delete_defaults
S+ 12-delete_default
S+ 12-dldft
S+ 12-ddft
S+ 13-replace_defaults
S+ 13-replace_default
S+ 13-rpdft
            ", "
S+ 13-rdft
S+ 14-list_defaults
S+ 14-list_default
S+ 14-lsdft
S+ 14-ldft
N 101-print
N 101-pr
N 201-punch
N 201-pch
N 301-plot
N 102-delete
N 102-dl
N 002-no_delete
N 002-ndl
N 103-notify
N 103-nt
  ", "
N 003-no_notify
N 003-nnt
Nb 04-copies
Nb 04-copy
Nb 04-cp
Nb 05-queue
Nb 05-q
N 306-mcc_punch
N 306-mcc
N 406-raw_punch
N 406-raw
N 206-7punch
N 206-7p
Nb 07-indent
Nb 07-ind
Nb 07-in
              ", "
Nb 08-line_length
Nb 08-ll
Nb 09-page_length
Nb 09-pl
N 110-defer_until_process_termination
N 110-dupt
N 010-no_defer_until_process_termination
N 010-ndupt
PL101-header
PL101-he
PL202-destination
   ", "
PL202-ds
PL303-label
PL303-lbl
PL304-top_label
PL304-tlbl
PL405-bottom_label
PL405-blbl
Sp 06-access_label
Sp 06-albl
Sp 07-no_label
Sp 07-nlbl
Sp 08-no_end_page
Sp 08-nep
Sp 09-all
Sp 09-a
         ", "
Ch 10-request_type
Ch 10-rqt
Ch 11-set_default_request_type
Ch 11-sdftrqt
Ch 11-sdrqt
Ch 12-name
Ch 12-nm
Ch 13-default_name
Ch 13-dftnm
Ch 13-dnm
Ch 14-forms
"),
     arg_table char (2000) based (addr (arg_tbl)),
     arg_tbl_array (2000) char (1) based (addr (arg_tbl));

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This is the entry point for the enter_output_request command.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	call init ();
	on cleanup call janitor ();			/* free space in system free area during cleanup. */

	call cu_$arg_count (Nargs, code);		/* find out how many arguments we were called with */
	if code ^= 0
	then go to NOT_AF;				/* This command doesn't work as an active function */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The following code parses arguments in 3 passes.				*/
/* 1) Find out whether we are printing, punching, or plotting.  This information is needed */
/*    to determine which set of defaults (print/punch/plot) to apply.  During this	*/
/*    pass, we also detect and diagnose bad control args.  Any bad args abort all	*/
/*    processing.								*/
/* 2) Apply proper set of defaults, and then process args to allow user to override the	*/
/*    defaults.  Argument processing can be skipped if pass 1 determines there are no	*/
/*    non-pathname args.  However, any control arguments values (given with control	*/
/*    arguments or obtained from defaults) must still be validated.  This validation is	*/
/*    part of pass 2.							*/
/* 3) Process pathname args, submitting requests as appropriate.  Also change settings	*/
/*    for defaults, if necessary.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	S = FALSE;				/* Initialize argument-holding structures.	*/
	N = 0;
	O = "";
	PLS (*).P = null;
	PLS (*).L = 0;
	PLS (*).S = FALSE;

	call find_default_header ();			/* get user's default request types.		*/
	if Pdefault_header = null
	then go to FINISH;

	Sgive_label_warning = TRUE;			/* Initialize flags for PASS 1.		*/
	Sgive_nep_warning = TRUE;
	Parg_list = cu_$arg_list_ptr ();
	call proc_args (FALSE, Nqueued);
	if S.error
	then return;

	S.dnm_or_rqt_omitted = (O.request_type = "" | O.name_of_default = "");
						/* Set flag which indicates that either		*/
						/*   -default_name or -request_type control arg	*/
						/*   was NOT given in this invocation.		*/
	if O.name_of_default = ""
	then					/* Use user-supplied operand of -request_type name */
	     O.name_of_default = O.request_type;	/*   for default name if -default_name not given.	*/
	Ntype = UNDEFINED;
	if O.name_of_default ^= ""
	then do;					/* If default name given, look for user-defined	*/
						/*   set of default control arguments in value seg */
	     call find_default (O.name_of_default, "", UNDEFINED, FALSE, FALSE, warn_count, Pdefault);
	     if Pdefault ^= null
	     then do;
		O.request_type = default_print.request_type;
		Ntype = default_print.Ntype;
	     end;
	end;

	if Ntype ^= UNDEFINED
	then ;					/* If no user-defined defaults, look for generic	*/
	else if O.request_type ^= ""
	then do;					/*   type of request type in iod_tables		*/
	     call iod_info_$generic_type (O.request_type, gen_type, code);
	     if code ^= 0
	     then go to UNDEFINED_REQUEST_TYPE;
	     do Ntype = DP_PRINT to DP_PLOT while (gen_type ^= DEFAULT_RQT (Ntype));
	     end;
	     if Ntype > DP_PLOT
	     then go to UNDEFINED_GENERIC_TYPE;
	end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* At this point in PASS 1, we may or may not know the generic type, depending upon	*/
/* whether or not the user gave a -default_name or -request_type control argument.  If	*/
/* we know the generic type, we must examine other control args to be sure they are	*/
/* consistent with that generic type.  If we don't know the generic type, we must	*/
/* examine other control args to see if any specific to a particular type were given	*/
/* (eg, -print, -punch, -plot, -end_page, etc).  If all else fails, assume -print.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Ntypes_set = 0;
	if N.output_module > PRINT |			/* -7punch, -mcc, -raw given.			*/
	     N.pt_pch = DP_PUNCH |			/* -punch given				*/
	     Ntype = DP_PUNCH
	then do;					/* punch generic type found from -request_type	*/
	     Ntype = DP_PUNCH;
	     Ntypes_set = Ntypes_set + 1;
	end;
	if N.pt_pch = DP_PRINT |			/* -print given.				*/
	     Ntype = DP_PRINT |			/* print generic type found from -request_type	*/
	     S.nep | S.single | S.non_edited | S.truncate |
						/* other printer-oriented control args.		*/
	     S.label.top | S.label.bottom | S.label.access | N.lmargin > 0 | N.line_lth > 0 | N.page_lth > 0
	     | O.forms_name ^= ""
	then do;
	     Ntype = DP_PRINT;
	     Ntypes_set = Ntypes_set + 1;
	end;
	if N.pt_pch = DP_PLOT |			/* -plot given.				*/
	     Ntype = DP_PLOT
	then do;					/* plotter generic type found from -request_type	*/
	     Ntype = DP_PLOT;
	     Ntypes_set = Ntypes_set + 1;
	end;

	if Ntypes_set = 0
	then					/* If all else fails, assume -print.		*/
	     Ntype = DP_PRINT;
	else if Ntypes_set = 1
	then ;
	else					/* If some inconsistency found, abort.		*/
	     go to INCONSISTENT_PRINT_PUNCH_PLOT;	/* END OF PASS 1.  Generic type of request has now */
	N.pt_pch = Ntype;				/* been determined, and is stored in Ntype.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* If caller gave -set_default_request_type, then set the default request type name in	*/
/* the header, being sure that defaults for that request type are actually defined.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if O.default_request_type ^= ""
	then do;
	     call find_default (O.default_request_type, "", Ntype, FALSE, FALSE, warn_count, Pdefault);

	     if Pdefault = null & (O.name_of_default ^= O.request_type | O.default_request_type ^= O.request_type)
	     then go to DEFAULT_RQT_NOT_DEFINED;

	     default_header.default_request_type (Ntype) = O.default_request_type;
	     call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._", Pdefault_header, currentsize (default_header),
		null, null, 0, code);
	     if code ^= 0
	     then go to STORE_FAILURE;
	end;

	if O.request_type = ""
	then					/* Use default request type if -rqt not given.	*/
	     O.request_type = default_header.default_request_type (Ntype);

	if O.name_of_default = ""
	then					/* If -default_name not given, use request type 	*/
	     O.name_of_default = O.request_type;	/*   as the name.				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* At this point, we definitely have the name of the request type to be used.  Find	*/
/* defaults for this request type.  The defaults can be user-defined or (if the user has	*/
/* not defined defaults for this request type) they may have to be built just for this	*/
/* invocation.								*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Sdefault_is_stored = TRUE;
	call find_default (O.name_of_default, O.request_type, N.pt_pch, S.set_default | S.replace_default,
	     (S.pathnames), warn_count, Pdefault);
	if Pdefault = null
	then do;					/* User default not set.  Get system values.	*/
	     Pdefault = addr (auto_default);
	     call init_default (Pdefault, O.name_of_default, O.request_type, N.pt_pch);
	     Sdefault_is_stored = FALSE;
	end;

	if S.replace_default
	then do;					/* For -replace_defaults, reinitialize defaults.	*/
	     call init_default (Pdefault, O.name_of_default, O.request_type, N.pt_pch);
	     S.set_default = TRUE;
	end;

	if Ntype = DP_PRINT
	then do;					/* Apply user-defined defaults to argument 	*/
	     S = default_print.Sdft, by name;		/*   structures.				*/
	     N = default_print.Ndft, by name;
	     O = default_print.Odft, by name;
	     PLS_struc = default_print.LSV.fixed_part, by name;
	     PLS_struc.heading.P = addr (default_print.LSV.V.heading);
	     PLS_struc.destination.P = addr (default_print.LSV.V.destination);
	     PLS_struc.top_label.P = addr (default_print.LSV.V.top_label);
	     PLS_struc.bottom_label.P = addr (default_print.LSV.V.bottom_label);
	end;
	else do;
	     S = default_punch.Sdft, by name;
	     N = default_punch.Ndft, by name;
	     O = default_punch.Odft, by name;
	     PLS_struc = default_punch.LSV.fixed_part, by name;
	     PLS_struc.heading.P = addr (default_punch.LSV.V.heading);
	     PLS_struc.destination.P = addr (default_punch.LSV.V.destination);
	end;

	Sgive_label_warning = FALSE;			/* MIDDLE OF PASS 2.  Apply user-specified 	*/
	Sgive_nep_warning = FALSE;			/*   control args to override the defaults.	*/

	if S.non_path_ctl_args
	then					/* Parse arguments for PASS 2.		*/
	     call proc_args (FALSE, Nqueued);


	if O.request_type = default_print.name
	then					/* If the -default_name control arg was omitted,	*/
						/*   then its value came from -rqt control arg	*/
						/*   (or from default_header).  The same is true	*/
						/*   if -request_type was omitted.  In both cases, */
	     if S.dnm_or_rqt_omitted
	     then					/*   use real request type associated with this 	*/
		O.request_type = default_print.request_type;
						/*   group of user-defined defaults.		*/

	if ^S.dnm_or_rqt_omitted
	then					/* If both -request_type and -default_name were	*/
	     if O.request_type ^= default_print.request_type & ^(S.set_default | S.replace_default)
	     then					/*   given and we're not setting/replacing the	*/
		go to INCONSISTENT_DNM_RQT_ARGS;	/*   defaults, and the given request type differs */
						/*   from the one stored with the defaults assoc. */
						/*   with the group identified by -default_name,	*/
						/*   then complain about the inconsistency.	*/

	if N.queue = 0
	then do;					/* Make sure request type is defined.		*/
	     call iod_info_$queue_data (O.request_type, 0, 0, code);
	     if code ^= 0
	     then do;
		if (S.print_default | S.list_defaults | S.delete_default) & ^S.pathnames
		then ;
		else go to DEFAULT_QUEUE_UNDEFINED;
	     end;
	end;
	else do;					/* If user gave a queue, make sure this request	*/
	     call iod_info_$queue_data (O.request_type, 0, max_q, code);
	     if code ^= 0
	     then do;				/*   type defines that queue.			*/
		if (S.print_default | S.list_defaults | S.delete_default) & ^S.pathnames
		then ;
		else go to MAX_QUEUE_UNDEFINED;
	     end;
	     else if N.queue > max_q
	     then go to MAX_QUEUE_EXCEEDED;
	end;

	if N.copies = 0
	then					/* Set default copy count.			*/
	     N.copies = 1;
	else if N.copies > MAX_COPIES
	then do;
	     call ioa_ ("Warning: -copies ^d is too large.  -copies ^d will be used instead.", N.copies, MAX_COPIES);
	     N.copies = MAX_COPIES;
	end;

	if Ntype = DP_PRINT
	then do;					/* Check printer-related items.		*/
	     N.output_module = PRINT;
	     if N.line_lth > MAX_LINE_LENGTH
	     then go to MAX_LINE_LENGTH_EXCEEDED;
	     if N.line_lth > 0
	     then if N.lmargin >= N.line_lth
		then go to INDENT_INCONSISTENT_WITH_LINE_LENGTH;
	     if N.lmargin >= MAX_LINE_LENGTH
	     then go to MAX_INDENT_EXCEEDED;

	     input_forms_string_length = length (rtrim (O.forms_name));
	     allocate validate_forms_info_input in (area);
	     validate_forms_info_input.version = VALIDATE_FORMS_INFO_INPUT_VERSION_1;
	     validate_forms_info_input.request_type = O.request_type;
	     validate_forms_info_input.user_area_ptr = Parea;
	     validate_forms_info_input.max_forms_string_length = 64;
	     validate_forms_info_input.forms_string = rtrim (O.forms_name);
	     call iod_info_$validate_forms_info (validate_forms_info_input_ptr, validate_forms_info_output_ptr, code);
	     if code ^= 0
	     then if code ^= error_table_$no_forms_table_defined
		then go to ERROR_VALIDATING_FORM;
	     if N.line_lth > validate_forms_info_output.chars_per_line
	     then call ioa_ ("Warning: Specified line length (^d) is greater than request type maximum of ^d.",
		     N.line_lth, validate_forms_info_output.chars_per_line);
	     if N.page_lth > validate_forms_info_output.lines_per_page
	     then call ioa_ ("Warning: Specified page length (^d) is greater than request type maximum of ^d.",
		     N.page_lth, validate_forms_info_output.lines_per_page);
	     if O.forms_name ^= "" & ^validate_forms_info_output.forms_allowed
	     then call ioa_ (
		     "Warning:^-The ^a request type does not support user specified forms.^/^-The forms specified may be ignored.",
		     O.request_type);
	     if validate_forms_info_output.forms_length ^= 0
	     then if validate_forms_info_output.returned_forms ^= O.forms_name
		then O.forms_name = validate_forms_info_output.returned_forms;
	end;					/* END OF PASS 2.				*/


	if S.set_default
	then do;					/* Set user-defined group of defaults, based upon */
	     if Ntype = DP_PRINT
	     then do;				/*   current control arguments.		*/
		allocate default_print in (area) set (Pnew_default);
		Pnew_default -> default_print.header = default_print.header;
		Pnew_default -> default_print.size = currentsize (Pnew_default -> default_print);
		Pnew_default -> default_print.Sdft = S, by name;
		Pnew_default -> default_print.Ndft = N, by name;
		Pnew_default -> default_print.Odft.request_type = O.request_type;
		Pnew_default -> default_print.Odft.forms_name =
		     substr (O.forms_name, 1, length (Pnew_default -> default_print.Odft.forms_name));
		Pnew_default -> default_print.LSV.fixed_part = PLS_struc, by name;
		Pnew_default -> default_print.LSV.V.heading = PLS_heading;
		Pnew_default -> default_print.LSV.V.destination = PLS_destination;
		Pnew_default -> default_print.LSV.V.top_label = PLS_top_label;
		Pnew_default -> default_print.LSV.V.bottom_label = PLS_bottom_label;
	     end;
	     else do;
		allocate default_punch in (area) set (Pnew_default);
		Pnew_default -> default_punch.header = default_punch.header;
		Pnew_default -> default_punch.size = currentsize (Pnew_default -> default_punch);
		Pnew_default -> default_punch.Sdft = S, by name;
		Pnew_default -> default_punch.Ndft = N, by name;
		Pnew_default -> default_punch.Odft = O, by name;
		Pnew_default -> default_punch.LSV.fixed_part = PLS_struc, by name;
		Pnew_default -> default_punch.LSV.V.heading = PLS_heading;
		Pnew_default -> default_punch.LSV.V.destination = PLS_destination;
	     end;
	     call free_default (Pdefault);		/* small window here where cleanup would not free	*/
	     Pdefault_temp = Pnew_default;		/*   new defaults storage.  This is better then	*/
	     Pnew_default = null;			/*   trying to free same storage twice.		*/
	     Pdefault = Pdefault_temp;

	     call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pdefault), Pdefault, default_print.size,
		null, null, 0, code);
	     if code ^= 0
	     then go to STORE_FAILURE;
	end;

	if N.queue = 0
	then do;					/* Get default queue for request type, if needed.	*/
	     call iod_info_$queue_data (O.request_type, N.queue, 0, code);
	end;

	if S.pathnames
	then do;
	     if warn_count > 0
	     then call ioa_ ("^/Warning: no eor defaults are defined for the ^a request type.", O.request_type);
	     dpap = addr (dprint_arg_buf);		/* overlay storage space with dprint arg structure */
	     dprint_arg.version = dprint_arg_version_10;	/* initialize the structure.			*/
	     dprint_arg.dest = "";
	     dprint_arg.carriage_control = FALSE;
	     dprint_arg.pad (*) = 0;
	     dprint_arg.forms, dprint_arg.form_name, dprint_arg.forms_name = "";
	     dprint_arg.class = "";
	     dprint_arg.bit_count = 0;
	     dprint_arg.chan_stop_path = "";
	     dprint_arg.carriage_control = S.carriage_control, by name;
	     dprint_arg = N, by name;
	     dprint_arg.request_type = O.request_type;
	     dprint_arg.forms_name = substr (O.forms_name, 1, length (dprint_arg.forms_name));
	     Nqueued = 0;				/* initialize operand counter.		*/
	     call proc_args (TRUE, Nqueued);
EXIT:
	     call print_totals (Nqueued);
	end;
	else if S.set_default | S.print_default | S.list_defaults | S.delete_default | O.default_request_type ^= ""
	then ;
	else do;
	     Nqueued = 0;
	     call print_totals (Nqueued);		/* END OF PASS 3.				*/
	end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The following code handles -print_defaults, -delete_defaults, -list_defaults and -all. */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.delete_default
	then do;
	     if Sdefault_is_stored
	     then do;
		if S.print_default & ^S.all
		then do;				/* For some reason, user wants to print the 	*/
		     call print_defaults (Pdefault, Sdefault_is_stored);
		     S.print_default = FALSE;		/*   defaults he is deleting.			*/
		end;
		call delete_default (Pdefault);
	     end;
	     else call ioa_ ("^/^a user defaults are not defined.", default_print.name);
	end;

	if S.print_default
	then do;
	     if S.all
	     then do;
		if ^Sdefault_is_stored
		then call print_defaults (Pdefault, Sdefault_is_stored);
		call list_defaults (TRUE);
	     end;
	     else do;
		call print_defaults (Pdefault, Sdefault_is_stored);
		call ioa_ ("");
	     end;
	end;
	if S.list_defaults
	then do;
	     call list_defaults (FALSE);
	     call ioa_ ("");
	end;

FINISH:
	call janitor ();
	return;

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

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*		O  T  H  E  R        E  N  T  R  Y        P  O  I  N  T  S		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

default_count:
     entry (ANrequest_types);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This entry point returns a count of the user-defined request types known to		*/
/* enter_output_request.  It is an internal interface called by print_request_types	*/
/* command to all prt to factor user-defined request types into its output.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


dcl  ANrequest_types fixed bin;			/* number of user-defined groups of default eor	*/
						/*   control arg settings.			*/

	ANrequest_types = 0;
	call init ();
	on cleanup call janitor ();

	call find_default_header ();
	if Pdefault_header = null
	then go to FINISH;

	mi.name (1) = dft_name$given_name ("**.*");
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr (mi), Parea, value_list_info_ptr, code);
	do Idft = 1 to value_list_info.pair_count;
	     call free_default (Pdefault);
	     call value_$get_data (DEFAULT_VALUE_SEG, PERM,
		substr (value_list_info.chars, value_list_info.pairs (Idft).name_index,
		value_list_info.pairs (Idft).name_len), Parea, Pdefault, 0, code);
	     if default_print.Ntype ^= UNDEFINED
	     then ANrequest_types = ANrequest_types + 1;
	end;
	go to FINISH;

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


default_request_type:
     entry (Agen_type, Arequest_type, Adefault_q, Amax_q, Acode);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This entry point is called by cor/lor/mor to get the user-defined default request	*/
/* type (actually the system-defined target for a user request type) for a particular	*/
/* generic type of I/O Daemon queue, along with the user-defined default queue and	*/
/* system-defined max queue numbers for that request type.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  Agen_type char (*),				/* Generic type for which default is wanted. (In) */
     Arequest_type char (*),				/* Default request type for that gen type. (Out)	*/
     Adefault_q fixed bin,				/* User-defined default queue for that rqt. (Out) */
     Amax_q fixed bin;				/* System-defined max queue for that rqt. (Out)	*/

	Acode = 0;				/* Provide defaults when all else fails.	*/
	Adefault_q = 3;
	Amax_q = 4;
	Arequest_type = Agen_type;

	call init ();
	do Ntype = DP_PRINT to DP_PLOT		/* Convert generic type string to a number.	*/
	     while (Agen_type ^= DEFAULT_RQT (Ntype));
	end;
	if Ntype <= DP_PLOT
	then do;					/* if printer/punch/plotter, get user-defined	*/
	     on cleanup call janitor ();		/*   default request type info.		*/
	     call find_default_header ();
	     if Pdefault_header = null
	     then go to FINISH;
	     O.name_of_default = default_header.default_request_type (Ntype);
	     call find_default (O.name_of_default, "", Ntype, FALSE, FALSE, warn_count, Pdefault);
	     if Pdefault = null
	     then do;				/* user-defined default info does not exist.	*/
		O.request_type = O.name_of_default;	/*   This is probably an inconsistency in user's	*/
		call iod_info_$queue_data (O.request_type, Adefault_q, Amax_q, Acode);
						/*   eor values in the value segment.		*/
	     end;
	     else do;				/* user-defined default info does exist.	*/
		O.request_type = default_print.Odft.request_type;
		if default_print.Ntype = DP_PRINT
		then Adefault_q = default_print.Ndft.queue;
		else Adefault_q = default_punch.Ndft.queue;
		if Adefault_q = 0
		then call iod_info_$queue_data (O.request_type, Adefault_q, Amax_q, Acode);
		else call iod_info_$queue_data (O.request_type, 0, Amax_q, Acode);
	     end;
	     Arequest_type = O.request_type;
	end;
	else					/* Not a generic type handled by eor.		*/
	     call iod_info_$queue_data (Arequest_type, Adefault_q, Amax_q, Acode);
	go to FINISH;

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


list_defaults:
     entry (AParea, APeor_defaults, Acode);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This entry point fills in the eor_defaults structure (shown below) with information	*/
/* about the user-defined default groups of control arg settings known to eor.  It is	*/
/* called by print_request_types to factor user-defined requests into prt output.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  AParea ptr,
     APeor_defaults ptr,
     Acode fixed bin (35);

%include eor_defaults;

	Acode = 0;
	call init ();
	on cleanup call janitor ();

	call find_default_header ();
	if Pdefault_header = null
	then go to FINISH;

	mi.name (1) = dft_name$given_name ("**.*");
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr (mi), Parea, value_list_info_ptr, code);

	if AParea ^= null
	then do;					/* Allocate structure in user-supplied area.	*/
	     call default_count (Nrequest_types);
	     allocate eor_defaults in (AParea -> area) set (APeor_defaults);
	     Peor_defaults = APeor_defaults;
	     eor_defaults.version = Veor_defaults_1;
	end;
	else do;					/* Use user-supplied automatic storage for struc. */
	     Peor_defaults = APeor_defaults;
	     if eor_defaults.version ^= Veor_defaults_1
	     then do;
		Acode = error_table_$unimplemented_version;
		go to FINISH;
	     end;
	     call default_count (Nrequest_types);
	     if eor_defaults.N < Nrequest_types
	     then do;
		Acode = error_table_$too_many_names;
		go to FINISH;
	     end;
	     eor_defaults.N = 0;
	end;

	do Idft = 1 to value_list_info.pair_count;	/* Fill in the structure.			*/
	     call free_default (Pdefault);
	     call value_$get_data (DEFAULT_VALUE_SEG, PERM,
		substr (value_list_info.chars, value_list_info.pairs (Idft).name_index,
		value_list_info.pairs (Idft).name_len), Parea, Pdefault, 0, code);
	     if default_print.Ntype ^= UNDEFINED
	     then do;
		eor_defaults.N = eor_defaults.N + 1;
		eor_defaults.request_type (eor_defaults.N).name = default_print.name;
		eor_defaults.request_type (eor_defaults.N).generic_type = DEFAULT_RQT (default_print.Ntype);
		eor_defaults.request_type (eor_defaults.N).Sdefault =
		     default_print.name = default_header.default_request_type (default_print.Ntype);
		eor_defaults.request_type (eor_defaults.N).target_request_type_name = default_print.Odft.request_type;
	     end;
	end;
	go to FINISH;

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


request_type:
     entry (Arqt_in, Agen_type, Arequest_type, Adefault_q, Amax_q, Acode);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This entry point is called by cor/lor/mor to convert a user-specified request type	*/
/* name into a system request type with appropriate user-defined default queue number,	*/
/* system-defined max queue number and generic type.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  Arqt_in char (*);

	Acode = 0;
	Adefault_q = 3;
	Amax_q = 4;

	call init ();
	on cleanup call janitor ();
	call find_default_header ();
	if Pdefault_header = null
	then go to FINISH;

	call find_default (Arqt_in, "", 0, FALSE, FALSE, warn_count, Pdefault);
	if Pdefault = null
	then do;					/* Not a user-defined request type.  Give system	*/
	     Arequest_type = Arqt_in;			/*   values for gen_type, default_q, max_q.	*/
	     call iod_info_$generic_type (Arequest_type, gen_type, Acode);
	     if Acode ^= 0
	     then go to FINISH;
	     Agen_type = gen_type;
	     call iod_info_$queue_data (Arequest_type, Adefault_q, Amax_q, Acode);
	end;
	else do;					/* Use user-defined values for gen_type, 	*/
	     Agen_type = DEFAULT_RQT (default_print.Ntype);
						/*   default_q, and system value for max_q.	*/
	     Arequest_type = default_print.Odft.request_type;
	     if default_print.Ntype = DP_PRINT
	     then Adefault_q = default_print.Ndft.queue;
	     else Adefault_q = default_punch.Ndft.queue;
	     if Adefault_q = 0
	     then call iod_info_$queue_data (default_print.Odft.request_type, Adefault_q, Amax_q, Acode);
	     else call iod_info_$queue_data (default_print.Odft.request_type, 0, Amax_q, Acode);
	end;
	go to FINISH;

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


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 		I  N  T  E  R  N  A  L        P  R  O  C  E  D  U  R  E  S		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


dft_name$given_ptr:
     proc (Pd) returns (char (30));

dcl  Pd ptr;

dcl  1 d aligned like default_print.header based (Pd),
     name char (30) varying;

	name = "eor.";
	name = name || rtrim (d.name);
	name = name || "._";
	return (name);


dft_name$given_name:
     entry (Aname) returns (char (30));

dcl  Aname char (*);

	name = "eor.";
	name = name || rtrim (Aname);
	name = name || "._";
	return (name);

     end dft_name$given_ptr;

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


delete_default:
     proc (Pd);

dcl  Pd ptr;

dcl  Pnew_default ptr,
     1 d aligned like default_print.header based (Pd);

	if default_header.default_request_type (Ntype) = d.name
	then do;
	     default_header.default_request_type (Ntype) = DEFAULT_RQT (Ntype);
	     Pnew_default = null;
	     on cleanup call free_default (Pnew_default);
	     call find_default (DEFAULT_RQT (Ntype), DEFAULT_RQT (Ntype), Ntype, TRUE, FALSE, warn_count, Pnew_default);
	     call free_default (Pnew_default);		/* Make sure defaults exist for this generic type. */
	     call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._", Pdefault_header, currentsize (default_header),
		null, null, 0, code);
	     if code ^= 0
	     then go to STORE_FAILURE;		/* Store new default_header.			*/
	end;

	call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pd), null, 0, null, null, 0, code);
	if code ^= 0
	then go to DELETE_FAILURE;

     end delete_default;

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


find_default:
     proc (name, rqt, Ntype, Screate, Sset_warn_count, warn_count, Pd);

dcl  name char (*),
     rqt char (*),
     Ntype fixed bin,
     Screate bit (1),
     Sset_warn_count bit (1),
     warn_count fixed bin,
     Pd ptr;

dcl  Syes bit (1),
     1 d aligned like default_print.header based (Pd),
     size builtin;

	warn_count = 0;
	if Pd ^= null
	then if d.name ^= name
	     then call free_default (Pd);
	if Pd = null
	then call value_$get_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_name (name), Parea, Pd, 0, code);
	else code = 0;

	if code = 0
	then do;
	     if d.Ntype = UNDEFINED
	     then do;
		if Screate | ^Sset_warn_count
		then do;
		     call free_default (Pd);
		     code = error_table_$noentry;
		end;
		else do;				/* Issue warning that no user defaults defined.	*/
		     warn_count, d.size = d.size + 1;
		     if d.size > 3
		     then do;
			call free_default (Pd);
			code = error_table_$out_of_bounds;
			warn_count = 0;
			call ioa_ ("^/Setting user defaults for ^a request type to system default values.
No more warnings will be issued.", name);
		     end;
		     else do;
			call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pd), Pd, size (d), null,
			     null, 0, code);
			if code ^= 0
			then go to STORE_FAILURE;
			call free_default (Pd);
			code = error_table_$noentry;
		     end;
		end;
	     end;
	end;
	else if code ^= 0 & Sset_warn_count & ^Screate
	then do;
	     Pd = addr (auto_default);
	     d.name = name;
	     d.Ntype = UNDEFINED;
	     d.size = 1;
	     call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pd), Pd, size (d), null, null, 0, code);
	     if code ^= 0
	     then go to STORE_FAILURE;
	     code = error_table_$noentry;
	     warn_count = 1;
	     Pd = null;
	end;

	if code ^= 0
	then do;
	     if ^Screate & code ^= error_table_$out_of_bounds
	     then do;
		Pd = null;
		return;
	     end;
	     Pd = addr (auto_default);
	     call init_default (Pd, name, rqt, Ntype);
	     call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pd), Pd, d.size, null, null, 0, code);
	     if code ^= 0
	     then go to STORE_FAILURE;
	end;
	else do;
	     if Ntype ^= UNDEFINED & d.Ntype ^= Ntype
	     then do;
		if Screate
		then do;
		     call command_query_$yes_no (Syes, 0, proc, "yes, y
   change the generic type of ^a to ^3s^[printer^;punch^;plotter^]
no, n
   do not change the generic type of ^a to ^[printer^;punch^;plotter^].
   Instead, exit the eor command without doing anything.

Change the generic type?", "The ^a eor default already exists, and is a^[
^; ^]^[printer^;punch^;plotter^] generic type.^[
^;  ^]Do you want to change its generic type to ^[printer^;punch^;plotter^]?", name, ll_query () < 90, d.Ntype,
			ll_query () >= 90, Ntype, name, Ntype);
		     if Syes
		     then do;
			call free_default (Pd);
			Pd = addr (auto_default);
			call init_default (Pd, name, rqt, Ntype);
			call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pd), Pd, d.size, null,
			     null, 0, code);
			if code ^= 0
			then go to STORE_FAILURE;
		     end;
		     else go to FINISH;
		end;
		else do;
		     call com_err_ (error_table_$inconsistent, proc, "^[-print^;-punch^;-plot^]
cannot be used with the ^a eor defaults, which are ^[printer^;punch^;plotter^] defaults.", Ntype, name, d.Ntype);
		     go to FINISH;
		end;
	     end;
	end;

     end find_default;

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


find_default_header:
     proc;

dcl  Idft fixed bin,
     header char (6),
     old_header char (28);

	header = "eor._";				/* Name of default_header structure value.	*/

REFIND_HEADER:
	call value_$get_data (DEFAULT_VALUE_SEG, PERM, header, Parea, Pdefault_header, 0, code);
	if code = error_table_$oldnamerr
	then do;
	     old_header = rtrim (person) || ".eor._";
	     call value_$get_data (DEFAULT_VALUE_SEG, PERM, old_header, Parea, Pdefault_header, 0, code);
	end;
	if code = error_table_$oldnamerr
	then do;
	     Pdefault_header = addr (auto_default_header);
	     default_header.version = Vdefault_header_10;
	     do Idft = DP_PRINT to DP_PLOT;
		default_header.default_request_type (Idft) = DEFAULT_RQT (Idft);
		Pdefault = addr (auto_default);
		call init_default (Pdefault, DEFAULT_RQT (Idft), DEFAULT_RQT (Idft), Idft);
		call value_$set_data (DEFAULT_VALUE_SEG, PERM, dft_name$given_ptr (Pdefault), Pdefault,
		     default_print.size, null, null, 0, code);
		if code ^= 0
		then go to STORE_FAILURE;
	     end;
	     call value_$set_data (DEFAULT_VALUE_SEG, PERM, header, Pdefault_header, currentsize (default_header), null,
		null, 0, code);
	     if code ^= 0
	     then go to STORE_FAILURE;
	end;

	else if code = error_table_$noentry
	then do;
	     call value_$set_path (value_seg_path, TRUE, code);
	     if code = 0
	     then go to REFIND_HEADER;
	     else do;
		call com_err_ (code, proc, "Creating default value segment
(^a).", value_seg_path);
		go to FINISH;
	     end;
	end;

	else if code ^= 0
	then do;
	     call com_err_ (code, proc, "^[^/^]Getting defaults from value segment
(^a).", ll_err () < 100, value_seg_path);
	     Pdefault_header = null;
	     return;
	end;

	if default_header.version = Vdefault_header_5
	then do;
	     call eor_cv5_6_ (addr (default_header), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, proc, "
Converting eor defaults in value segment from version 5 to 6.
(^a).", value_seg_path);
		go to FINISH;
	     end;
	end;

	if default_header.version = Vdefault_header_6
	then do;
	     call eor_cv6_7_ (addr (default_header), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, proc, "
Converting eor defaults in value segment from version 6 to 7.
(^a).", value_seg_path);
		go to FINISH;
	     end;
	end;


	if default_header.version = Vdefault_header_7
	then do;
	     call eor_cv7_8_ (addr (default_header), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, proc, "
Converting eor defaults in value segment from version 7 to 8.
(^a).", value_seg_path);
		go to FINISH;
	     end;
	end;

	if default_header.version = Vdefault_header_8
	then do;
	     call eor_cv8_9_ (addr (default_header), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, proc, "
Converting eor defaults in value segment from version 8 to 9.
(^a).", value_seg_path);
		go to FINISH;
	     end;
	end;

	if default_header.version = Vdefault_header_9
	then do;
	     call eor_cv9_10_ (addr (default_header), code);
	     if code ^= 0
	     then do;
		call com_err_ (code, proc, "
Converting eor defaults in value segment from version 9 to 10.
(^a).", value_seg_path);
		go to FINISH;
	     end;
	end;

	if default_header.version = Vdefault_header_10
	then ;
	else do;
	     call com_err_ (error_table_$unimplemented_version, proc, "
eor defaults are structured as version ^d defaults.  eor has never supported
this version.  Evidently, your value segment has been damaged
(^a).", default_header.version, value_seg_path);
	     free default_header in (area);
	     Pdefault_header = null;
	end;

     end find_default_header;

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


free_default:
     proc (Pd);

dcl  1 dwarn aligned like default_print.header based (Pd);

	if Pd ^= null
	then if Pd ^= addr (auto_default)
	     then if dprint.Ntype = DP_PRINT
		then free dprint in (area);
		else if dprint.Ntype = UNDEFINED
		then free dwarn in (area);
		else free dpunch in (area);
	Pd = null;
	return;

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


init_default:
     entry (Pd, name, rqt, Ntype);

dcl  Pd ptr,
     name char (*),
     rqt char (*),
     Ntype fixed bin;

dcl  1 dprint aligned based (Pd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 LSV,
         3 fixed_part like default_print.LSV.fixed_part,
         3 V,
	 4 heading char (0 refer (dprint.LSV.heading.L)) unal,
	 4 destination char (0 refer (dprint.LSV.destination.L)) unal,
	 4 top_label char (0 refer (dprint.LSV.top_label.L)) unal,
	 4 bottom_label char (0 refer (dprint.LSV.bottom_label.L)) unal,
     1 dpunch aligned based (Pd),
       2 header like default_punch.header,
       2 Odft like default_punch.Odft,
       2 Sdft like default_punch.Sdft,
       2 Ndft like default_punch.Ndft,
       2 LSV,
         3 fixed_part like default_punch.LSV.fixed_part,
         3 V,
	 4 heading char (0 refer (dpunch.LSV.heading.L)) unal,
	 4 destination char (0 refer (dpunch.LSV.destination.L)) unal;

	dprint.Ntype = Ntype;
	dprint.name = name;
	if Ntype = DP_PRINT
	then do;					/* Initialize printer defaults.		*/
	     dprint.Odft = "";
	     dprint.Odft.request_type = rqt;
	     dprint.Sdft = FALSE;
	     dprint.Sdft.label.access = TRUE;
	     dprint.Ndft = 0;
	     dprint.Ndft.pt_pch = DP_PRINT;
	     dprint.Ndft.copies = 1;
	     dprint.Ndft.output_module = PRINT;
	     dprint.Ndft.line_lth = -1;
	     dprint.Ndft.page_lth = -1;
	     dprint.Ndft.queue = 0;			/*   Use default queue for this request type.	*/
	     dprint.LSV.heading.S = FALSE;
	     dprint.LSV.heading.L = 0;
	     dprint.LSV.destination.S = FALSE;
	     dprint.LSV.destination.L = 0;
	     dprint.LSV.top_label.S = FALSE;
	     dprint.LSV.top_label.L = 0;
	     dprint.LSV.bottom_label.S = FALSE;
	     dprint.LSV.bottom_label.L = 0;
	     dprint.LSV.V.heading = "";
	     dprint.LSV.V.destination = "";
	     dprint.size = currentsize (dprint);
	end;
	else do;					/* Initialize punch/plotter defaults.		*/
	     dpunch.Odft.request_type = rqt;
	     dpunch.Sdft = FALSE;
	     dpunch.Ndft = 0;
	     dpunch.Ndft.pt_pch = Ntype;
	     dpunch.Ndft.copies = 1;
	     if Ntype = DP_PUNCH
	     then dpunch.Ndft.output_module = MCC;
	     else dpunch.Ndft.output_module = PLOT;
	     dpunch.Ndft.queue = 0;			/*   Use default queue for this request type.	*/
	     dpunch.LSV.heading.S = FALSE;
	     dpunch.LSV.heading.L = 0;
	     dpunch.LSV.destination.S = FALSE;
	     dpunch.LSV.destination.L = 0;
	     dpunch.LSV.V.heading = "";
	     dpunch.LSV.V.destination = "";
	     dpunch.size = currentsize (dpunch);
	end;

     end free_default;

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


init:
     proc ();

	if person = ""
	then do;					/* Get per-process values.			*/
	     call user_info_ (person, proj, "");
	     Parea = get_system_free_area_ ();
	end;

	call value_$get_path (value_seg_path, code);	/* Get path of default value seg for error msgs.	*/
	if code ^= 0
	then do;
	     call com_err_ (code, proc, "Getting default value segment pathname.");
	     go to FINISH;
	end;

	Pdefault_header = null;			/* Establish cleanup on unit.			*/
	Pdefault = null;
	Pnew_default = null;
	value_list_info_ptr = null;
	Pfcb = null;
	Pseg = null;
	star_entry_ptr = null;

	validate_forms_info_input_ptr, validate_forms_info_output_ptr = null;

     end init;

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


janitor:
     proc ();

	if star_entry_ptr ^= null
	then free star_names in (area), star_entries in (area);
						/* free structures.				*/
	if value_list_info_ptr ^= null
	then free value_list_info in (area);
	if Pseg ^= null
	then call hcs_$terminate_noname (Pseg, 0);
	if Pfcb ^= null
	then call msf_manager_$close (Pfcb);
	if Pdefault_header ^= null
	then if Pdefault_header ^= addr (auto_default_header)
	     then free default_header in (area);
	call free_default (Pdefault);
	call free_default (Pnew_default);
	if validate_forms_info_input_ptr ^= null
	then free validate_forms_info_input in (area);
	if validate_forms_info_output_ptr ^= null
	then free validate_forms_info_output in (area);

     end janitor;

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


list_defaults:
     proc (Sprint_defaults);

dcl  Sprint_defaults bit (1);

dcl  Idft fixed bin,
     Ntype fixed bin,
     Sfirst bit (1);

	mi.name (1) = dft_name$given_name ("**.*");
	if value_list_info_ptr ^= null
	then free value_list_info in (area);
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr (mi), Parea, value_list_info_ptr, code);
	do Ntype = DP_PRINT to DP_PLOT;
	     Sfirst = TRUE;
	     do Idft = 1 to value_list_info.pair_count;
		if substr (value_list_info.chars, value_list_info.pairs (Idft).name_index, 1) ^= " "
		then do;
		     call free_default (Pdefault);
		     call value_$get_data (DEFAULT_VALUE_SEG, PERM,
			substr (value_list_info.chars, value_list_info.pairs (Idft).name_index,
			value_list_info.pairs (Idft).name_len), Parea, Pdefault, 0, code);
		     if Pdefault = null
		     then ;			/* Do nothing for warn_count structures.	*/
		     else if default_print.Ntype = Ntype
		     then do;
			if Sprint_defaults
			then do;
			     call print_defaults (Pdefault, TRUE);
			     call ioa_ ("");
			     Sfirst = FALSE;
			end;
			else do;
			     call ioa_ ("^[Defaults for ^[print^;punch^;plott^]ing:
^;^s^]  ^a^[  -rqt ^a^;^s^]^[  (default)^]", Sfirst, Ntype, default_print.name,
				default_print.request_type ^= default_print.name, default_print.request_type,
				default_print.name = default_header.default_request_type (Ntype));
			     Sfirst = FALSE;
			end;
			substr (value_list_info.chars, value_list_info.pairs (Idft).name_index, 1) = " ";
		     end;
		end;
	     end;

	     if Sfirst
	     then do;
		if Sprint_defaults
		then do;
		     call free_default (Pdefault);
		     Pdefault = addr (auto_default);
		     call init_default (Pdefault, default_header.default_request_type (Ntype),
			default_header.default_request_type (Ntype), Ntype);
		     call print_defaults (Pdefault, TRUE);
		     call ioa_ ("");
		end;
		else do;
		     call ioa_ ("Defaults for ^[print^;punch^;plott^]ing:
  ^a  (default)", Ntype, default_header.default_request_type (Ntype));
		end;
	     end;
	end;

     end list_defaults;

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


ll_err:
     proc returns (fixed bin) reducible;

	if line_length_error = 0
	then line_length_error = get_line_length_$switch (iox_$error_output, 0);
	return (line_length_error);

ll_query:
     entry returns (fixed bin) reducible;

	if line_length_query = 0
	then line_length_query = get_line_length_$switch (iox_$user_io, 0);
	return (line_length_query);

     end ll_err;

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


path:
     proc (dir, ent) returns (char (168) varying);

dcl  dir char (*),
     ent char (*);

	if dir = ">"
	then return (rtrim (dir) || rtrim (ent));
	else return (rtrim (dir) || ">" || rtrim (ent));

     end path;

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


print_defaults:
     proc (Pd, Sdefault_is_stored);

dcl  Pd ptr,
     Sdefault_is_stored bit (1);

dcl  Srqt_defined bit (1),
     code fixed bin (35),
     default_queue fixed bin;

dcl  1 dprint aligned based (Pd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 LSV,
         3 fixed_part like default_print.LSV.fixed_part,
         3 V,
	 4 heading char (0 refer (dprint.LSV.heading.L)) unal,
	 4 destination char (0 refer (dprint.LSV.destination.L)) unal,
	 4 top_label char (0 refer (dprint.LSV.top_label.L)) unal,
	 4 bottom_label char (0 refer (dprint.LSV.bottom_label.L)) unal,
     1 dpunch aligned based (Pd),
       2 header like default_punch.header,
       2 Odft like default_punch.Odft,
       2 Sdft like default_punch.Sdft,
       2 Ndft like default_punch.Ndft,
       2 LSV,
         3 fixed_part like default_punch.LSV.fixed_part,
         3 V,
	 4 heading char (0 refer (dpunch.LSV.heading.L)) unal,
	 4 destination char (0 refer (dpunch.LSV.destination.L)) unal;

	if ^Sdefault_is_stored
	then call ioa_ ("^/^a user defaults are not defined.  System defaults are:", dprint.name);
	if dprint.Ntype = DP_PRINT
	then do;
	     default_queue = 0;
	     call iod_info_$queue_data (dprint.request_type, default_queue, 0, code);
	     Srqt_defined = (code = 0);
	     call ioa_ ("^a:^[ (default for printing)^]
  -rqt ^a^[^; (undefined)^]  -print
  -he^[ -astr^]^[ -enm^] ^[^a (default)^s^;^s^a^]
  -ds^[ -astr^]^[ -enm^] ^[^a (default)^s^;^s^a^]" || "
^[  -dl^]^[  -nt^]^[  -dupt^]  -q ^[^d (default)^s^;^s^d^]^[  -cp ^d^;^s^]^[  -ll ^d^;^s^]^[  -pl ^d^;^s^]"
		|| "^[  -ind ^d^;^s^]^[  -bf^]^[  -fc^]^[  -albl^]^[
^]^[  -nep^]^[  -nvertsp^]^[  -ned^]^[  -tc^]^[  -nsep^]^[  -nb^]^[^[" || "
  -label^[ -astr^]^[ -enm^]^[ -center^] ^a^10s^;^4s^[
  -tlbl^[ -astr^]^[ -enm^]^[ -center^] ^a^;^4s^]^[
  -blbl^[ -astr^]^[ -enm^]^[ -center^] ^a^;^4s^]^]^;^15s^]^[
  -forms ^a^;^s^]", dprint.name, dprint.name = default_header.default_request_type (DP_PRINT), dprint.Odft.request_type,
		Srqt_defined, dprint.LSV.heading.S.active_string, dprint.LSV.heading.S.equal_name,
		dprint.LSV.V.heading = "", person, requote_string_ (dprint.LSV.V.heading),
		dprint.LSV.destination.S.active_string, dprint.LSV.destination.S.equal_name,
		dprint.LSV.V.destination = "", proj, requote_string_ (dprint.LSV.V.destination),
		dprint.Ndft.delete = 1, dprint.Ndft.notify = 1, dprint.Ndft.defer_until_process_termination = 1,
		dprint.Ndft.queue = 0, default_queue, dprint.Ndft.queue, dprint.Ndft.copies > 1, dprint.Ndft.copies,
		dprint.Ndft.line_lth > 0, dprint.Ndft.line_lth, dprint.Ndft.page_lth > 0, dprint.Ndft.page_lth,
		dprint.Ndft.lmargin > 0, dprint.Ndft.lmargin, dprint.Sdft.brief, dprint.Sdft.force,
		dprint.Sdft.label.access,
		(dprint.Sdft.nep | dprint.Sdft.single | dprint.Sdft.non_edited | dprint.Sdft.truncate),
		dprint.Sdft.nep, dprint.Sdft.single, dprint.Sdft.non_edited, dprint.Sdft.truncate,
		dprint.Sdft.no_separator, dprint.Sdft.line_nbrs, (dprint.Sdft.label.top | dprint.Sdft.label.bottom),
		(dprint.LSV.V.top_label = dprint.LSV.V.bottom_label
		& unspec (dprint.LSV.top_label.S) = unspec (dprint.LSV.bottom_label.S)),
		dprint.LSV.top_label.S.active_string, dprint.LSV.top_label.S.equal_name,
		dprint.LSV.top_label.S.center, requote_string_ (dprint.LSV.V.top_label), dprint.Sdft.label.top,
		dprint.LSV.top_label.S.active_string, dprint.LSV.top_label.S.equal_name,
		dprint.LSV.top_label.S.center, requote_string_ (dprint.LSV.V.top_label), dprint.Sdft.label.bottom,
		dprint.LSV.bottom_label.S.active_string, dprint.LSV.bottom_label.S.equal_name,
		dprint.LSV.bottom_label.S.center, requote_string_ (dprint.LSV.V.bottom_label),
		(dprint.Odft.forms_name ^= ""), requote_string_ (rtrim (dprint.Odft.forms_name)));
	end;


	else do;
	     default_queue = 0;
	     call iod_info_$queue_data (dpunch.request_type, default_queue, 0, code);
	     Srqt_defined = (code = 0);
	     call ioa_ ("^a:^[ (default for ^[^;punch^;plott^]ing)^;^s^]
  -rqt ^a^[^; (undefined)^]  ^[^;-punch^;-plot^]
  -he^[ -astr^]^[ -enm^] ^[^a (default)^s^;^s^a^]"
		||
		"
  -ds^[ -astr^]^[ -enm^] ^[^a (default)^s^;^s^a^]
^[  -dl^]^[  -nt^]^[  -dupt^]  -q ^[^d (default)^s^;^s^d^]^[  -cp ^d^;^s^]^[  -bf^]^[  -fc^]^[^;  -7punch^;  -mcc^;  -raw^]",
		dpunch.name, dpunch.name = default_header.default_request_type (dpunch.Ntype), dpunch.Ntype,
		dpunch.Odft.request_type, Srqt_defined, dpunch.Ntype, dpunch.LSV.heading.S.active_string,
		dpunch.LSV.heading.S.equal_name, dpunch.LSV.V.heading = "", person,
		requote_string_ (dpunch.LSV.V.heading), dpunch.LSV.destination.S.active_string,
		dpunch.LSV.destination.S.equal_name, dpunch.LSV.V.destination = "", proj,
		requote_string_ (dpunch.LSV.V.destination), dpunch.Ndft.delete = 1, dpunch.Ndft.notify = 1,
		dpunch.Ndft.defer_until_process_termination = 1, dpunch.Ndft.queue = 0, default_queue,
		dpunch.Ndft.queue, dpunch.Ndft.copies > 1, dpunch.Ndft.copies, dpunch.Sdft.brief, dpunch.Sdft.force,
		dpunch.Ndft.output_module);
	end;

     end print_defaults;

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


print_totals:
     proc (Nqueued);

dcl  Nqueued fixed bin;

dcl  Nalready_in_queue fixed bin,			/* number of entries queued.			*/
     code fixed bin (35);

	if S.brief
	then ;					/* if in brief mode, don't report queue statistics */
	else do;
	     call dprint_$queue_contents (O.request_type, N.queue, Nalready_in_queue, code);
	     if code = error_table_$noentry
	     then Nalready_in_queue = 0;
	     else Nalready_in_queue = Nalready_in_queue - Nqueued;
						/* compute how many were queued before we added	*/
	     if Nalready_in_queue < 0
	     then					/* ours.  Make sure total doesn't come out	*/
		Nalready_in_queue = 0;		/* negative (one of ours already printed).	*/
	     call ioa_ ("^[^d request^[s^] submitted; ^d already^s^;^2s^d request^[s^]^] in ^a queue ^d.", Nqueued > 0,
		Nqueued, Nqueued > 1, Nalready_in_queue, Nalready_in_queue ^= 1, O.request_type, N.queue);
	end;

     end print_totals;

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


proc_args:
     proc (Ssubmit, Nqueued);

dcl  Ssubmit bit (1),
     Nqueued fixed bin;

dcl  IPLS fixed bin,
     Iarg fixed bin,
     Isearch fixed bin,
     Larg fixed bin (21),
     Lop fixed bin (21),
     Parg ptr,
     Pop ptr,
     Snon_path_ctl_arg bit (1),
     Sstring bit (1),
     arg char (Larg) based (Parg),
     argv char (32) varying,
     arg_no fixed bin,
     op char (Lop) based (Pop),
     op_no fixed bin unsigned;

	do Iarg = 1 to Nargs;
	     call cu_$arg_ptr_rel (Iarg, Parg, Larg, code, Parg_list);
	     if index (arg, "-") ^= 1
	     then do;
		S.pathnames = TRUE;
		if Ssubmit
		then call proc_path (arg, FALSE, Nqueued);
	     end;
	     else do;
		Snon_path_ctl_arg = TRUE;
		argv = arg || NL;			/* add a NL to user-supplied control arg to 	*/
		Isearch = index (arg_table, argv);	/*   that search through arg_table finds exactly	*/
		if Isearch = 0
		then do;				/*   the control arg user specified.		*/
		     S.error = TRUE;
		     call com_err_ (error_table_$badopt, proc, "^a", arg);
		end;
		else do;
		     Pdesc = addr (Pdesc);
		     Pdesc = addr (arg_tbl_array (Isearch - length (string (desc))));
		     arg_no = desc.arg_no;
		     if desc.type = "S+" & ^Ssubmit
		     then switch_array (arg_no) = TRUE;
		     else if desc.type = "S^" & ^Ssubmit
		     then switch_array (arg_no) = FALSE;
		     else if desc.type = "N " & ^Ssubmit
		     then number_array (arg_no) = desc.arg_val;

		     else if desc.type = "Nb" | desc.type = "Ch" | desc.type = "PL" | desc.type = "Sp"
		     then do;
			if desc.type = "Nb" | desc.type = "Ch" | desc.type = "PL"
			then do;
			     if Iarg = Nargs
			     then do;
				S.error = TRUE;
				call com_err_ (error_table_$noarg, proc, "^a requires an operand.", arg);
				Pop = addr (Pop);
				Lop = 0;
			     end;
			     else do;
				Iarg = Iarg + 1;
				call cu_$arg_ptr_rel (Iarg, Pop, Lop, code, Parg_list);
			     end;
			end;

			if desc.type = "Nb" & ^Ssubmit
			then do;
			     if op = "default" | op = "dft" | op = "-default" | op = "-dft"
			     then op_no = 0;
			     else do;
				on conversion, size
				     begin;
				     S.error = TRUE;
				     call com_err_ (error_table_$bad_arg, proc, "^a ^a
^a requires a nonnegative integer operand.", arg, op, arg);
				     op_no = 0;
				     go to IGNORE_OPERAND;
				end;
				op_no = convert (op_no, op);
IGNORE_OPERAND:
				revert conversion, size;
			     end;
			     number_array (arg_no) = op_no;
			end;

			else do;
			     if desc.type = "PL"
			     then do;
				IPLS = desc.arg_val;
				if ^Ssubmit
				then PLS.S (IPLS) = FALSE;
				Sstring = FALSE;
				Sdefault = FALSE;
				do while (index (op, "-") = 1 & ^Sstring & Iarg <= Nargs);
				     if op = "-active_string" | op = "-astr"
				     then if Ssubmit
					then ;
					else PLS.S (IPLS).active_string = TRUE;
				     else if op = "-equal_name" | op = "-enm" | op = "-eqnm" | op = "-equal"
					| op = "-eq"
				     then if Ssubmit
					then ;
					else PLS.S (IPLS).equal_name = TRUE;
				     else if op = "-center" & (IPLS > 2)
						/* -center cannot be used with -ds or -he. */
				     then if Ssubmit
					then ;
					else PLS.S (IPLS).center = TRUE;
				     else if op = "-string" | op = "-str"
				     then Sstring = TRUE;

				     else if (op = "-default" | op = "-dft") & (IPLS <= 2)
				     then do;
					Sdefault = TRUE;
					Iarg = Iarg + 1;
					op = "";
					if PLS.S (IPLS).center | PLS.S (IPLS).active_string
					     | PLS.S (IPLS).equal_name
					then do;
					     S.error = TRUE;
					     call com_err_ (error_table_$badopt, proc,
						"^a^[ -astr^]^[ -enm^] -default." || "
The only control arguments which can follow^[ -astr^]^[ -enm^] are:
  -string, -str     ^[-active_string, -astr^]" || "^[^/  -equal_name, -enm^]
If you want -default as a literal ^[heading^;destination^], use: ^a^[ -astr^]^[ -enm^] -string -default", arg,
						PLS.S (IPLS).active_string, PLS.S (IPLS).equal_name,
						PLS.S (IPLS).active_string, PLS.S (IPLS).equal_name,
						PLS.S (IPLS).equal_name, PLS.S (IPLS).active_string, IPLS,
						arg, PLS.S (IPLS).active_string, PLS.S (IPLS).equal_name);
					end;
				     end;

				     else do;
					S.error = TRUE;
					call com_err_ (error_table_$badopt, proc, "^a ^a.
The only control arguments which can follow ^a are:
  -string, -str	-active_string, -astr
  -equal_name, -enm ^[-center^;-default, -dft^]
If you want ^a as a literal ^[heading^;destination^;label^;label^;label^], use:  ^a -string ^a", arg, op, arg,
					     (arg ^= "-ds" & arg ^= "-destination" & arg ^= "-he"
					     & arg ^= "-header"), op, IPLS, arg, op);
					Pop = addr (Pop);
					Lop = 0;
				     end;
				     if Pop = addr (Pop)
				     then ;	/* got an error above.  */
				     else if Sdefault
				     then ;

				     else if Iarg = Nargs
				     then do;
					S.error = TRUE;
					call com_err_ (error_table_$noarg, proc, "^[
^]^a^[ -center^]^[ -active_string^]^[ -equal_name^]^[ -string^] requires an operand.", ll_err () < 85, arg,
					     PLS.S (IPLS).center, PLS.S (IPLS).active_string,
					     PLS.S (IPLS).equal_name, Sstring);
					Pop = addr (Pop);
					Lop = 0;
				     end;
				     else do;
					Iarg = Iarg + 1;
					call cu_$arg_ptr_rel (Iarg, Pop, Lop, code, Parg_list);
				     end;
				end;
				if ^Ssubmit
				then do;
				     PLS.P (IPLS) = addr (op);
				     PLS.L (IPLS) = length (rtrim (op));
				     if ^Sstring
				     then if search (op, "=%") > 0
					then PLS.S (IPLS).equal_name = TRUE;
				end;
			     end;

			     if Ssubmit
			     then if arg_no ^= 12	/* check for -name */
				then go to END_OP;
			     go to PROC_OP (arg_no);

PROC_OP (01):
PROC_OP (02):
			     go to END_OP;

PROC_OP (03):
			     S.label.top, S.label.bottom = TRUE;
			     S.label.access = FALSE;
			     PLS_struc.bottom_label = PLS_struc.top_label;
GIVE_LABEL_WARNING:
			     if Sgive_nep_warning
			     then do;
				if S.nep
				then do;
				     call ioa_ ("Warning: -no_end_page is ignored when ^a is given.", arg);
				     Sgive_nep_warning = FALSE;
				end;
			     end;
			     S.nep = FALSE;
			     go to END_OP;

PROC_OP (04):
			     S.label.top = TRUE;
			     if S.label.access
			     then S.label.access = ^S.label.bottom;
			     go to GIVE_LABEL_WARNING;

PROC_OP (05):
			     S.label.bottom = TRUE;
			     if S.label.access
			     then S.label.access = ^S.label.top;
			     go to GIVE_LABEL_WARNING;

PROC_OP (06):
			     S.label.access = TRUE;
			     S.label.top, S.label.bottom = FALSE;
			     go to GIVE_LABEL_WARNING;

PROC_OP (07):
			     S.label.access, S.label.top, S.label.bottom = FALSE;
			     go to END_OP;

PROC_OP (08):
			     S.nep = TRUE;
			     if Sgive_label_warning
			     then do;
				if (S.label.access | S.label.top | S.label.bottom)
				then do;
				     call ioa_ ("Warning: labels are ignored when -no_end_page is given.");
				     Sgive_label_warning = FALSE;
				end;
			     end;
			     S.label = FALSE;
			     go to END_OP;

PROC_OP (09):
			     S.all = TRUE;
			     S.print_default = TRUE;
			     go to END_OP;

PROC_OP (10):
			     O.request_type = op;
			     if length (op) > length (O.request_type)
			     then do;
				call com_err_ (error_table_$bigarg, proc, "^a ^a
A request type name must be less than ^d characters long.", arg, op, length (O.request_type) + 1);
				S.error = TRUE;
			     end;
			     else if index (op, "-") = 1 | search (op, "*?") > 0
			     then do;
				if op = "-all" | op = "-a"
				then call com_err_ (error_table_$badopt, proc, "^a ^a
A request type name cannot begin with a hyphen.  To change all sets of^[
^; ^]user-defined defaults, use:^[^/^]  eor -dnm ([prt ** -udf]) -sdft {-control_args}", arg, op, ll_err () < 132,
					ll_err () >= 132);
				else if index (op, "-") = 1
				then call com_err_ (error_table_$badopt, proc, "^a ^a^[
^;   ^]A request type name cannot begin with a hyphen.", arg, op, ll_err () < 118);
				else call com_err_ (error_table_$nostars, proc, "^a ^a
To change several sets of user-defined defaults, use:^[
^]  eor -dnm ([prt ^a -udf]) -sdft {-control_args}", arg, op, ll_err () < 118, op);
				S.error = TRUE;
			     end;
			     go to END_OP;

PROC_OP (11):
			     O.default_request_type = op;
			     if O.request_type = ""
			     then O.request_type = op;
			     go to END_OP;

PROC_OP (12):
			     if Ssubmit
			     then call proc_path (op, TRUE, Nqueued);
			     Snon_path_ctl_arg = FALSE;
			     S.pathnames = TRUE;
			     go to END_OP;

PROC_OP (13):
			     O.name_of_default = op;
			     if length (op) > length (O.name_of_default)
			     then do;
				call com_err_ (error_table_$bigarg, proc, "^a ^a
A default name must be less than ^d characters long.", arg, op, length (O.name_of_default) + 1);
				S.error = TRUE;
			     end;
			     else if index (op, "-") = 1 | search (op, "*?") > 0
			     then do;
				if op = "-all" | op = "-a"
				then call com_err_ (error_table_$badopt, proc, "^a ^a
A default name cannot begin with a hyphen.  To change all sets of user-defined^[
^; ^]defaults, use:^[^/^]  eor -dnm ([prt ** -udf]) -sdft {-control_args}", arg, op, ll_err () < 132, ll_err () >= 132);
				else if index (op, "-") = 1
				then call com_err_ (error_table_$badopt, proc, "^a ^a^[
^;   ^]A default name cannot begin with a hyphen.", arg, op, ll_err () < 125);
				else call com_err_ (error_table_$nostars, proc, "^a ^a
To change several sets of user-defined defaults, use:^[
^]  eor -dnm ([prt ^a -udf]) -sdft {-control_args}", arg, op, ll_err () < 118, op);
				S.error = TRUE;
			     end;
			     go to END_OP;

PROC_OP (14):
			     O.forms_name = op;
			     go to END_OP;

END_OP:
			end;
		     end;
		end;
		if Snon_path_ctl_arg
		then S.non_path_ctl_args = TRUE;
	     end;
	end;

     end proc_args;

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


proc_label:
     proc (Ipls, pls, pls_string, dir, ent, Scenter) returns (char (136) varying);

	Scenter = pls.S.center;


proc_heading:
     entry (Ipls, pls, pls_string, dir, ent) returns (char (136) varying);

dcl  Ipls fixed bin,
     1 pls aligned like PLS,
     pls_string char (*),
     dir char (*),
     ent char (*),
     Scenter bit (1);

dcl  equal char (32),				/* name returned by get_equal_name_ for heading.	*/
     result char (136) varying;


	if pls.S.active_string
	then do;
	     result = "";
	     call cu_$evaluate_active_string (null,
		"do " || requote_string_ ("[" || pls_string || "]") || " " || path (dir, ent), NORMAL_ACTIVE_STRING,
		result, code);
	     if code = error_table_$command_line_overflow
	     then ;
	     else if code ^= 0
	     then do;
		call cp_for_error_msg ("string [do " || requote_string_ ("[" || pls_string || "]") || " "
		     || path (dir, ent) || "]");
		go to EXIT;
	     end;
	end;
	else result = pls_string;

	if pls.S.equal_name
	then do;
	     call get_equal_name_ (ent, (result), equal, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, proc, "
Applying equal convention to construct ^[heading^;destination^;top_label^;bottom_label^] field.
equal_name = ^a, entryname = ^a", Ipls, requote_string_ ((result)), requote_string_ (ent));
		go to EXIT;
	     end;
	     else result = equal;
	end;

	return (result);

cp_for_error_msg:
	proc (active_string);

dcl  active_string char (*);

dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35)),
     ioa_$ioa_switch entry () options (variable);

	     call cu_$cp (addr (active_string), length (active_string), code);
	     call ioa_$ioa_switch (iox_$error_output,
		"^a: While constructing ^[heading^;destination^;top_label^;bottom_label^] field using the active string:",
		proc, Ipls);			/* Let command processor report the error code.	*/
	     call ioa_$ioa_switch (iox_$error_output, "^a", after (active_string, "string "));

	end cp_for_error_msg;


     end proc_label;

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


proc_path:
     proc (path, Signore_stars, Nqueued);

dcl  path char (*),
     Signore_stars bit (1),
     Nqueued fixed bin;

dcl  ERROR_LABEL label variable,			/* variable error branch point label.		*/
     Ientry fixed bin,				/* do-group index for entries from hcs_$star_	*/
     Nmatches fixed bin,				/* number of entries matching a star name that	*/
						/* have been submitted for operation.		*/
     Ssuppress_errors bit (1),
     code fixed bin (35),
     dir char (168),				/* dir part of a path name.			*/
     ent char (32),					/* entry part of a path name.			*/
     name char (32);				/* a name temporary.			*/

	call expand_pathname_ (path, dir, ent, code);	/* expand it into an absolute path.		*/
	if code ^= 0
	then go to BAD_EXPAND;
	if Signore_stars
	then do;
	     ERROR_LABEL = BAD_PATH;
	     call submit (dir, ent, FALSE, ERROR_LABEL, Nqueued, 0, code);
	end;
	else do;
	     call check_star_name_$entry (ent, code);	/* see if name has *'s, or is a bad star name.	*/
	     if code = error_table_$badstar
	     then go to BAD_EXPAND;
	     else if code = 0
	     then do;				/* name contains no *'s.			*/
		ERROR_LABEL = BAD_PATH;		/* error exit to print a message, and skip operand */
		call submit (dir, ent, FALSE, ERROR_LABEL, Nqueued, 0, code);
						/* submit entry; never suppress errors.		*/
	     end;
	     else do;				/* name contains stars.			*/
		ERROR_LABEL = IGNORE_ENTRY;		/* error exit to print message, and ignore entry	*/
						/* whose name matches operand.		*/
		Nmatches = 0;			/* initialize count of matching branches which are */
						/* submitted successfully.			*/
		call hcs_$star_ (dir, ent, star_ALL_ENTRIES, addr (area), star_entry_count, star_entry_ptr,
		     star_names_ptr, code);
		if code ^= 0
		then				/* find branches which match starred operand.	*/
		     go to BAD_PATH;		/* Report any errors to user.			*/
		do Ientry = 1 to star_entry_count;	/* handle matching entries, one by one.		*/
		     name = star_names (star_entries (Ientry).nindex);
						/* copy name for efficiency.			*/
		     if star_entries (Ientry).type = Segment
		     then				/* report all errors occurring for segments.	*/
			Ssuppress_errors = FALSE;
		     else				/* suppress entry not found for link targets, and	*/
			Ssuppress_errors = TRUE;	/* attempt to print a directory errors.		*/
		     call submit (dir, name, Ssuppress_errors, ERROR_LABEL, Nqueued, Nmatches, code);
						/* submit the entry to the queue.		*/
		     go to NEXT_ENTRY;		/* handle the next entry.			*/

IGNORE_ENTRY:
		     call com_err_ (code, proc, "Entry will not be submitted
(^a^[>^]^a).", dir, dir ^= ">", name);

NEXT_ENTRY:
		end;

		free star_names in (area), star_entries in (area);
		if Nmatches = 0
		then do;				/* if no matching entries were queued, complain.	*/
		     code = error_table_$nomatch;
		     go to BAD_PATH;
		end;
	     end;
	end;
	return;


BAD_EXPAND:
	call com_err_ (code, proc, " ^a", path);
	return;

BAD_PATH:
	call com_err_ (code, proc, "^[^/^]Entry will not be submitted
(^a^[>^]^a).", ll_err () < 100, dir, dir ^= ">", ent);
	return;

     end proc_path;

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


submit:
     procedure (dir, ent, Ssuppress_errors, ERROR_LABEL, Nqueued, Nmatches, code);
						/* An internal procedure to validate and submit	*/
						/* requests to operate on operand dir>ent.	*/

dcl  dir char (*),
     ent char (*),
     Ssuppress_errors bit (1),
     ERROR_LABEL label variable,
     Nqueued fixed bin,
     Nmatches fixed bin,
     code fixed bin (35);

dcl  COORD_ACCESS_NAME char (32) int static options (constant) init ("IO.SysDaemon.z"),
     Icomp fixed bin,				/* do-group index for MSF components.		*/
     Sdelete bit (1) aligned,				/* on if IO Daemon has access to delete entry.	*/
     Sread bit (1) aligned,				/* on if IO Daemon has access to read entry.	*/
     Sstatus bit (1) aligned,				/* on if IO Daemon has status access to entry.	*/
     Syes bit (1),					/* user's yes-or-no answer to my queries.	*/
     access_class bit (72) aligned,
     access_label char (136),
     adjusted_bit_count fixed bin (35),
     1 acl aligned,					/* acl structure passed to hcs_$add_acl_entries	*/
       2 name char (32) aligned,			/* access control process identifier to be added.	*/
       2 mode bit (36),				/* "rewa"b access mode.			*/
       2 pad bit (36),
       2 code fixed bin (35),				/* status code.				*/
     bit_count fixed bin (24),
     daemon_name char (24),				/* name of IO Daemon for our device class.	*/
     1 dir_acl aligned,				/* struc for hcs_$add_dir_acl_entries.		*/
       2 name char (32),
       2 mode bit (36),
       2 code fixed bin (35),
     explain_array (2) char (158) int static options (constant) init ("yes, y
   the request will be submitted, in spite of the problem reported above.
   The caller can take corrective action after the request is submitted,
   o", "r can do nothing in the hope that the IO Daemon will not encounter
   an error.
no, n
   do not submit the request.

Do you still wish to submit the request?"),
     explanation char (315) based (addr (explain_array)),
     lv_mode bit (36) aligned,
     lv_pub_bit bit (1) aligned,
     lv_name char (32),
     question char (41) int static options (constant) init ("
Do you still wish to submit the request?");

	call hcs_$status_long (dir, ent, 1, addr (branch), null, code);
						/* get status for entry. (chase links)		*/
	if (code ^= 0) & (code ^= error_table_$no_s_permission)
	then					/* check for errors besides no status permission.	*/
						/* for that error, we get all info we need.	*/
	     if code = error_table_$noentry
	     then					/* if branch linked to was not found, then	*/
		if Ssuppress_errors
		then				/* just ignore the entry if errors are suppressed. */
		     return;
		else go to ERROR_LABEL;
	     else					/* for all other errors, report the error, and	*/
		go to ERROR_LABEL;			/* ignore the entry.			*/

	if branch.type = Directory
	then do;
	     if branch.bit_count > 0
	     then					/* An MSF					*/
		branch.type = Msf;
	     else if Ssuppress_errors
	     then return;				/* A plain directory.  Can't dprint that.	*/
	     else do;
		code = error_table_$dirseg;
		go to ERROR_LABEL;
	     end;
	end;

	if branch.mode & bit (R_ACCESS_BIN, 5)
	then ;					/* make sure user has read access on entry.	*/
	else if S.force
	then do;
	     acl.name = get_group_id_$tag_star ();
	     acl.mode = R_ACCESS;
	     acl.pad = ""b;
	     if branch.type = Segment
	     then do;
		call hcs_$add_acl_entries (dir, ent, addr (acl), 1, code);
		if code ^= 0
		then do;
		     if acl.code ^= 0
		     then code = acl.code;
FORCE_READ_FAIL:
		     call com_err_ (code, proc, "Unable to force
read access for ^a to the entry.  Entry not submitted
(^a^[>^]^a).", acl.name, dir, dir ^= ">", ent);
		     return;
		end;
	     end;
	     else do;
		call msf_manager_$open (dir, ent, Pfcb, code);
		if code ^= 0
		then go to FORCE_READ_FAIL;
		call msf_manager_$acl_add (Pfcb, addr (acl), 1, code);
		call msf_manager_$close (Pfcb);
		Pfcb = null;
		if code ^= 0
		then do;
		     code = acl.code;
		     go to FORCE_READ_FAIL;
		end;
	     end;
	end;
	else do;
	     code = error_table_$moderr;
	     call command_query_$yes_no (Syes, code, proc, explanation, "^[
^]You do not have access to read the entry.
(^a^[>^]^a)." || question, ll_query () < 90, dir, dir ^= ">", ent);
	     if ^Syes
	     then return;
	end;

	if N.pt_pch ^= DP_PUNCH
	then do;					/* Don't print or plot an object segment.	*/
	     call object_lib_$initiate (dir, ent, "", "1"b, Pseg, (0), (""b), code);
	     if Pseg ^= null
	     then do;
		call hcs_$terminate_noname (Pseg, 0);
		Pseg = null;
		call com_err_ (error_table_$improper_data_format, proc, "Entry is an object segment
(^a^[>^]^a).
It will not be ^[print^;^;plott^]ed.", dir, dir ^= ">", ent, N.pt_pch);
		return;
	     end;
	end;

	call mdc_$find_lvname (branch.lvid, lv_name, code);
	if code ^= 0
	then go to ERROR_LABEL;
	call mdc_$get_lv_access (lv_name, 1, lv_mode, lv_pub_bit, code);
	if code ^= 0
	then go to ERROR_LABEL;
	if ^lv_pub_bit
	then do;					/* Make sure seg is on a public lv.		*/
	     call com_err_ (error_table_$private_volume, proc, "Entry cannot be ^[print^;punch^;plott^]ed
(^a^[>^]^a).", N.pt_pch, dir, dir ^= ">", ent);
	     return;
	end;

	if branch.type = Msf
	then do;					/* Compute bit count of MSF.			*/
	     dprint_arg.bit_count = 0;
	     call msf_manager_$open (dir, ent, Pfcb, code);
	     if code ^= 0
	     then do;
		call command_query_$yes_no (Syes, code, proc, explanation, "
(^a^[>^]^a)." || question, dir, dir ^= ">", ent);
		if ^Syes
		then return;
	     end;
	     else do;
		do Icomp = 0 to branch.bit_count - 1;
		     call msf_manager_$get_ptr (Pfcb, Icomp, FALSE, null, bit_count, code);
		     if code ^= 0
		     then do;
			call msf_manager_$close (Pfcb);
			code = error_table_$inconsistent_msf;
			go to ERROR_LABEL;
		     end;
		     dprint_arg.bit_count = dprint_arg.bit_count + bit_count;
		end;
		call msf_manager_$close (Pfcb);
	     end;
	end;
	else dprint_arg.bit_count = branch.bit_count;	/* Segment bit count comes from hcs_$status_long	*/

	if dprint_arg.bit_count = 0 & branch.type = Segment & S.force
	then do;
	     call adjust_bit_count_ ((dir), (ent), (TRUE), adjusted_bit_count, code);
	     if code = 0
	     then dprint_arg.bit_count, branch.bit_count = adjusted_bit_count;
	     else do;
		call com_err_ (code, proc, "Unable to adjust bit count^[
^; ^]on entry.  Entry not submitted
(^a^[>^]^a).", ll_err () < 100, dir, dir ^= ">", ent);
		return;
	     end;
	end;

	if dprint_arg.bit_count > 0
	then ;					/* ask user if he wants to print a segment with	*/

	else do;					/* a zero bit count.			*/
	     code = error_table_$zero_length_seg;
	     call command_query_$yes_no (Syes, code, proc, explanation, "Entry has a zero bit count
(^a^[>^]^a)." || question, dir, dir ^= ">", ent);
	     if ^Syes
	     then return;
	end;

	call dprint_$check_daemon_access (dir, ent, dprint_arg.request_type, Sdelete, Sread, Sstatus, daemon_name, code)
	     ;
	if code ^= 0
	then do;
	     call command_query_$yes_no (Syes, code, proc, explanation, "^[
^]Unable to determine access of IO Daemon (^a) to the entry
(^a^[>^]^a)." || question, ll_query () < 100, daemon_name, dir, dir ^= ">", ent);
	     if ^Syes
	     then return;
	     go to QUEUE_ENTRY;
	end;

	if ^Sread
	then do;					/* If IO Daemon has no read access:		*/
	     if S.force
	     then do;				/*    force access for IO Daemon.		*/
		acl.name = daemon_name;
		acl.mode = R_ACCESS;
		acl.pad = ""b;
		if branch.type = Segment
		then do;
		     call hcs_$add_acl_entries (dir, ent, addr (acl), 1, code);
		     if code ^= 0
		     then do;
			if acl.code ^= 0
			then code = acl.code;
FORCE_DAEMON_READ_FAIL:
			call com_err_ (code, proc, "Unable to^[
^; ^]force read access to entry for IO Daemon (^a).  Entry not submitted
(^a^[>^]^a).", ll_err () < 132, daemon_name, dir, dir ^= ">", ent);
			return;
		     end;
		end;
		else do;
		     call msf_manager_$open (dir, ent, Pfcb, code);
		     if code ^= 0
		     then go to FORCE_DAEMON_READ_FAIL;
		     call msf_manager_$acl_add (Pfcb, addr (acl), 1, code);
		     call msf_manager_$close (Pfcb);
		     Pfcb = null;
		     if code ^= 0
		     then do;
			code = acl.code;
			go to FORCE_DAEMON_READ_FAIL;
		     end;
		end;
	     end;
	     else do;
		code = error_table_$moderr;
		call command_query_$yes_no (Syes, code, proc, explanation, "^[
^]IO Daemon (^a) do not have access to read the entry.
(^a^[>^]^a)." || question, ll_query () < 100, daemon_name, dir, dir ^= ">", ent);
		if ^Syes
		then return;
	     end;
	end;

	if ^Sstatus
	then do;
	     if S.force
	     then do;				/*    force access for IO Daemon.		*/
		dir_acl.name = daemon_name;
		dir_acl.mode = S_ACCESS;
		call hcs_$add_dir_acl_entries (dir, "", addr (dir_acl), 1, code);
		if code ^= 0
		then do;
		     if dir_acl.code ^= 0
		     then code = dir_acl.code;
		     call com_err_ (code, proc, "Unable to^[
^; ^]force status access for IO Daemon (^a)
to directory containing entry.  Entry not submitted
(^a^[>^]^a).", ll_err () < 132, daemon_name, dir, dir ^= ">", ent);
		     return;
		end;
	     end;
	     else do;
		code = error_table_$moderr;
		call command_query_$yes_no (Syes, code, proc, explanation, "^[
^]IO Daemon (^a) does not have status access
to directory containing entry
(^a^[>^]^a)." || question, ll_query () < 100, daemon_name, dir, dir ^= ">", ent);
		if ^Syes
		then return;
	     end;
	end;

	if ^Sdelete & N.delete = 1
	then do;
	     call ioa_ ("Warning:  IO Coordinator process (normally ^a)
does not have sufficient access to delete entry
(^a^[>^]^a).
The entry will be submitted anyway.", COORD_ACCESS_NAME, dir, dir ^= ">", ent);
	end;

QUEUE_ENTRY:
	dprint_arg.heading = " for " || proc_heading (HEADING, PLS_struc.heading, PLS_heading, dir, ent);
	if dprint_arg.heading = " for "
	then dprint_arg.heading = "";			/* If the heading was null don't add the " for " */
	dprint_arg.destination = proc_heading (DESTINATION, PLS_struc.destination, PLS_destination, dir, ent);

	if S.label.access
	then do;
	     call hcs_$get_access_class (dir, ent, access_class, code);
	     if code ^= 0
	     then go to ERROR_LABEL;
	     call convert_authorization_$to_string (access_class, access_label, code);
	     if ^S.label.top
	     then do;
		dprint_arg.top_label = access_label;
		dprint_arg.center_top_label = TRUE;
	     end;
	     if ^S.label.bottom
	     then do;
		dprint_arg.bottom_label = access_label;
		dprint_arg.center_bottom_label = TRUE;
	     end;
	end;

	if S.label.top
	then dprint_arg.top_label =
		proc_label (TOP_LABEL, PLS_struc.top_label, PLS_top_label, dir, ent, dprint_arg.center_top_label);
	else if ^S.label.access
	then dprint_arg.top_label = "";

	if S.label.bottom
	then dprint_arg.bottom_label =
		proc_label (BOTTOM_LABEL, PLS_struc.bottom_label, PLS_bottom_label, dir, ent,
		dprint_arg.center_bottom_label);
	else if ^S.label.access
	then dprint_arg.bottom_label = "";

REQUEUE:
	call dprint_ (dir, ent, addr (dprint_arg), code); /* add request for operation to the queue.	*/
	if code ^= 0
	then if code = error_table_$notalloc
	     then go to QUEUE_FULL;
	     else if code = error_table_$noentry
	     then go to QUEUE_MISSING;
	     else if code = error_table_$bad_segment
	     then go to QUEUE_BAD;
	     else if code = error_table_$lock_wait_time_exceeded
	     then do;
		call command_query_$yes_no (Syes, code, proc, "yes, y
   reattempt to submit the request.  The same error may occur again.
no, n
   skip this request and those which follow.", "(^a^[>^]^a)
Do you want to try submitting the request again?", dir, dir ^= ">", ent);
		if Syes
		then go to REQUEUE;
		go to EXIT;
	     end;
	     else go to QUEUE_ERROR;
	Nqueued = Nqueued + 1;
	Nmatches = Nmatches + 1;
	return;

QUEUE_BAD:
QUEUE_ERROR:
QUEUE_MISSING:
	call com_err_ (code, proc, "Queue ^d of the ^a request type.
Entry ^a^[>^]^a
and requests following it have not been submitted.", dprint_arg.queue, dprint_arg.request_type, dir, dir ^= ">", ent);
	go to EXIT;

QUEUE_FULL:
	call com_err_ (error_table_$notalloc, proc, "Queue ^d of the ^a request type is full.
Entry ^a^[>^]^a
and requests following it have not been submitted.", dprint_arg.queue, dprint_arg.request_type, dir, dir ^= ">", ent);
	go to EXIT;

     end submit;

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


DEFAULT_QUEUE_UNDEFINED:
	call com_err_ (code, proc, "
Getting default queue number for ^a request type.", O.request_type);
	go to FINISH;

DEFAULT_RQT_NOT_DEFINED:
	call com_err_ (error_table_$typename_not_found, proc, "-set_default_request_type ^a 
^a does not have system defined eor defaults.  Use -set_defaults to set it.", O.default_request_type,
	     O.default_request_type);
	go to FINISH;

DELETE_FAILURE:
	call com_err_ (code, proc, "^[
^]Attempting to delete an eor default in the value segment
(^a)", ll_err () < 118, value_seg_path);
	go to FINISH;

ERROR_VALIDATING_FORM:
	if code = error_table_$bad_forms_option
	then if validate_forms_info_output.error_length ^= 0
	     then call com_err_ (code, proc, "^a", validate_forms_info_output.error_string);
	     else go to display_general_forms_error;
	else do;
display_general_forms_error:
	     call com_err_ (code, proc, "Validating forms string ""^a"" for ^a request type.", O.forms_name,
		O.request_type);
	end;
	go to FINISH;

INCONSISTENT_DNM_RQT_ARGS:
	call com_err_ (error_table_$inconsistent, proc, "-request_type ^a -default_name ^a.
The ^a group of defaults uses the ^a request type.", O.request_type, O.name_of_default, O.name_of_default,
	     default_print.request_type);
	go to FINISH;

INCONSISTENT_PRINT_PUNCH_PLOT:
	if O.request_type ^= ""
	then do;
	     call iod_info_$generic_type (O.request_type, gen_type, code);
	     if gen_type = "printer"
	     then Ntype = DP_PRINT;
	     else if gen_type = "punch"
	     then Ntype = DP_PUNCH;
	     else Ntype = DP_PLOT;
	     if Ntype = DP_PRINT
	     then call com_err_ (error_table_$inconsistent, proc, "
Request type ^a is a ^a generic type.
The following arguments are inconsistent with printing:^[^; -7punch^; -mcc^; -raw^]^[^; -punch^; -plot^]",
		     O.request_type, gen_type, N.output_module, N.pt_pch);
	     else call com_err_ (error_table_$inconsistent, proc, "
Request type ^a is a ^a generic type.
The following are inconsistent with ^[^;punch^;plott^]ing:^[
  -access_label^]^[
  -forms^]^[
  -indent^]^[
  -label, -top_label, or -bottom_label^]^[
  -line_length^]^[
  -no_end_page^]^[" || "
  -no_vertical_space^]^[
  -non_edited^]^[
  -page_length^]^[
  ^[-print^;-punch^;-plot^]^;^s^]^[
  -truncate^]^[
  ^[^;-7punch^;-mcc^;-raw^]^;^s^]", O.request_type, gen_type, Ntype, S.label.access, O.forms_name ^= "", N.lmargin > 0,
		     S.label.top | S.label.bottom, N.line_lth > 0, S.nep, S.single, S.non_edited, N.page_lth > 0,
		     (N.pt_pch ^= UNDEFINED & N.pt_pch ^= Ntype), N.pt_pch, S.truncate,
		     (Ntype = DP_PLOT & PUNCH <= N.output_module & N.output_module <= RAW), N.output_module);
	end;
	else call com_err_ (error_table_$inconsistent, proc, "^[
Punching arguments:^[^; -7punch^; -mcc^; -raw^]^[ -punch^]^;^2s^]^[
Plotting arguments: -plot^]
Printing arguments:^[
  -access_label^]^[
  -forms^]^[
  -indent^]^[
  -label, -top_label, or -bottom_label^]^[
  -line_length^]^[
  -no_end_page^]^[" || "
  -no_vertical_space^]^[
  -non_edited^]^[
  -page_length^]^[
  -print^]^[
  -truncate^]", ((PUNCH <= N.output_module & N.output_module <= RAW) | N.pt_pch = DP_PUNCH), N.output_module,
		N.pt_pch = DP_PUNCH, N.pt_pch = DP_PLOT, S.label.access, O.forms_name ^= "", N.lmargin > 0,
		S.label.top | S.label.bottom, N.line_lth > 0, S.nep, S.single, S.non_edited, N.page_lth > 0,
		N.pt_pch = DP_PRINT, S.truncate);
	go to FINISH;

INDENT_INCONSISTENT_WITH_LINE_LENGTH:
	call com_err_ (error_table_$inconsistent, proc, "-indent ^d -line_length ^d.", N.lmargin, N.line_lth);
	go to FINISH;

MAX_INDENT_EXCEEDED:
	call com_err_ (error_table_$out_of_bounds, proc, "-indent ^d
The line length must be <= ^d.", N.lmargin, MAX_LINE_LENGTH);
	go to FINISH;

MAX_LINE_LENGTH_EXCEEDED:
	call com_err_ (error_table_$out_of_bounds, proc, "-line_length ^d
The line length must be <= ^d.", N.line_lth, MAX_LINE_LENGTH);
	go to FINISH;

MAX_QUEUE_EXCEEDED:
	call com_err_ (error_table_$out_of_bounds, proc, "-queue ^d
The ^a request type has only ^d queue^[s^].", N.queue, O.request_type, max_q, max_q > 1);
	go to FINISH;

MAX_QUEUE_UNDEFINED:
	call com_err_ (code, proc, "^[
^]Getting highest queue number for ^a request type.", ll_err () < 120, O.request_type);
	go to FINISH;

NOT_AF:
	call com_err_ (code, proc);
	go to FINISH;

STORE_FAILURE:
	call com_err_ (code, proc, "^[
^]Attempting to store an eor default in the value segment
(^a).", ll_err () < 118, value_seg_path);
	go to FINISH;

UNDEFINED_GENERIC_TYPE:
	call com_err_ (error_table_$typename_not_found, proc, "Request type ^a is of
^a generic type.  ^a cannot handle this generic type.", O.request_type, gen_type, proc);
	go to FINISH;

UNDEFINED_REQUEST_TYPE:
	call com_err_ (code, proc, "^[
^]The ^a request type is not defined.", ll_err () < 118, O.request_type);
	go to FINISH;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include access_mode_values;

%include cp_active_string_types;

%include dprint_arg;

%include star_structures;

%include status_structures;

dcl  Msf fixed bin int static options (constant) init (3),
     1 branch aligned like status_branch;

%include value_structures;

dcl  1 mi aligned,					/* automatic copy of match_info		*/
       2 version fixed bin init (1),
       2 name_count fixed bin init (1),
       2 max_name_length fixed bin init (30),
       2 name_array (1),
         3 exclude_sw bit (1) unal init ("0"b),
         3 regexp_sw bit (1) unal init ("0"b),
         3 pad bit (34) unal init ("0"b),
         3 name char (30) varying;
%include user_forms_info;
     end enter_output_request;



		    eor_cv5_6_.pl1                  11/04/82  2006.8rew 11/04/82  1610.6       80208


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

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This program is called by enter_output_request.  eor stored user-defined default	*/
	/* control argument settings in the default value segment as binary data values.  This	*/
	/* program converts these values from version 5 to version 6 format.  The only		*/
	/* difference between versions is that version 5 makes no constraints on the names of	*/
	/* these groups of defaults.  Version 6 disallows names which begin with a hyphen or	*/
	/* contain * or ? characters.							*/
	/*									*/
	/* Status:								*/
	/* Created:    June 2, 1982 by G. C. Dixon					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

eor_cv5_6_:
	proc(Pdefault_header, code);

    dcl	Pdefault_header		ptr,
	code			fixed bin(35);

    dcl	Pd			ptr,
	answer			char(28) varying,
	area			area(4096),
	dft_name			char(28) varying,
	d_size			fixed bin(18),
	i			fixed bin,
	unseen(2)			bit(1) aligned,
	unseen_overall_reason	bit(1);

    dcl	1 default_header		aligned based(Pdefault_header),
	  2 version		fixed bin,	/* structure containing default request types and */
	  2 default_request_type (3)	char(24) unal,	/* defining version of default_(print punch)	*/
						/* structures above.  The default_request_type	*/
						/* array elements are for printing, punching and	*/
	Vdefault_header_6		fixed bin int static options(constant) init(6),
						/* Version 6 de-supports default names beginning	*/
						/*   with hyphen or which are starnames.	*/
	1 default,
	  2 header,
	    3 Ntype		fixed bin,	/* This structure holds information corresponding */
	    3 name		char(24) unal,	/*   to the O, S, N and PLS structures above, in	*/
	    3 size		fixed bin(18),	/*   the form in which it is stored as 		*/
	1 d			aligned based(Pd),
	  2 header		like default.header,
	  2 data (d_size - size(default))
				fixed bin;

    dcl  (addr, after, empty, index, length, null, search, size, substr, translate)
				builtin;

    dcl	command_query_		entry() options(variable),
	ioa_$ioa_switch		entry() options(variable),
	value_$delete_data		entry (ptr, bit(36) aligned, char(*), fixed bin(35)),
	value_$get_data		entry (ptr, bit(36) aligned, char(*), ptr, ptr, fixed bin(18),
				     fixed bin(35)),
	value_$list_data_names	entry (ptr, bit(36) aligned, ptr, ptr, ptr, fixed bin(35)),
	value_$set_data		entry (ptr, bit(36) aligned, char(*), ptr, fixed bin(18), ptr, ptr,
				     fixed bin(18), fixed bin(35));

    dcl	AZ			char(26) int static options(constant)
				     init("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
	DEFAULT_VALUE_SEG		ptr int static options(constant) init(null),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	PERM			bit(36) aligned int static options(constant) init("01"b),
	az			char(26) int static options(constant)
				     init("abcdefghijklmnopqrstuvwxyz"),
	iox_$user_io		ptr ext static,
	new_name_explanation	char(58) int static options(constant) init(
"Please give the new name for the ^a group of eor defaults:"),
	rename_explanation		char(250) int static options(constant) init(
"^7sThe enter_output_request user-defined defaults called ^a must be renamed
or deleted because the name is no longer valid.  Please type ""rename"" if you
wish to rename the group of defaults, or ""delete"" if you wish to delete it.
Rename or delete?");

	code = 0;
	unseen_overall_reason = TRUE;			/* Emit error messages like compilers, with each	*/
	unseen(*) = TRUE;				/*   message numbered and message text printed 	*/
						/*   only once.				*/

	mi.name(1) = "eor.**.*._";
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr(mi),
	   addr(area), value_list_info_ptr, code);	/* Get a list of eor-related data items from value*/
	do i = 1 to value_list_info.pair_count;		/*   seg.  Check name of each one.		*/
	   dft_name = substr(value_list_info.chars,
	      value_list_info.pairs(i).name_index, value_list_info.pairs(i).name_len);
	   dft_name = after(dft_name,".");
	   dft_name = substr(dft_name,1,length(dft_name)-2);
	   if index(dft_name,"-") = 1 then
	      call eliminate (dft_name, 1, "begin with a hyphen");
	   else if search(dft_name, "?*")>0 then
	      call eliminate (dft_name, 2, "be a starname (containing * or ? chars)");
	   end;
	default_header.version = Vdefault_header_6;
	call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._",
	   Pdefault_header, size(default_header), null, null, 0, code);
ERROR_EXIT:
	return;

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


eliminate:					/* Eliminate bad names by allowing user to choose */
	proc (name, Nerr, reason);			/*   renaming or deleting of the badly-named	*/
						/*   group of defaults			*/

    dcl  (name, reason)		char(*) varying,
	Nerr			fixed bin;

	qi.version = query_info_version_5;
	qi.switches = FALSE;
	qi.switches.yes_or_no_sw = FALSE;
	qi.suppress_name_sw = ^unseen_overall_reason;
	qi.status_code = 0;
	qi.query_code = 0;
	qi.question_iocbp = null;
	qi.answer_iocbp = null;
	qi.repeat_time = 0;

	qi.explanation_ptr = addr(rename_explanation);	/* Ask user whether to rename or delete?	*/
	qi.explanation_len = length(rename_explanation);
REASK_RENAME:
	call command_query_(addr(qi), answer, "enter_output_request",
	   "^[Invalid default name ^a.
^;^s^]ERROR ^d: ^[A default name may not ^a. ^;^s^]^[
This is a change to the naming conventions allowed by eor.  To accomodate this
change, do^s^;  ^a
Do^] you want to rename (rn) or delete (dl) the ^a defaults?",
	   unseen_overall_reason, name,
	   Nerr,
	   unseen(Nerr), reason,
	   unseen_overall_reason, name, name);

	answer = translate (answer, az, AZ);		/* Canonicalize user's answer.		*/
	if answer = "rename" | answer = "rn" | answer = "r" then
	   answer = "rename";
	else if answer = "delete" | answer = "dl" | answer = "d" then
	   answer = "delete";
	else do;
	   call ioa_$ioa_switch (iox_$user_io, "Please answer ""rename"" or ""delete"".");
	   go to REASK_RENAME;
	   end;

	unseen_overall_reason = FALSE;		/* Mark overall reason for change, and this error */
	unseen(Nerr) = FALSE;			/*   as already having been seen.		*/

	if answer = "rename" then do;			/* Renaming?  Ask for the new name and validate it*/
	   qi.explanation_ptr = addr(new_name_explanation);
	   qi.explanation_len = length(new_name_explanation);
	   call command_query_(addr(qi), answer, "enter_output_request",
	      "New name:", name);
ANSWER_CHECK:
	   if length(answer) > 24 then do;
	      call command_query_ (addr(qi), answer, "enter_output_request",
	         "^a is too long.  The new name must be less than 25 characters long.
New name:", answer);
	      go to ANSWER_CHECK;
	      end;
	   else if index(answer,"-")=1 then do;
	      call command_query_ (addr(qi), answer, "enter_output_request",
	         "^a is an illegal name.  The name cannot begin with a hyphen.
New name:", answer);
	      go to ANSWER_CHECK;
	      end;
	   else if search(answer,"*?")>0 then do;
	      call command_query_ (addr(qi), answer, "enter_output_request",
	         "^a is an illegal name.  The name cannot be a starname.
New name:", answer);
	      go to ANSWER_CHECK;
	      end;
	   call value_$get_data (DEFAULT_VALUE_SEG, PERM,
	      "eor." || name || "._", addr(area), Pd, d_size, code);
	   d.name = answer;
	   call value_$delete_data (DEFAULT_VALUE_SEG, PERM, "eor." || name || "._", code);
	   if code ^= 0 then go to ERROR_EXIT;
	   call value_$set_data (DEFAULT_VALUE_SEG, PERM,
	      "eor." || answer || "._", Pd, d_size, null, null, 0, code);
	   if code ^= 0 then go to ERROR_EXIT;
	   free d in (area);
	   end;

	else do;					/* delete					*/
	   call value_$delete_data (DEFAULT_VALUE_SEG, PERM, "eor." || name || "._", code);
	   if code ^= 0 then go to ERROR_EXIT;
	   end;

	end eliminate;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include query_info;

    dcl	1 qi			aligned like query_info;

%include value_structures;

    dcl	1 mi			aligned,		/* automatic copy of match_info		*/
	  2 version		fixed bin init(1),
	  2 name_count		fixed bin init(1),
	  2 max_name_length		fixed bin init(30),
	  2 name_array (1),
	    3 exclude_sw		bit(1) unal init("0"b),
	    3 regexp_sw		bit(1) unal init("0"b),
	    3 pad			bit(34) unal init("0"b),
	    3 name		char(30) varying;

	end eor_cv5_6_;



		    eor_cv6_7_.pl1                  10/28/88  1348.6r w 10/28/88  1302.1       66069


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

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This program is called by enter_output_request.  eor stored user-defined default	*/
	/* control argument settings in the default value segment as binary data values.  This	*/
	/* program converts these values from version 6 to version 7 format.  The only		*/
	/* difference between versions is that version 7 supports -dupt.			*/
	/*									*/
	/* Status:								*/
	/* Created:    June, 1982 by R. Kovalcik from eor_cv5_6_.pl1.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

eor_cv6_7_:
	proc(Pdefault_header, code);


%include dprint_arg;


%include value_structures;


    dcl	Pdefault_header		ptr,
	code			fixed bin(35);

    dcl	Pd			ptr,
    	Pnd			ptr,
	area			area(4096),
	dft_name			char(28) varying,
	d_size			fixed bin(18),
	i			fixed bin;

   dcl	Vdefault_header_7		fixed bin int static options(constant) init(7);
						/* Version 7 supports -dupt.			*/

    dcl	DEFAULT_VALUE_SEG		ptr int static options(constant) init(null),
	PERM			bit(36) aligned int static options(constant) init("01"b);
	

    dcl	1 default_header		aligned based(Pdefault_header),
	  					/* Structure containing default request types */
	  2 version		fixed bin,
	  2 default_request_type (3)	char(24) unal,

	1 default,				/* Structure containing general argument defaults	*/
	  2 header,
	    3 Ntype		fixed bin,
	    3 name		char(24) unal,
	    3 size		fixed bin(18),

	1 d			aligned based(Pd),
	  2 header		like default.header,
	  2 data (d_size - size(default))
				fixed bin,

	1 default_print		aligned,		/* Structure containing print argument defaults	*/
	  2 header,
	    3 Ntype		fixed bin,
	    3 name		char(24) unal,
	    3 size		fixed bin(18),
	  2 Odft,					
	    3 request_type		char(24) unal,
	    3 form_name		char(24) unal,
	  2 Sdft,
	    3 processing_control,
	      4 brief		bit(1),
	      4 force		bit(1),
	    3 carriage_control,
	      4 nep		bit(1),
	      4 single		bit(1),
	      4 non_edited		bit(1),
	      4 truncate		bit(1),
	    3 label,
	      4 top		bit(1),
	      4 bottom		bit(1),
	      4 access		bit(1),
	  2 Ndft,
	    3 pt_pch		fixed bin,
	    3 delete		fixed bin,
	    3 notify		fixed bin,
	    3 copies		fixed bin,
	    3 queue		fixed bin,
	    3 output_module		fixed bin,
	    3 lmargin		fixed bin,
	    3 line_lth		fixed bin,
	    3 page_lth		fixed bin,

	1 old_print		aligned based(Pd),
	  2 header		like default_print.header,
	  2 Odft			like default_print.Odft,
	  2 Sdft			like default_print.Sdft,
	  2 Ndft			like default_print.Ndft,
	  2 data (d_size - size(default_print))
				fixed bin,

	1 new_print		aligned based(Pnd),
	  2 header		like default_print.header,
	  2 Odft			like default_print.Odft,
	  2 Sdft			like default_print.Sdft,
	  2 Ndft			like default_print.Ndft,
	  2 defer_until_process_termination fixed bin,
	  2 data (d_size - size(default_print))
				fixed bin,

	1 default_punch		aligned,		/* Structure containing punch and plot argument defaults */
	  2 header,
	    3 Ntype		fixed bin,
	    3 name		char(24) unal,
	    3 size		fixed bin(18),
	  2 Odft,
	    3 request_type		char(24),
	  2 Sdft,
	    3 processing_control,
	      4 equal_header	bit(1),
	      4 brief		bit(1),
	      4 force		bit(1),
	  2 Ndft,
	    3 pt_pch		fixed bin,
	    3 delete		fixed bin,
	    3 notify		fixed bin,
	    3 copies		fixed bin,
	    3 queue		fixed bin,
	    3 output_module		fixed bin,

	1 old_punch		aligned based(Pd),
	  2 header		like default_punch.header,
	  2 Odft			like default_punch.Odft,
	  2 Sdft			like default_punch.Sdft,
	  2 Ndft			like default_punch.Ndft,
	  2 data (d_size - size(default_punch))
				fixed bin,

	1 new_punch		aligned based(Pnd),
	  2 header		like default_punch.header,
	  2 Odft			like default_punch.Odft,
	  2 Sdft			like default_punch.Sdft,
	  2 Ndft			like default_punch.Ndft,
	  2 defer_until_process_termination fixed bin,
	  2 data (d_size - size(default_punch))
				fixed bin;


    dcl	1 mi			aligned,		/* Automatic copy of match_info		*/
	  2 version		fixed bin init(1),
	  2 name_count		fixed bin init(1),
	  2 max_name_length		fixed bin init(30),
	  2 name_array (1),
	    3 exclude_sw		bit(1) unal init("0"b),
	    3 regexp_sw		bit(1) unal init("0"b),
	    3 pad			bit(34) unal init("0"b),
	    3 name		char(30) varying;


    dcl  (addr, after, empty, index, length, null, search, size, substr, translate)
				builtin;

    dcl	value_$delete_data		entry (ptr, bit(36) aligned, char(*), fixed bin(35)),
	value_$get_data		entry (ptr, bit(36) aligned, char(*), ptr, ptr, fixed bin(18),
				     fixed bin(35)),
	value_$list_data_names	entry (ptr, bit(36) aligned, ptr, ptr, ptr, fixed bin(35)),
	value_$set_data		entry (ptr, bit(36) aligned, char(*), ptr, fixed bin(18), ptr, ptr,
				     fixed bin(18), fixed bin(35));


	code = 0;					/* No error yet.				*/

	mi.name(1) = "eor.**.*._";
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr(mi),
	   addr(area), value_list_info_ptr, code);	/* Get a list of eor-related data items.	*/

	do i = 1 to value_list_info.pair_count;		/* Convert each one.			*/

	   dft_name = substr(value_list_info.chars,
	      value_list_info.pairs(i).name_index,
	      value_list_info.pairs(i).name_len);	/* Get a name.				*/
	   dft_name = after(dft_name,".");
	   dft_name = substr(dft_name,1,length(dft_name)-2);

	   call value_$get_data (DEFAULT_VALUE_SEG, PERM,
	      "eor." || dft_name || "._",
	      addr(area), Pd, d_size, code); 		/* Get the associated data.			*/ 
	   if code ^= 0 then go to ERROR_EXIT;

	   if d.Ntype = DP_PRINT then do;		/* These are print defaults.			*/
	      allocate new_print in (area);		/* Convert them.				*/
	      new_print = old_print, by name;
	      new_print.defer_until_process_termination = 0;
	      call value_$set_data (DEFAULT_VALUE_SEG, PERM,
	         "eor." || dft_name || "._", Pnd, size (new_print),
	         null, null, 0, code);
	      if code ^= 0 then go to ERROR_EXIT;
	      free new_print in (area);
	   end;					/* End of print conversion.			*/

	   else if (d.Ntype = DP_PUNCH) | (d.Ntype = DP_PLOT) then do;  /* These are punch or plot defaults. */
	      allocate new_punch in (area);		/* Convert them.				*/
	      new_punch = old_punch, by name;
	      new_punch.defer_until_process_termination = 0;
	      call value_$set_data (DEFAULT_VALUE_SEG, PERM,
	         "eor." || dft_name || "._", Pnd, size (new_punch),
	         null, null, 0, code);
	      if code ^= 0 then go to ERROR_EXIT;
	      free new_punch in (area);		
	   end;					/* End of punch and plot conversion.		*/

	   free d in (area);			/* Free the data.				*/

	end;					/* End of conversion loop.			*/

	default_header.version = Vdefault_header_7;	/* Set info in header.			*/
	call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._",
	   Pdefault_header, size(default_header), null, null, 0, code);

ERROR_EXIT:
	return;					/* All done. 				*/

	end eor_cv6_7_;
   



		    eor_cv7_8_.pl1                  10/28/88  1348.6r w 10/28/88  1302.1       56538


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

/* format: style4,delnl,insnl,^ifthendo */

/* format: off */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This program is called by enter_output_request.  eor stored user-defined default	*/
	/* control argument settings in the default value segment as binary data values.  This	*/
	/* program converts these values from version 7 to version 8 format.  The only		*/
	/* difference between versions is that version 8 supports -nsep.			*/
	/*									*/
	/* Status:								*/
	/* Created:    December, 1983 by C. Marker from eor_cv6_7_.pl1.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* format: on */

eor_cv7_8_:
     proc (Pdefault_header, code);


%include dprint_arg;


%include value_structures;


dcl  Pdefault_header ptr,
     code fixed bin (35);

dcl  Pd ptr,
     Pnd ptr,
     area area (4096),
     dft_name char (28) varying,
     d_size fixed bin (18),
     i fixed bin;

dcl  Vdefault_header_8 fixed bin int static options (constant) init (8);
						/* Version 8 supports -nsep.			*/

dcl  DEFAULT_VALUE_SEG ptr int static options (constant) init (null),
     PERM bit (36) aligned int static options (constant) init ("01"b);


dcl  1 default_header aligned based (Pdefault_header),	/* Structure containing default request types */
       2 version fixed bin,
       2 default_request_type (3) char (24) unal,
     1 default,					/* Structure containing general argument defaults	*/
       2 header,
         3 Ntype fixed bin,
         3 name char (24) unal,
         3 size fixed bin (18),
     1 d aligned based (Pd),
       2 header like default.header,
       2 data (d_size - size (default)) fixed bin,
     1 default_print aligned,				/* Structure containing print argument defaults	*/
       2 header,
         3 Ntype fixed bin,
         3 name char (24) unal,
         3 size fixed bin (18),
       2 Odft,
         3 request_type char (24) unal,
         3 form_name char (24) unal,
       2 Sdft,
         3 processing_control,
	 4 brief bit (1),
	 4 force bit (1),
         3 carriage_control,
	 4 nep bit (1),
	 4 single bit (1),
	 4 non_edited bit (1),
	 4 truncate bit (1),
         3 label,
	 4 top bit (1),
	 4 bottom bit (1),
	 4 access bit (1),
       2 Ndft,
         3 pt_pch fixed bin,
         3 delete fixed bin,
         3 notify fixed bin,
         3 copies fixed bin,
         3 queue fixed bin,
         3 output_module fixed bin,
         3 lmargin fixed bin,
         3 line_lth fixed bin,
         3 page_lth fixed bin,
         3 defer_until_process_termination fixed bin,
     1 new_Sdft,
       2 processing_control,
         3 brief bit (1),
         3 force bit (1),
       2 carriage_control,
         3 nep bit (1),
         3 single bit (1),
         3 non_edited bit (1),
         3 truncate bit (1),
         3 no_separator bit (1),
       2 label,
         3 top bit (1),
         3 bottom bit (1),
         3 access bit (1),
     1 old_print aligned based (Pd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 data (d_size - size (default_print)) fixed bin,
     1 new_print aligned based (Pnd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like new_Sdft,
       2 Ndft like default_print.Ndft,
       2 data (d_size - size (default_print)) fixed bin;
dcl  1 mi aligned,					/* Automatic copy of match_info		*/
       2 version fixed bin init (1),
       2 name_count fixed bin init (1),
       2 max_name_length fixed bin init (30),
       2 name_array (1),
         3 exclude_sw bit (1) unal init ("0"b),
         3 regexp_sw bit (1) unal init ("0"b),
         3 pad bit (34) unal init ("0"b),
         3 name char (30) varying;


dcl  (addr, after, empty, index, length, null, search, size, substr, translate) builtin;

dcl  value_$delete_data entry (ptr, bit (36) aligned, char (*), fixed bin (35)),
     value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35)),
     value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35)),
     value_$set_data
	entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35));


	code = 0;					/* No error yet.				*/

	mi.name (1) = "eor.**.*._";
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr (mi), addr (area), value_list_info_ptr, code);
						/* Get a list of eor-related data items.	*/

	do i = 1 to value_list_info.pair_count;		/* Convert each one.			*/

	     dft_name =
		substr (value_list_info.chars, value_list_info.pairs (i).name_index,
		value_list_info.pairs (i).name_len);	/* Get a name.				*/
	     dft_name = after (dft_name, ".");
	     dft_name = substr (dft_name, 1, length (dft_name) - 2);

	     call value_$get_data (DEFAULT_VALUE_SEG, PERM, "eor." || dft_name || "._", addr (area), Pd, d_size, code);
						/* Get the associated data.			*/
	     if code ^= 0
	     then go to ERROR_EXIT;

	     if d.Ntype = DP_PRINT
	     then do;				/* These are print defaults.			*/
		allocate new_print in (area);		/* Convert them.				*/
		new_print = old_print, by name;
		new_print.Sdft.no_separator = "0"b;
		call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor." || dft_name || "._", Pnd, size (new_print),
		     null, null, 0, code);
		if code ^= 0
		then go to ERROR_EXIT;
		free new_print in (area);
	     end;					/* End of print conversion.			*/

	     free d in (area);			/* Free the data.				*/

	end;					/* End of conversion loop.			*/

	default_header.version = Vdefault_header_8;	/* Set info in header.			*/
	call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._", Pdefault_header, size (default_header), null, null, 0,
	     code);

ERROR_EXIT:
	return;					/* All done. 				*/

     end eor_cv7_8_;
  



		    eor_cv8_9_.pl1                  10/28/88  1348.6r w 10/28/88  1302.1       59130


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

/****^  HISTORY COMMENTS:
  1) change(87-05-10,Gilcrease), approve(87-08-17,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Convert eor values from version 8 to version 9, eor -number.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */

/* format: off */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This program is called by enter_output_request.  eor stored user-defined default	*/
	/* control argument settings in the default value segment as binary data values.  This	*/
	/* program converts these values from version 8 to version 9 format.  The only		*/
	/* difference between versions is that version 9 supports -nb.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* format: on */

eor_cv8_9_:
     proc (Pdefault_header, code);


%include dprint_arg;


%include value_structures;


dcl  Pdefault_header ptr,
     code fixed bin (35);

dcl  Pd ptr,
     Pnd ptr,
     area area (4096),
     dft_name char (28) varying,
     d_size fixed bin (18),
     i fixed bin;

dcl  Vdefault_header_9 fixed bin int static options (constant) init (9);
						/* Version 9 supports -number.			*/

dcl  DEFAULT_VALUE_SEG ptr int static options (constant) init (null),
     PERM bit (36) aligned int static options (constant) init ("01"b);


dcl  1 default_header aligned based (Pdefault_header),	/* Structure containing default request types */
       2 version fixed bin,
       2 default_request_type (3) char (24) unal,
     1 default,					/* Structure containing general argument defaults	*/
       2 header,
         3 Ntype fixed bin,
         3 name char (24) unal,
         3 size fixed bin (18),
     1 d aligned based (Pd),
       2 header like default.header,
       2 data (d_size - size (default)) fixed bin,
     1 default_print aligned,				/* Structure containing print argument defaults	*/
       2 header,
         3 Ntype fixed bin,
         3 name char (24) unal,
         3 size fixed bin (18),
       2 Odft,
         3 request_type char (24) unal,
         3 form_name char (24) unal,
       2 Sdft,
         3 processing_control,
	 4 brief bit (1),
	 4 force bit (1),
         3 carriage_control,
	 4 nep bit (1),
	 4 single bit (1),
	 4 non_edited bit (1),
	 4 truncate bit (1),
	 4 no_separator bit (1),
         3 label,
	 4 top bit (1),
	 4 bottom bit (1),
	 4 access bit (1),
       2 Ndft,
         3 pt_pch fixed bin,
         3 delete fixed bin,
         3 notify fixed bin,
         3 copies fixed bin,
         3 queue fixed bin,
         3 output_module fixed bin,
         3 lmargin fixed bin,
         3 line_lth fixed bin,
         3 page_lth fixed bin,
         3 defer_until_process_termination fixed bin,
     1 new_Sdft,
       2 processing_control,
         3 brief bit (1),
         3 force bit (1),
       2 carriage_control,
         3 nep bit (1),
         3 single bit (1),
         3 non_edited bit (1),
         3 truncate bit (1),
         3 no_separator bit (1),
         3 line_nbrs bit (1),
       2 label,
         3 top bit (1),
         3 bottom bit (1),
         3 access bit (1),
     1 old_print aligned based (Pd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 data (d_size - size (default_print)) fixed bin,
     1 new_print aligned based (Pnd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like new_Sdft,
       2 Ndft like default_print.Ndft,
       2 data (d_size - size (default_print)) fixed bin;
dcl  1 mi aligned,					/* Automatic copy of match_info		*/
       2 version fixed bin init (1),
       2 name_count fixed bin init (1),
       2 max_name_length fixed bin init (30),
       2 name_array (1),
         3 exclude_sw bit (1) unal init ("0"b),
         3 regexp_sw bit (1) unal init ("0"b),
         3 pad bit (34) unal init ("0"b),
         3 name char (30) varying;


dcl  (addr, after, empty, length, null, size, substr) builtin;

dcl  value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35)),
     value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35)),
     value_$set_data
	entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35));


	code = 0;					/* No error yet.				*/

	mi.name (1) = "eor.**.*._";
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr (mi), addr (area), value_list_info_ptr, code);
						/* Get a list of eor-related data items.	*/

	do i = 1 to value_list_info.pair_count;		/* Convert each one.			*/

	     dft_name =
		substr (value_list_info.chars, value_list_info.pairs (i).name_index,
		value_list_info.pairs (i).name_len);	/* Get a name.				*/
	     dft_name = after (dft_name, ".");
	     dft_name = substr (dft_name, 1, length (dft_name) - 2);

	     call value_$get_data (DEFAULT_VALUE_SEG, PERM, "eor." || dft_name || "._", addr (area), Pd, d_size, code);
						/* Get the associated data.			*/
	     if code ^= 0
	     then go to ERROR_EXIT;

	     if d.Ntype = DP_PRINT
	     then do;				/* These are print defaults.			*/
		allocate new_print in (area);		/* Convert them.				*/
		new_print = old_print, by name;
		new_print.Sdft.line_nbrs = "0"b;
		call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor." || dft_name || "._", Pnd, size (new_print),
		     null, null, 0, code);
		if code ^= 0
		then go to ERROR_EXIT;
		free new_print in (area);
	     end;					/* End of print conversion.			*/

	     free d in (area);			/* Free the data.				*/

	end;					/* End of conversion loop.			*/

	default_header.version = Vdefault_header_9;	/* Set info in header.			*/
	call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._", Pdefault_header, size (default_header), null, null, 0,
	     code);

ERROR_EXIT:
	return;					/* All done. 				*/

     end eor_cv8_9_;
  



		    eor_cv9_10_.pl1                 10/28/88  1350.1rew 10/28/88  1350.1       59013


/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */

/****^  HISTORY COMMENTS:
  1) change(88-08-25,Farley), approve(88-10-12,MCR7911),
     audit(88-10-21,Wallman), install(88-10-28,MR12.2-1199):
     Convert eor data from version 9 to version 10, changes old 24 character
     "form_name" to a 64 character "forms_name".
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */

/* format: off */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This program is called by enter_output_request.  eor stored user-defined default	*/
	/* control argument settings in the default value segment as binary data values.  This	*/
	/* program converts these values from version 9 to version 10 format.  The only		*/
	/* difference between versions is that version 10 has a larger forms_name area.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* format: on */

eor_cv9_10_:
     proc (Pdefault_header, code);


%include dprint_arg;


%include value_structures;


dcl  Pdefault_header ptr parameter,
     code fixed bin (35) parameter;

dcl  Pd ptr,
     Pnd ptr,
     area area (4096),
     dft_name char (28) varying,
     d_size fixed bin (18),
     i fixed bin;

dcl  Vdefault_header_10 fixed bin int static options (constant) init (10);
						/* Version 10 supports larger forms_name.     */

dcl  DEFAULT_VALUE_SEG ptr int static options (constant) init (null),
     PERM bit (36) aligned int static options (constant) init ("01"b);


dcl  1 default_header aligned based (Pdefault_header),	/* Structure containing default request types */
       2 version fixed bin,
       2 default_request_type (3) char (24) unal;

dcl  1 default,					/* Structure containing general argument defaults	*/
       2 header,
         3 Ntype fixed bin,
         3 name char (24) unal,
         3 size fixed bin (18);

dcl  1 d aligned based (Pd),
       2 header like default.header,
       2 data (d_size - size (default)) fixed bin;

dcl  1 default_print aligned,				/* Structure containing print argument defaults	*/
       2 header,
         3 Ntype fixed bin,
         3 name char (24) unal,
         3 size fixed bin (18),
       2 Odft,
         3 request_type char (24) unal,
         3 form_name char (24) unal,
       2 Sdft,
         3 processing_control,
	 4 brief bit (1),
	 4 force bit (1),
         3 carriage_control,
	 4 nep bit (1),
	 4 single bit (1),
	 4 non_edited bit (1),
	 4 truncate bit (1),
	 4 no_separator bit (1),
	 4 line_nbrs bit (1),
         3 label,
	 4 top bit (1),
	 4 bottom bit (1),
	 4 access bit (1),
       2 Ndft,
         3 pt_pch fixed bin,
         3 delete fixed bin,
         3 notify fixed bin,
         3 copies fixed bin,
         3 queue fixed bin,
         3 output_module fixed bin,
         3 lmargin fixed bin,
         3 line_lth fixed bin,
         3 page_lth fixed bin,
         3 defer_until_process_termination fixed bin;

dcl  1 new_Odft,
       2 request_type char (24) unal,
       2 forms_name char (64) unal;

dcl  1 old_print aligned based (Pd),
       2 header like default_print.header,
       2 Odft like default_print.Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 data (d_size - size (default_print)) fixed bin;

dcl  1 new_print aligned based (Pnd),
       2 header like default_print.header,
       2 Odft like new_Odft,
       2 Sdft like default_print.Sdft,
       2 Ndft like default_print.Ndft,
       2 data (d_size - size (default_print)) fixed bin;

dcl  1 mi aligned,					/* Automatic copy of match_info		*/
       2 version fixed bin,
       2 name_count fixed bin,
       2 max_name_length fixed bin,
       2 name_array (1),
         3 exclude_sw bit (1) unal,
         3 regexp_sw bit (1) unal,
         3 pad bit (34) unal,
         3 name char (30) varying;

dcl  cleanup condition;
dcl  (addr, after, empty, length, null, size, substr) builtin;

dcl  value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35)),
     value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed bin (35)),
     value_$set_data
	entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35));


	code = 0;					/* No error yet.				*/

	area = empty;
	Pd, Pnd = null;
	on cleanup
	     begin;
	     if Pnd ^= null
	     then free new_print in (area);
	     if Pd ^= null
	     then free d in (area);
	end;

	mi.version = 1;
	mi.name_count = 1;
	mi.max_name_length = 30;
	mi.exclude_sw,
	     mi.regexp_sw,
	     mi.pad = "0"b;
	mi.name (1) = "eor.**.*._";
	call value_$list_data_names (DEFAULT_VALUE_SEG, PERM, addr (mi), addr (area), value_list_info_ptr, code);
						/* Get a list of eor-related data items.	*/

	do i = 1 to value_list_info.pair_count;		/* Convert each one.			*/

	     dft_name =
		substr (value_list_info.chars, value_list_info.pairs (i).name_index,
		value_list_info.pairs (i).name_len);	/* Get a name.				*/
	     dft_name = after (dft_name, ".");
	     dft_name = substr (dft_name, 1, length (dft_name) - 2);

	     call value_$get_data (DEFAULT_VALUE_SEG, PERM, "eor." || dft_name || "._", addr (area), Pd, d_size, code);
						/* Get the associated data.			*/
	     if code ^= 0
	     then go to ERROR_EXIT;

	     if d.Ntype = DP_PRINT
	     then do;				/* These are print defaults.			*/
		allocate new_print in (area) set (Pnd); /* Convert them.				*/
		new_print = old_print, by name;
		new_print.forms_name = old_print.form_name;
		call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor." || dft_name || "._", Pnd, size (new_print),
		     null, null, 0, code);
		if code ^= 0
		then go to ERROR_EXIT;
		free new_print in (area);
	     end;					/* End of print conversion.			*/

	     free d in (area);			/* Free the data.				*/

	end;					/* End of conversion loop.			*/

	default_header.version = Vdefault_header_10;	/* Set info in header.			*/
	call value_$set_data (DEFAULT_VALUE_SEG, PERM, "eor._", Pdefault_header, size (default_header), null, null, 0,
	     code);

ERROR_EXIT:
	if Pnd ^= null
	then free new_print in (area);
	if Pd ^= null
	then free d in (area);
	return;					/* All done. 				*/

     end eor_cv9_10_;
   



		    file_output.pl1                 05/11/83  1241.7rew 05/11/83  1234.5      141516


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


file_output:
fo:
     procedure () options (variable);

/* This module implements the file_output, terminal_output and
   revert_output commands. Both file_output and terminal_output push
   a stack of attachments. The revert_output command pops the latest
   attachment for a specified switch. revert_output -all pops the
   entire stack.

   Usage:
   file_output {path} {-ssw switchname}... {-truncate|-extend}
   terminal_output {-ssw switchname}...
   revert_output {-all} {-ssw switchname}...
   syn_output target_sw {-ssw source_switchname}...

   If no switchnames are specified, the default is user_output.
   revert_output -all reverts all switches, unless one is specified.
   */

/* Written 4/5/77 by Steve Herbst */
/* Modified 07/14/77 by G. Palter to work properly */
/* Modified 08/77 by B. Greenberg for syn_output */
/* Modified 06/78 by M. R. Jordan for -truncate and -extend */
/* test for invalid entrynames 04/18/79 S. Herbst */
/* Modified 10/82 by Linda Pugh to attach switch to segment containing
   a space in its name */

dcl 1 node aligned based (p),				/* node in list of saved attachments */
    2 next ptr,
    2 last ptr,
    2 this_iocb ptr,				/* ptr to saved IOCB */
    2 fo_def_ptr ptr,				/* ptr to definition of file_output_n for new attachment */
    2 saved_iocb ptr,				/* pointer to iocb where attachment moved */
    2 was_detached bit (1) aligned;			/* ON if switch not already attached */

dcl 1 fo_def aligned based,				/* definition of an file_output_n attachment */
    2 fo_ptr ptr,					/* ptr to file_output_n IOCB */
    2 ref_count fixed bin;				/* number of IOCB's syn'ed to this one */

dcl  area area based (area_ptr);

dcl  arg char (arg_len) based (arg_ptr);
dcl  attach_description char (200);
dcl  file_path char (168);
dcl (switch_name, target_name, save_name) char (32);	/* names of output I/O switches */
dcl  command char (32);				/* name of command entry point called */

dcl  ips_mask bit (36);				/* mask for disabling quits, etc. */
dcl (file, terminal, revert) bit (1) init ("0"b);		/* ON for fo, to, and ro */
dcl  syn_entry bit (1) init ("0"b);			/* ON for so */
dcl  console bit (1) init ("0"b);			/* ON for console_output (obsolete) */
dcl  all bit (1);					/* ON for revert_output -all */
dcl  all_switches bit (1);				/* ON for same without osw's */
dcl  found_one bit (1);				/* found a saved attachment to restore */
dcl  path_given bit (1);				/* pathname specified to file_output */
dcl  truncate bit (1);				/* truncate the output file */

dcl  area_ptr ptr int static init (null ());		/* for allocations */
dcl  new_fo_def_ptr ptr;				/* ptr to file_output_n definition */
dcl  new_fo_ptr ptr;				/* ptr to file_output_n IOCB */
dcl (first_p, last_p) ptr int static init (null ());	/* ptrs to threaded list of nodes */
dcl (p, prev_p) ptr;
dcl (arg_list_ptr, arg_ptr, iocb_ptr) ptr;

dcl (arg_count, i, iocb_count, iocb_limit) fixed bin;
dcl  last_processed fixed bin;			/* last IOCB saved/restored for cleanup */
dcl  arg_len fixed bin (21);
dcl  code fixed bin (35);
dcl  saved_code fixed bin (35);

dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$badstar fixed bin (35) ext;
dcl  error_table_$nostars fixed bin (35) ext;

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  check_star_name_$path entry (char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$reset_ips_mask entry (bit (36), bit (36));
dcl  hcs_$set_ips_mask entry (bit (36), bit (36));
dcl  iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$move_attach entry (ptr, ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35));
dcl  iox_$user_output ptr ext;
dcl  requote_string_ entry (char(*)) returns (char(*));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

dcl (divide, null, rtrim, substr) builtin;

dcl  error_table_$noarg fixed bin (35) external;

dcl  cleanup condition;

%include iox_modes;


/* file_output:
   fo:
   procedure () options (variable);
   */

	command = "file_output";
	file = "1"b;
	file_path = "output_file";
	go to COMMON;


terminal_output:
to:	entry () options (variable);

	command = "terminal_output";
	terminal = "1"b;
	go to COMMON;


revert_output:
ro:	entry () options (variable);

	command = "revert_output";
	revert = "1"b;
	all = "0"b;
	go to COMMON;

syn_output:
so:	entry () options (variable);

	command = "syn_output";
	syn_entry = "1"b;
	go to COMMON;


console_output:
co:	entry () options (variable);			/* Obsolete:  eqv to "revert_output user_output -all" */

	command = "console_output";
	revert, console = "1"b;
	all = "1"b;

COMMON:	iocb_count = 0;
	truncate = "0"b;				/* Default is to extend file */
	path_given = "0"b;				/* no pathname seen yet */
	all_switches = "0"b;
	call cu_$arg_count (arg_count);
	if console & arg_count>0 then do;		/* obsolete */
	     call com_err_ (0, command, "Usage:  console_output");
	     return;
	end;
	call cu_$arg_list_ptr (arg_list_ptr);
	iocb_limit = divide (arg_count, 2, 17, 0)+1;


	begin;

dcl  iocbp (iocb_limit) ptr;
dcl  iocb_name (iocb_limit) char (32);

	     do i = 1 to arg_count;
		call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr);
		if substr (arg, 1, 1) = "-" then do;
		     if arg = "-ssw" | arg = "-osw" | arg = "-source_switch" | arg = "-output_switch" then do;
			i = i+1;
			call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr);
			if code ^= 0 then do;
			     call com_err_ (code, command, "No value specified for source switch.");
			     return;
			end;
			call iox_$look_iocb (arg, iocb_ptr, code);
			if iocb_ptr = null () then do;
			     call com_err_ (code, command, "^a", arg);
			     return;
			end;
			iocb_count = iocb_count+1;
			iocbp (iocb_count) = iocb_ptr;
			iocb_name (iocb_count) = arg;
		     end;
		     else if revert & (arg = "-a" | arg = "-all") then all = "1"b;
		     else if file & (arg = "-tc" | arg = "-truncate") then truncate = "1"b;
		     else if file & (arg = "-extend") then truncate = "0"b;
		     else do;
			call com_err_ (error_table_$badopt, command, "^a", arg);
			return;
		     end;
		end;
		else if revert then do;
		     call com_err_ (0, command, "Usage:  revert_output {-all} {-ssw switchname}...");
		     return;
		end;
		else if terminal then do;
		     call com_err_ (0, command, "Usage:  terminal_output {-ssw switchname}...");
		     return;
		end;
		else if path_given then do;
		     if file then call com_err_ (0, command,
			"Usage:  file_output {path} {-ssw switchname}... {-truncate|-extend}");
		     else call com_err_ (0, command, "Usage:  syn_output target_switch {-ssw switchname}...");
		     return;
		end;
		else do;
		     path_given = "1"b;
		     file_path = arg;
		end;
	     end;

	     if path_given & file then do;		/* Check pathname for file_output */
		call check_star_name_$path (file_path, code);
		if code ^= 0 then do;
		     if code = error_table_$badstar then call com_err_ (code, command, "^a", file_path);
		     else call com_err_ (error_table_$nostars, command, "^a", file_path);
		     return;
		end;
	     end;

	     if iocb_count = 0 then do;		/* apply default */
		if all & revert & ^console then all_switches = "1"b;
		iocb_count = 1;
		iocbp (1) = iox_$user_output;
		iocb_name (1) = "user_output";
	     end;

	     if syn_entry & ^path_given then do;
		call com_err_ (error_table_$noarg, command, "No target switch given.");
		return;
	     end;


	     if terminal then target_name = "user_i/o";
	     else if syn_entry then do;
		target_name = file_path;
		call iox_$look_iocb (target_name, iocb_ptr, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, target_name);
		     return;
		end;
	     end;
	     else if file then do;
		call absolute_pathname_ ((file_path), file_path, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "^a", file_path);
		     return;
		end;

		target_name = "fo_" || unique_chars_ ("0"b);
		call iox_$find_iocb (target_name, new_fo_ptr, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "^a", target_name);
		     return;
		end;

		if truncate then attach_description = "vfile_ " || requote_string_ (rtrim (file_path)) ;
		else attach_description = "vfile_ " || requote_string_ (rtrim (file_path)) || " -extend";
		if ^path_given then			/* Say what's happening */
		     call com_err_ (0, command, "Writing output into ^a. Use revert_output to stop.", file_path);

		call iox_$attach_ptr (new_fo_ptr, attach_description, null (), code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "Unable to attach switch ""^a"" to ^a.", target_name, file_path);
		     call iox_$destroy_iocb (new_fo_ptr, code);
		     return;
		end;
		call iox_$open (new_fo_ptr, Stream_output, "0"b, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "Unable to open switch ""^a"" for write to ^a.", target_name, file_path);
		     call iox_$detach_iocb (new_fo_ptr, code);
		     call iox_$destroy_iocb (new_fo_ptr, code);
		     return;
		end;
		if area_ptr = null () then area_ptr = get_system_free_area_ ();
		allocate fo_def in (area) set (new_fo_def_ptr);
		new_fo_def_ptr -> fo_def.fo_ptr = new_fo_ptr;
		new_fo_def_ptr -> fo_def.ref_count = 0;
	     end;


	     last_processed = 0;			/* haven't done anything yet */

	     on condition (cleanup) call clean_up ();


	     do i = 1 to iocb_count;

		iocb_ptr = iocbp (i);
		switch_name = iocb_name (i);

		ips_mask = "0"b;

		if revert
		then call restore_attachment ();

		else do;
		     call save_attachment ();

		     call iox_$attach_ptr (iocb_ptr, "syn_ " || target_name, null (), code);
		     if code ^= 0 then do;
			saved_code = code;
			call restore_attachment ();
			call clean_up ();
			call com_err_ (saved_code, command, "^a", switch_name);
			return;
		     end;
		end;

		last_processed = i;
	     end;

	     return;


ABORT:	     call clean_up ();
	     return;


clean_up:	     procedure ();

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

		if last_processed ^= 0		/* have done some work */
		then if revert			/* always do reverts regardless */
		     then do i = last_processed + 1 to iocb_count;
			iocb_ptr = iocbp (i);
			call restore_attachment ();
		     end;

		     else				/* not revert: restore what was done */
		     do i = 1 to last_processed;
			iocb_ptr = iocbp (i);
			call restore_attachment ();
		     end;

		return;

	     end clean_up;


save_attachment: procedure ();

/* This internal procedure saves the current attachment of iocb_ptr */

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

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

		allocate node in (area) set (p);
		p -> node.this_iocb = iocb_ptr;

		save_name = "fo_save_" || unique_chars_ ("0"b);
		call iox_$find_iocb (save_name, p -> node.saved_iocb, code);
		if code ^= 0 then do;
		     call com_err_ (code, command, "^a", switch_name);
		     go to ABORT;
		end;

		call iox_$move_attach (iocb_ptr, p -> node.saved_iocb, code);
		if code = 0
		then p -> node.was_detached = "0"b;
		else p -> node.was_detached = "1"b;

		if file then do;			/* ptr to file_output_n definition */
		     p -> node.fo_def_ptr = new_fo_def_ptr;
		     new_fo_def_ptr -> fo_def.ref_count = new_fo_def_ptr -> fo_def.ref_count + 1;
		end;
		else p -> node.fo_def_ptr = null ();

		p -> node.next = null ();
		if first_p = null () then do;		/* this is the first node saved */
		     first_p = p;
		     p -> node.last = null ();
		end;
		else do;				/* thread to last node */
		     last_p -> node.next = p;
		     p -> node.last = last_p;
		end;
		last_p = p;

		call hcs_$reset_ips_mask ((ips_mask), ips_mask);

		return;

	     end save_attachment;


restore_attachment: procedure ();

/* This internal procedure restores the last or first (-all) saved
   attachment of iocb_ptr and frees the last node or all nodes (-all) */

		if first_p = null () then do;
NOT_FOUND:	     if all_switches then call com_err_ (0, command, "No previous attachments.");
		     else call com_err_ (0, command, "No previous attachment of ^a", switch_name);
		     if ips_mask ^= "0"b then call hcs_$reset_ips_mask ((ips_mask), ips_mask);
		     return;
		end;

/* Find the right saved attachment */

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

		if all then do;
		     found_one = "0"b;
		     do p = last_p repeat (p -> node.last) while (p ^= null ());
			if p -> node.this_iocb = iocb_ptr | all_switches then do;
			     found_one = "1"b;
			     call restore_iocb ();
			end;
		     end;
		     if ^found_one then go to NOT_FOUND;
		end;
		else do;
		     do p = last_p repeat (p -> node.last) while (p ^= null ());
			if p -> this_iocb = iocb_ptr then go to FOUND;
		     end;
FOUND:		     if p = null () then go to NOT_FOUND;
		     call restore_iocb ();
		end;

/* Free the appropriate nodes */

		if all then do;
		     prev_p = last_p;
		     do p = last_p repeat (prev_p) while (prev_p ^= null ());
			prev_p = p -> node.last;
			if p -> this_iocb = iocb_ptr | all_switches then call rethread ();
		     end;
		end;
		else call rethread ();

		call hcs_$reset_ips_mask ((ips_mask), ips_mask);

		return;


restore_iocb:	procedure ();

/* This procedure internal to restore_attachment restores one iocb */

		     call iox_$detach_iocb (p -> node.this_iocb, code);
		     if ^ (p -> node.was_detached)
		     then call iox_$move_attach (p -> node.saved_iocb, p -> node.this_iocb, code);
		     call iox_$destroy_iocb (p -> node.saved_iocb, code);

		     return;

		end restore_iocb;

	     end restore_attachment;


rethread:	     procedure ();

		if p = first_p then do;
		     first_p = p -> node.next;
		     if first_p ^= null () then first_p -> node.last = null ();
		     else last_p = null ();
		end;
		else if p = last_p then do;
		     last_p = p -> node.last;
		     if last_p ^= null () then last_p -> node.next = null ();
		     else first_p = null ();
		end;
		else do;
		     p -> node.next -> node.last = p -> node.last;
		     p -> node.last -> node.next = p -> node.next;
		end;

		if p -> node.fo_def_ptr ^= null () then do; /* was replaced by an fo attachment */
		     p -> node.fo_def_ptr -> fo_def.ref_count = p -> node.fo_def_ptr -> fo_def.ref_count - 1;
		     if p -> node.fo_def_ptr -> fo_def.ref_count = 0 then do; /* this file_output_n is unused */
			call iox_$close (p -> node.fo_def_ptr -> fo_def.fo_ptr, code);
			call iox_$detach_iocb (p -> node.fo_def_ptr -> fo_def.fo_ptr, code);
			call iox_$destroy_iocb (p -> node.fo_def_ptr -> fo_def.fo_ptr, code);
			free p -> node.fo_def_ptr -> fo_def in (area);
		     end;
		end;

		free p -> node in (area);

		return;

	     end rethread;

	end;					/* end begin block */


     end file_output;



		    get_com_channel_info_.pl1       08/05/87  0813.7r   08/04/87  1539.1       27099


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* get_com_channel_info_ -- subroutine interface to the
   as_request for com_channel_info. */

/* format: style2 */

get_com_channel_info_:
     procedure (P_info_ptr, P_code);

/**** Created 1985-02-19, BIM */


	declare P_info_ptr		 pointer;
	declare P_code		 fixed bin (35);

	declare as_user_message_$user_read_message
				 entry (pointer, pointer, fixed bin (35));
	declare get_system_free_area_	 entry () returns (ptr);
	declare send_as_request_$block entry (pointer, fixed binary, bit (72) aligned, bit (72) aligned,
				 fixed binary (35));

/* format: off */
%page; %include as_user_message_info;
%page; %include as_request_header;
%page; %include asr_com_channel_info;
%page; %include as_com_channel_info;
/* format: on */

	declare 1 asum_info		 aligned like as_user_message_info;
	declare 1 asrcci		 aligned like asr_com_channel_info;
	declare unique_bits_	 entry () returns (bit (70));
	declare asr_reply		 bit (72) aligned;
	declare error_table_$unimplemented_version
				 fixed bin (35) ext static;
	declare cleanup		 condition;

	declare addr		 builtin;
	declare currentsize		 builtin;
	declare null		 builtin;
	declare unspec		 builtin;

	as_com_channel_info_ptr = P_info_ptr;
	if as_com_channel_info.version ^= AS_COM_CHANNEL_INFO_VERSION_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	unspec (asrcci) = ""b;
	asrcci.header.version = as_request_version_1;
	asrcci.header.type = ASR_COM_CHANNEL_INFO;
	asrcci.version = ASR_CCI_VERSION_1;
	asrcci.channel_name = as_com_channel_info.channel_name;
	asrcci.reply_message_handle = unique_bits_ ();
	asrcci.reply_version_requested = AS_COM_CHANNEL_INFO_VERSION_1;

	unspec (asum_info) = ""b;
	asum_info.message_ptr = null ();
	on cleanup
	     begin;
		declare to_free		 (asum_info.message_length) bit (36) aligned
					 based (asum_info.message_ptr);
		if asum_info.message_ptr ^= null ()
		then free to_free;
	     end;

	asr_reply = ""b;
	call send_as_request_$block (addr (asrcci), currentsize (asrcci), (""b), asr_reply, P_code);
	if P_code ^= 0
	then return;

	asr_reply_cci_ptr = addr (asr_reply);
	P_code = asr_reply_com_channel_info.code;
	if P_code ^= 0
	then return;

	asum_info.version = AS_USER_MESSAGE_INFO_VERSION_1;
	asum_info.message_handle = asrcci.reply_message_handle;
	asum_info.message_ptr = null ();
	call as_user_message_$user_read_message (get_system_free_area_ (), addr (asum_info), P_code);
	if P_code ^= 0
	then return;
	as_com_channel_info = asum_info.message_ptr -> as_com_channel_info;
	begin;
	     declare to_free	      (asum_info.message_length) bit (36) aligned based (asum_info.message_ptr);
	     free to_free;
	end;
	return;
     end get_com_channel_info_;
 



		    get_line_length_.pl1            11/04/82  2006.8rew 11/04/82  1631.5       22995


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


/* GET_LINE_LENGTH_ - subroutine to return the line length of a given
   stream or switch.

   Written 750206 by PG from a program by the SIPB
   Modified 801104 (election day) by JRD to use mode_string_$parse (MCR 4721)
*/

/* format:  style3,ll122,idind30,ifthenstmt */

get_line_length_:
     procedure (P_stream) returns (fixed bin (17));

declare	P_stream			char (*) parameter,
	P_switch_ptr		ptr parameter,
	P_status			fixed bin (35) parameter;

declare	(addr, null)		builtin;

declare	mode_string		char (512),
	switch_ptr		ptr,
	have_code			bit (1) aligned,
	status			fixed bin (35);

declare	1 mv			aligned like mode_value;

declare	error_table_$action_not_performed
				fixed bin (35) external;

declare	mode_string_$get_mode	entry (char (*), char (*), ptr, fixed bin (35));
%page;
%include iox_dcls;
%page;
%include mode_string_info;
%page;
/* get_line_length_:
        procedure (P_stream) returns (fixed bin (17)); */

	have_code = "0"b;
	goto STREAM_JOIN;

get_line_length_$stream:
     entry (P_stream, P_status) returns (fixed bin (17));

	have_code = "1"b;


STREAM_JOIN:
	if P_stream = ""
	then switch_ptr = iox_$user_output;
	else do;
		call iox_$look_iocb (P_stream, switch_ptr, status);
		if status ^= 0 then go to RETURN_CODE;
	     end;

	go to JOIN;


get_line_length_$switch:
     entry (P_switch_ptr, P_status) returns (fixed bin (17));

	have_code = "1"b;
	switch_ptr = P_switch_ptr;
	if switch_ptr = null () then switch_ptr = iox_$user_output;

JOIN:
	call iox_$modes (switch_ptr, "", mode_string, status);
	if status ^= 0 then go to RETURN_CODE;

	mv.version = mode_value_version_3;
	call mode_string_$get_mode (mode_string, "ll", addr (mv), status);
	if status ^= 0 then goto RETURN_CODE;

	if ^mv.numeric_valuep then goto RETURN_NO_ACTION;

	if have_code then P_status = 0;

	return (mv.numeric_value);

RETURN_NO_ACTION:
	status = error_table_$action_not_performed;

RETURN_CODE:
	if have_code then P_status = status;

	return (72);				/* return default line length (policy decision) */

     end get_line_length_;
 



		    get_mode.pl1                    02/06/84  1105.5r   02/06/84  1101.1       31266


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


get_mode: procedure options (variable);			/* COMMAND AF */

/* A Command/AF to extract a mode value from a mode string
   James R. Davis Oct 80  MCR 4712
*/
/* Sept 1983 C Spitzer. Change to arg processing such that if 2nd arg is
        missing, the AF return arg is not used.*/

	dcl     mode_str		 char (mode_str_len) based (mode_str_ptr);
	dcl     mode_str_len	 fixed bin (21);
	dcl     mode_str_ptr	 ptr;

	dcl     mode_name		 char (mode_name_len) based (mode_name_ptr);
	dcl     mode_name_len	 fixed bin (21);
	dcl     mode_name_ptr	 ptr;

	dcl     af_result		 char (afl) varying based (afp);
	dcl     afl		 fixed bin (21);
	dcl     afp		 ptr;

	dcl     1 mv		 aligned like mode_value;

	dcl     nargs		 fixed bin,
	        code		 fixed bin (35),
	        active		 bit (1) aligned,
	        result		 char (66);

	dcl     complainer		 entry variable options (variable);

	dcl     myname		 char (32) internal static init ("get_mode") options (constant);

	dcl     mode_string_$get_mode	 entry (char (*), char (*), ptr, fixed bin (35));

	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     active_fnc_err_	 entry () options (variable);
	dcl     com_err_		 entry () options (variable);
	dcl     ioa_		 entry () options (variable);

	dcl     cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));

	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));

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

	dcl     addr builtin;
%page;
	complainer = com_err_;			/* default */
	active = "0"b;
	call cu_$af_return_arg (nargs, afp, afl, code);
	if code = 0 then do;
		active = "1"b;
		af_result = "";
		complainer = active_fnc_err_;
	     end;
	else if code = error_table_$not_act_fnc then
	     code = 0;
	else goto USAGE;

	if nargs > 2 then do;
		code = error_table_$too_many_args;
		goto USAGE;
	     end;
	else if active & nargs < 2 then do;
		code = error_table_$noarg;
		goto USAGE;
		end;

	call cu_$arg_ptr (1, mode_str_ptr, mode_str_len, code);
	if code ^= 0 then goto USAGE;
	call cu_$arg_ptr (2, mode_name_ptr, mode_name_len, code);
	if code ^= 0 then goto USAGE;

	mv.version = mode_value_version_3;

	call mode_string_$get_mode (mode_str, mode_name, addr (mv), code);
	if code ^= 0 then do;
		call complainer (code, myname, "^a in ^a", mode_name, mode_str);
		return;
	     end;

	if mv.boolean_valuep
	then if mv.boolean_value
	     then result = "true";
	     else result = "false";
	else if mv.numeric_valuep
	then result = mv.char_value;
	else result = requote_string_ ((mv.char_value));

	if active then af_result = result;
	else call ioa_ ("^a", result);
	return;

USAGE:	call complainer (code, myname,
	     "Usage:  ^[[^]^a MODE-STR MODE-NAME^[]^]",
	     active, myname, active);
	return;
%page;
%include mode_string_info;
     end get_mode;
  



		    have_queue_entries.pl1          09/11/84  1318.6rew 09/11/84  1317.2       72432


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


/* Returns "true" if there are messages in the specified message segment */

/* Created:  September 1982 by G. Palter */
/* Modified:  July 1984 by Jim Lippard to accept starnames and multiple
   paths */

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


have_queue_entries:
     procedure () options (variable);


dcl  code fixed binary (35);

dcl  active_function bit (1) aligned;			/*  ON => invoked as an active function */

dcl  complain entry () options (variable) variable;
dcl  get_argument entry (fixed binary, pointer, fixed binary (21), fixed binary (35)) variable;

dcl  n_arguments fixed binary;

dcl  return_value character (return_value_max_lth) varying based (return_value_ptr);
dcl  return_value_max_lth fixed binary (21);
dcl  return_value_ptr pointer;

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

dcl  file_dname character (168);			/* dir/entryname of the message-segment */
dcl  file_ename character (32);
dcl  file_index fixed binary;				/* message-segment index of above */
dcl  message_count fixed binary;			/* # of messages in it */

dcl  multiple_paths bit (1) aligned;			/* ON => if any starnames or more than one path */

dcl  (arg_index, name_index) fixed binary;

dcl  HAVE_QUEUE_ENTRIES character (32) static options (constant) initial ("have_queue_entries");

/* format: off */
dcl (active_fnc_err_, active_fnc_err_$suppress_name, com_err_, com_err_$suppress_name)
	entry () options (variable);
/* format: on */

dcl  check_star_name_$path entry (character (*), fixed binary (35));
dcl  cu_$af_arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$star_
	entry (character (*), character (*), fixed binary (2), pointer, fixed binary, pointer, pointer,
	fixed binary (35));
dcl  ioa_ entry () options (variable);
dcl  message_segment_$close entry (fixed binary, fixed binary (35));
dcl  message_segment_$get_message_count_index entry (fixed binary, fixed binary, fixed binary (35));
dcl  message_segment_$open entry (character (*), character (*), fixed binary, fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));

/* format: off */
dcl (error_table_$badopt, error_table_$badstar, error_table_$not_act_fnc)
	fixed binary (35) external;
/* format: on */

dcl  (index, null, sum) builtin;

dcl  cleanup condition;
%page;
/* have_queue_entries: entry () options (variable) */

	call cu_$af_return_arg (n_arguments, return_value_ptr, return_value_max_lth, code);

	if code = 0 then do;
	     active_function = "1"b;
	     complain = active_fnc_err_;
	     get_argument = cu_$af_arg_ptr;
	     return_value = "false";			/* in case of error be sure to return something */
	end;

	else if code = error_table_$not_act_fnc then do;
	     active_function = "0"b;
	     complain = com_err_;
	     get_argument = cu_$arg_ptr;
	end;

	else do;
	     call com_err_ (code, HAVE_QUEUE_ENTRIES, "Determining type of call.");
	     return;
	end;

	if n_arguments = 0 then do;			/* must have a pathname */
	     if active_function then
		call active_fnc_err_$suppress_name (0, HAVE_QUEUE_ENTRIES, "Usage:  [have_queue_entries starnames]");
	     else call com_err_$suppress_name (0, HAVE_QUEUE_ENTRIES, "Usage:  have_queue_entries starnames");
	     return;
	end;

	if n_arguments > 1 then multiple_paths = "1"b;	/* more than one pathname */

	do arg_index = 1 to n_arguments;
	     call get_argument (arg_index, argument_ptr, argument_lth, code);
	     if code ^= 0 then do;
		call complain (code, HAVE_QUEUE_ENTRIES, "Fetching argument #^d.", arg_index);
		return;
	     end;

	     if index (argument, "-") = 1 then do;	/* can't be a control argument */
		call complain (error_table_$badopt, HAVE_QUEUE_ENTRIES, """^a""", argument);
		return;
	     end;

	     else do;				/* the pathname */
		call expand_pathname_$add_suffix (argument, "ms", file_dname, file_ename, code);
		if code ^= 0 then do;
		     call complain (code, HAVE_QUEUE_ENTRIES, "^a", argument);
		     return;
		end;

		call check_star_name_$path (argument, code);
		if code = error_table_$badstar then do;
		     call complain (code, HAVE_QUEUE_ENTRIES, "^a", argument);
		     return;
		end;
		else if code ^= 0 then do;		/* a star name */
		     star_names_ptr, star_entry_ptr = null ();
		     on condition (cleanup) call free_star_structures ();
		     call hcs_$star_ (file_dname, file_ename, star_ALL_ENTRIES, get_system_free_area_ (),
			star_entry_count, star_entry_ptr, star_names_ptr, code);
		     if code ^= 0 then do;
			call complain (code, HAVE_QUEUE_ENTRIES, "^a", pathname_ (file_dname, file_ename));
			return;
		     end;

		     do name_index = 1 to star_entry_count;
			call get_message_count (file_dname, star_names (star_entries.nindex (name_index)), message_count,
			     code);
			if code ^= 0 then do;
			     call complain (code, HAVE_QUEUE_ENTRIES, "^a",
				pathname_ (file_dname, star_names (star_entries.nindex (name_index))));
			     call free_star_structures ();
			     return;
			end;
			if (message_count = 0) then
			     if active_function then
				;
			     else call ioa_ ("No messages in ^a.",
				     pathname_ (file_dname, star_names (star_entries.nindex (name_index))));
			else if active_function then return_value = "true";
			else call ioa_ ("There are messages in ^a.",
				pathname_ (file_dname, star_names (star_entries.nindex (name_index))));
		     end;				/* star entries loop */
		     call free_star_structures ();
		end;				/* a star name */
		else do;				/* a path name */
		     call get_message_count (file_dname, file_ename, message_count, code);
		     if code ^= 0 then do;
			call complain (code, HAVE_QUEUE_ENTRIES, "^a", pathname_ (file_dname, file_ename));
			return;
		     end;
		     if (message_count = 0) then
			if active_function then
			     ;
			else call ioa_ ("No messages^[ in ^a^].", multiple_paths,
				pathname_ (file_dname, file_ename));
		     else if active_function then return_value = "true";
		     else call ioa_ ("There are messages^[ in ^a^].", multiple_paths,
			     pathname_ (file_dname, file_ename));
		end;				/* a path name */
	     end;
	end;					/* argument loop */

	return;

%page;

get_message_count:
     procedure (P_file_dname, P_file_ename, P_message_count, P_code);
dcl  (P_file_dname, P_file_ename) character (*) parameter;
dcl  P_message_count fixed binary parameter;
dcl  P_code fixed binary (35) parameter;

	P_code = 0;

/* Actual processing */

	call message_segment_$open (P_file_dname, P_file_ename, file_index, code);
	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;

	on condition (cleanup)			/* if here the mailbox/message-segment is opened */
	     call message_segment_$close (file_index, (0));

	call message_segment_$get_message_count_index (file_index, P_message_count, code);
	if code ^= 0 then do;
	     P_code = code;
	     call message_segment_$close (file_index, (0));
	     return;
	end;

	call message_segment_$close (file_index, (0));
     end get_message_count;

%page;

free_star_structures:
     procedure;
	if star_names_ptr ^= null () then free star_names;/* in system free area */
	if star_entry_ptr ^= null () then free star_entries;
						/* in system free area */
     end free_star_structures;

%page;
%include star_structures;

     end have_queue_entries;



		    io_call.pl1                     02/27/84  1340.7rew 02/27/84  1336.5      348417


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


/* Command interface to iox_ for performing operations on I/O switches. */

/* Completely rewritten in June 1975 by Larry Johnson */
/* Modified September 1975 by Larry Johnson to check for non-fatal input errors */
/* Modified December 1975 by Larry Johnson to extend position operation types */
/* Modified April 1976 by Larry Johnson to use io_call order in control operations */
/* Modified July 1976 by Larry Johnson to allow entry point names in attach module name. */
/* Modified June 1977 by Larry Johnson for io active function. Command was also split into several modules */
/* Modified: 12 November 1980 by G. Palter to increase possible size of the mode string to 512 */
/* Modified 1/83 by S. Krupp to add handling for new iox_ entry points:
   open_file, close_file, and detach.  Modified attach to call
   iox_$attach_loud rather than attaching switches differently from everyone
   else.  Moved the code that handles entry point names in attach
   module names to attach_name.pl1 which is common code used by all
   iox_$attach entries. */
/* Modified 08/02/83 by Jim Lippard to allow find_iocb as an AF and to print
   the name of the control order in error messages about the control order
   (rather than nonsensically using the name of the I/O switch) */
/* Modified 12/19/83 by Jim Lippard to make open_desc allow -no_quote */

io_call: io: proc;

/* Automatic storage */

dcl  code fixed bin (35);				/* System status code */
dcl  arg_list_ptr ptr;				/* Pointer to argument list */
dcl  arg_ptr ptr;					/* Pointer to current argument */
dcl  arg_len fixed bin;				/* Length of current argument */
dcl  arg2_len fixed bin;				/* Length of a second arg */
dcl  arg2_ptr ptr;					/* Pointer to a second arg */
dcl  n_args fixed bin;				/* Number of arguments on command line */
dcl  next_arg fixed bin;				/* Used in counting args */
dcl  dir char (168);				/* To hold directory names */
dcl  desc_len fixed bin;				/* The length of a description. */
dcl  ename char (32);				/* To hold entry names */
dcl  seg_ptr ptr;					/* Pointer to dir>ename */
dcl  arg_name char (32) var;				/* Name of current arg for error msg */
dcl  attach_entry char (32);				/* For building name of attach entry point */
dcl  iocb_ptr ptr;					/* Pointer to IOCB being processed */
dcl  iocb2_ptr ptr;					/* Pointer to target IOCB during move_attach */
dcl (i, j) fixed bin;				/* A binary number */
dcl  mode fixed bin;				/* Mode for open operation */
dcl  cv_dec_err fixed bin;				/* Error code from cv_dec_check_ */
dcl  data_ptr ptr;					/* Pointer to data if i/o from a segment */
dcl  data_len fixed bin (21);				/* Length of data if io from segment */
dcl  key char (256) var;				/* A key for seek type operations */
dcl  print_sw bit (1);				/* On if results of modes should be printed */
dcl  new_mode_sw bit (1);				/* On if modes command specified a new mode */
dcl  negate_sw bit (1);				/* For calculating position */
dcl  dummy_char char (1);				/* Used when null character string needed */
dcl  n_low fixed bin;				/* Lower bound of param array description */
dcl  n_high fixed bin;				/* Number of entries in param array */
dcl  max_l fixed bin;				/* Max length of an entry in param array */
dcl  msg_ptr ptr;					/* Will point to io_call_msg_$ if needed */
dcl  order char (32);				/* The order on a control operation */
dcl  error entry variable options (variable);		/* Will be com_err_ of active_fnc_err_ */
dcl  af_sw bit (1);					/* Set if invoked as active function */
dcl  af_retp ptr;					/* Pointer to active function return string */
dcl  af_retl fixed bin;				/* Length of active function return string */
dcl  no_quote_sw bit (1);				/* Set by -no_quote */
dcl  ev entry variable;				/* For valid_op operation */
dcl  valid_mode_sw bit (1);				/* To distinguish between valid and test mode ops */

/* Constants */

dcl  cmd_name char (7) int static options (constant) init ("io_call"); /* Name of this thing */

/* This array contains the names of 16 of the possible operations performed by this command. This
   array must agree with the names and positions of the entry variables in the IOCB */

dcl  opt_name (19) char (14) int static options (constant) init
    ("detach_iocb",					/* 1 */
     "open",					/* 2 */
     "close",					/* 3 */
     "get_line",					/* 4 */
     "get_chars",					/* 5 */
     "put_chars",					/* 6 */
     "modes",					/* 7 */
     "position",					/* 8 */
     "control",					/* 9 */
     "read_record",					/* 10 */
     "write_record",				/* 11 */
     "rewrite_record",				/* 12 */
     "delete_record",				/* 13 */
     "seek_key",					/* 14 */
     "read_key",					/* 15 */
     "read_length", 				/* 16 */
     "open_file",					/* 17 */
     "close_file",					/* 18 */
     "detach");					/* 19 */

/* The remaining operations performed by this command are numbered starting with 20, as follows:

   20 - attach		21 - find_iocb		22 - look_iocb
   23 - destroy_iocb	24 - move_attach		25 - print_iocb
   26 - attached		27 - opened		28 - closed
   29 - detached		30 - open_desc		31 - attach_desc
   32 - io_module		33 - valid_op		34 - test_mode
   35 - valid_mode
*/

/* This array contains the names of the rest of the operations performed by the command,
   including some abbreviations for things in the first array of operations */

dcl  opt_name2 (27) char (12) int static options (constant) init
    ("attach",					/* 1 -> 20 */
     "find_iocb",					/* 2 -> 21 */
     "find",					/* 3 -> 21 */
     "look_iocb",					/* 4 -> 22 */
     "look",					/* 5 -> 22 */
     "destroy_iocb",				/* 6 -> 23 */
     "destroy",					/* 7 -> 23 */
     "write",					/* 8 -> 11 */
     "rewrite",					/* 9 -> 12 */
     "delete",					/* 10 -> 13 */
     "seek",					/* 11 -> 14 */
     "move_attach",					/* 12 -> 24 */
     "move",					/* 13 -> 24 */
     "print_iocb",					/* 14 -> 25 */
     "piocb",					/* 15 -> 25 */
     "print",					/* 16 -> 25 */
     "read",					/* 17 -> 10 */
     "attached",					/* 18 -> 26 */
     "opened",					/* 19 -> 27 */
     "closed",					/* 20 -> 28 */
     "detached",					/* 21 -> 29 */
     "open_desc",					/* 22 -> 30 */
     "attach_desc",					/* 23 -> 31 */
     "io_module",					/* 24 -> 32 */
     "valid_op",					/* 25 -> 33 */
     "test_mode",					/* 26 -> 34 */
     "valid_mode");					/* 27 -> 35 */

/* This array defines the correspondence between operations in opt_name2 and
   the labels that perform the operations. (See the comments in opt_name2) */

dcl  op_match (27) fixed bin int static options (constant) init
    (20, 21, 21, 22, 22, 23, 23, 11, 12, 13, 14, 24, 24, 25, 25, 25, 10, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35);

/* The following array defines what operations are valid through the active function */

dcl  valid_af (35) bit (1) unal int static options (constant) init (
     "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b,
     "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b,
     "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b,
     "1"b, "1"b, "1"b, "1"b, "1"b);

/* The following array defines what tests must be performed in
   order to determine if an operation is valid (for the valid_op operation ).
   The tests are:
   1 - check IOCB entry variable
   2 - valid if detached
   3 - valid if IOCB exists
   4 - always valid
   5 - valid if open
   6 - valid if attached */

dcl  valid_op (35) fixed bin int static options (constant) init (
     1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2,
     4, 4, 2, 6, 3, 4, 4, 4, 4, 5, 6, 6, 4, 6, 6);

/* Full names of all open modes */

dcl  open_type (13) char (24) int static init
    ("stream_input",				/* 1 */
     "stream_output",				/* 2 */
     "stream_input_output",				/* 3 */
     "sequential_input",				/* 4 */
     "sequential_output",				/* 5 */
     "sequential_input_output",			/* 6 */
     "sequential_update",				/* 7 */
     "keyed_sequential_input",			/* 8 */
     "keyed_sequential_output",			/* 9 */
     "keyed_sequential_update",			/* 10 */
     "direct_input",				/* 11 */
     "direct_output",				/* 12 */
     "direct_update");				/* 13 */

/* Abbreviations for open types */

dcl  open_abbrev (13) char (4) int static init
    ("si",					/* 1 */
     "so",					/* 2 */
     "sio",					/* 3 */
     "sqi",					/* 4 */
     "sqo",					/* 5 */
     "sqio",					/* 6 */
     "squ",					/* 7 */
     "ksqi",					/* 8 */
     "ksqo",					/* 9 */
     "ksqu",					/* 10 */
     "di",					/* 11 */
     "do",					/* 12 */
     "du");					/* 13 */

/* Static storage */

dcl  req char (32) static init (".");			/* Current operation, remembered for next call */
dcl  ioname char (32) static init (".");		/* Current io switch, remembered for next call */
dcl  WHITESPACE char(2) init(" 	") int static options(constant);

/* Based storage */

dcl  arg char (arg_len) based (arg_ptr);		/* Some arbitrary argument */
dcl  arg2 char (arg2_len) based (arg2_ptr);		/* A second argument */
dcl  af_ret char (af_retl) based (af_retp) var;		/* To return active function value */
dcl  ev_array (16) entry based;			/* Array of entry variables in iocb */

dcl 1 word aligned based (data_ptr),			/* Used for help messages */
    2 upper bit (18) unal,
    2 lower bit (18) unal;


dcl 1 descrip aligned based,				/* An attach or open description */
    2 msg_len fixed bin,
    2 msg char (0 refer (descrip.msg_len)) unal;


/* External variables */

dcl  error_table_$bad_mode ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$end_of_info ext fixed bin (35);
dcl  error_table_$key_order ext fixed bin (35);
dcl  error_table_$no_ext_sym ext fixed bin (35);
dcl  error_table_$no_operation ext fixed bin (35);
dcl  error_table_$no_record ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_detached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl  error_table_$request_not_recognized ext fixed bin (35);
dcl  error_table_$seg_not_found ext fixed bin (35);
dcl  error_table_$too_many_args ext fixed bin (35);
dcl  error_table_$undefined_order_request ext fixed bin (35);

dcl  io_call_msg_$ ext;				/* External error message stuff */

/* Builtin functions */

dcl (addr, addrel, bin, hbound, index, length, max, min, null, reverse, rtrim, search, substr) builtin;


/* Entry variables */

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  cu_$ptr_call entry options (variable);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  cu_$decode_entry_value entry (entry, ptr, ptr);

dcl  cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));

dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));

dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);

dcl  io_call_print_iocb_ entry (ptr);
dcl  io_call_read_write_$put_chars entry (ptr, ptr);
dcl  io_call_read_write_$get_chars entry (ptr, ptr);
dcl  io_call_read_write_$get_line entry (ptr, ptr);
dcl  io_call_read_write_$read_record entry (ptr, ptr);
dcl  io_call_read_write_$write_record entry (ptr, ptr);
dcl  io_call_read_write_$rewrite_record entry (ptr, ptr);

dcl  iox_$attach_loud entry (ptr, char(*), ptr, fixed bin(35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$close_file entry(ptr, char(*), fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$delete_record entry (ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
dcl  iox_$detach entry(ptr, char(*), fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$move_attach entry (ptr, ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$open_file entry(ptr, fixed bin, char(*), bit(1) aligned, fixed bin(35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$read_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
dcl  iox_$read_length entry (ptr, fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
dcl  iox_$err_no_operation entry;
dcl  iox_$err_not_attached entry;
dcl  iox_$err_not_closed entry;
dcl  iox_$err_not_open entry;

dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  term_$single_refname entry (char (*) aligned, fixed bin (35));

%include iocb;

/* Check first to see if command or active function */

	call cu_$af_return_arg (n_args, af_retp, af_retl, code); /* This guy knows */
	if code = 0 then do;
	     af_sw = "1"b;				/* We are an active function */
	     error = active_fnc_err_;			/* For reporting errors */
	end;
	else do;					/* Plain old command */
	     af_sw = "0"b;
	     error = com_err_;
	     call cu_$arg_count (n_args);		/* Get command arg count */
	end;
	call cu_$arg_list_ptr (arg_list_ptr);		/* Need this in any case */

/* Get operation to be performed (the first argument) */

	if n_args = 0 then do;			/* If no args, setup help message */
	     i = 0;
	     arg_name = "opname";
	     go to help;
	end;
	next_arg = 1;
	call get_arg ("operation");
	if arg ^= "." then req = arg;			/* "." means same req as last time */
	if req = "." then do;			/* There was no last time */
	     code = error_table_$noarg;
	     arg_name = "operation";
	     go to err_1;
	end;

/* Determine if the operation specified is valid. */

	i = get_op_number (req);			/* Look up opertion */

	if i = 0 then do;
bad_req:	     code = error_table_$request_not_recognized;	/* Unknown request */
	     arg_name = req;
	     go to err_1;
	end;

	if af_sw then if ^valid_af (i) then go to bad_req; /* Only valid in command */
	if n_args > 1 then go to get_sw;		/* If a switch name also specified */

/* Command specification is incomplete so print a help message */

	arg_name = req;				/* Type of help being given */
help:	msg_ptr = addr (io_call_msg_$);		/* Get pointer to segment with help messages */
	data_ptr = addrel (msg_ptr, i);		/* Pointer to header word for command */
	j = bin (word.lower);			/* Number of messages */
	data_ptr = addrel (msg_ptr, word.upper);	/* Pointer to first message pointer */
	if ^af_sw then call ioa_ ("^a: Usage is: io_call ^a switchname ^A",
	     cmd_name, arg_name, addrel (msg_ptr, word.upper));
	else call error (0, cmd_name, "Usage is: [io_call ^a switchname ^A]",
	     arg_name, addrel (msg_ptr, word.upper));

	do i = 2 to j;				/* Print rest of message */
	     data_ptr = addrel (data_ptr, 1);
	     call ioa_ ("^A", addrel (msg_ptr, word.upper));
	end;
	return;

/* Get I/O switch name (the second argument) */

get_sw:	call get_arg ("switchname");
	if arg ^= "." then ioname = arg;		/* "." means same switch again */
	if ioname = "." then do;			/* There was no last time */
	     code = error_table_$noarg;
	     arg_name = "switchname";
	     go to err_1;
	end;


	go to op (i);				/* Dispatch to appropriate routine */

/* This is the exit from the command */


finish:	if code ^= 0 then go to err_2;		/* Most operations finish here to check last error code */
          return;

finish_attach:
          if code = error_table_$seg_not_found		/* Cannot locate I/O module. */
	then go to err_4;
	else if code ^= 0
	then go to err_2;
	return;

exit:	return;


/* True/false type active function entries exit here */

true:	call report ("true");
	go to exit;

false:	call report ("false");
	go to exit;

/* DETACH_IOCB operation */

/* Note:  the DETACH operation transfers control to here ONLY when there
   is no detach description specified on the command line. */

op (1):	call look_iocb;				/* Get IOCB pointer */
	call check_eol;
	call iox_$detach_iocb (iocb_ptr, code);		/* Do the real detach */
	go to finish;

/* OPEN operation */

op (2):   call open_common();				/* Gets iocb_ptr and open mode. */
	call check_eol;

	call iox_$open (iocb_ptr, mode, "0"b, code);	/* Open the switch */
	go to finish;

/* CLOSE operation */

op (3):	call look_iocb;				/* Get IOCB pointer */
	call check_eol;
	call iox_$close (iocb_ptr, code);
	go to finish;

/* GET_LINE operation */

op (4):	call look_iocb;
	call io_call_read_write_$get_line (iocb_ptr, arg_list_ptr);
	go to exit;

/* GET_CHARS operation */

op (5):	call look_iocb;				/* Locate the IOCB */
	call io_call_read_write_$get_chars (iocb_ptr, arg_list_ptr);
	go to exit;

/* PUT_CHARS operation */

op (6):	call look_iocb;
	call io_call_read_write_$put_chars (iocb_ptr, arg_list_ptr);
	go to exit;

/* MODES operation */

op (7):	call look_iocb;
	arg_name = "new modes.";			/* Looking for new modes */
	print_sw = "1"b;				/* Assume for now old modes will be printed */
	new_mode_sw = "0"b;				/* Mode not found yet */
	do while (next_arg <= n_args);
	     call get_arg ("");
	     if arg = "-brief" | arg = "-bf" then print_sw = "0"b; /* This means don't print old modes */
	     else if new_mode_sw then do;
		code = error_table_$badopt;
		go to err_3;
	     end;
	     else do;
		arg2_len = arg_len;			/* Remember this arg */
		arg2_ptr = arg_ptr;
		new_mode_sw = "1"b;
	     end;
	end;
	if ^new_mode_sw then do;			/* If a new mode was not given */
	     arg2_ptr = addr (dummy_char);		/* Set up a dummy one */
	     arg2_len = 1;
	     dummy_char = " ";
	end;

	begin;

dcl  old_modes char (512);				/* Allow for long modes string */

	     old_modes = "";
	     call iox_$modes (iocb_ptr, arg2, old_modes, code); /* Do modes operation */
	     if code ^= 0 then go to err_2;
	     else if af_sw then af_ret = requote_string_ (rtrim (old_modes));
	     else if print_sw & old_modes ^= "" then	/* If printing wanted, and something returned */
		call ioa_ ("^a: ^a", cmd_name, old_modes);
	end;
	go to exit;

/* POSITION operation */

op (8):	call look_iocb;
	call get_arg ("position type");
	negate_sw = "0"b;				/* Initialize switch */
	i = cv_dec ();				/* Should be decimal number */
	if cv_dec_err ^= 0 then do;			/* Check for some keywords */
	     if arg = "bof" | arg = "b" then i = -1;	/* Beginning of file */
	     else if arg = "eof" | arg = "e" then i = 1;	/* End of file */
	     else if arg = "forward" | arg = "foward" | arg = "fwd" | arg = "f" then do; /* Move forward */
		i = 0;
	     end;
	     else if arg = "reverse" | arg = "rev" | arg = "r" then do; /* If reverse move */
		i = 0;
		negate_sw = "1"b;			/* The number will have to be inverted */
	     end;
	     else do;
		call error (0, cmd_name, "Invalid position specification. ^a", arg);
		go to exit;
	     end;
	end;

/* Another argument is required if i = 0, is illegal for i = 1 and i = -1,
   and is optional for other values of i */

	if i = 0 | ((i ^= 1) & (i ^= -1) & (next_arg <= n_args)) then do;
	     call get_arg ("position value");
	     data_len = cv_dec ();			/* Which also is decimal */
	     if cv_dec_err ^= 0 then do;
		call error (0, cmd_name, "Invalid decimal number. ^a", arg);
		go to exit;
	     end;
	     if negate_sw then data_len = -data_len;	/* If reverse position */
	end;
	else data_len = 0;				/* Don't care */
	call check_eol;
	call iox_$position (iocb_ptr, i, data_len, code); /* Do operation */
	if af_sw then do;
	     if code = 0 then go to true;
	     if code = error_table_$end_of_info then go to false;
	end;
	go to finish;

/* CONTROL operation */

op (9):	call look_iocb;				/* First, locate the IOCB */
	call get_arg ("order");
	order = arg;				/* Save order name */
	if order = "io_call" | order = "io_call_af" then do;
	     call error (0, cmd_name, "The ^a ^[active function^;command^] cannot perform an ^a order.",
		cmd_name, af_sw, order);
	     go to exit;
	end;
	call check_args;				/* Scan rest of argument list */

	begin;					/* Begin block allocates param structure */

dcl  io_call_order_name char (10);			/* Will be io_call or io_call_af */
dcl 1 io_call_info aligned,				/* This structure must look like io_call_info.incl.pl1 */
    2 version fixed bin,
    2 caller_name char (32),
    2 order_name char (32),
    2 ioa_entry entry variable options (variable),
    2 com_err_entry entry variable options (variable),
    2 af_returnp ptr,				/* Pointer to active function return string */
    2 af_returnl fixed bin,				/* Its max length */
    2 fill (5) bit (36) aligned,
    2 nargs fixed bin,
    2 max_arglen fixed bin,
    2 args (n_high) char (max_l) varying;

	     io_call_info.version = 1;
	     io_call_info.caller_name = cmd_name;	/* Initialize param list */
	     io_call_info.order_name = order;
	     io_call_info.ioa_entry = ioa_;
	     if af_sw then do;
		io_call_info.af_returnp = af_retp;
		io_call_info.af_returnl = af_retl;
		io_call_order_name = "io_call_af";
	     end;
	     else do;
		io_call_info.af_returnp = null;
		io_call_info.af_returnl = 0;
		io_call_order_name = "io_call";
	     end;
	     io_call_info.com_err_entry = error;
	     io_call_info.fill = "0"b;
	     io_call_info.nargs = n_high;
	     io_call_info.max_arglen = max_l;
	     i = 1;
	     do while (next_arg <= n_args);
		call get_arg ("");
		io_call_info.args (i) = arg;
		i = i + 1;
	     end;

/* First try to perform the control operation with the "io_call" order */

	     call iox_$control (iocb_ptr, io_call_order_name, addr (io_call_info), code);

	end;

	if code = 0 then go to exit;			/* Io module did the order. */
	if af_sw then go to err_2;
	if code = error_table_$no_operation | code = error_table_$undefined_order_request then do;
						/* Module does not seem to like io_call order */
	     call iox_$control (iocb_ptr, rtrim (order), null, code); /* Retry original order */
	     if code ^= 0 then do;
		call error (code, cmd_name, "Order ^a on switch ^a.", order, ioname);
		go to exit;
	     end;
	     end;
	go to finish;

/* READ_RECORD operation */

op (10):	call look_iocb;				/* Locate IOCB */
	call io_call_read_write_$read_record (iocb_ptr, arg_list_ptr);
	go to exit;

/* WRITE_RECORD operation */

op (11):	call look_iocb;
	call io_call_read_write_$write_record (iocb_ptr, arg_list_ptr);
	go to exit;

/* REWRITE_RECORD operation */

op (12):	call look_iocb;
	call io_call_read_write_$rewrite_record (iocb_ptr, arg_list_ptr);
	go to exit;

/* DELETE_RECORD operation */

op (13):	call look_iocb;
	call check_eol;
	call iox_$delete_record (iocb_ptr, code);
	go to finish;

/* SEEK_KEY operation */

op (14):	call look_iocb;
	call get_arg ("key");
	call check_eol;
	key = arg;				/* Copy key to varying string */
	data_len = -1;
	call iox_$seek_key (iocb_ptr, key, data_len, code);
	if af_sw then do;				/* Active function */
	     if code = 0 then go to true;
	     if code = error_table_$no_record then go to false;
	end;
	if code ^= 0 then do;
	     if data_len = -1 then do;		/* No record length returned */
		if code = error_table_$no_record | code = error_table_$key_order then
		     call error (code, cmd_name, "^a", key);
		else go to err_2;
	     end;
	     else call error (code, cmd_name, "len=^d.", data_len);
	end;
	else call ioa_ ("^a: key=""^a"" len=^d.", cmd_name, key, data_len);
	go to exit;


/* READ_KEY operation */

op (15):	call look_iocb;
	call check_nq;				/* Look for -no_quote */
	call check_eol;
	data_len = -1;
	key = "";
	call iox_$read_key (iocb_ptr, key, data_len, code); /* Do the operation */
	if code ^= 0 then do;
	     if data_len = -1 then go to err_2;		/* Nothing returned */
	     else call error (code, cmd_name, "key=""^a"" len=^d.", key, data_len);
	end;
	else if af_sw then do;
	     if no_quote_sw then af_ret = key;
	     else af_ret = requote_string_ ((key));
	end;
	else call ioa_ ("^a: key=""^a"" len=^d.", cmd_name, key, data_len);
	go to exit;


/* READ_LENGTH operation */

op (16):	call look_iocb;
	call check_eol;
	data_len = -1;
	call iox_$read_length (iocb_ptr, data_len, code); /* Get length */
	if code ^= 0 then do;
	     if data_len = -1 then go to err_2;
	     call error (code, cmd_name, "len=^d.", data_len);
	end;
	else if af_sw then call ioa_$rsnnl ("^d", af_ret, (0), data_len);
	else call ioa_ ("^a: len=^d.", cmd_name, data_len);
	go to exit;

/* OPEN_FILE operation */

op (17):  call open_common();				/* Gets IOCB ptr and open mode. */
          call get_desc_len(desc_len);

	begin;

	     dcl description char(desc_len);

	     call get_desc(description);
	     call iox_$open_file(iocb_ptr, mode, description, "0"b, code);

	end;

	go to finish;

/* CLOSE_FILE operation */

op (18):  call look_iocb();				/* Get IOCB ptr. */
          call get_desc_len(desc_len);

	begin;

	     dcl description char(desc_len);

	     call get_desc(description);
	     call iox_$close_file(iocb_ptr, description, code);

	end;

	go to finish;

/* DETACH operation */

op (19):  call look_iocb();				/* Get IOCB ptr. */

          if at_eol()				/* No detach description specified. */
	then go to op(1);				/* Transfer to DETACH_IOCB op. */

          call get_desc_len(desc_len);

	begin;

	     dcl description char(desc_len);

	     call get_desc(description);
	     call iox_$detach(iocb_ptr, description, code);

	end;

	go to finish;


/* ATTACH operation */

op (20):	call find_iocb();				/* Get IOCB pointer */
          call get_desc_len(desc_len);

	begin;

	     dcl description char(desc_len);

	     call get_desc(description);
	     call iox_$attach_loud(iocb_ptr, description, (null), code);
	if code = error_table_$no_ext_sym then do;
		call error (code, cmd_name, "Attaching ^a on switch ^a.", description, ioname);
		code = 0;
	end;

	end;

	go to finish_attach;


/* FIND_IOCB operation */

op (21):	call find_iocb;
findx:	call check_eol;
	if af_sw then call ioa_$rsnnl ("^p", af_ret, (0), iocb_ptr);
	else call ioa_ ("^a: ^a at ^p", cmd_name, ioname, iocb_ptr);
	go to exit;

/* LOOK_IOCB operation */

op (22):	call iox_$look_iocb (ioname, iocb_ptr, code);	/* Get IOCB pointer */
	if af_sw then do;
	     if code = 0 then go to true;
	     else go to false;
	end;
	else if code ^= 0 then go to err_2;
	else go to findx;


/* DESTROY_IOCB operation */

op (23):	call look_iocb;
	call check_eol;
	call iox_$destroy_iocb (iocb_ptr, code);
	go to finish;


/* MOVE_ATTACH operation */

op (24):	call look_iocb;				/* Locate source IOCB */
	call get_arg ("target iocb");
	call check_eol;
	call iox_$find_iocb (arg, iocb2_ptr, code);	/* Get pointer to target IOCB */
	if code ^= 0 then go to err_3;		/* If this failed */
	call iox_$move_attach (iocb_ptr, iocb2_ptr, code);
	if code ^= 0 then do;
	     if code = error_table_$not_detached then go to err_3; /* Error applies to target IOCB */
	     else go to err_2;			/* Error applies to source IOCB */
	end;
	go to exit;

/* PRINT_IOCB operation */

op (25):	call look_iocb;				/* Find IOCB */
	call check_eol;
	call io_call_print_iocb_ (iocb_ptr);
	go to exit;

/* ATTACHED operation */

op (26):	call check_eol;
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to false;
	if iocb_ptr -> iocb.attach_descrip_ptr = null then go to false;
	else go to true;

/* OPENED operation */

op (27):	call check_eol;
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to false;
	if iocb_ptr -> iocb.open_descrip_ptr = null then go to false;
	else go to true;

/* CLOSED operation */

op (28):	call check_eol;
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to true;
	if iocb_ptr -> iocb.open_descrip_ptr = null then go to true;
	else go to false;

/* DETACHED operation */

op (29):	call check_eol;
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to true;
	if iocb_ptr -> iocb.attach_descrip_ptr = null then go to true;
	else go to false;

/* OPEN_DESC operation */

op (30):	call check_eol;
	call look_iocb;
	call check_nq;
	if iocb_ptr -> iocb.open_descrip_ptr = null then do;
	     code = error_table_$not_open;
	     go to err_2;
	end;
          if no_quote_sw then call report (iocb_ptr -> iocb.open_descrip_ptr -> descrip.msg);
	else call report (requote_string_ (iocb_ptr -> iocb.open_descrip_ptr -> descrip.msg));
	go to exit;

/* ATTACH_DESC operation */

op (31):	call look_iocb;
	call check_nq;
	call check_eol;
	if iocb_ptr -> iocb.attach_descrip_ptr = null then do;
	     code = error_table_$not_attached;
	     go to err_2;
	end;
	if no_quote_sw then call report (iocb_ptr -> iocb.attach_descrip_ptr -> descrip.msg);
	else call report (requote_string_ (iocb_ptr -> iocb.attach_descrip_ptr -> descrip.msg));
	go to exit;

/* IO_MODULE operation */

op (32):	call check_eol;
	call look_iocb;
	if iocb_ptr -> iocb.attach_descrip_ptr = null then do; /* No attachment */
	     code = error_table_$not_attached;
	     go to err_2;
	end;
	i = index (iocb_ptr -> iocb.attach_descrip_ptr -> descrip.msg, " ");
	if i = 0 then i = length (iocb_ptr -> iocb.attach_descrip_ptr -> descrip.msg);
	else i = i - 1;
	call report (substr (iocb_ptr -> iocb.attach_descrip_ptr -> descrip.msg, 1, i));
	go to exit;

/* VALID_OP operation */

op (33):	call get_arg ("operation");
	i = get_op_number (arg);			/* Look it up */
	if i = 0 then do;
	     code = error_table_$badopt;
	     go to err_3;
	end;
	call check_eol;
	go to valid_op_test (valid_op (i));		/* Go check if valid */
valid_op_test (1):					/* Valid if no error entry in IOCB */
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to false;
	ev = addr (iocb_ptr -> iocb.detach_iocb) -> ev_array (i);
	if equal_ev (ev, iox_$err_no_operation) then go to false;
	if equal_ev (ev, iox_$err_not_attached) then go to false;
	if equal_ev (ev, iox_$err_not_closed) then go to false;
	if equal_ev (ev, iox_$err_not_open) then go to false;
	go to true;
valid_op_test (2):					/* Valid if detached */
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to true;
	if iocb_ptr -> iocb.attach_descrip_ptr = null then go to true;
	else go to false;
valid_op_test (3):					/* Valid if iocb exists */
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code = 0 then go to true;
	else go to false;
valid_op_test (4):					/* Always valid */
	go to true;
valid_op_test (5):					/* True if open */
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to false;
	if iocb_ptr -> iocb.open_descrip_ptr = null then go to false;
	else go to true;
valid_op_test (6):					/* Valid if attached */
	call iox_$look_iocb (ioname, iocb_ptr, code);
	if code ^= 0 then go to false;
	if iocb_ptr -> iocb.attach_descrip_ptr = null then go to false;
	else go to true;

/* TEST_MODE operation */

op (34):	valid_mode_sw = "0"b;			/* Not a valid_mode operation */
test_mode_join:
	call look_iocb;
	call get_arg ("mode");
	call check_eol;

	begin;

dcl  not_sw bit (1);				/* Set if ^mode asked for */
dcl  test_mode char (32) var;
dcl  mode_str char (512);
dcl  modes char (512) var;

	     not_sw = (substr (arg, 1, 1) = "^");
	     if not_sw then test_mode = substr (arg, 2);
	     else test_mode = arg;
	     call iox_$modes (iocb_ptr, "", mode_str, code);
	     if code ^= 0 then go to err_2;
	     modes = rtrim (mode_str, " .");		/* Trim spaces and trailing period */
	     do while (modes ^= "");			/* Loop till string gone */
		i = index (modes, ",");		/* Find end of next mode */
		if i = 0 then i = length (modes);
		else i = i - 1;
		if substr (modes, 1, 1) = "^" then
		     if substr (modes, 2, i-1) = test_mode then
			if valid_mode_sw then go to true;
			else if not_sw then go to true;
			else go to false;
		     else;
		else if substr (modes, 1, i) = test_mode then
		     if valid_mode_sw then go to true;
		     else if not_sw then go to false;
		     else go to true;
		if i+1 >= length (modes) then modes = ""; /* Done */
		else modes = substr (modes, i+2);	/* Strip off mode */
	     end;

	     if valid_mode_sw then go to false;
	     code = error_table_$bad_mode;
	     go to err_3;

	end;

/* VALID_MODE operation */

op (35):	valid_mode_sw = "1"b;
	go to test_mode_join;

/* Get next argument and print error if not found */

get_arg:	proc (s);

dcl  s char (*);					/* Comment for error message */

	     call get_arg_ptr;
	     if code = 0 then return;
	     call error (code, cmd_name, "^a", s);
	     go to exit;

	end get_arg;

/* Internal procedure to call cu_$arg_ptr_rel so that this argument list is only built once */

get_arg_ptr: proc;

	     if af_sw then call cu_$af_arg_ptr_rel (next_arg, arg_ptr, arg_len, code, arg_list_ptr);
	     else call cu_$arg_ptr_rel (next_arg, arg_ptr, arg_len, code, arg_list_ptr);
	     next_arg = next_arg + 1;

	end get_arg_ptr;


/* Internal procedure to check next argument for a decimal value */

cv_dec:	proc returns (fixed bin (35));

	     return (cv_dec_check_ (arg, cv_dec_err));

	end cv_dec;


/* Entry to print or return a result */

report:	proc (answer);

dcl  answer char (*);

	     if af_sw then af_ret = answer;		/* If active function */
	     else call ioa_ ("^a", answer);		/* If command */
	     return;

	end report;

/* Each operation starts with a call to one of the following internal procedures: The call
   is to look_iocb if the IOCB must exist prior to the command being issued:  the call is to
   find_iocb if this is not required. */

look_iocb: proc;

	     call iox_$look_iocb (ioname, iocb_ptr, code);
	     if code ^= 0 then go to err_2;
	     return;

	end look_iocb;


find_iocb: proc;

	     call iox_$find_iocb (ioname, iocb_ptr, code);
	     if code ^= 0 then go to err_2;
	     return;

	end find_iocb;


/* This procedure scan the rest of the argument list to determine how much space must be allocated
   to hold it. This is used by control operations. */

check_args: proc;

dcl  save_next_arg fixed bin;				/* Arg to start with */

	     save_next_arg = next_arg;
	     max_l = 1;				/* Length of longest arg */
	     do while (next_arg <= n_args);
		call get_arg ("");
		max_l = max (max_l, arg_len);
	     end;

	     next_arg = save_next_arg;
	     n_high = n_args - next_arg + 1;		/* Number of elements in array */
	     n_low = min (1, n_high);			/* Bounds are 1:n_high or 0:0 */
	     return;

	end check_args;

/* Check for too many arguments */

check_eol: proc;

	     if next_arg > n_args then return;		/* Ok */
	     call get_arg_ptr;
	     call error (error_table_$too_many_args, cmd_name, "^a", arg);
	     go to exit;

	end check_eol;

/* Check the next argument for -no_quote */

check_nq:	proc;


	     no_quote_sw = "0"b;
	     if next_arg > n_args then return;
	     call get_arg ("");
	     if arg = "-no_quote" | arg = "-nq" then do;
		no_quote_sw = "1"b;
		return;
	     end;

	     code = error_table_$badopt;
	     go to err_3;

	end check_nq;

/* This function looks up an operation and returns its index */

get_op_number: proc (op) returns (fixed bin);

dcl  op char (*);
dcl  i fixed bin;

	     do i = 1 to hbound (opt_name, 1);
		if op = opt_name (i) then return (i);
	     end;
	     do i = 1 to hbound (opt_name2, 1);
		if op = opt_name2 (i) then return (op_match (i));
	     end;
	     return (0);

	end get_op_number;

/* This procedure scans the rest of the argument list to determine the
   maximum length of the description.  It is used by attach, open_file,
   close_file and detach. */

get_desc_len:  proc(desc_len);

          dcl desc_len fixed bin;
	dcl save_next_arg fixed bin;

	save_next_arg = next_arg;
	desc_len = 0;

	do while(next_arg <= n_args);
	     call get_arg("");
	     if search(arg, WHITESPACE) ^= 0
	     then desc_len = desc_len + (2 * arg_len + 2);     /* (2 * arg_len + 2) from requote_string_. */
	     else desc_len = desc_len + arg_len;
	     if next_arg <= n_args
	     then desc_len = desc_len + 1;		/* +1 for space between args. */
	end;

	next_arg = save_next_arg;

     end get_desc_len;

/* Concatenates the rest of the argument list forming the description. */

get_desc: proc(description);

          dcl description char(*);
	dcl var_description char(length(description)) var;

	description = "";
	var_description = "";

	do while(next_arg <= n_args);
	     call get_arg("");
	     if search(arg, WHITESPACE) ^= 0
	     then var_description = var_description || requote_string_(arg);
	     else var_description = var_description || arg;
	     if next_arg <= n_args
	     then var_description = var_description || " ";

	end;

	description = var_description;

     end get_desc;

/* This function compares two entry variables and returns true if they have the same procedure pointer */

equal_ev:	proc (e1, e2) returns (bit (1));

dcl (e1, e2) entry;
dcl (p1, p2, p3) ptr;

	     call cu_$decode_entry_value (e1, p1, p3);
	     call cu_$decode_entry_value (e2, p2, p3);
	     return (p1 = p2);

	end equal_ev;

open_common: proc();

          call look_iocb;				/* Get IOCB pointer */
	call get_arg ("open mode");
	mode = cv_dec ();				/* First test for numeric mode */
	if cv_dec_err = 0 then do;			/* If it is numeric.. */
	     if mode < 1 | mode > hbound (open_type, 1) then do; /* If out of range */
		code = error_table_$badopt;
		go to err_3;
	     end;
	     return;				/* Found type */
	end;

	do mode = 1 to hbound (open_type, 1);		/* Scan array of possible modes */
	     if arg = open_type (mode) | arg = open_abbrev (mode)
	     then return;				/* Found match */
	end;

	code = error_table_$badopt;
	go to err_3;

     end open_common;

/* Says whether or not we have already gotten the last argument on the
   command line. */

at_eol: proc() returns(bit(1) aligned);

               return(next_arg > n_args);

          end at_eol;


/* Come here for various kinds of error messages */

err_1:	call error (code, cmd_name, "^a", arg_name);
	go to exit;

err_2:	arg_name = ioname;
	go to err_1;

err_3:	call error (code, cmd_name, "^a", arg);
	go to exit;

err_4:    call error (code, cmd_name, "Cannot locate I/O module to attach ^a.", ioname);

     end io_call;
   



		    io_call_msg_.alm                03/19/87  1510.5rew 03/19/87  1510.1       46755


" ******************************************************
" *                                                    *
" * Copyright (c) 1987 by Massachusetts Institute of   *
" * Technology and Honeywell Information Systems, Inc. *
" *                                                    *
" * Copyright (c) 1972 by Massachusetts Institute of   *
" * Technology and Honeywell Information Systems, Inc. *
" *                                                    *
" ******************************************************

" HISTORY COMMENTS:
"  1) change(87-02-02,TLNguyen), approve(87-02-02,MCR7611),
"     audit(87-02-03,Lippard), install(87-03-19,MR12.1-1003):
"     Make "io_call" display a correct usage message for the attach operation.
"                                                      END HISTORY COMMENTS


"	help messages for the io_call command

"	Written June 1975 by Larry Johnson
"	Updated June 1977 by Larry Johnson
"	Updated 1/83 by S. Krupp to add help for open_file,
"	   close_file, and detach.  Also to change attach help.
"	Updated December 1983 by Jim Lippard to use braces
"	   instead of hyphens, like the rest of the world.

	segdef	io_call_msg_

io_call_msg_:
start:

"	The first table consists of one word for each operation supported
"	by the io_call command (there are 35). The upper part of the word
"	contains an indirect address to a list of message address and
"	the lower part of the word contains a count of the number of
"	lines to be printed to give help on the operation
"	requested.

	zero	command-start,6	(0)
	zero	deti-start,1	(1)
	zero	open-start,5	(2)
	zero	close-start,1	(3)
	zero	getl-start,2	(4)
	zero	getc-start,2	(5)
	zero	putc-start,2	(6)
	zero	modes-start,2	(7)
	zero	posit-start,1	(8)
	zero	control-start,1	(9)
	zero	readr-start,2	(10)
	zero	write-start,2	(11)
	zero	rewrite-start,2	(12)
	zero	delete-start,1	(13)
	zero	seek-start,1	(14)
	zero	readk-start,2	(15)
	zero	readl-start,1	(16)
	zero	openf-start,5	(17)
	zero	closef-start,1	(18)
	zero	det-start,1	(19)
	zero	attach-start,1	(20)
	zero	find-start,1	(21)
	zero	look-start,1	(22)
	zero	destroy-start,1	(23)
	zero	move-start,1	(24)
	zero	print-start,1	(25)
	zero	attached-start,1	(26)
	zero	opened-start,1	(27)
	zero	closed-start,1	(28)
	zero	detached-start,1	(29)
	zero	open_desc-start,2	(30)
	zero	attach_desc-start,2	(31)
	zero	io_module-start,1	(32)
	zero	valid_op-start,1	(33)
	zero	test_mode-start,1	(34)
	zero	valid_mode-start,1	(35)

"
"	Each word in this table is an indirect address of an acc string.


command:	zero	m14-start
	zero	m15-start
	zero	m16-start
	zero	m17-start
	zero	m18-start
	zero	m19-start
deti:	zero	null-start
open:	zero	m1-start
	zero	m20-start
	zero	m21-start
	zero	m22-start
	zero	m23-start
close:	zero	null-start
getl:	zero	m2-start
	zero	m4-start
getc:	zero	m2-start
	zero	m4-start
putc:	zero	m5-start
	zero	m6-start
modes:	zero	m7-start
	zero	m8-start
posit:	zero	m9-start
control:	zero	m10-start
readr:	zero	m2-start
	zero	m4-start
write:	zero	m5-start
	zero	m6-start
rewrite:	zero	m5-start
	zero	m6-start
delete:	zero	null-start
seek:	zero	m11-start
readk:	zero	m26-start
	zero	m27-start
readl:	zero	null-start
openf:	zero	m25-start
	zero	m20-start
	zero	m21-start
	zero	m22-start
	zero	m23-start
closef:	zero	m14-start
det:	zero	m14-start
attach:	zero	m12-start
find:	zero	null-start
look:	zero	null-start
destroy:	zero	null-start
move:	zero	m13-start
print:	zero	null-start
attached:	zero	null-start
opened:	zero	null-start
closed:	zero	null-start
detached:	zero	null-start
open_desc:zero	m26-start
	zero	m27-start
attach_desc:
	zero	m26-start
	zero	m27-start
io_module:zero	null-start
valid_op:	zero	m24-start
test_mode:zero	m1-start
valid_mode:
	zero	m1-start


"

null:	acc	""
m1:	acc	"mode"
m2:	acc	"{n} {-control_args}"
m3:	acc	"{-control_args} are -segment path {offset}, -allow_newline, -append_newline, -remove_newline, -lines"
m4:	acc	"{-control_args} are -segment path {offset}, -allow_newline, -append_newline, -remove_newline, -lines, -no_quote"
m5:	acc	"{string} {-control_args}"
m6:	acc	"{-control_args} are -segment path {offset} {length}, -allow_newline, -append_newline, -remove_newline, -lines"
m7:	acc	"{string} {-control_arg}"
m8:	acc	"{-control_arg} may be -brief"
m9:	acc	"type {n}"
m10:	acc	"order"
m11:	acc	"key"
m12:	acc	"attach_description"
m13:	acc	"switchname2"
m14:	acc	"{args}"
m15:	acc	"opname may be: attach, attached, attach_desc, close, closed, control,"
m16:	acc	"delete_record, detach, detached, destroy_iocb, find_iocb, get_chars, get_line,"
m17:	acc	"io_module, modes, move_attach, look_iocb, open, opened, open_desc, position,"
m18:	acc	"print_iocb, put_chars, read_key, read_length, read_record, rewrite_record,"
m19:	acc	"seek_key, test_mode, valid_mode, valid_op, or write_record."
m20:	acc	"mode may be: stream_input, stream_output, stream_input_output,"
m21:	acc	"sequential_input, sequential_output, sequential_input_output,"
m22:	acc	"sequential_update, keyed_sequential_input, keyed_sequential_output,"
m23:	acc	"keyed_sequential_update, direct_input, direct_output, direct_update"
m24:	acc	"operation"
m25:	acc	"mode {args}"
m26:	acc	"{-control_arg}"
m27:	acc	"{-control_arg} may be -no_quote"

	end
 



		    io_call_print_iocb_.pl1         05/18/83  0907.7rew 05/18/83  0853.3       58041


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

/* Procedure use by the io_call command to print the IOCB in a readable form */

/* Extracted from the main command May 1977 by Larry Johnson */
/* Modified 1/83 by S. Krupp to print version 2 iocb. */

io_call_print_iocb_: proc (iocb_ptr);

/* Parameters */

dcl  iocb_ptr ptr;

/* Automatic */

dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  dir char (168);
dcl  ename char (32);
dcl  p ptr;					/* Pointer with short name to point to IOCB */
dcl  ptr1 ptr;					/* Temporary pointer used for various things */
dcl  ptr2 ptr;					/* Second temp pointer */
dcl  temp_name char (32) var;				/* Temp name used for various things */
dcl  int char (32);					/* Internal entry name */
dcl  path char (232) var;
dcl  inh bit (37);					/* Syn_ inhibit bits */
dcl  ev_ptr ptr;					/* Pointer to entry variable array */
dcl  last_ptr ptr;					/* Temp pointer to last entry variable */
dcl  dir_len fixed bin;				/* Length of directory in question */

/* Based  */

dcl 1 descrip aligned based (ptr2),			/* Open or attach description */
    2 msg_len fixed bin,				/* Length of text */
    2 msg char (0 refer (descrip.msg_len));		/* The actual message */

dcl  ev (N_ENTRY_VARS) entry based (ev_ptr);			/* Entry variable array in IOCB */


/* External stuff */

dcl (ioa_, ioa_$nnl, ioa_$rsnnl) entry options (variable);
dcl  cu_$decode_entry_value entry (entry, ptr, ptr);
dcl  get_entry_name_ entry (ptr, char (*), fixed bin, char (8), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));

dcl (addr, baseno, null, ptr, rtrim, substr) builtin;

/* Constants */

dcl  N_ENTRY_VARS fixed bin init(19) int static options(constant);

dcl  opt_name (19) char (14) int static options (constant) init
    ("detach_iocb",					/* 1 */
     "open",					/* 2 */
     "close",					/* 3 */
     "get_line",					/* 4 */
     "get_chars",					/* 5 */
     "put_chars",					/* 6 */
     "modes",					/* 7 */
     "position",					/* 8 */
     "control",					/* 9 */
     "read_record",					/* 10 */
     "write_record",				/* 11 */
     "rewrite_record",				/* 12 */
     "delete_record",				/* 13 */
     "seek_key",					/* 14 */
     "read_key",					/* 15 */
     "read_length", 				/* 16 */
     "open_file",					/* 17 */
     "close_file",					/* 18 */
     "detach");					/* 19 */

%include iocbx;

/* Print header line */

	p = iocb_ptr;				/* Copy IOCB pointer to thing with shorter name */
	call ioa_$nnl ("IOCB ""^a"" @ ^p", p -> iocb.name, iocb_ptr); /* Print name and addr */
	if p -> iocb.actual_iocb_ptr = iocb_ptr then call ioa_ (""); /* If not syned to something, end line */
	else call ioa_ (" (actual IOCB is ""^a"" @ ^p)",
	     p -> iocb.actual_iocb_ptr -> iocb.name,
	     p -> iocb.actual_iocb_ptr);		/* Otherwise say what real IOCB is */

/* Print data on syn_ attachments */

	ptr1 = p -> iocb.syn_father;
	temp_name = "father";
	call print_syn;
	ptr1 = p -> iocb.syn_brother;
	temp_name = "brother";
	call print_syn;
	ptr1 = p -> iocb.syn_son;
	temp_name = "son";
	call print_syn;

/* Print attach data */

	temp_name = "attach";
	ptr1 = p -> iocb.attach_data_ptr;
	ptr2 = p -> iocb.attach_descrip_ptr;
	call print_dat;

/* Print open data */

	temp_name = "open";
	ptr1 = p -> iocb.open_data_ptr;
	ptr2 = p -> iocb.open_descrip_ptr;
	call print_dat;


/* Print event channel */

	if p -> iocb.event_channel ^= "0"b then
	     call ioa_ ("event channel is ^24.3b", p -> iocb.event_channel);

/* IOS compatability pointer */

	if p -> iocb.ios_compatibility ^= null then
	     call ioa_ ("IOS transfer vector @ ^p", p -> iocb.ios_compatibility);

/* Print entry variables */

	ev_ptr = addr (p -> iocb.detach_iocb);		/* Pointer to entry variable list */
	if iocb_ptr = p -> iocb.actual_iocb_ptr then inh = "0"b; /* If not syned, then no inhibits in effect */
	else inh = "0"b || p -> iocb.syn_inhibits;	/* Otherwise copy inhibit array, supplying a "0"b
						   for detach, which is never inhibited */
	last_ptr = null;

	do i = 1 to N_ENTRY_VARS;			/* Scan all variables */
	     call cu_$decode_entry_value (ev (i), ptr1, ptr2); /* Turn entry variable into pointers */
	     if (i > 1) & (ptr1 = last_ptr) then do;	/* If two identical pointers in a row */
		path = " """;			/* Path name is a ditto mark */
	     end;
	     else do;				/* A real path must be determined */
		call get_entry_name_ (ptr1, int, (0), (""), code); /* Get entry point name */
		if code ^= 0 then int = "";		/* If not found */
		if (i = 1) | (baseno (ptr1) ^= baseno (last_ptr)) then do; /* If 1st time or different seg */
		     call hcs_$fs_get_path_name (ptr (ptr1, 0), dir, dir_len, ename, code); /* Get path name */
		     if code ^= 0 then dir, ename = ""; /* If it failed */
		end;
		path = substr (dir, 1, dir_len);	/* Build pathname */
		if path ^= ">" then path = path || ">"; /* Only add > if seg not in root */
		path = path || rtrim (ename);
		if (int ^= ename) & (int ^= "") then path = path || "$" || rtrim (int);
		call ioa_$rsnnl (" (^p)", temp_name, (0), ptr1); /* Edit pointer value */
		path = path || temp_name;
	     end;
	     last_ptr = ptr1;			/* Save previous pointer */
	     if substr (inh, i, 1) then temp_name = " (inh)"; /* If inhibited */
	     else temp_name = "";
	     call ioa_ ("^15a ^a^a", opt_name (i), path, temp_name);
	end;
	return;

/* Subroutines used by print_iocb */

/* Procedure to print syn_ attachments */

print_syn: proc;

	     if ptr1 = null then return;		/* If no attachment */
	     call ioa_ ("SYN ^a is ""^a"" @ ^p", temp_name, ptr1 -> iocb.name, ptr1);
	     return;

	end print_syn;


/* Procedure to print attach and open data */

print_dat: proc;

	     if ptr2 = null then call ioa_$nnl ("not ^aed,", temp_name);
	     else call ioa_$nnl ("^a description: ""^a"",", temp_name, descrip.msg);

	     if ptr1 = null then call ioa_ (" ^a data is null", temp_name);
	     else call ioa_ (" ^a data at ^p", temp_name, ptr1);

	     return;

	end print_dat;


     end io_call_print_iocb_;
   



		    io_call_read_write_.pl1         02/27/84  1340.7rew 02/27/84  1333.5      299556


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


/* This module does the put_chars, write_record, rewrite_record, get_chars,
   get_line, and read_record functions of the io_call command. */
/* Removed from main command June 1977 by Larry Johnson, and made to work as an active function */
/* Modified 08/03/83 by Jim Lippard to not require specification of buffer
   length, to not complain about short records when called as an AF,
   to add a -string control argument for output requests, to print
   the right information in error messages, and to fix write_record
   and rewrite_record to leave things alone when -segment is used without
   -nl or -nnl */
/* Modified 12/13/83 by Jim Lippard to add -allow_newline (-alnl),
   -append_newline (-apnl), and -remove_newline (-rmnl) and to
   not require buffer length for read_record */

io_call_read_write_: proc;

/* Parameters */

dcl  arg_iocb_ptr ptr;				/* Pointer to the IOCB */
dcl  arg_arg_list_ptr ptr;				/* Pointer to the commands argument list */

/* Automatic storage */

dcl  code fixed bin (35);				/* System status code */
dcl  arg_list_ptr ptr;				/* Pointer to argument list */
dcl  arg_ptr ptr;					/* Pointer to current argument */
dcl  arg_len fixed bin;				/* Length of current argument */
dcl  n_args fixed bin;				/* Number of arguments on command line */
dcl  next_arg fixed bin;				/* Used in counting args */
dcl  dir char (168);				/* To hold directory names */
dcl  ename char (32);				/* To hold entry names */
dcl  seg_ptr ptr;					/* Pointer to dir>ename */
dcl  arg_name char (32) var;				/* Name of current arg for error msg */
dcl  iocb_ptr ptr;					/* Pointer to IOCB being processed */
dcl  offset_val fixed bin (21);			/* Value of offset into segment if specified */
dcl  length_val fixed bin (21);			/* Value of length of string if specified */
dcl  bit_count fixed bin (24);			/* Length of segment in bits */
dcl  char_cnt fixed bin (21);				/* Length of segment in characters */
dcl  offset_sw bit (1);				/* Set if offset given in command */
dcl  length_sw bit (1);				/* Set if length given in command */
dcl  lines_sw bit (1);				/* Set if -lines specified */
dcl  cv_dec_err fixed bin;				/* Error code from cv_dec_check_ */
dcl  data_ptr ptr;					/* Pointer to data if i/o from a segment */
dcl  data_len fixed bin (21);				/* Length of data if io from segment */
dcl  init_sw bit (1) init ("0"b);			/* Set if segment has been inited so it can be termed */
dcl  cmd_type bit (1);				/* 0 if input operation, 1 if output */
dcl (input init ("0"b), output init ("1"b)) bit (1) int static options (constant); /* Possible values for cmd_type */
dcl  string_sw bit (1);				/* Set if string appears on command line */
dcl  string_ptr ptr;				/* Pointer to string command argument */
dcl  string_len fixed bin (21);			/* Length of string command argument */
dcl  nl_sw bit (1);					/* Set if -append_newline appears */
dcl  nnl_sw bit (1);				/* Set of -remove_newline appears */
dcl  alnl_sw bit (1);				/* Set if -allow_newline appears */
dcl  nhe_sw bit (1);				/* Set if -nhe or -no_header is used */
dcl  path_sw bit (1);				/* Set if -segment or -sm appears */
dcl  temp_val fixed bin (35);				/* Temp area used in conversions */
dcl  input_len fixed bin (21);			/* Length of data read on input operation */
dcl  alloc_sw bit (1) init ("0"b);			/* Set if string allocated and should be freed */
dcl  print_length bit (1) init ("0"b);			/* Set if length of input record should be printed */
dcl  length_printed bit (1) init ("0"b);		/* Set on input ops once length is printed */
dcl  ptr_array (1) ptr init (null);			/* Array of pointers used by get_temp_segments_ */
dcl  ioname char (32);				/* Name of current switch */
dcl  request_name char (32);				/* Name of current request */
dcl  af_sw bit (1);					/* Set if called as an active function */
dcl  no_quote_sw bit (1);				/* Set if -no_quote specified */
dcl  error entry variable options (variable);		/* Either com_err_ of active_fnc_err_ */
dcl  af_retp ptr;					/* Pointer to af return string */
dcl  af_retl fixed bin;				/* Its max length */

/* Constants */

dcl  cmd_name char (7) int static options (constant) init ("io_call"); /* Name of this thing */
dcl  new_line char (1) int static options (constant) init ("
");						/* A new line character */

/* Static storage */

dcl  old_dir char (168) static init (" ");		/* Previous directory used */
dcl  old_ename char (32) static init (" ");		/* Previous entry name */

/* Based storage */

dcl  arg char (arg_len) based (arg_ptr);		/* Some arbitrary argument */
dcl  based_seg char (char_cnt) based (seg_ptr);		/* One way of looking at a segment */
dcl  based_seg_array (1:char_cnt) char (1) based (seg_ptr); /* Another way */
dcl  arg_string char (string_len) based (string_ptr);	/* Command argument used as output string */
dcl  input_string char (input_len) based (data_ptr);	/* Input string during read operation */
dcl  af_ret char (af_retl) based (af_retp) var;		/* Return string for active function */

/* Things allocated in system free area */

dcl  free_area_ptr ptr init (null);			/* Pointer to the area */
dcl  free_area area based (free_area_ptr);		/* A representation of the area */
dcl  free_area_string char (free_area_string_len) based (free_area_string_ptr); /* A string allocated there */
dcl  free_area_string_len fixed bin (21);		/* Length of the string */
dcl  free_area_string_ptr ptr init (null);		/* Pointer to that string */

/* External variables */

dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$long_record ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$no_operation ext fixed bin (35);
dcl  error_table_$short_record ext fixed bin (35);
dcl  error_table_$too_many_args ext fixed bin (35);

dcl  iox_$user_output ext ptr;

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

/* Builtin functions */

dcl (addr, addrel, bin, divide, index, length, max, mod, null, size, substr) builtin;

dcl (area, cleanup) condition;

/* Entry variables */

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);

dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  cu_$arg_count_rel entry (fixed bin, ptr);
dcl  cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);

dcl  cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));

dcl  hcs_$get_max_length entry (char (*), char (*), fixed bin (18), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl  hcs_$set_max_length_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));

dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);


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  iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));

dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));

%include iocb;

/* PUT_CHARS operation */

put_chars: entry (arg_iocb_ptr, arg_arg_list_ptr);

	request_name = "put_chars";
	on cleanup call clean_up;
	call setup;
	cmd_type = output;				/* Output command */
	call scan_cmd;				/* Scan the command */
	if  ^(nl_sw | nnl_sw | alnl_sw) then nl_sw = "1"b;		/* -apnl default */
	call build_optr;				/* Build pointer to data */
	call iox_$put_chars (iocb_ptr, data_ptr, data_len, code); /* Write it */
	if code ^= 0 then go to err_2;
exit:	call clean_up;
	return;

/* WRITE_RECORD operation */

write_record: entry (arg_iocb_ptr, arg_arg_list_ptr);

	request_name = "write_record";
	on cleanup call clean_up;
	call setup;
	cmd_type = output;				/* Output command */
	call scan_cmd;				/* Scan command */
	if ^path_sw & ^(nl_sw | nnl_sw | alnl_sw) then nnl_sw = "1"b;
	else if path_sw & ^(nl_sw | nnl_sw | alnl_sw) then alnl_sw = "1"b;
	call build_optr;				/* Build pointer to data */
	call iox_$write_record (iocb_ptr, data_ptr, data_len, code); /* Write it */
	if code ^= 0 then go to err_2;
	else go to exit;

/* REWRITE_RECORD operation */

rewrite_record: entry (arg_iocb_ptr, arg_arg_list_ptr);

	request_name = "rewrite_record";
	on cleanup call clean_up;
	call setup;
	cmd_type = output;				/* Output command */
	call scan_cmd;				/* Scan command line */
	if ^path_sw & ^(nl_sw | nnl_sw | alnl_sw) then nnl_sw = "1"b;
	else if path_sw & ^(nl_sw | nnl_sw | alnl_sw) then alnl_sw = "1"b;
	call build_optr;				/* Build pointer to data */
	call iox_$rewrite_record (iocb_ptr, data_ptr, data_len, code);
	if code ^= 0 then go to err_2;
	else go to exit;

/* GET_CHARS operation */

get_chars: entry (arg_iocb_ptr, arg_arg_list_ptr);

	request_name = "get_chars";
	on cleanup call clean_up;
	call setup;
	cmd_type = input;
	call scan_cmd;
	if af_sw & ^(nl_sw | nnl_sw | alnl_sw) then nnl_sw = "1"b;
	else if ^af_sw & path_sw & ^(nl_sw | nnl_sw | alnl_sw) then alnl_sw = "1"b;
	else if ^af_sw & ^path_sw & ^(nl_sw | nnl_sw | alnl_sw) then nl_sw = "1"b;
	call build_iptr;				/* Get pointer to input area */
	print_length = "1"b;
	input_len = -1;
	call iox_$get_chars (iocb_ptr, data_ptr, data_len, input_len, code); /* Read chars */
	if code ^= 0 then do;
	     call print_code;
	     if input_len > 0 then call input_dispose;
	     go to exit;
	end;
	call input_dispose_final;
	go to exit;

/* READ_RECORD operation */

read_record: entry (arg_iocb_ptr, arg_arg_list_ptr);

	request_name = "read_record";
	on cleanup call clean_up;
	call setup;
	cmd_type = input;
	call scan_cmd;				/* Scan command */
	if af_sw & ^(nl_sw | nnl_sw | alnl_sw) then nnl_sw = "1"b;
	else if ^af_sw & ^(nl_sw | nnl_sw | alnl_sw) then alnl_sw = "1"b;
	call build_iptr;
	print_length = "1"b;			/* Length should be printed */
	input_len = -1;
	call iox_$read_record (iocb_ptr, data_ptr, data_len, input_len, code); /* Read record */
	if code ^= 0 then do;			/* An error */
	     if code = error_table_$long_record then do;
		if input_len > data_len then do;	/* If true length returned */
		     call error (code, cmd_name, "^d characters in record, ^d returned.", input_len, data_len);
		     input_len = data_len;
		     length_printed = "1"b;		/* Remember length already printed */
		end;
		else call print_code;		/* Use standard error print */
	     end;
	     else call print_code;
	     if input_len > 0 then call input_dispose;
	     go to exit;
	end;
	call input_dispose_final;
	go to exit;

/* GET_LINE operation */

get_line:	entry (arg_iocb_ptr, arg_arg_list_ptr);

	request_name = "get_line";
	on cleanup call clean_up;
	call setup;
	cmd_type = input;
	call scan_cmd;				/* Scan command line */
	if af_sw & ^(nl_sw | nnl_sw | alnl_sw) then nnl_sw = "1"b;
	else if ^af_sw & path_sw & ^(nl_sw | nnl_sw | alnl_sw) then alnl_sw = "1"b;
	else if ^af_sw & ^path_sw & ^(nl_sw | nnl_sw | alnl_sw) then nl_sw = "1"b;
	call build_iptr;				/* Get pointer to input area */
	print_length = length_sw;			/* If user supplied buffer length there will only be
						   one read so I can print the length */
getl:	input_len = -1;
	call iox_$get_line (iocb_ptr, data_ptr, data_len, input_len, code); /* Read line */
	if code ^= 0 then do;			/* If error */
	     if length_sw then do;			/* User supplied buffer */
		call print_code;
		if input_len > 0 then call input_dispose;
		go to exit;
	     end;
	     if code = error_table_$long_record then do;	/* Didn't get it all */
		if path_sw then do;			/* If reading into segment */
		     offset_val = offset_val+input_len; /* Adjust offset */
		     data_ptr = addr (based_seg_array (offset_val+1)); /* Compute new address */
		     data_len = data_len-input_len;	/* Space left */
		     go to getl;
		end;
		else do;
		     call write_first;		/* Write standard header */
		     call iox_$put_chars (iox_$user_output, data_ptr, input_len, code); /* Write section to user_output */
		     if code ^= 0 then go to out_err;
		     go to getl;			/* And read more */
		end;
	     end;
	     else do;				/* Other errors */
		call print_code;
		if input_len > 0 then call input_dispose;
		go to exit;
	     end;
	end;
 print_length = "1"b;	/* If only one get_line needed, I can print the length */
	call input_dispose_final;
	go to exit;

/* Procedure to scan command line on input or output operations to extract rest of options */

scan_cmd:	proc;

dcl  carg_flag bit (1) init ("0"b);			/* Once set, only control args are allowed */

	     string_sw = "0"b;			/* Output string not yet found */
	     path_sw = "0"b;			/* Segment specification not yet found */
	     offset_sw = "0"b;			/* Offset not yet found */
	     length_sw = "0"b;			/* Length not yet found */
	     lines_sw = "0"b;			/* -lines has not been specified */
	     nl_sw = "0"b;				/* -append_newline has not been specified */
	     nnl_sw = "0"b;				/* -remove_newline has not been specified */
	     alnl_sw = "0"b;			/* -allow_newline has not been specified */
	     nhe_sw = "0"b;				/* -no_header has not been specified */
	     no_quote_sw = "0"b;			/* -no_quote not specified */

arg_loop:	     if next_arg > n_args then do;		/* If no more arguments to process */
		if ^length_sw then length_val = sys_info$max_seg_size * 4;
		return;
	     end;
	     call get_arg_ptr;			/* Get next arg */
	     if code ^= 0 then go to err_8;		/* This shouldn't happen */
	     if substr (arg, 1, 1) = "-" then go to carg; /* Go process control argument */
	     if carg_flag then do;			/* If only control arguments being accepted */
		code = error_table_$too_many_args;
		go to err_3;
	     end;
	     if cmd_type = output then do;		/* If output type command */
		string_sw = "1"b;			/* Then this is the output string */
		string_ptr = arg_ptr;		/* Save pointer */
		string_len = arg_len;		/* Save length */
		carg_flag = "1"b;			/* Only control arguments may appear now */
	     end;
	     else do;				/* If input type command */
		length_val = cv_dec ();		/* This must be length */
		if cv_dec_err ^= 0 then go to err_9;
		length_sw = "1"b;			/* Length has been specified */
		carg_flag = "1"b;			/* Only control arguments may follow */
	     end;
narg:	     next_arg = next_arg+1;			/* Next argument to process */
	     go to arg_loop;

/* Process control argument */

carg:	     if arg = "-nl" then nl_sw = "1"b;
	     else if arg = "-nnl" then nnl_sw = "1"b;
	     else if arg = "-allow_newline" | arg = "-alnl" then do;
		     nl_sw = "0"b;
		     nnl_sw = "0"b;
		     alnl_sw = "1"b;
	     end;
	     else if arg = "-append_newline" | arg = "-apnl" then do;
		     nl_sw = "1"b;
		     nnl_sw = "0"b;
		     alnl_sw = "0"b;
	     end;
	     else if arg = "-remove_newline" | arg = "-rmnl" then do;
		     nl_sw = "0"b;
		     nnl_sw = "1"b;
		     alnl_sw = "0"b;
	     end;
	     else if arg = "-lines" | arg = "-l" then lines_sw = "1"b;
	     else if arg = "-no_header" | arg = "-nhe" then nhe_sw = "1"b;
	     else if arg = "-no_quote" | arg = "-nq" then no_quote_sw = "1"b;
	     else if (arg = "-string" | arg = "-str") & cmd_type = output then do;
		     next_arg = next_arg + 1;
		     call get_arg_ptr;
		     if code ^= 0 then go to err_8;
		     if string_sw then do;
			call com_err_ (0, cmd_name, "Output string may only be specified once.");
			go to exit;
			end;
		     string_sw = "1"b;
		     string_ptr = arg_ptr;
		     string_len = arg_len;
		     carg_flag = "1"b;
		     end;
	     else if ^af_sw & (arg = "-segment" | arg = "-sm") then do;
		call sm_spec;			/* Analyze segment specification */
		carg_flag = "1"b;			/* Only control arguments may follow */
	     end;
	     else do;
		code = error_table_$badopt;		/* Bad control arg */
		go to err_3;
	     end;
	     go to narg;

	end scan_cmd;

/* Scan -segment portion of command line */

sm_spec:	proc;

	     if path_sw then do;			/* If duplicate specification */
		call error (0, cmd_name, "Duplicate -segment specification.");
		go to exit;
	     end;
	     arg_name = "pathname after -segment.";	/* Looking for this now */
	     next_arg = next_arg + 1;			/* This should be path name */
	     call get_arg_ptr;
	     if code ^= 0 then go to err_1;		/* Failed */
	     if arg = "." then do;			/* "." means re-use last segment */
		if old_dir = "" | old_ename = "" then do; /* Assuming there was one */
		     code = error_table_$noarg;
		     go to err_1;
		end;
		dir = old_dir;			/* Copy saved name */
		ename = old_ename;
	     end;
	     else do;				/* Analyze new name */
		call expand_path_ (arg_ptr, arg_len, addr (dir), addr (ename), code);
		if code ^= 0 then go to err_3;
		old_dir = dir;			/* Save name */
		old_ename = ename;
	     end;
	     path_sw = "1"b;			/* A path has been specified */
	     if next_arg = n_args then return;		/* If all args process, then done */
	     next_arg = next_arg + 1;			/* Step to next */
	     call get_arg_ptr;
	     if code ^= 0 then go to err_8;		/* Shouldn't happen */
	     if substr (arg, 1, 1) = "-" then do;	/* If this is control argument, -sm scan is done */
sm_back:		next_arg = next_arg - 1;		/* Back up so caller can process this arg */
		return;
	     end;
	     temp_val = cv_dec ();			/* Next arg should be decimal */
	     if cv_dec_err ^= 0 then go to err_9;	/* But wasn't */
	     if cmd_type = input then do;		/* If input type command */
		offset_sw = "1"b;			/* This was the offset */
		offset_val = temp_val;
		return;				/* And done */
	     end;
	     length_sw = "1"b;			/* If this is output command, then this may be the length */
	     length_val = temp_val;
	     if next_arg = n_args then return;		/* Done if this was last arg */
	     next_arg = next_arg+1;			/* Try next */
	     call get_arg_ptr;
	     if code ^= 0 then go to err_8;
	     if substr (arg, 1, 1) = "-" then go to sm_back; /* If control arg, then done with -sm */
	     temp_val = cv_dec ();			/* Should be decimal */
	     if cv_dec_err ^= 0 then go to err_9;
	     offset_sw = "1"b;			/* The first number was really the offset */
	     offset_val = length_val;			/* So move it */
	     length_val = temp_val;			/* This new number is the length */
	     return;

	end sm_spec;

/* Procedure used on output commands to compute pointer to and length of output data */

build_optr: proc;

dcl  has_nl bit (1) init ("0"b);			/* Set if string given already has new line */

	     if string_sw then do;			/* If data is from command line string */
check_nl:		data_ptr = string_ptr;		/* Pointer is known */
		data_len = string_len;		/* Length is also known */
		if string_len > 0 then
		     if substr (arg_string, string_len, 1) = new_line then has_nl = "1"b; /* Check for a new-line */
		if nnl_sw then do;			/* If requested to remove a newline */
		     if has_nl then data_len = data_len-1; /* Easy to do by changing count */
		end;
		if nl_sw then do;			/* If requested to add a newline */
		     if has_nl then return;		/* Already there */
		     call alloc_string (string_len+1);	/* Create temporary string */
		     data_ptr = free_area_string_ptr;	/* Data located here */
		     data_len = free_area_string_len;	/* And is this long */
		     free_area_string = arg_string;	/* Copy body of string */
		     substr (free_area_string, free_area_string_len, 1) = new_line; /* Append new-line */
		end;
		return;
	     end;
	     if path_sw then do;			/* If input from segment */
		call path_init;			/* Find data there */
		string_ptr = addr (based_seg_array (offset_val+1)); /* Get pointer to data */
		string_len = length_val;
		go to check_nl;			/* Go check -nl and -nnl options */
	     end;

	     call error (0, cmd_name, "No output specification.");
	     go to exit;

	end build_optr;

/* Procedure used by input commands to compute pointer to data area */

build_iptr: proc;

dcl  max_len fixed bin (18);				/* Used to hold max length of segment */

	     if path_sw then do;			/* If reading into segment */
		call path_init;			/* Initiate it */
		data_ptr = addr (based_seg_array (offset_val+1)); /* Data goes here */
		if length_sw then data_len = length_val; /* If length given, use it */
		else do;				/* If length not given */
		     call hcs_$get_max_length (dir, ename, max_len, code); /* Get max segment length */
		     if code ^= 0 then go to err_5;
		     data_len = 4*max_len-offset_val;	/* Compute space remaining in segment */
		end;
	     end;
	     else do;				/* Not reading into segment */
		call alloc_string (length_val);	/* And create a string */
		data_ptr = free_area_string_ptr;	/* Here */
		data_len = free_area_string_len;	/* For this length */
	     end;

	     return;

	end build_iptr;

/* This procedure is called after an input operation to handle the final disposition of the data */

input_dispose: proc;

dcl  new_bit_count fixed bin (24);			/* New segment bit count */
dcl  has_nl bit (1) init ("0"b);			/* Set if newline at end of data */
dcl  word_cnt fixed bin (18);				/* Word count of segment */
dcl  last_word_ptr ptr;				/* Pointer to last word of segment */
dcl  last_word bit (36) based (last_word_ptr);		/* Last word */
dcl  bits_used fixed bin;				/* Bits used in last word */

	     if input_len > 0 then
		if substr (input_string, input_len, 1) = new_line then has_nl = "1"b; /* Check for newline at end */
	     if path_sw then do;			/* If data is to go into segment */
		if nl_sw & ^has_nl then do;		/* If wants newline and doesn't have one */
		     input_len = input_len+1;		/* Make string longer */
		     substr (input_string, input_len, 1) = new_line; /* Insert newline */
		end;
		else if nnl_sw then			/* If requested to strip newline */
		     if has_nl then input_len = input_len-1; /* Strip it if present */
		new_bit_count = 9 * (offset_val + input_len); /* Compute new segment bit count */
		call hcs_$set_bc_seg (seg_ptr, new_bit_count, code); /* Set it */
		if code ^= 0 then go to err_5;
		if new_bit_count < bit_count then do;	/* If segment is shrinking */
		     word_cnt = divide (new_bit_count+35, 36, 18, 0); /* Get length in words */
		     call hcs_$truncate_seg (seg_ptr, word_cnt, code); /* And truncate it */
		     if code ^= 0 then go to err_5;
		     bits_used = mod (new_bit_count, 36); /* Bits used in last word (0 if full) */
		     if bits_used ^= 0 then do;	/* If word partially filled */
			last_word_ptr = addrel (seg_ptr, word_cnt-1); /* Get pointer to last word */
			substr (last_word, bits_used+1) = "0"b; /* Zero remaining bits */
		     end;
		end;
	     end;
	     else if ^af_sw then do;			/* Data will be written to terminal */
		call write_first;			/* Write header  */
		call iox_$put_chars (iox_$user_output, data_ptr, input_len, code);
		if code ^= 0 then go to out_err;
		if ^has_nl & nl_sw then do;		/* If no newline */
		     call iox_$put_chars (iox_$user_output, addr (new_line), 1, code);
		     if code ^= 0 then go to out_err;
		end;
	     end;
	     else do;				/* Called as an active function */
		if has_nl & nnl_sw then input_len = input_len - 1;
		if no_quote_sw then af_ret = input_string;
		else af_ret = requote_string_ (input_string);
	     end;

	     return;

	end input_dispose;

input_dispose_final: proc;

	     call input_dispose;
	     if path_sw & ^length_printed then do;
		print_length = "1"b;
		call write_first;
	     end;
	     return;

	end input_dispose_final;

/* This routines writes a standard message at the beginning of the data obtained on input commands.
   This consists of at least the word "io_call:" and is usually followed by the number of characters
   read by the command. */

write_first: proc;

dcl  header char (50);				/* Temp area */
dcl  headl fixed bin;				/* Value returned by ioa_$rsnnl */

	     if length_printed | nhe_sw | af_sw then return; /* Only do this once */
	     header = cmd_name || ": ";		/* This is data to write */
	     call iox_$put_chars (iox_$user_output, addr (header), length (cmd_name)+2, code);
	     if code ^= 0 then go to out_err;
	     if print_length then do;			/* If length should be printed too */
		call ioa_$rsnnl ("^d character^v(s^) returned.", header, headl, input_len, bin (input_len ^= 1, 1));
		if path_sw then substr (header, headl+1, 1) = new_line; /* If data going to segment, this is end */
		call iox_$put_chars (iox_$user_output, addr (header), headl+1, code); /* Write data with extra char */
		if code ^= 0 then go to out_err;
	     end;
	     length_printed = "1"b;
	     return;

	end write_first;

/* The following procedure are used when input operations get an error code. The error is printed and
   plus the length of the data (if any) returned. */

print_code: proc;

dcl (l, lt) fixed bin (21);

	  if code = error_table_$short_record & (af_sw | ^length_sw) then return;
	     l = input_len;				/* Length read on last operation */
	     lt = max (l, 0);			/* Total length to print */

	     if lt = 0 then do;			/* If no data */
		if l < 0 then call error (code, cmd_name, "^a on switch ^a", request_name, ioname); /* Print this message if no length returned */
		else call error (code, cmd_name, "No data returned by ^a on switch ^a.", request_name, ioname);
	     end;

	     else call error (code, cmd_name, "^d character^v(s^) returned by ^a on switch ^a.", lt, bin (lt ^= 1, 1), request_name, ioname);

	     length_printed = "1"b;

	     return;

	end print_code;

/* Procedure to allocate a temporary string */

alloc_string: proc (string_len);

dcl  string_len fixed bin (21);			/* Length to allocate */

	     if free_area_ptr = null then
		free_area_ptr = get_system_free_area_ (); /* Start with pointer to free area */
	     free_area_string_len = string_len;		/* Length to allocate */
	     on area go to alloc_err;			/* In case error */
	     allocate free_area_string in (free_area);	/* Create string */
	     alloc_sw = "1"b;			/* Remember that I did this */
	     return;

alloc_err:     revert area;

/* Try to make a temporary segment since the allocate failed */

	     call get_temp_segments_ (cmd_name, ptr_array, code);
	     if code ^= 0 then do;
		call error (code, cmd_name, "Unable to allocate temp segment for data.");
		go to exit;
	     end;
	     call hcs_$set_max_length_seg (ptr_array (1), size (free_area_string), code); /* Make seg bit enough */
	     if code ^= 0 then do;
		call error (code, cmd_name, "Unable to get ^d word segment to hold data.", size (free_area_string));
		go to exit;
	     end;
	     free_area_string_ptr = ptr_array (1);
	     return;


	end alloc_string;

/* Procedure to locate data if in a segment */

path_init: proc;

dcl  cur_pos fixed bin (21);				/* Used during scan for line feeds */

	     call hcs_$initiate_count (dir, ename, "", bit_count, 0, seg_ptr, code); /* This is a good start */
	     if seg_ptr = null then do;		/* Initiate failed */
		if cmd_type = output then go to err_5;	/* Must succeed if this is output */
		call hcs_$make_seg (dir, ename, "", 01010b, seg_ptr, code); /* Make new segment to read into */
		if seg_ptr = null then go to err_5;	/* This should succeed */
		call ioa_ ("^a: Segment ^a^v(>^)^a created.", cmd_name, dir, bin (dir ^= ">", 1), ename);
		bit_count = 0;			/* New segment has no length */
	     end;
	     init_sw = "1"b;			/* Remember that I did this */
	     char_cnt = divide (bit_count, 9, 21, 0);	/* Compute length in characters */

	     if ^lines_sw then do;			/* If measurements are in characters */
		if cmd_type = output then do;		/* If output command */
		     if ^offset_sw then offset_val = 0; /* Assume 0 if offset omitted */
		     if offset_val > char_cnt then go to bound_err; /* Check range */
		     if ^length_sw then length_val = char_cnt-offset_val; /* Default length is rest of seg */
		     if (offset_val + length_val) > char_cnt then go to bound_err; /* Check range */
		end;
		else do;				/* If input command */
		     if ^offset_sw then offset_val = char_cnt; /* If no offset, assume end */
		     if offset_val > char_cnt then go to bound_err; /* Check range */
		end;
	     end;
	     else do;				/* If measurements in lines */
		cur_pos = 0;			/* Initialize current position for scan */
		if cmd_type = output then do;		/* If output command */
		     if ^offset_sw then offset_val = 0; /* If no offset, assume 0 */
		     call find_nl (offset_val, cur_pos); /* Scan down offset new-lines */
		     offset_val = cur_pos;		/* Offset now converted to chars */
		     if ^length_sw then length_val = char_cnt-offset_val; /* If no length, use rest */
		     else do;			/* If length given */
			call find_nl (length_val, cur_pos); /* Scan down for new-lines */
			length_val = cur_pos-offset_val; /* Length in characters */
		     end;
		end;
		else do;				/* If input command */
		     if ^offset_sw then offset_val = char_cnt; /* If no offset, use end of seg */
		     else do;
			call find_nl (offset_val, cur_pos); /* Scan down for new-lines */
			offset_val = cur_pos;	/* Offset in characters */
		     end;
		end;
	     end;

	     return;


	end path_init;

/* Procedure to scan down string for a given number of new-lines */

find_nl:	proc (n, pos);

dcl  n fixed bin (21);				/* Number of new-lines wanted */
dcl  pos fixed bin (21);				/* Current loc in segment (input and output) */
dcl  i fixed bin (21);				/* Loop index  */
dcl  new_pos fixed bin (21);				/* Temp pos */

	     do i = 1 to n;				/* Do for each new-line */
		if pos >= char_cnt then go to bound_err; /* Error if off end */
		new_pos = index (substr (based_seg, pos+1), new_line); /* Length of next line */
		if new_pos = 0 then go to bound_err;	/* If new-line not found */
		pos = pos + new_pos;		/* Compute new loc */
	     end;

	     return;

	end find_nl;

/* Internal procedure to call cu_$arg_ptr_rel so that this argument list is only built once */

get_arg_ptr: proc;

	     if af_sw then call cu_$af_arg_ptr_rel (next_arg, arg_ptr, arg_len, code, arg_list_ptr);
	     else call cu_$arg_ptr_rel (next_arg, arg_ptr, arg_len, code, arg_list_ptr);

	end get_arg_ptr;


/* Internal procedure to check next argument for a decimal value */

cv_dec:	proc returns (fixed bin (35));

	     return (cv_dec_check_ (arg, cv_dec_err));

	end cv_dec;

/* Procedure to set up args at all entries */

setup:	proc;

	     iocb_ptr = arg_iocb_ptr;
	     arg_list_ptr = arg_arg_list_ptr;
	     next_arg = 3;
	     ioname = iocb_ptr -> iocb.name;
	     call cu_$af_return_arg_rel (n_args, af_retp, af_retl, code, arg_list_ptr);
	     if code = 0 then do;			/* Called as active function */
		af_sw = "1"b;
		error = active_fnc_err_;
	     end;
	     else do;				/* Called as command */
		af_sw = "0"b;
		error = com_err_;
		call cu_$arg_count_rel (n_args, arg_list_ptr);
	     end;
	     return;

	end setup;


/* Come here for various kinds of error messages */

err_1:	call error (code, cmd_name, "^a", arg_name);
	go to exit;

err_2:	if code = error_table_$no_operation then call error (code, cmd_name, "^a on switch ""^a"".", request_name, ioname);
	else call error (code, cmd_name, "^a", ioname);
	go to exit;

err_3:	call error (code, cmd_name, "^a", arg);
	go to exit;

err_5:	call error (code, cmd_name, "^a^v(>^)^a", dir, bin (dir ^= ">", 1), ename);
	go to exit;

err_6:	call get_arg_ptr;
	if code = 0 then do;
	     code = error_table_$too_many_args;
	     go to err_3;
	end;
err_8:	call error (code, cmd_name, " (arg ^d)", next_arg);
	go to exit;

err_9:	call error (0, cmd_name, "Invalid decimal number. ^a", arg);
	go to exit;

bound_err: call error (0, cmd_name, "Offset/length exceeds bit count of segment.");
	go to exit;
need_len: call error (0, cmd_name, "Length of input area must be specified.");
	go to exit;

out_err:	arg_name = "user_output";
	go to err_1;

/* Cleanup procedure for command termination */

clean_up:	proc;


	     if init_sw then do;			/* If an init was done */
		init_sw = "0"b;
		call hcs_$terminate_noname (seg_ptr, code);
	     end;

	     if alloc_sw then do;
		alloc_sw = "0"b;
		free free_area_string in (free_area);
	     end;

	     if ptr_array (1) ^= null then
		call release_temp_segments_ (cmd_name, ptr_array, code);


	end clean_up;


     end io_call_read_write_;



		    iocall.pl1                      11/04/82  2006.8rew 11/04/82  1631.6      132210


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


	/*	IOCALL -
		This command allows the user to make calls directly to the I/O system from
			command level. The following I/O calls are provided:

			attach
			detach
			read
			write
			seek
			tell
			setsize
			getsize
			abort
			order
			changemode
			resetread
			resetwrite
			readsync
			writesync
			worksync

		In addition the entry checkstatus is provided so that an I/O system
			caller may interpret the status returned from an I/O call.

		Originally coded by R. J. Feiertag on February 21, 1970 due to unremitting
			pressure.							*/
	/*	Modified on April 8, 1971 by R. J. Feiertag to add some new calls.		*/

iocall:	proc;

dcl whoami char(8) static aligned init("iocall");

	/*	AUTOMATIC VARIABLES */

	dcl (l1,l2,l3,l4,l5) fixed bin(17),	/* arg lengths */
	    (p1,p2,p3,p4,p5) ptr,		/* arg pointers */
	    statusp ptr,			/* pointer to status string */
	    call_name char(l1) based(p1),	/* the name of the I/O call */
	    command_name char(32) init(whoami),		/* name of this command */
	    ioname char(l2) based(p2),	/* the stream name for this call */
	    arg3 char(l3) based(p3),		/* third arg */
	    arg4 char(l4) based(p4),	/* fourth arg */
	    arg5 char(l5) based(p5),		/* fifth arg */
	    count fixed bin(17),	/* the number of arguments for this call */
	    mode char(128),		/* the mode to be passed to the I/O system */
	    pos fixed bin,		/* position in mode string */
	    old_mode char(128),	/* the previous mode of this device */
	    old_status bit(72) aligned,	/* a previous status string */
	    limit fixed bin,	/* the limit of readahead or writebehind */
	    status bit(72) aligned,		/* the status string returned by the I/O system */
	    ioname2 char(32),	/* the detach id for a detach call */
	    path char(168),		/* the path name of a segment */
	    dir char(168),		/* the directory of a segment */
	    entry char(32),		/* the name of a segment */
	    code fixed bin(35),	/* error code */
	    segptr ptr,		/* pointer to a segment */
	    offset fixed bin(17),	/* an offset from the beginning of a segment */
	    nelem fixed bin(17),	/* the number of elements to be read or written */
	    bit_count fixed bin(24),	/* bit-count from hcs_$initiate_count */
	    nelemt fixed bin(17),	/* the number of elements read or written */
	    ptrname2 char(32),
	    element_size fixed bin(17),	/* the size in bits of an element */
	    name char(32);		/* the stream name */

	dcl 1 s based(statusp) aligned,
		2 code fixed bin(17),	/* error code */
		2 comp bit(5) unaligned,
		2 p1 bit(4) unaligned,
		2 eof bit(1) unaligned,	/* end of file */
		2 p2 bit(4) unaligned,
		2 abs bit(1) unaligned,	/* device absent */
		2 det bit(1) unaligned,	/* detached */
		2 quit bit(1) unaligned,	/* quit detected */
		2 abort bit(1) unaligned,	/* transaction aborted */
		2 p3 bit(18) unaligned;

	/*	EXTERNAL DATA */

	dcl (error_table_$noarg fixed bin(35),
	     sys_info$max_seg_size fixed bin) ext;	/* # of pages/segment */

	/*	EXTERNAL ENTRIES */

	dcl cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(35)),
	    expand_path_ ext entry(ptr,fixed bin(17),ptr,ptr,fixed bin(35)),
	hcs_$make_seg entry(char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)),
	hcs_$initiate_count entry(char(*), char(*), char(*), fixed bin(24), fixed bin, ptr, fixed bin(35)),
	hcs_$set_bc entry(char(*), char(*), fixed bin(24), fixed bin(35)),
	cv_dec_check_ entry(char(*), fixed bin(35), fixed bin),
	    (com_err_, ioa_) entry options(variable);

dcl	ios_$attach entry(char(*), char(*), char(*), char(*), bit(72) aligned), 
	ios_$detach entry(char(*), char(*), char(*), bit(72) aligned), 
	ios_$read entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned), 
	ios_$write entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned), 
	ios_$seek entry(char(*), char(*), char(*), fixed bin, bit(72) aligned), 
	ios_$tell entry(char(*), char(*), char(*), fixed bin, bit(72) aligned), 
	ios_$setsize entry(char(*), fixed bin, bit(72) aligned), 
	ios_$getsize entry(char(*), fixed bin, bit(72) aligned), 
	ios_$order entry(char(*), char(*), ptr, bit(72) aligned), 
	ios_$changemode entry(char(*), char(*), char(*), bit(72) aligned), 
	ios_$resetread entry(char(*), bit(72) aligned), 
	ios_$resetwrite entry(char(*), bit(72) aligned), 
	ios_$abort entry(char(*), bit(72) aligned, bit(72) aligned), 
	ios_$readsync entry(char(*), char(*), fixed bin, bit(72) aligned), 
	ios_$writesync entry(char(*), char(*), fixed bin, bit(72) aligned), 
	ios_$worksync entry(char(*), char(*), char(*), bit(72) aligned);

dcl (addr, bin, divide, length, null, substr) builtin;

/**/

	statusp = addr(status);
	call cu_$arg_ptr(1,p1,l1,code); /* get call name */
	if code ^= 0 then go to bad_args;
	call cu_$arg_ptr(2,p2,l2,code); /* get ioname */
	if code ^= 0 then go to bad_args;
	call cu_$arg_ptr(3,p3,l3,code); /* get third arg */
	if code ^= 0 then count = 2; /* remember which is last arg */
	 else do;
		call cu_$arg_ptr(4,p4,l4,code);
		if code ^= 0 then count = 3; /* remember last arg */
		 else do;
			call cu_$arg_ptr(5,p5,l5,code);
			if code ^= 0 then count = 4;
			 else count = 5;
			end;
		end;
	if call_name = "attach" then do;	/* this is an attach call */
		if count < 4 then go to bad_args;
		mode = ""; /* initialize mode string */
		pos = 1; /* start from beginning of mode string */
		do count = 6 by 1 while(code = 0); /* process remaining arguments */
			substr(mode,pos,l5) = arg5; /* place next mode in mode string */
			pos = pos + l5 + 1; /* update position in mode string */
			call cu_$arg_ptr(count,p5,l5,code); /* pick up next argument */
			if code = 0 then substr(mode,pos-1,1) = ","; /* insert delimiter in mode string */
			end;
		call ios_$attach(ioname,arg3,arg4,mode,status);	/* make attach call */
		end;
	 else if call_name = "detach" then do;	/* detach call */
		if count = 2 then ioname2,mode = "";
		 else if count = 3 then do;
			ioname2 = arg3;
			mode = "";
			end;
		  else if count = 4 then do;
			ioname2 = arg3;
			mode = arg4;
			end;
		   else go to bad_args;
		call ios_$detach(ioname,ioname2,mode,status); /* make detach call */
		end;
	 else if call_name = "read" then do; /* read call */
		if count < 3 | count > 5 then go to bad_args;
		path = arg3;	/* align for expand_path_ */
		call expand_path_(addr(path),length(arg3),addr(dir),addr(entry),code);
			/* get the directory and entry */
		if code ^= 0 then go to path_err;
		call hcs_$make_seg(dir,entry,"",01011b,segptr,code);
			/* create the segment */
		if segptr = null then go to path_err;
		call ios_$getsize(ioname,element_size,status); /* get element size */
		if substr(status,1,36) ^= "0"b then element_size = 9; /* if can't get element size assume 9 */
		if count = 3 then do; /* set up args */
			offset = 0;
			nelem = divide(sys_info$max_seg_size * 36, element_size, 17, 0);
			end;
		 else if count = 4 then do;
			offset = 0;
			call cv_dec_check_(arg4, code, nelem); /* convert count */
			if code ^= 0
			then /* ! */
nelem_4:			     call num_err(arg4, "nelem");
			end;
		  else if count = 5 then do;
			call cv_dec_check_(arg4, code, offset);
			if code ^= 0
			then /* ! */
offset_4:			     call num_err(arg4, "offset");
			call cv_dec_check_(arg5, code, nelem);
			if code ^= 0
			then /* ! */
nelem_5:			     call num_err(arg5, "nelem");
			end;
		call ios_$read(ioname,segptr,offset,nelem,nelemt,status); /* make read call */
		if s.code = 0 then do; /* no problems */
			call hcs_$set_bc(dir,entry,nelemt*element_size,code);	/* set segment bit count */
			if code ^= 0 then
				call ioa_("iocall: Unable to set bit count for segment. ^a",path);
			call ioa_("The number of elements read is ^d.",nelemt);
			end;
		end;
	 else if call_name = "write" then do;	/* write call */
		if count < 3 | count > 5 then go to bad_args;
		path = arg3;	/* align for expand_path_ */
		call expand_path_(addr(path),length(arg3),addr(dir),addr(entry),code);
			/* process path name */
		if code ^= 0 then go to path_err;
		call hcs_$initiate_count(dir,entry,"",bit_count,1,segptr,code);
			/* get pointer to segment */
		if segptr = null then go to path_err;
		call ios_$getsize(ioname,element_size,status); /* get element size */
		if substr(status,1,36) then element_size = 9; /* if can't get element size assume 9 */
		if count = 3 then do;	/* set up args */
			offset = 0;
			nelem = divide(bit_count,element_size,17,0); /* get element count */
			nelemt = nelem * element_size;		/* Calc # bits to be sent */
			bit_count = bit_count - nelemt;
			if bit_count ^= 0
			then call ioa_("^d bits at bit-offset ^d not transmitted to device ^a",
				bit_count, nelemt, ioname);
			end;
		 else if count = 4 then do;
			offset = 0;
			call cv_dec_check_(arg4, code, nelem);
			if code ^= 0
			then go to nelem_4;
			end;
		  else if count = 5 then do;
			call cv_dec_check_(arg4, code, offset);
			if code ^= 0
			then go to offset_4;
			call cv_dec_check_(arg5, code, nelem);
			if code ^= 0
			then go to nelem_5;
			end;
		call ios_$write(ioname,segptr,offset,nelem,nelemt,status); /* make write call */
		if s.code = 0 then call ioa_("The number of elements written is ^d.",nelemt);
		end;
	 else if call_name = "seek" then do; /* seek call */
		if count = 3 then do; /* set up args */
			ptrname2 = "first";
			offset = 0;
			end;
		 else if count = 4 then do;
			ptrname2 = arg4;
			offset = 0;
			end;
		  else if count = 5 then do;
			ptrname2 = arg4;
			call cv_dec_check_(arg5, code, offset);
			if code ^= 0
			then call num_err(arg5, "offset");
			end;
		   else go to bad_args;
		call ios_$seek(ioname,arg3,ptrname2,offset,status);	/* make seek call */
		end;
	 else if call_name = "tell" then do;	/* tell call */
		if count = 3 then ptrname2 = "first";	/* set up args */
		 else if count = 4 then ptrname2 = arg4;
		  else go to bad_args;
		call ios_$tell(ioname,arg3,ptrname2,offset,status);	/* make tell call */
		if s.code = 0 then call ioa_("Offset is ^d.",offset);
		end;
	 else if call_name = "setsize" then do; /* setsize call */
		if count ^= 3 then go to bad_args;
		call cv_dec_check_(arg3, code, element_size); /* convert element size */
		if code ^= 0
		then call num_err(arg3, "element_size");
		call ios_$setsize(ioname,element_size,status); /* make setsize call */
		end;
	 else if call_name = "getsize" then do; /* getsize call */
		if count ^= 2 then go to bad_args;
		call ios_$getsize(ioname,element_size,status); /* make getsize call */
		if s.code = 0 then call ioa_("Element size is ^d.",element_size); /* tell user the element size */
		end;
	 else if call_name = "order" then do; /* order call */
		if count ^= 3 then go to bad_args;
		call ios_$order(ioname,arg3,null,status); /* make order call */
		end;
	 else if call_name = "changemode" then do; /* changemode call */
		mode = ""; /* initialize mode string */
		if count >= 3 then code = 0; /* we have at least three arguments */
		pos = 1; /* start at beginning of mode string */
		do count = 4 by 1 while(code = 0); /* process remaining arguments */
			substr(mode,pos,l3) = arg3; /* add mode to mode string */
			pos = pos + l3 + 1; /* update position in mode string */
			call cu_$arg_ptr(count,p3,l3,code); /* get next argument */
			if code = 0 then substr(mode,pos-1,1) = ","; /* insert mode delimiter */
			end;
		call ios_$changemode(ioname,mode,old_mode,status); /* issue changemode call */
		if s.code = 0 then call ioa_("Mode changed from ^a",old_mode); /* tell user old mode */
		end;
	 else if call_name = "resetread" then do; /* resetread call */
		if count ^= 2 then go to bad_args;
		call ios_$resetread(ioname,status); /* issue resetread call */
		end;
	 else if call_name = "resetwrite" then do; /* resetwrite call */
		if count ^= 2 then go to bad_args;
		call ios_$resetwrite(ioname,status); /* issue resetwrite call */
		end;
	 else if call_name = "abort" then do; /* abort call */
		if count ^= 2 then go to bad_args;
		old_status = ""b; /* abort all transactions */
		call ios_$abort(ioname,old_status,status); /* issue abort call */
		end;
	 else if call_name = "readsync" then do; /* readsync call */
		if count = 3 then limit = bin(131071, 17); /* set high limit for default */
		 else if count = 4 then do;
			call cv_dec_check_(arg4, code, limit); /* else set given limit */
			if code ^= 0
			then /* ! */
limit_4:			     call num_err(arg4, "limit");
			end;
		  else go to bad_args;
		call ios_$readsync(ioname,arg3,limit,status); /* issue readsync call */
		end;
	 else if call_name = "writesync" then do; /* writesync call */
		if count = 3 then limit = bin(131071, 17); /* set high default limit */
		 else if count = 4 then do;
			call cv_dec_check_(arg4, code, limit); /* else set given limit */
			if code ^= 0
			then go to limit_4;
			end;
		  else go to bad_args;
		call ios_$writesync(ioname,arg3,limit,status); /* issue writesync call */
		end;
	 else if call_name = "worksync" then do; /* worksync call */
		if count ^= 3 then go to bad_args;
		call ios_$worksync(ioname,arg3,"",status); /* issue worksync call */
		end;
	 else do;
		call ioa_("iocall: The ^a call to the I/O system is not permitted by iocall.",call_name);
		return;
		end;
	name = ioname;
	go to status_check; /* go interpret status */

path_err:	call com_err_(code,whoami,path);	/* report error to user */
	return;


bad_args:	call com_err_(error_table_$noarg,whoami,""); /* incorrect number of args */
	return;

	/* This entry point interprets a status string */

checkstatus:	entry(input_status);

	dcl input_status bit(72) aligned;

	name = "";
	statusp = addr(status);
	status = input_status;
	command_name = "I/O Error";
status_check:
	/* print out status interpretation */
	if s.code ^= 0 then call com_err_(s.code,command_name,name);
	if s.eof then call ioa_("^a at end of file.",name);
	if s.abs then call ioa_("^a device absent.",name);
	if s.det then call ioa_("^a device detached.",name);
	if s.quit then call ioa_("^a quit detected.",name);
	if s.abort then call ioa_("^a transaction aborted.",name);

num_err: proc(str, id);

dcl (str, id) char(*);

	call com_err_(0, whoami, "Non-numeric digits in ^a argument to ^a request: ^a", id, call_name, str);

	go to end_iocall;

end;

end_iocall:
end iocall;
  



		    iod_forms_.pl1                  11/14/88  1105.0rew 11/14/88  1100.1      205191


/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-02-25,Brunelle), approve(88-06-09,MCR7911),
     audit(88-10-25,Wallman), install(88-11-08,MR12.2-1199):
     Created.
  2) change(88-11-03,Brunelle), approve(88-11-03,MCR7911),
     audit(88-11-03,Wallman), install(88-11-08,MR12.2-1199):
     Corrected case where mode_string_$parse broke a mode of elite6 into two
     parts, "elite" and "6".  Put the pieces back together.
  3) change(88-11-11,Brunelle), approve(88-11-11,MCR7911),
     audit(88-11-11,Wallman), install(88-11-14,MR12.2-1212):
     Corrected error messages for both a bad forms string and an invalid forms
     option.
                                                   END HISTORY COMMENTS */

/* format: style4 */

iod_forms_: proc;
	return;					/*  no entry here */

/* this module contains the common routines to evaluate a given forms option
   and to return forms information for a given request type */

/* Arguments */

dcl  a_area_ptr ptr parameter;			/* ptr to user area */
dcl  a_code fixed bin (35) parameter;			/* error code */
dcl  a_input_ptr ptr parameter;			/* ptr to input data structure */
dcl  a_output_ptr ptr parameter;			/* ptr to allocated return data structure */

/* External Procedures and Variables */

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$bad_forms_option fixed bin (35) ext static;
dcl  error_table_$bad_mode_syntax fixed bin (35) ext static;
dcl  error_table_$no_table fixed bin (35) ext static;
dcl  error_table_$no_forms_table_defined fixed bin (35) ext static;
dcl  error_table_$notalloc fixed bin (35) ext static;
dcl  error_table_$null_info_ptr fixed bin (35) ext static;
dcl  ioa_$rsnpnnl entry () options (variable);
dcl  mode_string_$parse entry (char (*), ptr, ptr, fixed bin (35));

dcl  (addr, char, hbound, length, ltrim, null, ptr, rtrim, substr, unspec) builtin;

dcl  (area, cleanup) condition;

/* Internal Static */

/* Automatic */

dcl  code fixed bin (35);				/* error code */
dcl  element_index fixed bin;
dcl  i fixed bin;					/* misc indices */
dcl  return_error_string char (1024) varying;
dcl  return_escape_string char (1024) varying;
dcl  return_forms_string char (512) varying;
dcl  return_special_string char (1024) varying;
dcl  user_area area based (user_area_ptr);
dcl  user_area_ptr ptr;

/* the following structure defines the following data elements
   1) The start index for the first forms element in the forms table defined
   .  by either the device or request type entries in the I/O daemon tables
   2) indices within the forms elements in the forms table for each of the
   .  types of forms elements currently allowed.  These indices are for both
   .  the default forms string and the user supplied forms string. */

dcl  1 parse_info,
       2 forms_table_start_index fixed bin,
       2 default_type_indices (hbound (FORMS_TYPE_STRINGS, 1)) fixed bin,
       2 user_type_indices (hbound (FORMS_TYPE_STRINGS, 1)) fixed bin;

dcl  1 size_info,
       2 page_height float bin,
       2 page_width float bin,
       2 char_height float bin,
       2 char_width float bin,
       2 line_height float bin,
       2 pagelength fixed bin,
       2 linelength fixed bin,
       2 lpi fixed bin;
%page;

/* given pointers to a request type and major/minor device entries in the i/o
   daemon tables and a user supplied forms string, evaluate the the elements
   in the string are legal and return the max line & page length to the user
*/

evaluate: entry (a_input_ptr, a_output_ptr, a_code);

/* copy args */
	evaluate_forms_info_input_ptr = a_input_ptr;
	a_output_ptr = null;
	a_code = 0;

/* get ptrs to appropriate places in the i/o daemon tables */
	ithp = evaluate_forms_info_input.ithp;
	qgtep = evaluate_forms_info_input.qgtep;
	idtep = evaluate_forms_info_input.idtep;
	mdtep = evaluate_forms_info_input.mdtep;
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);
	ifitp = ptr (ithp, iod_tables_hdr.forms_info_tab_offset);

/* initialize internal version of output variables */
	size_info.page_height,
	     size_info.page_width,
	     size_info.char_height,
	     size_info.char_width,
	     size_info.line_height = 0e0;
	size_info.pagelength,
	     size_info.linelength,
	     size_info.lpi = 0;
	return_error_string,
	     return_escape_string,
	     return_forms_string,
	     return_special_string = "";

	unspec (parse_info) = "0"b;

/* locate the forms table to use to evaluate the default and user forms string */
	call locate_forms_table;
	if code ^= 0 then go to evaluate_forms_option_return;

/* evaluate the default forms string.  the default forms string for the
   device/minor device takes precedence but if there is none and the request
   type has one then use it. */
	parse_info.default_type_indices (*) = 0;
	if idtep ^= null then do;
	     if mdtep ^= null then do;
		if mdte.default_form.total_chars > 0 then do;
		     call process_forms_string (return_string (mdte.default_form),
			parse_info.default_type_indices, code);
		end;
	     end;
	end;
	else if qgtep ^= null then do;
	     if qgte.default_form.total_chars > 0 then do;
		call process_forms_string (return_string (qgte.default_form),
		     parse_info.default_type_indices, code);
	     end;
	end;
	else code = error_table_$no_table;
	if code ^= 0 then go to evaluate_forms_option_return;

/* evaluate the user forms string */
	parse_info.user_type_indices (*) = 0;
	call process_forms_string ((evaluate_forms_info_input.forms_string),
	     parse_info.user_type_indices, code);
	if code ^= 0 then go to evaluate_forms_option_return;

/* now let's do something with the values we've found.  Evaluate elements to
   get the dimensions and set up the return strings */
	call evaluate_the_form_type (TYPE_SPECIAL);
	call evaluate_the_form_type (TYPE_PREAMBLE);
	call evaluate_the_form_type (TYPE_FONT_DESC);
	call evaluate_the_form_type (TYPE_FONT_NAME);
	call evaluate_the_form_type (TYPE_FONT_SIZE);
	call evaluate_the_form_type (TYPE_ORIENTATION);
	call evaluate_the_form_type (TYPE_LINE_DESC);
	call evaluate_the_form_type (TYPE_HOLES);
	call evaluate_the_form_type (TYPE_POSTAMBLE);

/* now compute lines per page and chars per line */
	if size_info.line_height = 0 then do;
	     if size_info.char_height > 0 then do;
		size_info.pagelength = size_info.page_height / size_info.char_height;
		size_info.lpi = 72 / size_info.char_height;
	     end;
	end;
	else do;
	     size_info.pagelength = size_info.page_height / size_info.line_height;
	     size_info.lpi = 72 / size_info.line_height;
	end;
	if size_info.char_width > 0 then
	     size_info.linelength = size_info.page_width / size_info.char_width;

evaluate_forms_option_return:
	user_area_ptr = evaluate_forms_info_input.area_ptr; /* area to put output in */

/* set up lengths of all strings we will be returning */
	system_returned_forms_length = length (return_forms_string);
	system_error_string_length = length (return_error_string);
	system_escape_string_length = length (return_escape_string);
	system_special_string_length = length (return_special_string);
	allocate evaluate_forms_info_output in (user_area);

	evaluate_forms_info_output.version = EVALUATE_FORMS_INFO_OUTPUT_VERSION_1;
	evaluate_forms_info_output.lines_per_page = size_info.pagelength;
	evaluate_forms_info_output.chars_per_line = size_info.linelength;
	evaluate_forms_info_output.lines_per_inch = size_info.lpi;
	evaluate_forms_info_output.error_string = return_error_string;
	evaluate_forms_info_output.escape_string = return_escape_string;
	evaluate_forms_info_output.special_string = return_special_string;

	a_output_ptr = evaluate_forms_info_output_ptr;
	a_code = code;
	return;
%page;

/* given a request type name, return all forms entries allowed for the given
   request type in a user supplied area */

info: entry (a_input_ptr, a_area_ptr, a_code);

/* copy args */
	evaluate_forms_info_input_ptr = a_input_ptr;
	a_area_ptr = null;
	a_code = 0;

/* get ptrs to appropriate places in the i/o daemon tables */
	ithp = evaluate_forms_info_input.ithp;
	qgtep = evaluate_forms_info_input.qgtep;
	idtep = evaluate_forms_info_input.idtep;
	mdtep = evaluate_forms_info_input.mdtep;
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);
	ifitp = ptr (ithp, iod_tables_hdr.forms_info_tab_offset);

	user_area_ptr = evaluate_forms_info_input.area_ptr;

	if user_area_ptr = null then do;		/* no place to put the data */
	     a_code = error_table_$null_info_ptr;
	     return;
	end;

/* locate the forms table */
	call locate_forms_table;
	if code ^= 0 then do;
	     a_code = code;
	     return;
	end;

/* loop through all the entries in the table so we can get counts to define
   size of the allocation structure */
	forms_info_entry_count,
	     forms_info_name_count,
	     forms_info_comment_count,
	     forms_info_types_count,
	     forms_info_uses_count,
	     forms_info_specials_count = 0;

	element_index = parse_info.forms_table_start_index;
	do while (element_index > 0);
	     fep = addr (iod_forms_info_tab.element_data_block (element_index));

	     forms_info_entry_count = forms_info_entry_count + 1;
	     forms_info_name_count = forms_info_name_count + element_common.n_names;
	     if element_common.comment.total_chars ^= 0 then
		forms_info_comment_count = forms_info_comment_count + 1;
	     if element_common.type = TYPE_USES then
		forms_info_uses_count = forms_info_uses_count + 1;
	     if element_common.type = TYPE_SPECIAL then
		forms_info_specials_count = forms_info_specials_count + 1;
	     element_index = element_common.next_element_index;
	end;
	forms_info_types_count = forms_info_entry_count;
	forms_info_default_forms_length = qgte.default_form.total_chars;

/* allocate the return info structure & clear the beastie out */
	on area go to no_allocation;

	allocate forms_info in (user_area);

	revert area;

	forms_info.entry (*) = 0;
	forms_info.names (*),
	     forms_info.comments (*),
	     forms_info.uses (*),
	     forms_info.specials (*) = "";
	forms_info.types (*) = -1;
	forms_info.default_form = return_string (qgte.default_form);

/* now loop through the entries again, copying out the data for the user */
	forms_info_entry_count,
	     forms_info_name_count,
	     forms_info_comment_count,
	     forms_info_types_count,
	     forms_info_uses_count,
	     forms_info_specials_count = 0;

	element_index = parse_info.forms_table_start_index;
	do while (element_index > 0);
	     fep = addr (iod_forms_info_tab.element_data_block (element_index));

	     forms_info_entry_count = forms_info_entry_count + 1; /* processing next entry */

/* save name information for the element */
	     forms_info.entry (forms_info_entry_count).first_name_index = forms_info_name_count + 1;
	     do i = 1 to element_common.n_names;
		forms_info_name_count = forms_info_name_count + 1;
		forms_info.names (forms_info_name_count) = return_string (element_common.names (i));
	     end;
	     forms_info.entry (forms_info_entry_count).last_name_index = forms_info_name_count;

/* if the element has comments, save them; else return 0 */
	     if element_common.comment.total_chars ^= 0 then do;
		forms_info_comment_count = forms_info_comment_count + 1;
		forms_info.entry (forms_info_entry_count).comment_index = forms_info_comment_count;
		forms_info.comments (forms_info_comment_count) = return_string (element_common.comment);
	     end;
	     else forms_info.entry (forms_info_entry_count).comment_index = 0;

/* save the string describing the type of element this is */
	     forms_info_types_count = forms_info_types_count + 1;
	     forms_info.types (forms_info_types_count) = element_common.type;
	     forms_info.entry (forms_info_entry_count).type_index = forms_info_types_count;

/* if this is a uses element, build & save the uses name string; else return 0 */
	     if element_common.type = TYPE_USES then do;
		forms_info_uses_count = forms_info_uses_count + 1;
		forms_info.entry (forms_info_entry_count).uses_index = forms_info_uses_count;
		do i = 1 to uses_element.n_indices;
		     forms_info.uses (forms_info_uses_count) = rtrim (forms_info.uses (forms_info_uses_count))
			|| return_string (uses_element.index_blocks (i).name);
		     if i ^= uses_element.n_indices then
			forms_info.uses (forms_info_uses_count) = rtrim (forms_info.uses (forms_info_uses_count)) || ",";
		end;
	     end;
	     else forms_info.entry (forms_info_entry_count).uses_index = 0;

/* if this is a special element, return the special string; else 0 */
	     if element_common.type = TYPE_SPECIAL then do;
		forms_info_specials_count = forms_info_specials_count + 1;
		forms_info.entry (forms_info_entry_count).special_index = forms_info_specials_count;
		forms_info.specials (forms_info_specials_count) = return_string (special_element.special_string);
	     end;
	     else forms_info.entry (forms_info_entry_count).special_index = 0;
	     element_index = element_common.next_element_index;
	end;

/* tell user where we put the data */
	a_area_ptr = forms_info_ptr;

	return;

/* when we can't allocate in the supplied area */
no_allocation:
	a_code = error_table_$notalloc;
	return;
%page;

process_forms_string: proc (string_to_process, parse_indices, parse_error);

/* subroutine to parse the forms string and locate matching data in the
   forms table starting at parse_info.start_index */

dcl  string_to_process char (*) parameter;		/* forms string to parse out */
dcl  parse_indices (*) fixed bin parameter;		/* type indices to fill in */
dcl  parse_error fixed bin (35) parameter;		/* my error code */

dcl  element_index fixed bin;
dcl  error_string_long char (100) aligned;
dcl  error_string_short char (8) aligned;
dcl  got_a_match bit (1);
dcl  (i, j) fixed bin;
dcl  parsed_element_name char (64) varying;

/* initialize things */
	parse_indices (*) = 0;
	mode_string_info_ptr = null;
	on cleanup go to process_forms_string_cleanup;

/* now parse the given mode string */
	call mode_string_$parse (string_to_process, null, mode_string_info_ptr, parse_error);
	if parse_error ^= 0 then do;
	     if parse_error = error_table_$bad_mode_syntax then
		parse_error = error_table_$bad_arg;
	     go to process_forms_string_cleanup;
	end;

/* now let's see what we got.  loop for each forms element parsed */
	do i = 1 to mode_string_info.number;
	     mode_value_ptr = addr (mode_string_info.modes (i)); /* get info for parsed element */

/* if there were any problems, add descriprive error comment to error string
   and continue to next parsed forms element */
	     if mode_value.code ^= 0 then do;
		parse_error = mode_value.code;
		call convert_status_code_ (parse_error, error_string_short, error_string_long);
		call ioa_$rsnpnnl ("^a^/^a: option ^a",
		     return_error_string, (0),
		     return_error_string,
		     error_string_long, mode_value.mode_name);
		goto skip_this_mode_entry;
	     end;

/* scan through all the forms elements defined for the forms table looking for
   an element which matches the parsed element name (this includes looking at
   any additional names each forms element may have).

   If we find a match, we save the elements index within the forms table in
   the parse indices in the slot corresponding to the type of element defined
   by the element index.

   If the element is a USES element (made up of one or more other elements),
   call another routine to expand the USES element into its component types */
	     got_a_match = "0"b;
	     element_index = parse_info.forms_table_start_index;
	     parsed_element_name = rtrim (mode_value.mode_name);
	     if mode_value.char_valuep then
		parsed_element_name = parsed_element_name || mode_value.char_value;
	     else if mode_value.numeric_valuep then
		parsed_element_name = parsed_element_name || ltrim (rtrim (char (mode_value.numeric_value)));
	     do while (element_index > 0 & ^got_a_match);
		fep = addr (iod_forms_info_tab.element_data_block (element_index));
		do j = 1 to element_common.n_names;
		     if return_string (element_common.names (j)) = parsed_element_name then do;
			parse_indices (element_common.type) = element_index;
			if element_common.type = TYPE_USES then /* expand 'uses' if found */
			     call expand_uses_definitions (parse_indices (TYPE_USES), parse_indices);
			got_a_match = "1"b;
		     end;
		end;
		element_index = element_common.next_element_index;
	     end;

/* if no element was found matching the parsed element, add a descriptive
   error string to the error string we are going to return to the user */
	     if ^got_a_match then do;
		parse_error = error_table_$bad_forms_option;
		call ioa_$rsnpnnl ("^a^/Option ^a invalid.",
		     return_error_string, (0),
		     return_error_string, mode_value.mode_name);
	     end;

skip_this_mode_entry:
	end;

process_forms_string_cleanup:				/* clean up after ourselves */
	if mode_string_info_ptr ^= null then do;
	     free mode_string_info;
	     mode_string_info_ptr = null;
	end;

     end process_forms_string;
%page;
locate_forms_table: proc;

/* locate the default forms table and return the starting index of the forms
   entries to use.  The logic it will use to find the table is
   1. if there is a device entry defined
   .  1a. if there is a forms_table string defined, use that.
   .  1b. if no forms string defined, go to step 2.
   2. if there is a request type entry defined and it has a forms_table string
   .  defined, use that.
   3. return no table error */

dcl  forms_table_name char (32);

/* first locate the name of the forms table to use */
	forms_table_name = "";
	code = 0;
	if idtep ^= null then
	     forms_table_name = return_string (idte.forms_table);
	if forms_table_name = "" then
	     if qgtep ^= null then
		forms_table_name = return_string (qgte.forms_table);

	if forms_table_name = "" then do;
	     code = error_table_$no_forms_table_defined;
	     return;
	end;

/* locate the given forms table */
	do i = 1 to iod_forms_info_tab.n_groups
	     while (forms_table_name ^= iod_forms_info_tab.groups.name (i));
	end;
	if i > iod_forms_info_tab.n_groups then do;	/* not there! */
	     code = error_table_$no_table;
	     return;
	end;

/* remember where the table starts for this forms table  */
	parse_info.forms_table_start_index = iod_forms_info_tab.groups.first_element_index (i);

     end locate_forms_table;
%page;

evaluate_the_form_type: proc (type_index);

/* given a particular type index, take the element index from parse_info for
   that type index slot and evaluate it.  This evaluation will set one or more
   of the size parameters and the return_escape or return_special strings */

dcl  type_index fixed bin parameter;

/* if the user specified this type of element, use it; else use the default */
	element_index = parse_info.user_type_indices (type_index);
	if element_index <= 0 then
	     element_index = parse_info.default_type_indices (type_index);

/* if this type of element was specified, set up the information for it */
	if element_index > 0 then do;
	     fep = addr (iod_forms_info_tab.element_data_block (element_index));
	     if type_index = TYPE_PREAMBLE then do;
		return_escape_string = return_escape_string
		     || return_string (preamble_element.escape_string);
	     end;
	     else if type_index = TYPE_ORIENTATION then do;
		return_escape_string = return_escape_string
		     || return_string (orientation_element.escape_string);
		size_info.page_height = orientation_element.height;
		size_info.page_width = orientation_element.width;
	     end;
	     else if type_index = TYPE_FONT_DESC then do;
		return_escape_string = return_escape_string
		     || return_string (font_element.escape_string);
		size_info.char_height = font_element.height;
		size_info.char_width = font_element.width;
	     end;
	     else if type_index = TYPE_FONT_NAME then do;
		return_escape_string = return_escape_string
		     || return_string (font_element.escape_string);
	     end;
	     else if type_index = TYPE_FONT_SIZE then do;
		return_escape_string = return_escape_string
		     || return_string (font_element.escape_string);
		size_info.char_height = font_element.height;
		size_info.char_width = font_element.width;
	     end;
	     else if type_index = TYPE_LINE_DESC then do;
		return_escape_string = return_escape_string
		     || return_string (line_element.escape_string);
		size_info.line_height = line_element.height;
	     end;
	     else if type_index = TYPE_HOLES then do;
		return_escape_string = return_escape_string
		     || return_string (holes_element.escape_string);
		size_info.page_height = size_info.page_height - orientation_element.height;
		size_info.page_width = size_info.page_width - orientation_element.width;
	     end;
	     else if type_index = TYPE_POSTAMBLE then do;
		return_escape_string = return_escape_string
		     || return_string (postamble_element.escape_string);
	     end;
	     else if type_index = TYPE_SPECIAL then do;
		return_special_string = return_special_string
		     || return_string (special_element.special_string);
	     end;
	end;

     end evaluate_the_form_type;
%page;

expand_uses_definitions: proc (element_to_use, save_elements);

/* Expand the given uses element by going through the indices stored in the
   uses element to get the indices and types of the elements referred to by
   the uses element. */

dcl  element_to_use fixed bin parameter;
dcl  save_elements (*) fixed bin parameter;

dcl  i fixed bin;
dcl  temp_fep ptr;

	fep = addr (iod_forms_info_tab.element_data_block (element_to_use));
	do i = 1 to uses_element.n_indices;
	     temp_fep = addr (iod_forms_info_tab.element_data_block (uses_element.index (i)));
	     if temp_fep -> element_common.type = TYPE_USES then
		call expand_uses_definitions ((temp_fep -> uses_element.index (i)), save_elements);
	     else save_elements (temp_fep -> element_common.type) = uses_element.index (i);
	end;

     end expand_uses_definitions;


return_string: proc (target) returns (char (*));

/* small procedure to extract a string from text_strings.chars in the I/O daemon tables */

dcl  1 target like text_offset parameter;

	if target.total_chars = 0 then
	     return ("");
	else return (substr (text_strings.chars, target.first_char, target.total_chars));
     end return_string;
%page; %include iod_device_tab;
%page; %include iod_tables_hdr;
%page; %include iod_forms_info_tab;
%page; %include mode_string_info;
%page; %include q_group_tab;
%page; %include system_forms_info;
%page; %include user_forms_info;

     end iod_forms_;
 



		    iod_info_.pl1                   11/01/88  1242.4rew 11/01/88  1237.8      186345


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

/* format: style4 */

iod_info_: proc;
	return;					/* no entry here */

/* This subroutine is provided to extract information from the io daemon
   tables, thereby sparing its callers the need to understand the structure
   and location of these tables.  A pointer to the iod_working_tables segment
   is obtained the first time the procedure is called.  Recovery from a
   seg_fault_error is attempted because the IO Coordinator, as a matter of
   standard procedure, may delete the iod_working_tables segment and replace
   it with a new one when starting.
*/

/* Written by J. Stern, 2/13/75 */
/* Modified by J. C. Whitmore, 4/78, to add queue_data and rqt_list entries; and for new iod_tables format */
/* Modified by J. C. Whitmore, 10/78, to use version 3 iod_tables */

/****^  HISTORY COMMENTS:
  1) change(88-02-26,Brunelle), approve(88-10-31,MCR7911),
     audit(88-10-25,Wallman):
     Add forms_info, validate_forms_info and evaluate_forms_info entrypoints.
     Use version 5 iod tables.
  2) change(88-10-31,Brunelle), approve(88-10-31,MCR7911),
     audit(88-11-01,Wallman):
     Correct error in evaluate_forms_info entrypoint where invalid return
     pointer for evaluate_forms_info_output was being returned.
                                                   END HISTORY COMMENTS */

/* Arguments */

dcl  acc_name char (32) parameter;			/* driver access name argument */
dcl  code fixed bin (35) parameter;			/* error code */
dcl  default_q fixed bin parameter;			/* number of the default q for a request type */
dcl  gen_type char (32) parameter;			/* generic type name argument */
dcl  max_queues fixed bin parameter;			/* number of queues for a given request type */
dcl  n_queues fixed bin parameter;			/* number of q_group names returned in q_list */
dcl  ptr_to_user_area ptr parameter;
dcl  q_group char (*) parameter;			/* queue group name argument */
dcl  q_list (*) char (32) parameter;			/* array for returning q_group names */
dcl  return_area_ptr ptr parameter;
dcl  rqtip ptr parameter;				/* ptr to rqti seg to use */
dcl  efiip ptr parameter;				/* ptr to evaluate_forms_info_input to use */
dcl  efiop ptr parameter;				/* return ptr to evaluate_forms_info_output */

/* External Procedures & Variables */

dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
dcl  error_table_$id_not_found fixed bin (35) ext static;
dcl  error_table_$improper_data_format fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$no_forms_table_defined fixed bin (35) ext static;
dcl  error_table_$too_many_names fixed bin (35) ext static;
dcl  get_system_free_area_ entry () returns (ptr);
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  iod_forms_$evaluate entry (ptr, ptr, fixed bin (35));
dcl  iod_forms_$info entry (ptr, ptr, fixed bin (35));

dcl  (addr, hbound, null, ptr, rtrim, substr) builtin;

dcl  (cleanup, seg_fault_error) condition;

/* Internal Static */

dcl  ACC fixed bin int static options (constant) init (0);
dcl  GEN fixed bin int static options (constant) init (1);
dcl  Q fixed bin int static options (constant) init (2);
dcl  RQTL fixed bin int static options (constant) init (3);
dcl  VFI fixed bin int static options (constant) init (4);
dcl  FI fixed bin int static options (constant) init (5);
dcl  itp ptr int static init (null);			/* ptr to iod_working_tables segment */
dcl  my_area_ptr ptr int static init (null);
dcl  sysdir char (168) int static init (">daemon_dir_dir>io_daemon_dir");
dcl  undefined char (32) int static options (constant) init ("UNDEFINED"); /* a preset value */

/* Automatic */

dcl  bitcount fixed bin (24);
dcl  entry fixed bin;				/* entry switch */
dcl  i fixed bin;
dcl  icode fixed bin (35);				/* internal error code */
dcl  forms_info_entry entry (ptr, ptr, fixed bin (35)) variable;
dcl  generic_type char (32) aligned;			/* local copy of generic type name */
dcl  my_area area based (my_area_ptr);
dcl  qg_name char (32) aligned;			/* local copy of q group name */
dcl  return_forms_allowed bit (1);
dcl  return_lines_per_inch fixed bin;
dcl  return_max_line_length fixed bin;
dcl  return_max_page_length fixed bin;
dcl  user_area_ptr ptr;
dcl  user_area area based (user_area_ptr);
dcl  evaluate_forms_entry entry (ptr, ptr, fixed bin (35)) variable;
%page;

/* Given a specific request type, return name of driver as defined in the I/O
   daemon tables */
driver_access_name: entry (q_group, acc_name, code);

	entry = ACC;
	qg_name = q_group;				/* copy the request type name */
	generic_type = undefined;
	acc_name = "";				/* clear the return arg */
	go to common;


/* Given a specific request type, return generic type as defined in the I/O
   daemon tables */
generic_type: entry (q_group, gen_type, code);

	entry = GEN;
	qg_name = q_group;				/* copy the args */
	gen_type = "";				/* clear the return value */
	generic_type = undefined;
	go to common;


/* Given a specific request type, return default and max # queues as defined
   in the I/O daemon tables */
queue_data: entry (q_group, default_q, max_queues, code);

	entry = Q;
	qg_name = q_group;				/* copy the args */
	default_q, max_queues = 0;			/* clear the return values */
	generic_type = undefined;
	go to common;


/* Given a specific generic type, return list of all request type of that type
   as defined in the I/O daemon tables */
rqt_list: entry (gen_type, q_list, n_queues, code);

	entry = RQTL;
	qg_name = undefined;
	generic_type = gen_type;			/* does caller only want one generic type */
						/* if blank, we give him all */
	n_queues = 0;				/* init the return value */
	go to common;
%page;
/* Given a specific request type, return all forms information available */

forms_info: entry (q_group, ptr_to_user_area, return_area_ptr, code);

	entry = FI;
	qg_name = q_group;				/* copy the request type name */
	user_area_ptr = ptr_to_user_area;
	return_area_ptr = null;
	go to common;


/* Given a specific request type and forms string, validate that the forms
   string is correct and return max line and page lengths */

validate_forms_info: entry (validate_forms_info_input_ptr, validate_forms_info_output_ptr, code);

	entry = VFI;
	qg_name = validate_forms_info_input.request_type;
	user_area_ptr = validate_forms_info_input.user_area_ptr;
	go to common;


/* This entrypoint is only for internal use by the I/O daemons to evaluate the
   forms information and return all the data required.  It is put in this
   module just so there is a common place for all calls. */

evaluate_forms_info: entry (rqtip, efiip, efiop, code);

	call evaluate_forms_data (rqtip, efiip, efiop, code);

/* if the evaluation routine didn't return an output structure, there was some
   sort of major error.  Allocate a return structure ourselves so we don't
   mess up anyone who calls us */
	if efiop = null then do;
	     system_returned_forms_length,
		system_error_string_length,
		system_escape_string_length,
		system_special_string_length = 0;
	     user_area_ptr = efiip -> evaluate_forms_info_input.area_ptr;
	     if user_area_ptr = null then
		allocate evaluate_forms_info_output in (my_area);
	     else allocate evaluate_forms_info_output in (user_area);

	     evaluate_forms_info_output.version = EVALUATE_FORMS_INFO_OUTPUT_VERSION_1;
	     evaluate_forms_info_output.lines_per_inch = return_lines_per_inch;
	     evaluate_forms_info_output.lines_per_page = return_max_page_length;
	     evaluate_forms_info_output.chars_per_line = return_max_line_length;
	     efiop = evaluate_forms_info_output_ptr;
	end;

	return;
%page;
common:
	evaluate_forms_info_input_ptr,
	     evaluate_forms_info_output_ptr = null;

	on seg_fault_error go to try_again;

	if itp = null then do;			/* get ptr to iod_working_tables */
initiate:	     call initiate_file_ (sysdir, "iod_working_tables", R_ACCESS, itp, bitcount, code);
	     if itp = null then return;
	     ithp = itp;
	end;
	else ithp = itp;
	if iod_tables_hdr.version ^= IODT_VERSION_5 then do; /* wrong version number */
	     code = error_table_$improper_data_format;
	     return;
	end;

	code = 0;

/* get ptrs to various needed tables in the iod tables */
	qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset);
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);

	do i = 1 to q_group_tab.n_q_groups;
	     qgtep = addr (q_group_tab.entries (i));
	     if entry = RQTL then do;			/* when listing the request types */
		if generic_type = "" | generic_type = qgte.generic_type then do; /* want this one? */
		     if hbound (q_list, 1) > n_queues then do;
			n_queues = n_queues + 1;
			q_list (n_queues) = qgte.name;
		     end;
		     else code = error_table_$too_many_names;
		end;
	     end;
	     else if qgte.name = qg_name then do;	/* looking for a specific request type */
		if entry = ACC then acc_name = qgte.driver_id;
		else if entry = GEN then gen_type = qgte.generic_type;
		else if entry = Q then do;		/* we want queue data */
		     default_q = qgte.default_queue;
		     max_queues = qgte.max_queues;
		end;
		else if entry = VFI then do;
		     call return_forms_validation_info;
		end;
		else if entry = FI then do;
		     call return_forms_info;
		end;
		return;
	     end;
	end;

	if entry = RQTL then do;			/* may not be an error for this entry */
	     if n_queues = 0 then code = error_table_$noentry;
	end;
	else code = error_table_$id_not_found;		/* did not find what we were looking for */
	return;

try_again: itp = null;				/* come here after seg_fault_error */
	revert seg_fault_error;			/* if it happens again, let it go */
	go to initiate;				/* try to reinitiate iod_working_tables */

tables_dir: entry returns (char (*));

/* This entry returns the pathname of the current iod_working_tables being
   used by iod_info_ */

	return (sysdir);

tables_ptr: entry returns (ptr);

/* This entry returns a pointer to the current iod_working_tables being used
   by iod_info_ */

	if itp = null then do;
	     call initiate_file_ (sysdir, "iod_working_tables", R_ACCESS, itp, bitcount, code);
	end;
	return (itp);

test: entry (test_dir);				/* for setting test directory */

dcl  test_dir char (*);

	sysdir = test_dir;
	call initiate_file_ (sysdir, "iod_working_tables", R_ACCESS, itp, bitcount, icode);

	return;
%page;
return_forms_validation_info: proc;

	call evaluate_forms_data (null, null, evaluate_forms_info_output_ptr, code);

/* allocate the structure to return data back to the user */
	if evaluate_forms_info_output_ptr ^= null then do;
	     returned_forms_length = evaluate_forms_info_output.forms_length;
	     error_string_length = evaluate_forms_info_output.error_length;
	end;
	else do;
	     returned_forms_length,
		error_string_length = 0;
	end;
	if user_area_ptr = null then
	     allocate validate_forms_info_output in (my_area);
	else allocate validate_forms_info_output in (user_area);

	validate_forms_info_output.version = VALIDATE_FORMS_INFO_OUTPUT_VERSION_1;
	validate_forms_info_output.lines_per_inch = return_lines_per_inch;
	validate_forms_info_output.lines_per_page = return_max_page_length;
	validate_forms_info_output.chars_per_line = return_max_line_length;
	validate_forms_info_output.forms_allowed = return_forms_allowed;
	if returned_forms_length > 0 then
	     validate_forms_info_output.returned_forms = evaluate_forms_info_output.returned_forms;
	if error_string_length > 0 then
	     validate_forms_info_output.error_string = evaluate_forms_info_output.error_string;

	if evaluate_forms_info_output_ptr ^= null then
	     free evaluate_forms_info_output in (my_area);

     end return_forms_validation_info;
%page;
evaluate_forms_data: proc (rqti_ptr, vfiip, vfiop, code);

dcl  rqti_ptr ptr;					/* input ptr to rqti seg to use or NULL */
dcl  vfiip ptr;					/* ptr to evaluate_forms_info_input to use or NULL */
dcl  vfiop ptr;					/* ptr to return evaluate_forms_info_output */
dcl  code fixed bin (35);				/* error code */

	if my_area_ptr = null then
	     my_area_ptr = get_system_free_area_ ();

/* start with known state for the output pointer */
          evaluate_forms_info_output_ptr = null;

/* default to system maximums for page and line length and lpi.  These will be
   replaced by the forms validation routine or the contents of the rqti seg
   if they are applicable.  Also assume forms string not allowed */

	return_lines_per_inch = 6;
	return_max_page_length = 66;
	return_max_line_length = 132;
	return_forms_allowed = "0"b;

/* get page & line limits from the rqti seg if available */

	if rqti_ptr = null then do;			/* have to find rqti_seg ourselves */
	     call initiate_file_ (rtrim (sysdir) || ">ris", (qgte.rqti_seg_name), R_ACCESS, prt_rqtip, bitcount, icode);
	     if icode ^= 0 then
		go to terminate_the_rqti_seg;
	end;
	else prt_rqtip = rqti_ptr;			/* user supplied ptr to rqti_seg */

/* punt out of here if wrong version */
	if prt_rqti.version ^= prt_rqti_version_1 then
	     go to terminate_the_rqti_seg;

/* set return lengths based on data in rqti */
	return_lines_per_inch = prt_rqti.lines_per_inch;
	return_max_page_length = prt_rqti.paper_length;
	return_max_line_length = prt_rqti.paper_width;

terminate_the_rqti_seg:				/* clean up after outselves */
	if rqti_ptr = null then			/* if I initiated, then terminate rqti seg */
	     call terminate_file_ (prt_rqtip, bitcount, TERM_FILE_TERM, icode);

/* now let us see what the forms parser routine finds out for us */

/* if user passed us input structure already built, use it (called from the
   iod_info_$evaluate_forms_info entrypoint by a daemon);

   otherwise we will generate one and fill it in (called from the
   iod_info_$validate_forms_info entrypoint by a user queueing job for
   printing) */
	if vfiip = null then do;
	     evaluate_forms_info_input_ptr = null;

	     on cleanup begin;
		if vfiip = null then		/* if user didn't pass a structure */
		     if evaluate_forms_info_input_ptr ^= null then /* and we have one, we created it */
			free evaluate_forms_info_input; /* so free it */
	     end;

/* allocate input evaluation structure and fill it in with data  */
	     system_input_forms_string_length = validate_forms_info_input.forms_string_length;
	     allocate evaluate_forms_info_input in (my_area);

	     evaluate_forms_info_input.version = EVALUATE_FORMS_INFO_INPUT_VERSION_1;
	     evaluate_forms_info_input.ithp = ithp;	/* copy ptr to daemon tables to use */
	     evaluate_forms_info_input.qgtep = qgtep;	/* & ptr to request type to process for */
	     evaluate_forms_info_input.idtep,		/* no major device */
		evaluate_forms_info_input.mdtep = null; /* no minor device */
	     evaluate_forms_info_input.max_forms_string_length = validate_forms_info_input.max_forms_string_length;
	     evaluate_forms_info_input.forms_string = validate_forms_info_input.forms_string;
	     evaluate_forms_info_input.area_ptr = my_area_ptr;
	end;
	else evaluate_forms_info_input_ptr = vfiip;

	call call_validation_routine;
	if code = 0 then do;
	     return_forms_allowed = "1"b;
	     return_lines_per_inch = evaluate_forms_info_output.lines_per_inch;
	     return_max_page_length = evaluate_forms_info_output.lines_per_page;
	     return_max_line_length = evaluate_forms_info_output.chars_per_line;
	end;

	vfiop = evaluate_forms_info_output_ptr;

/* if I allocated the input structure then get rid of it */
	if vfiip = null then
	     free evaluate_forms_info_input;

     end evaluate_forms_data;

%page;
call_validation_routine: proc;

/* this routine will call the forms validation routine to authenticate any
   forms strings either passed in or defined as default.  It will locate the
   routine to validate the forms string using the following precedence:
   .  device_table value
   .  request_type value
   .  default of "iod_forms_$evaluate"
   However, it will not make any calls unless there is a forms table defined
   for the routine to use.  If the device entry pointer is given, any elements
   in the request type entry will be ignored */

dcl  validation_routine_name char (256);

/* set up all the pointers we will need from the input structure */
	ithp = evaluate_forms_info_input.ithp;
	qgtep = evaluate_forms_info_input.qgtep;
	idtep = evaluate_forms_info_input.idtep;
	mdtep = evaluate_forms_info_input.mdtep;
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);
	validation_routine_name = "";

/* if a device entry is defined, use the name in the device entry iff a forms
   table name is defined for the device to use.  Otherwise return error */
	if idtep ^= null then do;
	     if return_string (idte.forms_table) = "" then do;
		code = error_table_$no_forms_table_defined;
		return;
	     end;
	     validation_routine_name = return_string (idte.forms_validation);
	end;

/* if no name defined, there was no device entry data available so will will
   use what is available in the request type entry */
	else if qgtep ^= null then do;
	     if return_string (qgte.forms_table) = "" then do;
		code = error_table_$no_forms_table_defined;
		return;
	     end;
	     validation_routine_name = return_string (qgte.forms_validation);
	end;

/* if no name is defined yet, create entrypoint to default, else use the name defined */
	if validation_routine_name = "" then
	     evaluate_forms_entry = iod_forms_$evaluate;
	else do;
	     evaluate_forms_entry = cv_entry_ (
		rtrim (validation_routine_name) || "$evaluate",
		null (), code);
	     if code ^= 0 then return;
	end;

/* now call the given module */
	call evaluate_forms_entry (evaluate_forms_info_input_ptr, evaluate_forms_info_output_ptr, code);

     end call_validation_routine;
%page;

/* return all forms information for a given request type */
return_forms_info: proc;

	if my_area_ptr = null then
	     my_area_ptr = get_system_free_area_ ();

/* if there is no forms validation routine defined for the request type, call
   the system default routine; else call the one defined for the queue */

	if qgte.forms_validation.total_chars = 0 then
	     forms_info_entry = iod_forms_$info;
	else do;
	     forms_info_entry = cv_entry_ (
		return_string (qgte.forms_validation) || "$info",
		null (), code);
	     if code ^= 0 then return;
	end;

/* set up the structure to pass in */
	system_input_forms_string_length = 0;
	evaluate_forms_info_input_ptr = null;

	on cleanup begin;
	     if evaluate_forms_info_input_ptr ^= null then
		free evaluate_forms_info_input;
	end;

	allocate evaluate_forms_info_input in (my_area);

	evaluate_forms_info_input.version = EVALUATE_FORMS_INFO_INPUT_VERSION_1;
	evaluate_forms_info_input.ithp = ithp;		/* iod tables ptr */
	evaluate_forms_info_input.qgtep = qgtep;	/* ptr to request type forms info desired for */
	evaluate_forms_info_input.idtep,		/* no major device defined */
	     evaluate_forms_info_input.mdtep = null;	/* no minor device defined */
	evaluate_forms_info_input.max_forms_string_length = 0; /* no string to validate */
	if user_area_ptr = null then			/* set ptr to area to return data in */
	     evaluate_forms_info_input.area_ptr = my_area_ptr;
	else evaluate_forms_info_input.area_ptr = user_area_ptr;

/* now call the given module */
	call forms_info_entry (evaluate_forms_info_input_ptr, return_area_ptr, code);

/* make sure we clean up after ourselves */
	free evaluate_forms_info_input;

     end return_forms_info;


/* little routine to return a string from text_strings.chars in the i/o daemon tables */
return_string: proc (target) returns (char (*));

dcl  1 target unaligned like text_offset;
	if target.total_chars = 0 then
	     return ("");
	else return (substr (text_strings.chars, target.first_char, target.total_chars));

     end return_string;
%page; %include access_mode_values;
%page; %include iod_device_tab;
%page; %include iod_tables_hdr;
%page; %include prt_rqti;
%page; %include q_group_tab;
%page; %include terminate_file;
%page; %include system_forms_info;
%page; %include user_forms_info;

     end iod_info_;
   



		    line_length.pl1                 08/10/84  1132.7rew 08/10/84  1131.0       36450


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


/* This procedure allows the user to change the line length of the device he is
   presently attached to on the stream user_output.

   Coded by R. J. Feiertag on February 21, 1970			 */
/* Modified 08/04/83 by Jim Lippard to use iox_$modes */
/* Modified 84-07-24 by Charlie Spitzer. Let work as an AF. */

line_length: ll: proc;

dcl  ME char (11) internal static options (constant) init ("line_length");
dcl  active_fnc bit (1) aligned,
     af_return_arg_ptr ptr,
     af_return_arg_len fixed bin (21),
     af_return_arg char (af_return_arg_len) varying based (af_return_arg_ptr),
     cmaxl fixed bin(21),				/* length of cmax */
     cmaxp ptr,					/* pointer to cmax */
     cmax char (cmaxl) based (cmaxp),			/* line length in ascii */
     ll_ch char (8),
     code fixed bin(35),				/* error code */
     n_args fixed bin,
     error_table_$not_act_fnc fixed bin(35) ext static,
     error_table_$too_many_args fixed bin(35) ext static,
     new_line_length fixed bin,
     old_line_length fixed bin,
     get_line_length_$switch entry (ptr, fixed bin(35)) returns(fixed bin),
     iox_$modes entry (ptr, char(*), char(*), fixed bin(35)),
     iox_$user_output ext static ptr,
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin(21), fixed bin (35)),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     error_routine entry variable entry options (variable),
     ioa_ entry() options(variable),
     active_fnc_err_ entry options(variable),
     com_err_ ext entry options (variable);
dcl  conversion condition;
dcl  (char, convert, ltrim) builtin;

	new_line_length = 0;			/* init not to set */

	call cu_$af_return_arg (n_args, af_return_arg_ptr, af_return_arg_len, code);
	if code = error_table_$not_act_fnc then do;
	     active_fnc = "0"b;
	     error_routine = com_err_;
	end;
	else do;
	     active_fnc = "1"b;
	     error_routine = active_fnc_err_;
	end;
	
	if n_args > 1 then do;
	     call error_routine (error_table_$too_many_args, ME);
	     return;
	end;
	else if n_args = 1 then do;
		call cu_$arg_ptr (1, cmaxp, cmaxl, code);    /* get first arg */
		if code ^= 0 then do;		/* incorrect calling sequence */
		     call error_routine (code, ME, "");
		     return;
		     end;

		on conversion begin;
		     call error_routine ((0), ME, """^a"" is not a decimal integer.", cmax);
		     goto done;
		     end;

		new_line_length = convert (new_line_length, cmax);
		if new_line_length <= 4
		then do;			/* He doesn't seem to know what he's doing */

		     call com_err_ (0, ME, "Line length must be greater than 4.");
		     return;
		     end;

		ll_ch = "ll" || cmax;
		end;

	if n_args = 0 | active_fnc then do;		/* need old line length */
	     old_line_length = get_line_length_$switch (iox_$user_output, code);
	     if code ^= 0 then do;
		call error_routine (code, ME, "Determining old line length.");
		return;
	     end;
	end;
	
	if new_line_length > 0 then do;		/* Set new line length */
	     call iox_$modes (iox_$user_output, ll_ch, (""), code);
	     if code ^= 0 then do;
		call error_routine (code, ME, "Setting new line length of ^d", new_line_length);
		return;
	     end;
	end;
	
	if new_line_length > 0 then do;
	     call iox_$modes (iox_$user_output, ll_ch, "", code); /* set line length */

	     if code ^= 0 then do;
		call error_routine (code, ME, "^a", cmax);
		return;
		end;
	     end;

	if active_fnc then af_return_arg = ltrim (char (old_line_length));
	else if n_args = 0 then call ioa_ ("^d", old_line_length);

done:	return;

     end line_length;
  



		    parse_file_.pl1                 11/04/82  2006.8rew 11/04/82  1631.7       83646


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


/* PARSE_FILE_ - Character String Parsing Program.
   1/22/70 - Noel I. Morris
   with apologies to C. Garman		*/

/* last modified by E Stone on 14 Dec 1970 */

parse_file_$parse_file_init_name: proc (dir, entry, p, code);

dcl  name char (*),					/* segment name of segment to be examined */
     p ptr,					/* pointer to segment (returned) */
     code fixed bin (35);				/* error code */

dcl (segp ptr,					/* static pointer to segment */
     cur_pos fixed bin (17),				/* current scanning index */
     cur_nl fixed bin (17),				/* index of last NL encountered */
     line_no fixed bin,				/* current line number */
     msl fixed bin (17)) static;			/* maximum number of characters in segment */
						/*  less one */

dcl  NL char (1) static init ("
");

dcl 1 break_table static aligned,			/* table of break characters */
    2 bit (0:127) bit (1) unaligned;

dcl  bitcnt fixed bin (24),				/* bit count of segment */
     i fixed bin (17),				/* loop index */
     dir char (*),					/* directory path name of segment */
     dname char (168),
     entry char (*),				/* entry name of segment */
     ename char (32);

dcl (null, index, addr, divide, min, substr, fixed, unspec) builtin;

dcl (expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
     com_err_ entry options (variable)) ext;


/*  */

/* PARSE_FILE_INIT_NAME - Initialize Program.

   Calling Sequence:
   call parse_file_init_name (dir, entry, p, code);

   Where:
   dir	= directory path name of segment to be examined (input)
   entry	= entry name of segment to be examined (input)
   p	= pointer to segment (returned)
   code	= error code (returned)

*/

	code = 0;					/* Clear the error code. */

	call hcs_$initiate_count (dir, entry, "", bitcnt, 0, segp, code);
	if segp = null then return;			/* Test for null pointer returned. */
	code = 0;					/* Clear any residual error code. */

	p = segp;					/* Return pointer to segment. */
	msl = divide (bitcnt, 9, 18, 0) - 1;		/* Compute character count from bit count. */

common:
	cur_pos, cur_nl = 0;			/* Zero the position indices. */
	line_no = 1;				/* Start with the first line. */

	do i = 0 to 47, 58 to 64, 91 to 96, 123 to 127;	/* Set up the break table. */
	     break_table.bit (i) = "1"b;
	end;
	do i = 48 to 57, 65 to 90, 97 to 122;		/* 0-9, A-Z, a-z are not break characters. */
	     break_table.bit (i) = "0"b;
	end;

	return;					/* Return to caller. */


/*  */

/* PARSE_FILE_INIT_PTR - Initialize Program with Supplied Pointer.

   Calling Sequence:
   call parse_file_init_ptr (p, cc);

   Where:
   p	= pointer to segment (supplied).
   cc	= character count.

*/

parse_file_init_ptr: entry (p, cc);

dcl  cc fixed bin (17);				/* character count */


	segp = p;					/* Save pointer to segment. */
	msl = cc - 1;				/* Save character count. */

	go to common;				/* Tom VV says we should do this. */


/*  */

/* PARSE_FILE_SET_BREAK - Define Break Character(s).

   Calling Sequence:
   call parse_file_set_break (cs);

   Where:
   cs	= control string.  A break will be set for each
   character in the control string.

*/

parse_file_set_break: entry (cs);

dcl  cs char (*);					/* control string */

dcl  setting bit (1);				/* table setting */


	setting = "1"b;				/* Setting is on. */

set:
	do i = 1 to length (cs);			/* Scan the control string. */
	     c1 = substr (cs, i, 1);
	     break_table.bit (fixed (unspec (c1), 9)) = setting;
						/* Set appropriate bit. */
	end;

	return;


/*  */

/* PARSE_FILE_UNSET_BREAK - Undefine Break Character(s).

   Calling Sequence:
   call parse_file_unset_break (cs);

*/

parse_file_unset_break: entry (cs);


	setting = "0"b;				/* Setting is off. */
	go to set;				/* Join common code. */


/*  */

/* PARSE_FILE_ - Return Atom from Text.

   Calling Sequence:
   call parse_file_ (ci, cc, break, eof);

   Where:
   ci	= character index of start of atom (1st char = 1)
   cc	= count of characters in atom
   break	= non-zero if atom is single-character break
   eof	= non-zero if end of segment encountered

*/

parse_file_: entry (ci, cc, break, eof);

dcl  ci fixed bin (17),				/* character index */
     break fixed bin (1),				/* break indicator */
     eof fixed bin (1);				/* end-of-file indicator */

dcl  c1 char (1),					/* current character */
     sw fixed bin (1);				/* non-zero if pointer to be returned */

dcl 1 text based (segp) aligned,			/* text overlay declaration */
    2 ch (0:65535) char (1) unaligned;


	sw = 0;					/* Clear the return pointer switch. */

loop:
	if cur_pos > msl then do;			/* Test for end of file. */
seteof:	     eof = 1;				/* Set end-of-file switch. */
	     return;				/* Return to caller. */
	end;

	c1 = text.ch (cur_pos);			/* Grab current character. */

	if c1 <= " " then do;			/* Ignore all blanks and control characters. */
	     cur_pos = cur_pos + 1;			/* Step character position. */
	     if c1 = NL then do;			/* Test for new line character. */
		cur_nl = cur_pos;			/* Save position of beginning of line. */
		line_no = line_no + 1;		/* Count one line. */
	     end;
	     go to loop;				/* Try for another character. */
	end;

	if c1 = "/" then if cur_pos < msl then if text.ch (cur_pos + 1) = "*" then do;
						/* Test for a comment. */
		     do i = cur_pos + 2 to msl - 1;	/* Scan for end of comment. */
			if text.ch (i) = NL then line_no = line_no + 1; /* look for newlines in comment */
			if text.ch (i) = "*" then if text.ch (i + 1) = "/" then
				go to end_comment;
		     end;
		     go to seteof;			/* Hit the end of file. */
end_comment:
		     cur_pos = i + 2;		/* Step over the comment. */
		     go to loop;			/* And continue scan. */
		end;


/*  */

/* Arrive here after finding a non-break, non-comment sequence. */

break_search:
	do i = cur_pos to msl;			/* Scan through the text. */
	     c1 = text.ch (i);			/* Pick up current character. */
	     if break_table.bit (fixed (unspec (c1), 9)) then go to break_found;
						/* Exit loop on break character. */
	     if c1 = "/" then if text.ch (i + 1) = "*" then
		     go to break_found;		/* Test for sneaky comment. */
	end break_search;

break_found:
	if i = cur_pos then do;			/* Test for single character break. */
	     i = cur_pos + 1;			/* Step to character following break. */
	     break = 1;				/* Indicate break character found. */
	end;
	else					/* Non-break sequence. */
	break = 0;				/* Turn of break indication. */

	if sw = 0 then				/* If index desired ... */
	     ci = cur_pos + 1;			/* Return character index. */
	else
	p = addr (text.ch (cur_pos));			/* Return pointer to string. */
	cc = i - cur_pos;				/* Return character count. */
	eof = 0;					/* Turn off end-of-file switch. */
	cur_pos = i;				/* Update current character position. */

	return;


/*  */

/* PARSE_FILE_PTR - Return Pointer to Atom.

   Calling Sequence:
   call parse_file_ptr (p, cc, break, eof);

   Where:
   p	= pointer to atom (with bit offset)

*/

parse_file_ptr: entry (p, cc, break, eof);


	sw = 1;					/* Set switch. */
	go to loop;				/* Enter main scanning loop. */


/*  */

/* PARSE_FILE_CUR_LINE - Return Current Line Being Scanned.

   Calling Sequence:
   call parse_file_cur_line (ci, cc);

*/

parse_file_cur_line: entry (ci, cc);


	do i = cur_pos to msl while (text.ch (i) ^= NL);
						/* Scan to end of file or NL. */
	end;

	ci = cur_nl + 1;				/* Return index to beginning of line. */
	cc = min (i, msl) - cur_nl + 1;		/* Return correct character count. */

	return;


/*  */

/* PARSE_FILE_LINE_NO - Return the current line number in text.

   Calling sequence:
   call parse_file_line_no (ci);

   Where:
   ci	= current line number (returned)

*/

parse_file_line_no: entry (ci);


	ci = line_no;				/* This is a complicated entry. */
	return;					/* Isn't it? */


/*  */

/* PARSE_FILE_INIT - Initialize Program.

   Calling Sequence:
   call parse_file_init (name, p, code);

   Where:
   name	= name of segment to be examined
   p	= pointer to segment (returned)
   code	= error code

*/

parse_file_init: entry (name, p, code);


	code = 0;					/* Clear the error code. */

	call expand_pathname_ (name, dname, ename, code);
						/* Convert segment name. */
	if code ^= 0 then do;			/* Test for error. */
error:	     call com_err_ (code, "parse_file_", name);	/* Print error message. */
	     return;
	end;

	call hcs_$initiate_count (dname, ename, "", bitcnt, 0, segp, code);
	if segp = null then go to error;		/* Test for null pointer returned. */
	code = 0;					/* Clear any residual error code. */

	p = segp;					/* Return pointer to segment. */
	msl = divide (bitcnt, 9, 18, 0) - 1;		/* Compute character count from bit count. */

	go to common;

     end;
  



		    pool_manager_.pl1               03/15/89  0847.3r w 03/15/89  0800.0      263259


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

/* format: style2,indcomtxt */

pool_manager_:
     proc;

/*  System storage pool management module  */

/* Coded January 1975 by Stan C. Vestal */
/* Modified in Sept. 1975 by J. C. Whitmore to fix quota reference bug in clean_pool entry */
/* Modified in April 1976 by J. C. Whitmore to check for non-terminal quota when closing pool */
/* Modified 84-01-05 BIM to stop gratuitously fooling with quota.
   personid dirs are never given terminal quota now,
   since users lack access to take advantage of it.
   For perfection, card stuff should set max lengths. */
/* Modified 84-12-27 by Keith Loepere to set dir_quota. */
/* Modified 85-01-30 by Keith Loepere to be smarter about same. */

	return;					/*  shouldn't be called here */

	dcl     aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     convert_authorization_$encode
				 entry (bit (72) aligned, char (*));
	dcl     cu_$level_get	 entry returns (fixed bin);
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	dcl     get_authorization_	 entry returns (bit (72) aligned);
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     get_system_free_area_	 entry returns (ptr);
	dcl     hcs_$add_dir_acl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_inacl_entries
				 entry (char (*), char (*), ptr, fixed bin, fixed bin, fixed bin (35));
	dcl     hcs_$create_branch_	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$get_access_class	 entry (char (*), char (*), bit (72) aligned, fixed bin (35));
	dcl     hcs_$quota_get	 entry (char (*), fixed bin (18), fixed bin (35), bit (36) aligned, fixed bin,
				 fixed bin (1), fixed bin, fixed bin (35));
	dcl     hcs_$quota_move	 entry (char (*), char (*), fixed bin (18), fixed bin (35));
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$star_list_	 entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr,
				 fixed bin (35));
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     priv_move_quota_	 entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (35));
	dcl     system_privilege_$dir_priv_off
				 entry (fixed bin (35));
	dcl     system_privilege_$dir_priv_on
				 entry (fixed bin (35));
	declare pathname_		 entry (character (*), character (*)) returns (character (168));

	dcl     error_table_$ai_restricted
				 external fixed bin (35);
	dcl     error_table_$action_not_performed
				 external fixed bin (35);
	dcl     error_table_$rqover	 external fixed bin (35);
	dcl     error_table_$invalid_move_qmax
				 external fixed bin (35);
	dcl     error_table_$invalid_move_quota
				 external fixed bin (35);
	dcl     error_table_$namedup	 external fixed bin (35);
	dcl     error_table_$no_dir	 external fixed bin (35);
	dcl     error_table_$nomatch	 external fixed bin (35);
	dcl     error_table_$nondirseg external fixed bin (35);
	dcl     error_table_$noentry	 external fixed bin (35);
	dcl     error_table_$notadir	 external fixed bin (35);


	dcl     a_path		 char (*);
	dcl     a_personid		 char (*);	/*  person name for this pool entry */
	dcl     a_grace_quota	 fixed bin;	/* quota to be left on access class dir over used */
	dcl     ac		 bit (72) aligned;	/*  bit rep of access_class for desired personid dir */
	dcl     access		 bit (36) aligned;	/*  mode to set in inacl of access_class_dir */
	dcl     access_class_dir	 char (32);	/*  entry name for the access_class directory */
	dcl     access_class_path	 char (168);	/*  full pathname of access_class_dir */
	dcl     access_quota	 fixed bin (18);	/*  quota on access_class_dir */
	dcl     access_used		 fixed bin;	/*  pages used on access_class_dir */
	dcl     age		 fixed bin;	/*  age olde than which segs are to be deleted */
	dcl     all_switches	 bit (6);		/*  for both */
	dcl     bc		 fixed bin;	/*  number of dirs and segs in dir */
	dcl     bitcnt		 fixed bin (24);	/*  bit count of branch entry */
	dcl     caller_auth		 bit (72) aligned;	/*  access_class of the process */
	dcl     code		 fixed bin (35);	/*  error code */
	dcl     dir_switches	 bit (6);		/*  and for dirs */
	dcl     dir_lk_switches	 bit (6);		/* and for dirs and links only */
	dcl     dum72		 bit (72) aligned;	/*  dummy for time storage */
	dcl     ec		 fixed bin (35);	/*  return error code */
	dcl     grace_quota		 fixed bin;	/*  amount of quota in excess of used to leave of dir */
	dcl     i			 fixed bin;	/*  loop index */
	dcl     infqcnt		 fixed bin;	/*  no. of inferior dirs with terminal quota */
	dcl     key_path		 (2) char (168) int static init (">ddd>tape_pool", ">ddd>cards");
	dcl     keyword		 (2) char (168) int static init ("System_Tape_Pool", "System_Card_Pool");
	dcl     lc		 fixed bin;	/*  numbe of links in dir */
	dcl     limit		 fixed bin (71);	/*  max age of segment to be deleted */
	dcl     mask		 bit (36) aligned;
	dcl     mask_set		 bit (1) aligned;
	dcl     msdays		 fixed bin (71);	/*  age in microseconds */
	dcl     need_priv		 bit (1) int static;/* on if the process is upgraded WRT root */
	dcl     no_of_keywords	 fixed bin init (2);/*  number of known keywords */
	dcl     now		 fixed bin (71);	/*  time of day in clock_ terms */
	dcl     old_mask		 bit (36) aligned;
	dcl     path		 char (168);	/* pathname of personid dir */
	dcl     person_path		 char (168);	/*  pathname of personid dir */
	dcl     personid		 char (32);
	dcl     pool_access_class	 bit (72) aligned int static;
						/*  access class of the pool dirs */
	dcl     pool_dir_parent	 char (168);	/*  dir portion of pool root */
	dcl     pool_dirname	 char (32);	/*  entry portion of pool root */
	dcl     pool_root_dir	 char (168);	/*  pool root directory */
	dcl     priv_code		 fixed bin (35) init (1);
	dcl     quota		 fixed bin;	/*  desired quota on the access class dir */
	dcl     quota_change	 fixed bin (18);	/*  amount of quota to move */
	dcl     root		 char (168);	/*  path of the pool root or keyword */
	dcl     root_quota		 fixed bin (18);	/*  quota on pool_root_dir */
	dcl     root_used		 fixed bin;	/*  pages used in pool_root_dir */
	dcl     rt		 char (*);
	dcl     seg_switches	 bit (6);		/*  delete_$path switches for segments */
	dcl     taccsw		 fixed bin (1);	/*  on if terminal quota on this dir */
	dcl     trp		 fixed bin (35);	/*  time-record product */
	dcl     tup		 bit (36) aligned;	/*  time trp last updated */
	dcl     type		 fixed bin (2);	/*  branch type from status_minf */
	dcl     (adumdir, pdumdir)	 char (168);	/*  pathnames */
	dcl     (aname, pname, sname)	 char (32);	/*  directory and segment names */
	dcl     (area_ptr, eptr, nptr, aep, peptr, pnptr, pep, septr, snptr, sep)
				 ptr init (null);
	dcl     (j, k)		 fixed bin;	/*  loop indices */
	dcl     (no_of_adirs, no_of_pdirs, no_of_segs)
				 fixed bin;
	dcl     (person_del_count, seg_del_count)
				 fixed bin;	/*  number of deletes performed */

	dcl     1 create_info	 aligned like create_branch_info;
						/* real storage for the create branch structure */

%include create_branch_info;

	dcl     acl_count		 fixed bin;	/*  number of acl entries */

	dcl     1 dir_acl		 (2) aligned,	/*  ACL structure for hcs_ entries */
		2 access_name	 char (32),	/*  access name */
		2 dir_modes	 bit (36),	/*  sma for the dir, bits 0,1,2 resp. */
		2 status_codes	 fixed bin (35);	/*  status for the access_name */

	dcl     entries		 (bc + lc) bit (144) aligned based;

	dcl     1 branch		 aligned based,
	        ( 2 type		 bit (2),
		2 nname		 bit (16),
		2 nindex		 bit (18),
		2 dtm		 bit (36),
		2 dtu		 bit (36),
		2 mode		 bit (5),
		2 pad		 bit (13),
		2 records		 bit (18)
		)		 unaligned;

	dcl     names		 (1000) char (32) aligned based;

	dcl     (addr, clock, divide, fixed, index, max, min, null, rtrim, substr, unspec)
				 builtin;

	dcl     (any_other, cleanup)	 condition;

	dcl     1 status_info	 aligned,
	        ( 2 type		 bit (2),
		2 nnames		 bit (16),
		2 nrp		 bit (18),
		2 dtm		 bit (36),
		2 dtu		 bit (36),
		2 mode		 bit (5),
		2 pad1		 bit (13),
		2 records		 bit (18),
		2 dtd		 bit (36),
		2 dtem		 bit (36),
		2 pad2		 bit (36),
		2 curlen		 bit (12),
		2 bitcnt		 bit (24),
		2 did		 bit (4),
		2 pad3		 bit (4),
		2 copysw		 bit (9),
		2 pad4		 bit (9),
		2 rbs		 (0:2) bit (6),
		2 uid		 bit (36)
		)		 unaligned;


init:
     entry (rt, quota, access, ec);			/*  first entry point called by a process managing pools */

/*  This entry requires that the caller have access to the system_privilege_ gate  */

	root = rt;

	call parse_root;

	call expand_pathname_ (pool_root_dir, pool_dir_parent, pool_dirname, ec);
	if ec ^= 0
	then return;				/*  trouble? */

	call hcs_$get_access_class (pool_dir_parent, pool_dirname, pool_access_class, ec);
						/*  used to determine if pool exists */
	if ec ^= 0
	then return;				/*  it doesn't, can't continue */

	if aim_check_$equal (caller_auth, pool_access_class)
	then need_priv = "0"b;
	else need_priv = "1"b;			/* must be able to call system_privilege_ gate */

	call hcs_$get_access_class (pool_root_dir, access_class_dir, pool_access_class, code);
						/*  dir already exist */

	if code = 0
	then do;					/*  yes, were through */
		if ^aim_check_$equal (caller_auth, pool_access_class)
		then do;
			ec = error_table_$ai_restricted;
			return;
		     end;
		acl_count = 1;
		dir_acl (1).dir_modes = "111"b || (33)"0"b;
		dir_acl (1).access_name = get_group_id_$tag_star ();
		mask = (36)"0"b;
		mask_set = "0"b;
		on cleanup call clean_up;
		on any_other go to condition_error;
		if need_priv
		then do;				/* only set the privileges when needed */
			call hcs_$set_ips_mask (mask, old_mask);
			mask_set = "1"b;
			call system_privilege_$dir_priv_on (priv_code);
		     end;
		call hcs_$add_dir_acl_entries (pool_root_dir, access_class_dir, addr (dir_acl), acl_count, ec);

		if priv_code = 0
		then do;				/*  be sure we reset privileges as found */
			call system_privilege_$dir_priv_off (priv_code);
			priv_code = 1;		/*  so we won't do it again */
		     end;

		revert any_other;			/*  we don't want to catch ips signals */

		if mask_set
		then do;
			mask_set = "0"b;
			call hcs_$set_ips_mask (old_mask, mask);
						/*  let'er rip */
		     end;

		return;
	     end;

	if code = error_table_$noentry
	then do;					/*  have to create it */
						/*  build branch structure */

		create_info.version = create_branch_version_2;
		create_info.copy_sw = "0"b;
		create_info.chase_sw = "0"b;		/* we should never chase a link to create */
		create_info.priv_upgrade_sw = "0"b;	/* not a ring 1 special seg */
		create_info.parent_ac_sw = "0"b;	/* we will give the access class */
		create_info.mbz1 = (31)"0"b;		/* this must be zero */
		create_info.bitcnt = 0;
		create_info.mbz2 = (33)"0"b;
		create_info.dir_sw = "1"b;
		create_info.mode = "100"b;
		create_info.userid = "*.*.*";		/* always give "s" to *.*.* */
		i = cu_$level_get ();		/* to get around a compiler bug */
		create_info.rings (*) = i;
		create_info.quota = quota;
		create_info.dir_quota = max (10, divide (quota, 10, 17));
		pool_access_class = caller_auth;	/* save this for future calls */
		create_info.access_class = pool_access_class;

		mask_set = "0"b;			/*  info to the handler */
		mask = (36)"0"b;

		on cleanup call clean_up;
		on any_other go to condition_error;

		if need_priv
		then do;				/* only when we need to */
			call hcs_$set_ips_mask (mask, old_mask);
			mask_set = "1"b;

			call system_privilege_$dir_priv_on (priv_code);
		     end;

create_branch:
		call hcs_$create_branch_ (pool_root_dir, access_class_dir, addr (create_info), code);

		if code = error_table_$invalid_move_qmax
		then if create_info.dir_quota = 0
		     then go to error;
		     else do;			/* try create without dir quota */
			     create_info.dir_quota = 0;
			     go to create_branch;
			end;
		else if code ^= 0
		then go to error;			/*  unable to create */

		acl_count = 2;			/*  set the ACL of access_class_dir */
		dir_acl (1).access_name = get_group_id_$tag_star ();
						/*  sma for *.SysDaemon.* */
		dir_acl (1).dir_modes = "111"b || (33)"0"b;
		dir_acl (2).dir_modes = "100"b || (33)"0"b;
						/* there is only s to *.*.* at this level */
		dir_acl (2).access_name = "*.*.*";

		call hcs_$add_dir_acl_entries (pool_root_dir, access_class_dir, addr (dir_acl), acl_count, code);

		if code ^= 0
		then go to error;

		if priv_code = 0
		then /* if we set the priv, reset it */
		     call system_privilege_$dir_priv_off (priv_code);

		priv_code = 1;			/* so we don't try again */

		revert any_other;			/* let ips signals fall through */

		if mask_set
		then do;
			mask_set = "0"b;
			call hcs_$set_ips_mask (old_mask, mask);
						/* restore the mask as we found it */
		     end;

		dir_acl (2).dir_modes = access & "100"b || (33)"0"b;
						/* set initial ACL as caller requested (limit = s) */

		call hcs_$add_dir_inacl_entries (pool_root_dir, access_class_dir, addr (dir_acl), acl_count, 4, ec);

		return;
	     end;

	go to error;

open_user_pool:
     entry (rt, a_personid, a_path, ec);

	personid = a_personid;
	root = rt;

	path, a_path = "";

	call parse_root;				/*  determine the pool root directory name */

	access_class_path = pathname_ (pool_root_dir, access_class_dir);

/*	see if there is sufficient quota to create the person directory */

	call hcs_$quota_get (access_class_path, access_quota, trp, tup, infqcnt, taccsw, access_used, ec);
	if ec ^= 0
	then return;				/* OOPS */

	if access_quota <= access_used
	then /* cover all bets, must be greater */
	     call add_quota (root, (access_used - access_quota) + 2, ec);
						/* try for quota of 2 pages */
						/* if not enough quota, keep going..user's dir may exist */
						/* don't check the code */

/*  build create_branch_ structure   */

	create_info.version = create_branch_version_2;
	create_info.copy_sw = "0"b;
	create_info.chase_sw = "0"b;			/* don't want to chase any links */
	create_info.priv_upgrade_sw = "0"b;		/* not a ring 1 special seg */
	create_info.mbz1 = "0"b;			/* must be zero */
	create_info.mbz2 = (33)"0"b;
	create_info.bitcnt = 0;
	create_info.dir_sw = "1"b;
	create_info.mode = "100"b;			/* new dir will have "s" to personid at the start */
	i = cu_$level_get ();			/* to get around a compiler bug */
	create_info.rings (*) = i;
	create_info.userid = substr (personid, 1, index (personid, " ") - 1) || ".*.*";
	create_info.quota = 0;
	create_info.dir_quota = 0;
	create_info.access_class = caller_auth;		/* we always run at the callers authorization */

	call hcs_$create_branch_ (access_class_path, personid, addr (create_info), ec);

	if ec = error_table_$namedup | ec = 0
	then do;					/* keep going as long as it is there */

		acl_count = 2;
		dir_acl (1).dir_modes = "111"b || (33)"0"b;
		dir_acl (1).access_name = get_group_id_$tag_star ();
		dir_acl (2).dir_modes = "100"b || (33)"0"b;
						/* give the user only s permission */
		dir_acl (2).access_name = rtrim (personid) || ".*.*";
						/* so he can't delete while we are writing */
		call hcs_$add_dir_acl_entries (access_class_path, personid, addr (dir_acl), acl_count, ec);

		if ec ^= 0
		then return;

		person_path = pathname_ (access_class_path, personid);
						/*  build pathname */
		a_path = person_path;		/*  quota set to zero, give user the pathname */
		ec = 0;				/*  return good status */
		return;
	     end;
	return;					/*  code was not namedup or 0 */


add_quota:
     entry (rt, quota, ec);

/*  This entry requires that the caller have access to the system_privilege_ gate */

	ec = 0;					/* be ready for a clean exit */
	if quota = 0
	then return;				/*  meaningless call */

	root = rt;

	call parse_root;				/*  determine the pool_root_dir */

	if quota < 0
	then do;					/*  user wants to move quota back to pool_root_dir */

		access_class_path = pathname_ (pool_root_dir, access_class_dir);
		call hcs_$quota_get (access_class_path, access_quota, trp, tup, infqcnt, taccsw, access_used, ec);
						/*  get quota info for the dir */

		if ec ^= 0
		then return;

		if access_used = 0
		then access_used = 1;		/* min used = 1, can't make quota non-terminal */

		if access_used >= access_quota
		then do;				/* any quota to move? */
			if -quota >= access_quota
			then ec = error_table_$invalid_move_quota;
						/* choose an error code */
			else ec = error_table_$rqover;
			return;
		     end;

		quota_change = -(min (-quota, (access_quota - access_used)));
						/*  move only what is not in use */

	     end;
	else do;					/* move quota to the access class pool dir */

		call hcs_$quota_get (pool_root_dir, root_quota, trp, tup, infqcnt, taccsw, root_used, ec);
						/*  get quota data on pool_root_dir */

		if ec ^= 0
		then return;

		if root_used = 0
		then root_used = 1;			/* min used = 1, can't make root non-terminal */

		if root_used >= root_quota
		then do;				/* see if there is any to move */
			if quota >= root_quota
			then ec = error_table_$invalid_move_quota;
						/* choose an error code */
			else ec = error_table_$rqover;
			return;
		     end;

		quota_change = min (root_quota - root_used, quota);
						/*  can move only up to used */
	     end;

	if need_priv
	then /* only use the privileged call if needed */
	     call priv_move_quota_ ((pool_root_dir), (access_class_dir), (quota_change), ec);
	else call hcs_$quota_move (pool_root_dir, access_class_dir, quota_change, ec);

	return;

close_user_pool:
     entry (rt, a_personid, quota, access, ec);

	root = rt;
	personid = a_personid;
	call parse_root;				/*  determine the pool root dir */

	access_class_path = pathname_ (pool_root_dir, access_class_dir);
	acl_count = 1;				/*  replace the acl for Person.*.* */
	dir_acl (1).access_name = rtrim (personid) || ".*.*";
	dir_acl (1).dir_modes = access & "110"b || (33)"0"b;
						/*  "sm" limit on caller specified access */
	call hcs_$add_dir_acl_entries (access_class_path, personid, addr (dir_acl), acl_count, ec);
	if ec ^= 0
	then return;
	return;					/*  all done */


find_pool:
     entry (rt, ac, a_personid, a_path, ec);

	path, a_path = "";
	personid = a_personid;
	root = rt;

	call parse_root;				/*  find the pool_root_dir */

	call convert_authorization_$encode (ac, access_class_dir);
						/*  might be asking about some other level */

	if access_class_dir = ""
	then access_class_dir = "system_low";

	access_class_path = pathname_ (pool_root_dir, access_class_dir);

	call hcs_$status_minf (access_class_path, personid, 0, type, bitcnt, code);

	if code ^= 0
	then do;					/*  non-zero code may be useful */

		if code = error_table_$noentry | code = error_table_$no_dir
		then do;				/*  access_class_dir>personid does not exist */
			code = error_table_$noentry;
return_path:
			a_path = pathname_ (access_class_path, personid);
			ec = code;		/*  return the correct path and tell him it doesn't exist */
			return;
		     end;

		a_path = "";			/*  don't give him a path for any other error */
		ec = code;			/*  copy the code and let the user figure it out */
		return;

	     end;

/*  zero code means we found a branch */

	if type = 2
	then go to return_path;			/*  must be a directory, however */

	ec = error_table_$notadir;			/*  if a seg or link, tell him not found */
	a_path = "";
	return;


clean_pool:
     entry (rt, age, a_grace_quota, ec);		/*  garbage collection entry */

/*  This entry requires that the caller have access to the system_privilege_ gate */

/*  We will walk through the entire pool hierarchy deleting entries which should
   not be there or have been there too long */

	priv_code = 1;				/*  only reset privileges if set */
	mask_set = "0"b;				/*  we have not changed the ips mask yet */
	mask = (36)"0"b;

	on cleanup call clean_up;			/*  establish handlers for consistency */
	on any_other go to condition_error;

	call hcs_$set_ips_mask (mask, old_mask);	/*  don't want any interrupts */
	mask_set = "1"b;
	call system_privilege_$dir_priv_on (priv_code);

	root = rt;				/*  copy args */
	call parse_root;				/*  get pname and auth for caller */

	msdays = age * 86400000000;			/*  convert time to msecs */
	now = clock ();
	limit = now - msdays;

	grace_quota = max (0, a_grace_quota);		/* must be 0 or positive */
	area_ptr = get_system_free_area_ ();

	seg_switches = "100100"b;			/*  for force deleting segments only - no questions */
	dir_switches = "101000"b;			/*  deletes dirs only */
	all_switches = "101110"b;			/*  deletes everything */
	dir_lk_switches = "101010"b;			/*  deletes just directory or link */

	call hcs_$star_list_ (pool_root_dir, "*", 2, area_ptr, bc, lc, eptr, nptr, code);

	if code = error_table_$nomatch
	then do;					/*  empty pool */
empty:
		ec = 0;				/*  we did what was asked */
		if priv_code = 0
		then call system_privilege_$dir_priv_off (priv_code);
						/* undo what we did */
		priv_code = 1;
		revert any_other;			/*  now the handler can be reset */
		call clean_up;			/*  free storage and reset privileges */
		return;
	     end;

	if code ^= 0
	then go to error;				/*  all other codes are bad news */

	no_of_adirs = bc + lc;			/*  number of entries in pool */

start_adir_loop:
	do i = 1 to no_of_adirs;			/*  look at each entry in the pool root dir */

	     aep = addr (eptr -> entries (i));		/*  get ptr to an entry */
	     if aep -> branch.type ^= "10"b
	     then go to end_adir_loop;		/*  if not a dir, then skip it */

	     aname = nptr -> names (fixed (aep -> branch.nindex, 17));
						/*  get its name */
	     adumdir = pathname_ (pool_root_dir, aname);	/*  and make a pname */

	     call hcs_$star_list_ (adumdir, "*", 3, area_ptr, bc, lc, peptr, pnptr, code);
						/*  now look in it */

	     if code = error_table_$nomatch
	     then do;				/*  it is empty */
		     code = 0;
		     no_of_pdirs, person_del_count = 0;
		     go to start_pdir_loop;
		end;

	     if code ^= 0
	     then go to end_adir_loop;		/*  oh well, try the next one */

	     person_del_count = 0;			/*  its not empty, init the delete count */
	     no_of_pdirs = bc + lc;			/*  no of entries in the access_class_dir */

start_pdir_loop:
	     do j = 1 to no_of_pdirs;			/*  look at everything in this access_class_dir */
		pep = addr (peptr -> entries (j));	/*  get an entry */
		pname = pnptr -> names (fixed (pep -> branch.nindex, 17));
						/*  build a name */
		pdumdir = pathname_ (adumdir, pname);

		if pep -> branch.type ^= "10"b
		then do;				/*  if not a dir then delete it */
delete_pdir:
			call delete_$path (adumdir, pname, all_switches, "pool_manager_", code);
			if code = 0
			then person_del_count = person_del_count + 1;
						/*  bump the count */
			go to end_pdir_loop;
		     end;

		call hcs_$status_long (adumdir, pname, 0, addr (status_info), null, code);
		if code ^= 0
		then go to end_pdir_loop;		/* trouble, try the next one */

		dum72 = "0"b;			/*  see if we can delete it without looking at entries */
		substr (dum72, 21, 36) = status_info.dtem;
						/*  get the dtem */
		if dum72 < unspec (limit)
		then go to delete_pdir;		/*  is it old */

		call hcs_$star_list_ (pdumdir, "**", 3, area_ptr, bc, lc, septr, snptr, code);
						/* no, must search it */

		if code = error_table_$nomatch
		then do;				/*  empty? */
			code = 0;
			no_of_segs, seg_del_count = 0;
			go to start_seg_loop;
		     end;

		if code ^= 0
		then go to end_pdir_loop;		/*  keep trying */

		seg_del_count = 0;			/*  get ready to look at segs in the person dir */
		no_of_segs = bc + lc;
start_seg_loop:
		do k = 1 to no_of_segs;		/*  look at each entry in person dir */
		     sep = addr (septr -> entries (k)); /*  get the entry */
		     sname = snptr -> names (fixed (sep -> branch.nindex, 17));
		     if sep -> branch.type ^= "01"b
		     then do;			/*  delete if not a segment */
			     call delete_$path (pdumdir, sname, dir_lk_switches, "pool_manager_", code);
			     if code = 0
			     then do;		/* we deleted it */
				     seg_del_count = seg_del_count + 1;
				     go to end_seg_loop;
				end;
			     if code ^= error_table_$nondirseg
			     then go to end_seg_loop; /* someone using it */
						/* otherwise, it was an MSF */
			end;


		     dum72 = "0"b;
		     substr (dum72, 21, 36) = sep -> branch.dtm;
						/*  get its age */

		     if dum72 < unspec (limit)
		     then do;			/*  can we delete it */

			     call delete_$path (pdumdir, sname, seg_switches, "pool_manager_", code);
			     if code = 0
			     then seg_del_count = seg_del_count + 1;
						/*  bump the delete count */
			     call hcs_$quota_move (adumdir, pname, -fixed (sep -> branch.records), code);
						/* recover quota */
			end;
end_seg_loop:
		end;
		if seg_del_count = no_of_segs
		then do;				/*  is the dir empty */
			call delete_$path (adumdir, pname, dir_switches, "pool_manager_", code);
						/*  if so delete it */
			if code = 0
			then person_del_count = person_del_count + 1;
		     end;

end_pdir_loop:
		if septr ^= null
		then free septr -> entries;
		if snptr ^= null
		then free snptr -> names;

	     end;

	     if person_del_count = no_of_pdirs
	     then do;				/*  is the access class dir empty */
		     call delete_$path (pool_root_dir, aname, dir_switches, "pool_manager_", code);
		     if code = 0
		     then go to end_adir_loop;	/* when deleted, we are done */
						/* otherwise try to move back to grace quota */
		end;

	     call hcs_$quota_get (adumdir, access_quota, trp, tup, infqcnt, taccsw, access_used, code);
	     if code ^= 0
	     then go to end_adir_loop;

	     quota_change = access_quota - max ((access_used + grace_quota), 1);
						/* adjust the quota */
	     if quota_change ^= 0
	     then /* if anything to move.... */
		call hcs_$quota_move (pool_root_dir, aname, (-quota_change), code);

end_adir_loop:
	     if peptr ^= null
	     then free peptr -> entries;
	     if pnptr ^= null
	     then free pnptr -> names;

	end;

	ec, code = 0;				/* just to be sure we say all is well */

	if priv_code = 0
	then call system_privilege_$dir_priv_off (priv_code);
	priv_code = 1;				/*  make it safe to revert the condition handler */

	revert any_other;				/* in case a condition occurs from clean_up */

	call clean_up;

	return;

/**/

error:
	ec = code;				/*  copy the status */

	if priv_code = 0
	then call system_privilege_$dir_priv_off (priv_code);
	priv_code = 1;

	revert any_other;

	call clean_up;

	return;					/*  and exit */


condition_error:					/*	Some condition occured.  Don't know the status of anything so we must */
						/*	return a failure code so we don't fool the caller */
	ec = error_table_$action_not_performed;

	if priv_code = 0
	then call system_privilege_$dir_priv_off (priv_code);
	priv_code = 1;

	revert any_other;				/* in case of a condition during clean_up */

	call clean_up;

	return;

parse_root:
     proc;

	do i = 1 to no_of_keywords;			/*  check for keyword match */
	     if root = keyword (i)
	     then go to hit;			/*  found a match */
	     else ;				/*  keep looking */
	end;

	pool_root_dir = root;			/*  must be a pathname */
	go to get_auth;				/*  determine the authorization */

hit:
	pool_root_dir = key_path (i);			/*  select the appropriate path */

get_auth:
	caller_auth = get_authorization_ ();		/*  get the access_class of the process */

	call convert_authorization_$encode (caller_auth, access_class_dir);
						/*  convert to a unique name */

	if access_class_dir = ""
	then access_class_dir = "system_low";

	return;


     end;


clean_up:
     proc;

/*  This internal proc is the handler for all conditions, cleanup, and a
   general tidying up routine.  However, if there is a default handler
   active which will call this, we are open to recursive errors or a tight loop.
   The freen_ proc could signal the area condition and there could be a
   linkage error on system_privilege_.  So, beware of the conditions at the
   time it is called.  */


	if priv_code = 0
	then call system_privilege_$dir_priv_off (priv_code);
						/*  turn priv off in case one is left */
	priv_code = 1;				/* don't do it again */

	if mask_set
	then do;

		mask_set = "0"b;			/* reset before any ips signal can interrupt */
		call hcs_$set_ips_mask (old_mask, mask);/* open the gate */

	     end;


	if septr ^= null
	then free septr -> entries;
	if snptr ^= null
	then free snptr -> names;
	if peptr ^= null
	then free peptr -> entries;
	if pnptr ^= null
	then free pnptr -> names;
	if eptr ^= null
	then free eptr -> entries;
	if nptr ^= null
	then free nptr -> names;


	return;
     end;

     end pool_manager_;
 



		    print_attach_table.pl1          02/06/84  1105.5r   02/06/84  1102.3      113472


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


/* Modified 10/06/83 by Charlie Spitzer. make it pay attention to -open/-att if
				 not doing star names. phx9394 */

print_attach_table:
pat: proc ();

dcl (ap, rsp) pointer,
    (al, rsl, nargs, argno) fixed bin,
     arg char (al) based (ap),
     rs char (rsl) varying based (rsp);

dcl 1 names (100) aligned,
    2 name char (32) unaligned,
    2 star bit (1) aligned,
    2 match bit (1) aligned;
dcl  name_count fixed bin;

dcl  out_str char (1024) varying;
dcl (i, j, k, len1, len2, len3, t1) fixed bin;
dcl (af_sw, default, no_names_specified, star_sw, brief_sw, switch_processed) bit (1) aligned;
dcl  select_type fixed bin;
dcl  code fixed bin (35);
dcl  iocb_ptr pointer;
dcl  attach_desc_ptr pointer;
dcl  open_desc_ptr pointer;

dcl  varying_string char (4096) varying based;

dcl  cu_$af_return_arg entry (fixed bin, pointer, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, pointer, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  active_fnc_err_ entry options (variable);
dcl  check_star_name_$entry entry (char (*), fixed bin (35));
dcl  match_star_name_ entry (char (*), char (*), fixed bin (35));
dcl  iox_$find_iocb_n entry (fixed bin, pointer, fixed bin (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed bin, fixed bin (35));

dcl  complain entry variable options (variable);

dcl  iox_$user_output pointer external;
dcl (error_table_$not_act_fnc,
     error_table_$badopt,
     error_table_$inconsistent,
     error_table_$noarg,
     error_table_$bigarg,
     error_table_$nomatch) fixed bin (35) external;


dcl  whoami char (32) aligned internal static options (constant) init ("print_attach_table");
dcl  newline char (1) aligned internal static options (constant) init ("
");
dcl  spaces char (80) aligned internal static options (constant) init ("");
dcl  not_attached char (32) varying internal static options (constant) init ("(not attached)");
dcl  not_open char (32) varying internal static options (constant) init ("(not open)");
dcl  null_string char (0) varying internal static options (constant) init ("");  /* open desc for syn_ attachments */
dcl  standard_switches (4) char (32) aligned internal static options (constant) init
    ("user_i/o", "user_output", "user_input", "error_output");

dcl (substr, length, rtrim, addr, null) builtin;

/**/

%include iocb;

/**/

	call cu_$af_return_arg (nargs, rsp, rsl, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     rs = "";
	     complain = active_fnc_err_;
	     end;

	else if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     rsp = null ();
	     complain = com_err_;
	     end;

	else do;
	     call com_err_ (code, whoami);
	     return;
	     end;

	brief_sw = "0"b;				/* default is to mention 4 standard ones */
	no_names_specified = "0"b;			/* true only if no names are specified */
	select_type = 0;

	name_count = 0;				/* initialize */
	do i = 1 to nargs;				/* look through arguments */
	     call cu_$arg_ptr (i, ap, al, code);
	     if substr (arg, 1, 1) = "-" then do;	/* control argument */
		if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
		else if arg = "-open" then do;
		     if select_type = 0 then select_type = 3;	/* set it */
		     else do;			/* otherwise, complina */
only_one_select_type:	call complain (error_table_$inconsistent, whoami,
			     "Only one of -open, -attached, or -all is allowed.");
			return;
			end;
		     end;

		else if arg = "-attached" | arg = "-att" then do;
		     if select_type = 0 then select_type = 2;
		     else goto only_one_select_type;
		     end;

		else if arg = "-all" | arg = "-a" then do;
		     if select_type = 0 then select_type = 1;
		     else goto only_one_select_type;
		     end;

		else if arg = "-name" | arg = "-nm" then do;	/* this one is NOT a starname */
		     if i = nargs then do;
			call complain (error_table_$noarg, whoami, "after -name.");
			return;
			end;

		     i = i + 1;
		     call cu_$arg_ptr (i, ap, al, code);

		     call add_to_list (arg, "0"b);		/* not a starname */
		     end;

		else do;
		     call complain (error_table_$badopt, whoami, "^a", arg);
		     return;
		     end;

		end;				/* of control argument processing */

	     else do;				/* it wasn't a control argument */
		call add_to_list (arg, "1"b);		/* since it wasn't a control arg, must be a starname */
		end;
	     end;

	if select_type = 0 then do;			/* if wasn't specified */
	      select_type = 2;			/* only attached switches */
	      default = "1"b;			/* for error msg if no match found */
	      end;
	 else default = "0"b;

	if name_count = 0 then do;			/* he didn't give any, so give the default */
	     call add_to_list ("**", "1"b);
	     no_names_specified = "1"b;		/* remember that we are looking at "all" switches */
	     end;

	do i = 1 by 1;				/* loop through all the switches */
	     call iox_$find_iocb_n (i, iocb_ptr, code);
	     if code ^= 0 then goto epilogue;		/* we've run out of switches */

	     switch_processed = "0"b;			/* nothing has been printed for this one yet */
	     do j = 1 to name_count;			/* loop thru all the names we're supposed to look for */

		if names.star (j) then do;
		     call match_star_name_ ((iocb_ptr -> iocb.name), names.name (j), code);
		     if code ^= 0 then goto next_name;	/* didn't match */

/*	check our other criteria now, like -brief and -all, -open, and -attached */

		     if brief_sw then do k = 1 to hbound (standard_switches, 1);
			if iocb_ptr -> iocb.name = standard_switches (k) then goto end_loop;  /* don't print it */
			end;

		     if select_type = 3 & (iocb_ptr -> iocb.open_descrip_ptr = null ()
			| iocb_ptr -> iocb.attach_descrip_ptr = null ()
			| iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr)  /* special crock for syn_ attachments */
			then goto end_loop;		/* not open */
		     if select_type = 2 & iocb_ptr -> iocb.attach_descrip_ptr = null () then goto end_loop;  /* not attached */

		     if ^switch_processed then
			call process_iocb (iocb_ptr);	/* it passed all our tests */
		     names.match (j) = "1"b;		/* remember that something matched this one */
		     switch_processed = "1"b;
		     goto next_name;			/* to avoid printing it twice */
		     end;				/* of starname case */

		else do;				/* we're looking for an explicit match */
		     if names.name (j) ^= iocb_ptr -> iocb.name then goto next_name;	/* not this one */

		     if select_type = 3 & (iocb_ptr -> iocb.open_descrip_ptr = null ()
			| iocb_ptr -> iocb.attach_descrip_ptr = null ()
			| iocb_ptr -> iocb.actual_iocb_ptr ^= iocb_ptr)  /* special crock for syn_ attachments */
			then goto end_loop;		/* not open */
		     if select_type = 2 & iocb_ptr -> iocb.attach_descrip_ptr = null () then goto end_loop;  /* not attached */

		     if ^switch_processed then
			call process_iocb (iocb_ptr);	/* process it */
		     names.match (j) = "1"b;		/* remember that we found this one */
		     switch_processed = "1"b;		/* to avoiod printing it more than once */
		     goto next_name;
		     end;
next_name:
		end;				/* of loop through possible names */

end_loop:
	     end;					/* of loop through IOCB's */

epilogue:

	if ^af_sw then do i = 1 to name_count;		/* print our error messages */
	     if names.match (i) = "0"b then do;		/* didn't find this one */
		if names.star (i) = "1"b then
		     if no_names_specified
		     then if default | select_type = 1
			then call complain (0, whoami, "No non-standard I/O switches found.");
		          else call complain (0, whoami, "No non-standard ^[attached^;open^] I/O switches found.", select_type=2);

		     else if default | select_type = 1	/* complain about a specific starname */
			then call complain (0, whoami, "No I/O switches matching the star name ^a.", names.name (i));
			else call complain (0, whoami, "No ^[attached^;open^] I/O switches matching the star name ^a.", select_type=2, names.name (i));


		else if default | select_type = 1
		     then call complain (0, whoami, "No I/O switch matching the name ^a.", names.name (i));
		     else call complain (0, whoami, "No ^[attached^;open^] I/O switch matching the name ^a.", select_type=2, names.name (i));
		end;
	     end;					/* of error printing loop */

main_return:
	return;					/* our work's all done */

/**/

/*	INTERNAL PROCEDURES	*/

add_to_list: proc (P_name, P_star_sw);	/* procedure to add a name to the naemes array */

dcl (P_name char (*),
     P_star_sw bit (1) aligned) parameter;

	star_sw = P_star_sw;

	if star_sw then do;			/* see if it's valid */
	     call check_star_name_$entry (P_name, code);
	     if code > 2 then do;
		call complain (code, whoami, "^a", P_name);
		goto main_return;
		end;
	     if code = 0 then star_sw = "0"b;		/* wasn't a starname, after all */
	     end;

	if length (P_name) > 32 then do;
	     call complain (error_table_$bigarg, whoami, "^a", P_name);
	     goto main_return;
	     end;

	if name_count >= hbound (names, 1) then do;	/* see if there is room */
	     call complain (0, whoami, "Too many switch names specified.  Maximum = ^d.", hbound (names, 1));
	     goto main_return;
	     end;

	do j = 1 to name_count;			/* make sure he hasn't already specified this name */
	     if names.name (j) = P_name then do;	/* a duplicate */
		if names.star (j) = star_sw then do;	/* but only if same starname type */
		     call com_err_ (0, whoami, "Warning -- duplicate switch name ""^a"" ignored.", P_name);
		     return;
		     end;
		end;
	     end;					/* of duplicate elimination loop */

	name_count = name_count + 1;
	names.name (name_count) = P_name;
	names.star (name_count) = star_sw;
	names.match (name_count) = "0"b;		/* initialize to not found state */
	return;

	end;					/* add_to_list */

/**/

process_iocb: proc (P_iocb_ptr);

/*	This procedure does the appropriate thing with the selected iocb */
/*	depending on af_sw, and on whether the switch is attached or open */

dcl  P_iocb_ptr pointer parameter;

	if af_sw then do;				/* just add it to the return string */
	     if length (rs) ^= 0 then rs = rs || " ";	/* space to separate returned values */
	     rs = rs || rtrim (P_iocb_ptr -> iocb.name);
	     return;
	     end;

	else attach_desc_ptr = P_iocb_ptr -> iocb.attach_descrip_ptr;
	if P_iocb_ptr -> iocb.actual_iocb_ptr = iocb_ptr then	/* crock for syn_ attachments */
	     open_desc_ptr = P_iocb_ptr -> iocb.open_descrip_ptr;
	else open_desc_ptr = addr (null_string);

	if attach_desc_ptr = null () then do;
	     attach_desc_ptr = addr (not_attached);
	     open_desc_ptr = addr (null_string);
	     end;
	else if open_desc_ptr = null () then open_desc_ptr = addr (not_open);

	len1 = length (rtrim (P_iocb_ptr -> iocb.name));
	len2 = length (rtrim (attach_desc_ptr -> varying_string));
	len3 = length (rtrim (open_desc_ptr -> varying_string));

	out_str = substr (P_iocb_ptr -> iocb.name, 1, len1);	/* initialize */

	if len1 < 19 & len2 < 59 then do;			/* attach description and name on same line */
	     out_str = out_str || substr (spaces, 1, 20 - len1);  /* yes, same line. columnize */
	     t1 = 20;				/* for test about open description */
	     end;					/* of case for short name */

	else do;					/* definitely goes on a different line */
	     out_str = out_str || newline;
	     out_str = out_str || substr (spaces, 1, 5);
	     t1 = 5;
	     end;

	out_str = out_str || substr (attach_desc_ptr -> varying_string, 1, len2);

	if len3 > 0 then do;			/* only process the open description if there is one */
	     t1 = t1 + len2;			/* t1 is now the last column of attach description */

	     if t1 > 38 then do;			/* put the open description on the next line */
		out_str = out_str || newline;
		out_str = out_str || substr (spaces, 1, 10);
		end;

	     else out_str = out_str || substr (spaces, 1, 40 - t1);

	     out_str = out_str || substr (open_desc_ptr -> varying_string, 1, len3);
	     end;

	out_str = out_str || newline;			/* and a newline to finish it off */

	call iox_$put_chars (iox_$user_output, addr (substr (out_str, 1, 1)), length (out_str), (0));
	return;					/* all done */

	end;					/* process_iocb */

     end;						/* print_attach_table */



		    print_request_types.pl1         10/28/88  1348.6rew 10/28/88  1257.4      262008


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

print_request_types:
prt: proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This command prints a list of request types handled by the IO daemon as determined by	*/
/* inspecting the "iod_working_tables" segment.  For each request type, the associated	*/
/* driver access name and the generic type are printed.				*/
/*									*/
/* Status									*/
/*									*/
/* 0) Written by J. Stern, 2/18/75						*/
/* 1) Modified by J. C. Whitmore, 6/78, for version 2 iod_tables and general upgrade	*/
/* 2) Modified by J. C. Whitmore, 10/78, to use version 3 iod_tables			*/
/* 3) Modified by G. C. Dixon, 12/81						*/
/*      - make prt work as active function					*/
/*      - interface with eor (ie, display user-defined request type names which eor	*/
/*	allows								*/
/*      - support -print, -punch, -plot to more easily select request types associated	*/
/*	with a given generic type						*/
/*      - sort output by generic type, then by name of target request type, finally by	*/
/*	name of user-defined request type					*/
/*      - change output format to shorten line length and eliminate redundant		*/
/*	information							*/
/*      - allow starname request type names to be given to select by request type name.	*/
/* 4) Modified:  May 3, 1982 by G. C. Dixon - add -user_defined control arg.		*/
/* 5) Modified: July 1984 by C. Marker so that when print_request_types is used as an     */
/*      active_function and given a starname, only names matching that starname will be   */
/*      returned.                                                                         */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/****^  HISTORY COMMENTS:
  1) change(88-09-23,Brunelle), approve(88-09-23,MCR7911),
     audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle Version 5 I/O daemon tables.  Added comment in
     request_type entries to the output display.
                                                   END HISTORY COMMENTS */


	dcl     accname		 char (32),	/* access name */
	        acc_pers		 char (22),
	        acc_proj		 char (9),
	        an_found		 bit (1),		/* ON if desired access name found */
	        af_sw		 bit (1),		/* ON if invoked as an active function. */
	        argp		 ptr,		/* ptr to arg */
	        arglen		 fixed bin (21),	/* length of arg */
	        arg		 char (arglen) based (argp),
						/* command argument */
	        bfsw		 bit (1),		/* ON for brief option */
	        code		 fixed bin (35),	/* error code */
	        comment_string		 char (300) varying,/* pgms using rqt as default, etc.		*/
	        comment_len		 fixed bin,
	        count		 fixed bin,
	        gen_type		 char (32),	/* generic type name */
	        gt_found		 bit (1),		/* ON if desired generic type found */
	        (i, j)		 fixed bin,
	        match		 bit (1),		/* ON if access name and/or generic type matched */
	        (max_acc, max_rqt)	 fixed bin,
	        nargs		 fixed bin,
	        nrqt_starnames	 fixed bin,
	        prev_gen_type	 char (32),
	        qgt_size		 fixed bin,
	        ret		 char (ret_len) varying based (retp),
	        ret_len		 fixed bin (21),
	        retp		 ptr,
	        rqt_starnames	 (20) char (32),
	        rqt_startypes	 (20) fixed bin,
	        select		 bit (1),		/* ON if selecting a subset of request types */
	        sysdir		 char (168),	/* directory containing iod_working_tables */
	        user_defined	 bit (1);		/* ON if -user_defined given.			*/

	dcl     (addr, after, before, copy, dim, hbound, index, lbound, length,
	        max, null, ptr, rtrim, substr)
				 builtin,
	        cleanup		 condition;

	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35)),
	        active_fnc_err_	 entry () options (variable),
	        arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable,
	        com_err_		 entry () options (variable),
	        check_star_name_$entry entry (char (*), fixed bin (35)),
	        cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	        cu_$af_arg_ptr	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	        cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	        enter_output_request$default_count
				 entry (fixed bin),
	        enter_output_request$list_defaults
				 entry (ptr, ptr, fixed bin (35)),
	        err		 entry options (variable) variable,
	        get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin),
	        hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35)),
	        hcs_$terminate_noname	 entry (ptr, fixed bin (35)),
	        ioa_		 entry () options (variable),
	        ll		 fixed bin,
	        match_star_name_	 entry (char (*), char (*), fixed bin (35)),
	        sort_items_$char	 entry (ptr, fixed bin (24));

	dcl     (FALSE		 init ("0"b),
	        TRUE		 init ("1"b)) bit (1) int static options (constant),
	        NL		 char (1) int static options (constant) init ("
"),
	        SP		 char (1) int static options (constant) init (" "),
	        (error_table_$badopt,
	        error_table_$too_many_names) fixed bin (35) ext static,
	        whoami		 char (19) int static options (constant) init ("print_request_types");

%include eor_defaults;

%include iod_tables_hdr;


%include q_group_tab;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*  initialize control argument defaults					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	bfsw, user_defined = FALSE;
	an_found, gt_found = TRUE;
	acc_pers, acc_proj, gen_type = "";
	ll = 0;
	nrqt_starnames = 0;
	sysdir = ">daemon_dir_dir>io_daemon_dir";


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* See how we were invoked (command/af), and process arguments.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call cu_$af_return_arg (nargs, retp, ret_len, code);
	if code = 0 then do;
		af_sw = TRUE;
		arg_ptr = cu_$af_arg_ptr;
		err = active_fnc_err_;
		ret = "";
	     end;
	else do;
		af_sw = FALSE;
		arg_ptr = cu_$arg_ptr;
		err = com_err_;
	     end;

	do i = 1 to nargs;
	     call arg_ptr (i, argp, arglen, code);
	     if arg = "-bf" | arg = "-brief"
	     then bfsw = TRUE;
	     else if arg = "-an" | arg = "-access_name" then do;
		     i = i + 1;
		     call arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then do;
noarg:			     call err (code, whoami, "
^a requires an operand.", arg);
			     return;
			end;
		     accname = arg;
		     acc_pers = before (arg, ".");
		     if acc_pers = "*" then
			acc_pers = "";
		     acc_proj = before (after (arg, "."), ".");
		     if acc_proj = "*" then
			acc_proj = "";
		     an_found = (acc_pers = "") & (acc_proj = "");
		end;				/* an_found is OFF until we find a match	*/

	     else if arg = "-gt" | arg = "-gen_type" | /* -gen_type is hold-over from earlier version	*/
		arg = "-generic_type" then do;
		     i = i + 1;
		     call arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then go to noarg;
		     gen_type = arg;
		     gt_found = FALSE;		/* gt_found is OFF until we find a match.	*/
		end;
	     else if arg = "-pr" | arg = "-print" then do;
		     gen_type = "printer";
		     gt_found = FALSE;
		end;
	     else if arg = "-pch" | arg = "-punch" then do;
		     gen_type = "punch";
		     gt_found = FALSE;
		end;
	     else if arg = "-plot" then do;
		     gen_type = "plotter";
		     gt_found = FALSE;
		end;
	     else if arg = "-udf" | arg = "-user_defined" then do;
		     user_defined = TRUE;
		end;
	     else if arg = "-dr" | arg = "-dir" | arg = "-directory" then do;
		     i = i + 1;			/* -dir is hold-over from earlier version of code.*/
		     call arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then go to noarg;
		     call absolute_pathname_ (arg, sysdir, code); /* take apart and put it back together */
		     if code ^= 0 then do;
			     call err (code, whoami, arg);
			     return;
			end;
		end;
	     else if index (arg, "-") ^= 1 then do;
		     nrqt_starnames = nrqt_starnames + 1;
		     if nrqt_starnames > dim (rqt_starnames, 1) then do;
			     call err (error_table_$too_many_names, whoami, "^a
Only ^d request type starnames may be given.", arg, dim (rqt_starnames, 1));
			     return;
			end;
		     rqt_starnames (nrqt_starnames) = arg;
		     call check_star_name_$entry (arg, code);
		     if 0 <= code & code <= 2 then
			rqt_startypes (nrqt_starnames) = code;
		     else do;
			     call err (code, whoami, arg);
			     return;
			end;
		end;
	     else do;
		     call err (error_table_$badopt, whoami, arg);
		     return;
		end;
	end;

	select = ^(an_found & gt_found) | nrqt_starnames > 0;
						/* selection occurs if any starnames were given	*/
						/* or if -an, -gt, -pr, -pch or -plot were given. */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* get a pointer to the queue group table					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	ithp = null;
	on cleanup begin;
		call hcs_$terminate_noname (ithp, code);
	     end;
	call hcs_$initiate (sysdir, "iod_working_tables", "", 0, 1, ithp, code);
	if ithp = null then do;
		call err (code, whoami, "^a>iod_working_tables", sysdir);
		return;
	     end;

	if iod_tables_hdr.version ^= IODT_VERSION_5 then do;
		call err (0, whoami, "Wrong version number for iod_working_tables.");
		go to EXIT;
	     end;
	qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset);
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Set sizes required for adjustable storage allocated in begin block below.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	qgt_size = q_group_tab.n_q_groups;		/* Number of system-defined request types.	*/
	call enter_output_request$default_count (Nrequest_types);
						/* Number of user-defined request types (eor 	*/
						/*   supports user-defined request types).	*/

BLOCK:	begin;

	     dcl	   1 eor_rqts	      aligned,
		     2 header	      like eor_defaults.header,
		     2 rqt	      (Nrequest_types) like eor_defaults.request_type,
		   name		      char (32),
		   1 q		      (qgt_size + Nrequest_types) aligned,
		     2 generic_type	      char (24),
		     2 target_request_type char (24),
		     2 name	      char (24),
		     2 access_name	      char (32),
                         2 comment unaligned like text_offset,
		     2 S,
		     ( 3 ignored_by_eor,
		       3 dprint_default,
		       3 dpunch_default,
		       3 dplot_default,
		       3 eor_print_default,
		       3 eor_punch_default,
		       3 eor_plot_default,
		       3 imft_default)    bit (1) unal,
		       3 mbz	      bit (28) unal,
		   1 qb		      aligned like q based (Pqb),
		   Pqb		      ptr,
		   1 v		      aligned,	/* Array for sorting entries.			*/
		     2 n		      fixed bin (24),
		     2 p		      (qgt_size + Nrequest_types)
				      ptr unal;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* get a list of user-defined request types from eor.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     eor_rqts.version = Veor_defaults_1;
	     eor_rqts.N = Nrequest_types;
	     call enter_output_request$list_defaults (null, addr (eor_rqts), code);
	     if code ^= 0 then do;
		     call err (code, whoami, "
Getting user-defined request types known to enter_output_request.");
		     go to EXIT;
		end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Add user-defined request types at beginning of the q structure.  This structure is	*/
/* used to merge info for user-defined request types and system-defined request types	*/
/* (from q_group_tab) into a common format.  The remainder of prt deals only with this	*/
/* common format structure (the q structure).					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     count = 0;
	     do i = 1 to Nrequest_types;
		count = count + 1;
		Pqb = addr (q (count));
		qb.generic_type = eor_rqts.rqt (i).generic_type;
		qb.target_request_type = eor_rqts.rqt (i).target_request_type_name;
		qb.name = eor_rqts.rqt (i).name;

		do j = lbound (q_group_tab.entries, 1) to /* copy access name from target request type	*/
		     hbound (q_group_tab.entries, 1) /*   into user-defined request type entry.	*/
		     while (q_group_tab.entries (j).name ^= qb.target_request_type);
		end;
		if j <= hbound (q_group_tab.entries, 1) then do;
		     qb.access_name = q_group_tab.entries (j).driver_id;
		     qb.comment = q_group_tab.entries (j).comment;
		end;
		else do;
		     qb.access_name = "";
		     qb.comment.first_char, qb.comment.total_chars = 0;
		end;

		qb.S = FALSE;
		if qb.generic_type = "printer" then
		     qb.S.eor_print_default = eor_rqts.rqt (i).Sdefault;
		else if qb.generic_type = "punch" then
		     qb.S.eor_punch_default = eor_rqts.rqt (i).Sdefault;
		else if qb.generic_type = "plotter" then
		     qb.S.eor_plot_default = eor_rqts.rqt (i).Sdefault;
	     end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Copy information from q_group_tab into q structure.				*/
/*									*/
/* CASE 1:  ^user_defined							*/
/* Eliminate any system-defined request type whose name duplicates a user-defined	*/
/* request type (when user-defined request type references the system-defined type as	*/
/* its target request type).  Flag any system-defined request type whose name is	*/
/* superceded by a user-defined request type (when user-defined request type references	*/
/* another request type as its target).						*/
/*									*/
/* CASE 2: user_defined, ^af_sw						*/
/* Include only those system-defined request types that are referenced as the target	*/
/* request type for a user-defined request type.  Eliminate duplicates as in case 1.  Do	*/
/* not flag superceded system-defined request types.				*/
/*									*/
/* CASE 3: user_defined, af_sw						*/
/* Do nothing with system-defined request types.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     if user_defined & af_sw then ;		/* CASE 3					*/
	     else do i = lbound (q_group_tab.entries, 1) to
		     hbound (q_group_tab.entries, 1);
		     qgtep = addr (q_group_tab.entries (i));
		     count = count + 1;
		     Pqb = addr (q (count));
		     qb.generic_type = substr (qgte.generic_type, 1, length (qb.generic_type));
		     qb.target_request_type = qgte.name;
		     qb.name = "";			/* system request names have no user-defined name */
		     qb.access_name = qgte.driver_id;

		     qb.comment = qgte.comment;

		     qb.S = FALSE;
		     if qgte.default_generic_queue = 1 then
			if qgte.generic_type = "printer" then
			     qb.S.dprint_default = TRUE;
			else if qgte.generic_type = "punch" then
			     qb.S.dpunch_default = TRUE;
			else if qgte.generic_type = "plotter" then
			     qb.S.dplot_default = TRUE;
			else if qgte.generic_type = "imft" then
			     qb.S.imft_default = TRUE;

		     if ^user_defined then do;	/* CASE 1					*/
			     do j = 1 to Nrequest_types /* search user-defined request types for one 	*/
				while (qgte.name ^= q (j).name); /*   having the same name.			*/
			     end;
			     if j <= Nrequest_types then
				if q (j).name = q (j).target_request_type then do;
						/* user-define type duplicates system type	*/
					q (j).S.dprint_default = qb.S.dprint_default;
					q (j).S.dpunch_default = qb.S.dpunch_default;
					q (j).S.dplot_default = qb.S.dplot_default;
					q (j).S.imft_default = qb.S.imft_default;
					q (j).name = ""; /* copy attributes from system type entry, make	*/
					count = count - 1; /*   user entry look like system type entry	*/
				     end;		/*   and delete the system type entry.		*/
				else
				     qb.S.ignored_by_eor = TRUE; /* flag system type entry as being ignored by 	*/
			end;			/*   cor/eor/lor/mor because of user-defined	*/
						/*   request type of same name.		*/

		     else do;			/* CASE 2					*/
			     do j = 1 to Nrequest_types
				while (qgte.name ^= q (j).target_request_type);
			     end;
			     if j > Nrequest_types then /*   system rqt not referenced by any user rqt	*/
				count = count - 1;
			     else if q (j).name = qgte.name then do; /*   user rqt has same name as its corresponding	*/
						/*   system rqt.				*/
				     q (j).S.dprint_default = qb.S.dprint_default;
				     q (j).S.dpunch_default = qb.S.dpunch_default;
				     q (j).S.dplot_default = qb.S.dplot_default;
				     q (j).S.imft_default = qb.S.imft_default;
				     q (j).name = ""; /* copy attributes from system type entry, make	*/
				     count = count - 1; /*   user entry look like system type entry	*/
				end;
			end;
		end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Select entries to be printed.  Columns widths of the display are computed as entries	*/
/* are selected.  Selection is made by access name of the IO Daemon process, by generic	*/
/* type of the request type (printer, punch or plotter), or by comparision with request	*/
/* type star names.								*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     v.n = 0;
	     if bfsw then do;			/* Prepare to compute column widths for printed	*/
		     max_rqt = 0;			/*    entries				*/
		     max_acc = 0;
		end;
	     else do;				/* If heading given, min column width is limited	*/
		     max_rqt = length ("Request type"); /*   by size of column headers.		*/
		     max_acc = length ("Access name");
		end;

	     do i = 1 to Nrequest_types, i to count while (^user_defined);
		Pqb = addr (q (i));
		match = TRUE;
		if select then do;
			if acc_pers ^= "" then
			     if acc_pers = before (qb.access_name, ".") then
				an_found = an_found | (acc_proj = "");
			     else
				match = FALSE;
			if acc_proj ^= "" then
			     if acc_proj = before (after (qb.access_name, "."), ".") then
				an_found = an_found | match;
			     else
				match = FALSE;
			if gen_type ^= "" then
			     if gen_type = qb.generic_type then gt_found = TRUE;
			     else match = FALSE;
			if match & nrqt_starnames > 0 then do;
				match = FALSE;
				if qb.name = "" then
				     name = qb.target_request_type;
				else
				     name = qb.name;
				do j = 1 to nrqt_starnames while (^match);
				     go to MATCH (rqt_startypes (j));

MATCH (0):			     match = (name = rqt_starnames (j));
				     go to END_MATCH;

MATCH (1):			     call match_star_name_ ((name), rqt_starnames (j), code);
				     match = (code = 0);
				     go to END_MATCH;

MATCH (2):			     match = TRUE;
END_MATCH:			end;
			     end;
		     end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This loop places matching entries into the array of entries to be sorted/displayed.	*/
/* A loop is used because, for user-defined request types, we want to display the	*/
/* system-defined target request type, no matter whether it would be normally selected	*/
/* or not.  Execution usually goes through the loop once, or at most twice.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

		do while (match);
		     do j = 1 to v.n while (Pqb ^= v.p (j)); /* Don't put entry in array if it is already there*/
		     end;
		     if j > v.n then do;
			     v.n = v.n + 1;		/* Add entry to the display array.		*/
			     v.p (v.n) = Pqb;
			     if qb.name = "" then /* Compute max length of request type and access	*/
				max_rqt = max (max_rqt, length (rtrim (qb.target_request_type)));
			     else /*   name display fields.			*/
				max_rqt = max (max_rqt, length (rtrim (qb.name)) + 2,
				     length (rtrim (qb.target_request_type)));
			     max_acc = max (max_acc, length (rtrim (before (qb.access_name, ".*"))));
			     if qb.name ^= "" & ^af_sw then do; /* For user-defined type, insure that 		*/
				     do j = 1 to count /*   system-defined target request type is also	*/
					while (q (j).target_request_type ^= qb.target_request_type |
					q (j).name ^= ""); /*   selected unless it is an active function.	*/
				     end;
				     if j <= count then
					Pqb = addr (q (j)); /*   add target to list.			*/
				     else
					match = FALSE; /*   no target found.			*/
				end;
			     else
				match = FALSE;	/* system-defined request type.		*/
			end;
		     else
			match = FALSE;		/* entry is already in the array.		*/
		end;
	     end;
	     max_rqt = max_rqt + 3;			/* allow 3 chars between columns.		*/
	     max_acc = max_acc + 3;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Sort the list to be displayed (or returned as AF value).				*/
/*									*/
/* If command invocation, then sort first by generic type, then by target request type,	*/
/* finally by user-defined request type.					*/
/*									*/
/* If af invocation, sort by name returned as active function value.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     if af_sw then do;			/*   Kludge af sorting by putting name returned	*/
		     do i = 1 to v.n;		/*   in af string into the gen_type field.	*/
			Pqb = v.p (i);
			if qb.name = "" then
			     qb.generic_type = qb.target_request_type;
			else
			     qb.generic_type = qb.name;
		     end;
		     if v.n > 1 then do;		/* sort if more than 1.			*/
			     call sort_items_$char (addr (v), length (qb.generic_type));
			end;
		end;
	     else do;
		     if v.n > 1 then do;		/* sort if more than 1.			*/
			     call sort_items_$char (addr (v), length (qb.generic_type) +
				length (qb.target_request_type) + length (qb.name));
			end;
		end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Now display the selected entries, or add them to the AF return string.  When		*/
/* displaying, a separate heading is put out for each generic type, identifying the	*/
/* generic type and the various output columns.  Columns include: (name of) Request	*/
/* type; Access name; and Comments.  The comments indicate which request types are	*/
/* default for dprint, for dpunch, for dplot and for eor -print, -punch and -plot.  Note	*/
/* that dprint and eor -print may well have different defaults, because eor allows the	*/
/* user to change the name of his default request type.  The comment also indicates any	*/
/* system-defined request types which are not accessible from cor/eor/lor/mor (because	*/
/* they have been overridden by a user-defined request type of the same name).		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     prev_gen_type = "";
	     do i = 1 to v.n;
		Pqb = v.p (i);
		if qb.generic_type ^= prev_gen_type then
		     if ^af_sw then do;
			     call ioa_ ("^/^[^;^/^-^]GENERIC TYPE:  ^a^[^5s^;^/^va^va^a^/^]",
				bfsw, qb.generic_type, bfsw, max_rqt, "Request type",
				max_acc, "Access name", "Comments");
			     prev_gen_type = qb.generic_type;
			end;
		if af_sw then do;
			ret = ret || rtrim (qb.generic_type);
			ret = ret || SP;
		     end;
		else do;
			comment_string = "";
			comment_len = max_rqt + max_acc;
			if qb.comment.total_chars ^= 0 then
			     call add_to_comment (substr (text_strings.chars,
			     qb.comment.first_char, qb.comment.total_chars) || ";");
			if qb.S.dprint_default then
			     call add_to_comment ("default for dprint");
			else if qb.S.dpunch_default then
			     call add_to_comment ("default for dpunch");
			else if qb.S.dplot_default then
			     call add_to_comment ("default for dplot");
			else if qb.S.imft_default then
			     call add_to_comment ("default for eir");
			if qb.S.eor_print_default then
			     if comment_string = "" then
				call add_to_comment ("default for eor -print");
			     else do;
				     call add_to_comment ("&");
				     call add_to_comment ("eor -print");
				end;
			else if qb.S.eor_punch_default then
			     if comment_string = "" then
				call add_to_comment ("default for eor -punch");
			     else do;
				     call add_to_comment ("&");
				     call add_to_comment ("eor -punch");
				end;

			else if qb.S.eor_plot_default then
			     if comment_string = "" then
				call add_to_comment ("default for eor -plot");
			     else do;
				     call add_to_comment ("&");
				     call add_to_comment ("eor -plot");
				end;
			if qb.S.ignored_by_eor then do;
				if comment_string ^= "" then do;
					comment_string = comment_string || ";";
					comment_len = comment_len + 1;
				     end;
				call add_to_comment ("ignored by eor -");
				do j = 1 to Nrequest_types
				     while (qb.target_request_type ^= q (j).name);
				end;
				call add_to_comment (rtrim (q (j).name));
				call add_to_comment ("is a");
				call add_to_comment ("user-defined");
				call add_to_comment ("name");
				call add_to_comment ("on the");
				call add_to_comment (rtrim (q (j).target_request_type));
				call add_to_comment ("request type");
			     end;
			call ioa_ ("^[^va^va^a^;^5s^2x^va^[^vx^a^;^2s^]",
			     qb.name = "",
			     max_rqt, qb.target_request_type,
			     max_acc, before (qb.access_name, ".*"), comment_string,
			     max_rqt - 2, qb.name,
			     comment_string ^= "", max_acc, comment_string);
		     end;
	     end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Emit errors diagnosing selection failures.  Handle completion of display or AF return	*/
/* string (remove trailing SP from AF return string).  Terminate the iod_working_tables.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	     if ^an_found then call err (0, whoami, "Access name not found: ^a", accname);
	     if ^gt_found then call err (0, whoami, "Generic type not found: ^a", gen_type);
	     if an_found & gt_found & v.n = 0 & ^af_sw then
		call err (0, whoami, "No request types meet selection criteria:^[
  -access_name ^a^;^s^]^[
  -generic_type ^a^;^s^]^[
  -user_defined^]^[
  request_type name matching:^v(
    ^a^)", acc_pers ^= "" | acc_proj ^= "", accname,
		     gen_type ^= "", gen_type,
		     user_defined,
		     nrqt_starnames > 0, nrqt_starnames, rqt_starnames);
	     if v.n > 0 then do;
		     if af_sw then /* remove trailing SP from return string.	*/
			ret = substr (ret, 1, length (ret) - 1);
		     else
			call ioa_ ("");		/* throw in an extra blank line */
		end;
	end BLOCK;

EXIT:	call hcs_$terminate_noname (ithp, code);
	return;

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


add_to_comment:
     proc (str);

	dcl     str		 char (*);

	if ll = 0 then do;				/* Tailor length of comments to terminal line len */
		ll = get_line_length_$switch (null, code); /*   Comments too long are folded onto several	*/
		if code ^= 0 then ll = 136;		/*   lines.				*/
	     end;
	if comment_string = "" then ;
	else if comment_len + length (SP) + length (str) > ll then do;
		comment_string = comment_string || NL;
		comment_string = comment_string || copy (SP, max_rqt + max_acc + 2);
		comment_len = max_rqt + max_acc + 2;
	     end;
	else if comment_string ^= "" then do;
		comment_string = comment_string || SP;
		comment_len = comment_len + length (SP);
	     end;
	comment_string = comment_string || str;
	comment_len = comment_len + length (str);
     end add_to_comment;

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

     end print_request_types;



		    read_list_.pl1                  11/09/82  0908.3rew 11/09/82  0902.5      197595


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


/*converted to v2pl1 by A. Downing 12.14.72*/
/* Free format input program, doing conversions as dictated
   by descriptors of the calling program.
   re-coded by M. Weaver 28 July 1970 */

/* Modified on:	23 September 1971 by Paul Green for new descriptors */

read_list_: procedure;				/*  Arguments to read_list_ are accessed through a based
						   declaration since their number and size are not
						   known at compile time.  */

dcl 1 arg based,					/* Multics argument list structure. */
    2 acount bit(18),
    2 spval bit(18),
    2 dcount bit(18),
    2 padding bit(18),
    2 ptr(100) pointer;

/* 	Dummy declarations to refer to arguments after their type is known */

dcl  strv char(131) based,				/* For character strings, fixed and varying */
     strvad char(ssize) based,			/* For prompting message character strings */
     bitv bit(131) based,				/* For bit strings, fixed and varying */
     fxdv fixed bin(35) based,			/* For single precision fixed point input */
     fxdvh fixed bin(17) based,			/* For other single prec. fixed point numbers */
     fxd2v fixed bin(71) based,			/* Double precision fixed point */
     fltv float bin(27) based,			/* Single precision floating point */
     flt2v float bin(63) based,			/* Double precision floating point */
     ptrv pointer based;				/* For pointer variables */

dcl  argct fixed bin,				/* Number of arguments in calling sequence. */
     argp pointer,					/* Holds pointer to argument list */
     argpos fixed bin,				/* Next argument position to be filled. */
     beg fixed bin,					/* First non-control argument */
     bpos fixed bin,				/* index of first char of value */
     cannedsw fixed bin,				/* Switch to permit printing of canned prompting message. */
     cend fixed bin,				/* Index of end of conversion scan */
     charpos fixed bin,				/* Index of next input character to be scanned */
     code fixed bin,				/* error code */
     comsw bit(1) aligned,				/* indicates prescence of comma followed by irrelevant chars */
     cstart fixed bin,				/* Index of start of conversion scan */
     cvindex fixed bin,				/* Index used during number conversion */
     digit fixed bin,				/* Holds value of next digit of input string */
     fltval float bin(63),				/* Holds floating point value during conversion */
     fxval fixed bin(71),				/* Holds fixed point values during conversion */
     i fixed bin,					/* index into label array for return from number conversion */
     iosw bit(1) aligned,				/* Console interaction switch */
     j fixed bin,					/* no. of relevant chars in bit string */
     lset bit(1) int static init("0"b),			/* Switch for initializing labels */
     neg fixed bin,					/* Sign of value being converted */
     ndims fixed bin,				/* Number of dimensions in array argument */
     nl char(1) aligned int static init("
"),						/* new-line character */
     octal_fix(0: 1) bit(36) aligned based,		/* array to pick out the low order word of a double prec. no. */
     p ptr,					/* Pointer to current argument */
     packed bit(1) aligned,				/* ="1"b if this argument is packed */
     plural char(1) aligned,				/* "s" or " " for more grammatical prompting */
     promptsw fixed bin,				/* Set to 1 if caller provides prompting messages */
     ptrbrk(0: 2) fixed bin(17) int static init(124, 40, 41), /* ascii for ptr break chars */
     q ptr,                                                 /* Pointer to intermediate conversion number */
     radix fixed bin,				/* Radix of integer conversion */
     rbuf char(rcount) based(rbufp),			/* Input string */
     rbufp pointer,					/* Pointer to input buffer */
     rcount fixed bin,				/* Number  of characters read or length of input string */
     readbuf char(131) aligned,			/* Typewriter input buffer area */
     scale fixed bin,				/* Arithemetic scale of argument */
    (size,ssize) fixed bin(35),			/* Arithmetic precision, string size, or number of structure elements */
     squosw bit(1) aligned,				/* Flag to indicate single quote in string */
     stop_at_break bit(1),				/* Flag to tell scan of input to stop at a break */
     tempc char(1) aligned,				/* temporary for looking at a character */
     type fixed binary,				/* Data type of next argument to be filled */
     typemsg char(32),				/* Holds an error message appropriate for input type */
     up fixed bin,					/* Last relevant digit corresponding to radix */
     vpos fixed bin,				/* index of last char of value */
     1 x aligned based(rbufp),			/* Structure for scanning input line */
     2 c(0: 3) char(1) unaligned;

dcl  retlab(0: 2) label local  int static;		/* Label array for returning from number conversion routine */

dcl  com_err_$suppress_name entry(fixed bin,char(*) aligned,char(*) aligned),
     com_err_ entry options(variable),
     cu_$arg_list_ptr entry(ptr),
     cv_float_double_ entry(char(*) aligned,fixed bin,float bin(63)),
     decode_descriptor_ entry(ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin,fixed bin(35),fixed bin),
     ioa_ entry options(variable),
     ioa_$nnl entry options(variable),
     ios_$read_ptr ext entry(ptr, fixed bin, fixed bin),
     ios_$resetread entry options(variable);

dcl (addr,addrel,baseptr,divide,fixed,min,substr,unspec) builtin;

/*	declare added for ios_$resetread */
dcl	status_bits bit(72) aligned;

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


/* 	Entry points.  Locate calling sequence. */


	promptsw = 0;				/* No prompting messages provided by user */
	cannedsw = 0;				/* Canned prompting is suppressed the first time */
	go to cmn;

prompt:	entry;
	promptsw = 1;				/* prompting messages are provided */
	go to cmn;

no_prompt: entry;
	promptsw = 0;				/* No prompting messages provided by user */
	cannedsw = 2;				/* Always suppress canned prompting */
	go to cmn;

scan_string: entry;
	promptsw = 0;				/* No prompting messages provided by user */
	cannedsw = 2;				/* Always suppress canned prompting */
	iosw = "0"b;				/* non-interactive entry */
	beg = 3;					/* third arg is first regular output arg */
	go to getap;


cmn:	rbufp = addr(readbuf);			/* want input to go into a buffer for most entries */
	beg = 1;					/* most entries don't have control arguments */
	iosw = "1"b;				/* most entries will interact with concole */
getap:	q = addr(digit);		                    /* init q pointer */
	call cu_$arg_list_ptr(argp);			/* get pointer to caller's argument list */
	argct = divide(fixed(argp->arg.acount,18), 2, 17, 0); /* get number of arguments */
	charpos = 0;				/* prepare to look at first character in input line */
	if ^iosw then do;				/* get addr and length of input string for $scan_string */
	     rbufp = argp->arg.ptr(1);		/* get pointer to input string */
	     call decode_descriptor_(argp,1,type,packed,ndims,size,scale);
	     if type = 21 then rcount = size-1;
						/* fixed length string; get length from it; indexing starts at 0 */
	     else rcount = addrel(rbufp,-1)->fxdvh - 1;	/* varying string; get current length from it*/

/* We want to look at the input string through an aligned based structure.  In order
   to do this, if the string is unaligned, we must adjust the pointer to the string
   and also adjust the offset and length.  */

	     up = fixed(substr(addr(rbufp)->bitv,55,9),9); /* isolate bit offset of input ptr */
	     if up > 0 then do;
		substr(addr(rbufp)->bitv,55,9) = "0"b;	/* zero out any bit offset */
		up = divide(up,9,17,0);		/* calculate character offset from bit offset */
		charpos = charpos + up;		/* adjust beginning offset to reflect aligned string */
		rcount = rcount + up;		/* adjust length to reflect aligned string */
	     end;
	end;
	else rcount = -1;				/* for rest of entries, rcount will come from ios_$read_ptr */

	if ^lset then do;				/* initiate label array once per process */
	     retlab(0) = retlab_0;
	     retlab(1) = retlab_1;
	     retlab(2) = retlab_2;
	     lset = "1"b;
	end;

/* 	Grand loop--fill in caller's arguments, one at a time */


	do argpos = (beg+promptsw) by (1+promptsw) to argct;

	     call decode_descriptor_(argp,argpos,type,packed,ndims,size,scale);

/* 	locate start of next typed input value */

cklth:	     if charpos > rcount then do;		/* we are at end of current input line */
		if ^iosw then do;			/* can't get any more lines */
		     argp->arg.ptr(2)->fxdv = argpos-3;	/* return number of args filled in */
		     return;
		end;
		else if promptsw = 1 then do;		/* print next prompting message */
		     call decode_descriptor_(argp,argpos-1,0,"0"b,0,ssize,0);
		     if ssize ^= 0 then call ioa_$nnl(argp->arg.ptr(argpos-1)->strvad);
		end;
		else if cannedsw = 1 then do;
		     radix = argct-argpos+1;		/* put calculation into a temporary */
		     if radix = 1 then plural = " ";
		     else plural = "s";
		     call ioa_("^d more input value^a expected",radix,plural);
		end;
		else if cannedsw = 0 then cannedsw = 1;	/* allow canned prompting messages from now on */

read_more:	call ios_$read_ptr(rbufp,130,rcount);
		comsw = "1"b;			/* new-line character at beginning of line is treated as a comma */
		rcount = rcount - 2;		/* discard "new line" character; indexing starts at 0 */
		charpos = 0;			/* Prepare to look at first character of input line */
	     end;

/* When looking for the next value, blanks, tabs, commas and new-line chars are
   skipped over.  Blanks and tabs are ignored.  Two consecutive commas, or 2
   commas separated by blanks and/or tabs indicate that the current parameter
   position is not to be filled in. */

	     tempc = x.c(charpos);			/* copy character into a temporary */
	     if tempc = " " then go to skipb;		/* skip over blanks */
	     if tempc = "	" then do;			/* skip over tabs */
skipb:		charpos = charpos + 1;
		go to cklth;
	     end;
	     if tempc = "," then do;			/* ",," implies do nothing to corresponding arg */
		if comsw then do;
		     charpos = charpos + 1;		/* don't want to get into a loop */
		     go to next_par;
		end;
set_com:		comsw = "1"b;			/* note passing of comma */
		go to skipb;
	     end;
	     if tempc = nl then go to set_com;		/* skip over imbedded new-line character */

/* 	The general strategy is as follows.  First the type of the next argument is determined and a pointer
   to it is obtained.  For fixed, floating or bit arguments, the input string is scanned until the
   first break character and then a branch is made to the appropriate conversion section.
   Pointer input is parsed only once--in the number conversion routine.  Character input is parsed once,
   but with a facility to recognize quotes and to suppress breaks.  */

	     p = argp->arg.ptr(argpos);		/* get pointer to current argument */

	     comsw = "0"b;				/* Have relevant character; forget any previous comma */
	     bpos = charpos;			/* remember beginning of value */

	     if type = 13 then go to ptr_input;
	     if type = 21 then go to char_input;
	     if type = 22 then go to char_input;

	     do charpos = charpos to rcount;		/* scan to the end of the input string if necessary */
		tempc = x.c(charpos);		/* copy character into a temporary */
		if tempc = " " then go to use_val;	/* test for blank */
		if tempc = "	" then go to use_val;	/* test for tab */
		if tempc = "," then go to use_val;	/* test for comma */
		if tempc = nl then go to use_val;	/* test for new line */
	     end;

use_val:	     vpos = charpos - 1;			/* don't include break character in value */
	     if type < 3 then go to fixed_input;
	     if type < 5 then go to fpt_input;
	     if type = 19 then go to bit_input;
	     if type = 20 then go to bit_input;

/* omitted types are: 5-8: complex; 9-10: decimal; 14: offset; 15: label; 16: entry; 23: file; 24: packed ptr. */

	     call com_err_(0,"read_list_","Unhandled data-type ^d for argument ^d. It has been ignored.",type,argpos);
	     go to next_par;


/* 	Try to interpret next input value as fixed  point */

fixed_input:   
	     cend = vpos;				/* normally scan whole value */
	     tempc = x.c(vpos);
	     if tempc = "b" then do;			/* input in binary form */
		radix = 2;
		cend = vpos - 1;			/* ignore last character */
	     end;
	     else if tempc = "o" then do;		/* input in octal form */
		radix = 8;
		cend = vpos - 1;			/* ignore last character */
	     end;
	     else radix = 10;			/* input in decimal form */
	     cstart = bpos;
	     typemsg = "an integer";
	     go to cvint;				/* convert the number */
retfx:	    					/* get here only if there were no errors */
	     if type = 2 then p->fxd2v = fxval;		/* double precision case */
						/* don't want positive sign to affect
						   single precision octal or binary input */
	     else if radix ^= 10 & neg > 0 then unspec(p->fxdv) = addr(fxval)->octal_fix(1);
	     else p->fxdv = fxval;			/* single precision case; decimal or negative octal/binary value */
	     go to next_par;


/* 	Try to interpret next input value as floating point */

fpt_input:     
	     typemsg = "a real (floating-point) number";
	     call cv_float_double_(substr(rbuf,bpos+1,vpos-bpos+1),code,fltval);
	     if code ^= 0 then go to illegal;
	     if type = 3 then argp->arg.ptr(argpos)->fltv = fltval; /* single precision */
	     else argp->arg.ptr(argpos)->flt2v = fltval;	/* double precision */
	     go to next_par;


/* 	Try to interpret next input value as a pointer variable */

ptr_input:     
	     radix = 8;				/* pointer input is in octal */
	     cstart = bpos;
	     cend = rcount;				/* go till get to break */
	     typemsg = "an (octal) pointer value";
	     i = 0;				/* set index into label array */
	     go to cvint;				/* start parsing and converting segment number */
retlab_0:     					/* breaks are checked by number conversion routine */
	     cstart = cvindex + 1;			/* set beginning of word offset scan */
	     i = 1;
	     go to cvint;
retlab_1:      
	     cstart = cvindex + 1;			/* set beginning of bit offset scan */
	     i = 2;
	     radix = 10;				/* bit offset is in decimal */
	     go to cvint;
retlab_2:      
	     charpos = cvindex + 1;			/* set for scanning next input value */
						/* 	check range ofbit offset */
	     if fxval > 35 then do;			/* check range of bit offset */
		call ioa_("^d is too large for a bit offset in a pointer.",fixed(fxval,35));
		beg = -1;
		go to illegal;
	     end;

	     go to next_par;


/* 	Try to interpret next input value as a bit string */

bit_input:     
	     typemsg = "a bit string";
	     if x.c(bpos) ^= """" then go to illegal;	/* check to see that value starts with " */
	     if substr(rbuf,vpos,2) ^= """b" then go to illegal; /* and that it ends with "b */
	     up = vpos - bpos - 2;			/* compute length of string */
	     j = min(size,up);			/* determine number of bits to fill in */

	     do cvindex = 1 to j;
		tempc = x.c(bpos+cvindex);		/* copy next character into a temporary */
		if tempc = "1" then substr(p->bitv,cvindex,1) = "1"b;
		else if tempc = "0" then substr(p->bitv,cvindex,1) = "0"b;
		else go to illegal;
	     end;

	     if j < up then do cvindex = j + 1 to up;	/* check rest of input for illegal characters */
		tempc = x.c(bpos+cvindex);
		if tempc ^= "1" then if tempc ^= "0" then go to illegal;
	     end;

	     if type = 19 then if j < size
	     then substr(p->bitv,j+1,size-j) = "0"b;	/* pad fixed string with zeros */
	     else;				/* no padding needed */
	     else addrel(p,-1)->fxdv = j;		/* set varying string length */
	     go to next_par;


/* 	Interpret next input value as a character string */

char_input:    
	     typemsg = "a character string";
	     squosw = "0"b;				/* init switch to indicate a quote after first character */
	     stop_at_break = "1"b;			/* presume scan goes to first break */
	     vpos = 0;				/* for number of characters inserted in arg */

	     do charpos = charpos to rcount;		/* scan to the end of the input string if needed */
		tempc = x.c(charpos);		/* copy character */
		if stop_at_break then do;		/* stop at a break unless in a quoted string */
		     if tempc = " " then go to setl;
		     if tempc = "	" then go to setl;	/* test for tab */
		     if tempc = "," then go to setl;
		     if tempc = nl then go to setl;	/* test for new-line */
		     if squosw then go to illegfinch;	/* had a single quote not followed by break */
		end;

		if tempc = """" then do;		/* check for quote mark */
		     if charpos = bpos /* first char */ then stop_at_break = "0"b;
		     else if charpos = rcount then go to lastquo; /* last char of input line */
		     else if x.c(charpos+1) = """" then do; /* next char is a quote */
			charpos = charpos + 1;	/* store only it */
			go to storech;
		     end;
		     else do;			/* either end of string of illegal */
lastquo:			if x.c(bpos) ^= """" then go to illegfinch; /* quotes don't match */
			stop_at_break = "1"b;	/* breaks are effective again */
			squosw = "1"b;		/* if next char is not a break, have illegal string */
		     end;
		end;
		else do;				/* character is not a quote mark */
storech:		     vpos = vpos + 1;
		     if vpos <= size then substr(p->strv,vpos,1) = tempc; /* store if there is room */
		end;
	     end;					/* end of character input loop */

	     if ^stop_at_break then do;		/* string started with a quote but didn't end with one */
		go to illegal;
	     end;

setl:	     
	     if type = 21 then if vpos < size
	     then substr(p->strv,vpos+1,size-vpos) = " ";	/* pad fixed string with blanks */
	     else;				/* no padding needed */
	     else addrel(p,-1)->fxdv = min(size,vpos);	/* set current length of varying string */
	     go to next_par;


/* 	Illegal syntax detected while converting input value.  Comment and try again. */

illegfinch:   					/* finish parsing illegal character string value */
	     cvindex = charpos;
illegfin:     					/* finish parsing illegal pointer value */
	     do charpos = cvindex to rcount;		/* parse until get to break */
		tempc = x.c(charpos);
		if tempc = " " then go to illegal;	/* test for blank */
		if tempc = "	" then go to illegal;	/* test for tab */
		if tempc = "," then go to illegal;
		if tempc = nl then go to illegal;	/* test for new-line */
	     end;

illegal:	     if ^iosw then do;			/* in non-interactive mode; set code and return */
		argp->arg.ptr(2)->fxdv = 2 - argpos;	/* here code must be negative */
		return;
	     end;

	     if beg > 0 then			/* tell user what was wrong */
	     call ioa_("Can't interpret ""^a"" as ^a.",substr(rbuf,bpos+1,charpos-bpos),typemsg);
	     else beg = 1;				/* reset so we can get proper messages later */
	     call ios_$resetread("user_input",status_bits);
	     call com_err_$suppress_name(0,"read_list_","Retype input starting with that value.");
	     rcount = -1;				/* discard remainder of this line */
	     argpos = argpos-(1+promptsw);		/* want to re-enter this argument */
	     go to next_par;


/* 	routine to convert ascii number to binary */
cvint:	     
	     up = radix + 47;			/* highest digit to look for; 60 octal = 0 */
	     neg = 1;				/* initialize scan */
	     fxval = 0;
	     digit = 0;

	     do cvindex = cstart to cend;
		q->x.c(3) = rbufp->x.c(cvindex);	/* copy next char into a number */
		if digit >= 48 then if digit <= up then do; /* could be a digit */
		     fxval = radix * fxval + (digit - 48);
		     go to end_loop;		/* this char was OK; get another */
		end;
		if type = 13 then do;		/* are processing a pointer */
		     if cvindex = cstart then go to illegfin; /* couldn't use any part of tokens */
storeptr:	     if i = 0 then			/* working on segment number */
		     p->ptrv = baseptr(fxval);
		     else if i = 1 then		/* working on offset */
		     p->ptrv = addrel(p->ptrv,fxval);
		     else if i = 2 then		/* working on bit offset */
		     substr(p->bitv,55,9) = substr(addr(fxval)->bitv,64,9);
		     if cvindex > cend then go to set_ind; /* stopped by end of input string */
		     if digit ^= ptrbrk(i) then do;	/* ptrbrk(1)="|"; ptrbrk(1)="("; ptrbrk(2)=")" */
			if i = 2 then go to illegfin;	/* bit offset must end with ")" */
			if digit ^= 32		/* space */
			then if digit ^= 9		/* tab */
			then if digit ^= 44		/* comma */
			then if digit ^= 10		/* new-line */
			then go to illegfin;	/* have illegal character */
set_ind:			charpos = cvindex + 1;	/* set charpos for scanning next input arg */
			go to next_par;		/* value is already stored in arg */
		     end;
		     go to retlab(i);
		end;				/* end of pointer processing */
		else if cvindex ^= cstart then go to illegal;
		else do;
		     if digit = 45 then neg = -1;	/* minus sign */
		     else if digit ^= 43 then go to illegal; /* could have a plus sign */
		end;
end_loop:      end;					/* end of character scanning for conversion */

	     if type = 13 then			/* end of input line */
	     if i = 2 then go to illegfin;		/* bit offset must end with ")" */
	     else go to storeptr;			/* finish up ptr */
	     if neg < 0 then fxval = -fxval;
	     go to retfx;				/* get here only during fixed point conversion */


/* 	Argument has been stored, move on to the next one */

next_par:      
	end;					/* End of grand loop */

	if promptsw = 1 then if argpos = argct + 1 then do; /* Is the last arg an extra prompting message? */
	     call decode_descriptor_(argp,argpos-1,0,"0"b,0,ssize,0);
	     if ssize ^= 0 then call ioa_$nnl(argp->arg.ptr(argpos-1)->strvad);
	end;
	if ^iosw then argp->arg.ptr(2)->fxdv = argpos - 3; /* return number of args filled in */
	return;

     end read_list_;
 



		    set_tty.pl1                     08/04/87  1447.9rew 08/04/87  1221.5      292635


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


/****^  HISTORY COMMENTS:
  1) change(87-07-09,LJAdams), approve(87-07-09,MCR7742),
     audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055):
     Added options for DSA.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo */
set_tty:
stty:
     proc;

/*  This command can be used to set the user's terminal type, terminal i/o modes, or both.
   *   The -print option may be used to ascertain the type and modes. When a type is specified,
   *   the default modes for that type are turned on; when -reset is specified, all default
   *   modes are turned on and all other modes are turned off. The -modes option
   *   is used to turn on or off explicitly specified modes.
   *
   *    modified by Robert Coren 8/4/76 to add delay and editing characters stuff
   *    modified by J. Stern 6/3/77 for new orders: set_term_type, set_default_modes, send_initial_string
   *    modified by Robert Coren 4/25/78 to add -frame and -print_frame
   *    modified by Robert Coren 8/14/79 to add flow control options
   *    modified by G. Palter 11/12/80 to use a larger mode string
   *    modified by Robert Coren 10/8/84 to set flow-control and framing characters before modes
   *    modified by Roger Negaret 05/20/85 to add some options meaningful on a DSA connection.
   *    modified by Robert Coren 06/16/86 to deal with unimplmented_version errors for editing_chars.
*/


/* ENTRIES */

dcl  cu_$arg_count entry returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));


/* EXTERNAL STATIC */

dcl  iox_$user_io ptr ext static;

dcl  error_table_$action_not_performed fixed bin(35) ext static;
dcl  error_table_$bad_mode fixed bin (35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$bigarg fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$smallarg fixed bin (35) ext static;
dcl  error_table_$undefined_order_request fixed bin(35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$unsupported_operation fixed bin (35) ext static;


/* INTERNAL STATIC */

dcl  printable_ctl_char (0:31) char (2)
	init ("^@", "^A", "^B", "^C", "^D", "^E", "^F", "^G", "^H", "^I", "^J", "^K", "^L", "^M", "^N", "^O", "^P",
	"^Q", "^R", "^S", "^T", "^U", "^V", "^W", "^X", "^Y", "^Z", "^[", "^\", "^]", "^^", "^_");
dcl  cmd_name char (8) int static options (constant) init ("set_tty");
dcl  max_tty_line_type fixed bin int static init (20);
dcl  NUL char (1) int static options (constant) init (" "); /* \000 */

dcl  1 delay internal static aligned,
       2 version fixed bin,
       2 default fixed bin,
       2 values like input_delays;


/* AUTOMATIC */

dcl  network_type fixed bin;
dcl  editing_chars_version fixed bin;
dcl  tab_int fixed bin;
dcl  line_ind char (2) var;
dcl  page_ind char (4) var;
dcl  (tab_int_switch, line_ind_switch, page_ind_switch) bit (1);
						/* flags indicating which args specified */

dcl  iarg fixed bin;
dcl  nargs fixed bin;
dcl  iocbp ptr;
dcl  code fixed bin (35);
dcl  input_modes char (512);
dcl  (reset_switch, type_switch, modes_switch, tabs_switch, initial_string_switch, set_frame_switch, print_frame_switch,
     all_switch, set_edit_switch, print_edit_switch, set_delay_switch, set_ifc_switch, set_osr_switch, set_oea_switch,
     set_bsize_switch, print_delay_switch, print_switch, brief_switch) bit (1);
						/* flags indicating which args specified */
dcl  standard_line_type bit (1);			/* "1"b -> standard_line_type */
dcl  position fixed bin;
dcl  next_comma fixed bin;
dcl  unchanged_delays bit (6);
dcl  typename char (32);
dcl  i fixed bin;
dcl  out_modes char (512);				/* modes returned by iox_$modes */

dcl  1 t_info aligned like terminal_info;		/* info structure for terminal_info order */

dcl  1 stt_info aligned like set_term_type_info;		/* info structure for set_term_type order */


dcl  1 input_delays aligned,				/* supplied values for delay setting */
       2 vert_nl fixed bin,
       2 horz_nl float bin,
       2 const_tab fixed bin,
       2 var_tab float bin,
       2 backspace fixed bin,
       2 vt_ff fixed bin;


dcl  1 editing_chars aligned,				/* if version 2 then length of chars is 2 (MCS) */
						/* if version 3 then length of chars is 3 (DSA) */
       2 version fixed bin,
       2 chars char (3) unaligned;

dcl  1 auto_ifc aligned like input_flow_control_info;
dcl  1 auto_ofc aligned like output_flow_control_info;

dcl  framing_chars char (2) aligned;


/* BASED */

dcl  based_float (6) float bin based;
dcl  based_fixed (6) fixed bin based;


/* ARGUMENT STUFF */

dcl  argptr ptr;
dcl  arglen fixed bin;
dcl  arg char (arglen) based (argptr);

dcl  rank builtin;
dcl  null builtin;
dcl  conversion condition;

%include terminal_info;
%include set_term_type_info;
%include flow_control_info;
%include net_event_message;
%include tty_attach_data_;
%include iocb;

/* parse arguments */

	nargs = cu_$arg_count ();
	if nargs = 0				/* no arguments, tell user what to do */
	then do;
	     call com_err_ (error_table_$noarg, cmd_name, "Usage: set_tty -control_args");
	     return;
	end;

	tab_int_switch, line_ind_switch, page_ind_switch = "0"b;

	reset_switch, modes_switch, tabs_switch, initial_string_switch, print_switch, set_edit_switch,
	     print_edit_switch, set_delay_switch, print_delay_switch, set_frame_switch, print_frame_switch, all_switch,
	     set_ifc_switch, set_osr_switch, set_oea_switch, set_bsize_switch, type_switch, brief_switch = "0"b;
						/* initially nothing specified */
	editing_chars_version = 0;			/* uninitialized, might have to test */

	standard_line_type = "1"b;
	iocbp = iox_$user_io;			/* default, may be overridden by "-switch" */

	do iarg = 1 to nargs;
	     call cu_$arg_ptr (iarg, argptr, arglen, code);
	     if substr (arg, 1, 1) = "-"		/* must be control argument */
	     then do;

/* START DSA */
		if arg = "-tab_interval" | arg = "-ti"
		then do;
		     tab_int_switch = "1"b;
		     call get_next_arg;		/* and increment iarg */
		     if code ^= 0
		     then return;

		     tab_int = cv_dec_check_ (arg, code);
		     if code ^= 0 | tab_int > 256
		     then do;
			call com_err_ (code, cmd_name, "Bad tabulation interval: ^a (max is 256).", arg);
			return;
		     end;
		end;

		else if arg = "-no_tab_interval" | arg = "-nti"
		then do;
		     tab_int_switch = "1"b;
		     tab_int = 0;
		end;

		else if arg = "-line_indicator" | arg = "-li"
		then do;
		     line_ind_switch = "1"b;
		     call get_next_arg;		/* and increment iarg */
		     if code ^= 0
		     then return;

		     if arglen > 2
		     then do;
			call com_err_ (error_table_$bigarg, cmd_name, "^a (max length is 2).", arg);
			return;
		     end;

		     line_ind = arg;
		end;

		else if arg = "-no_line_indicator" | arg = "-nli"
		then do;
		     line_ind_switch = "1"b;
		     line_ind = "";
		end;

		else if arg = "-page_indicator" | arg = "-pi"
		then do;
		     page_ind_switch = "1"b;
		     call get_next_arg;		/* and increment iarg */
		     if code ^= 0
		     then return;

		     if arglen > 4
		     then do;
			call com_err_ (error_table_$bigarg, cmd_name, "^a (Max length is 4).", arg);
			return;
		     end;

		     page_ind = arg;
		end;

		else if arg = "-no_page_indicator" | arg = "-npi"
		then do;
		     page_ind_switch = "1"b;
		     page_ind = "";
		end;

/* END DSA */

		else if arg = "-reset" | arg = "-rs"
		then reset_switch = "1"b;

		else if arg = "-terminal_type" | arg = "-ttp"
		then go to type_arg;

		else if arg = "-type" | arg = "-tp" | arg = "-device" | arg = "-dv"
		then do;
type_arg:
		     type_switch = "1"b;
		     call get_next_arg;		/* NOTE: this bumps iarg and gets next argument */
		     if code ^= 0
		     then return;			/* get_next_arg prints error message if required */


/* make name be upper case */
		     typename = translate (arg, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");

		end;

		else if arg = "-modes" | arg = "-md"
		then do;
		     modes_switch = "1"b;
		     call get_next_arg;		/* thereby bumping iarg */
		     if code ^= 0
		     then return;
		     input_modes = arg;
		end;

		else if arg = "-io_switch" | arg = "-is"
		then do;
		     call get_next_arg;		/* which bumps iarg */
		     if code ^= 0
		     then return;

		     call iox_$look_iocb (arg, iocbp, code);
						/* get iocb for specified switch */
		     if code ^= 0			/* couldn't get it */
		     then do;
			call com_err_ (code, cmd_name, "Could not find iocb for ^a", arg);
			return;
		     end;
		end;

		else if arg = "-tabs"
		then initial_string_switch, tabs_switch = "1"b;

		else if arg = "-initial_string" | arg = "-istr"
		then initial_string_switch = "1"b;

		else if arg = "-edit" | arg = "-ed"
		then do;
		     set_edit_switch = "1"b;
		     call get_next_arg;		/* and increment iarg */
		     if code ^= 0
		     then return;

		     if arglen > 3
		     then do;
			call com_err_ (error_table_$bigarg, cmd_name, "^a", arg);
			return;
		     end;

		     editing_chars.chars = "";
		     editing_chars.chars = arg;
		end;

		else if arg = "-frame" | arg = "-fr"
		then do;
		     set_frame_switch = "1"b;
		     call get_next_arg;
		     if code ^= 0
		     then return;
		     call check_two_chars;
		     if code ^= 0
		     then return;

		     framing_chars = arg;
		end;

		else if arg = "-delay" | arg = "-dly"
		then do;
		     set_delay_switch = "1"b;
		     call get_next_arg;
		     if code ^= 0
		     then return;

		     if arg = "default"		/* wants tty DIM to decide */
		     then delay.default = 1;

		     else do;
			unchanged_delays = "111111"b; /* initially not changing any */
			position = 1;

			do i = 1 to 6 while (position <= arglen);
			     next_comma = index (substr (arg, position), ",");
			     if next_comma = 0	/* no more commas */
			     then next_comma = arglen - position + 2;
						/* use whole thing */

			     if next_comma > 1	/* value is really there */
			     then do;
				substr (unchanged_delays, i, 1) = "0"b;
						/* we're changing this one */
				if i = 2 | i = 4	/* this is one of the floating ones */
				then do;
				     on conversion go to bad_value;
				     addr (input_delays) -> based_float (i) =
					float (substr (arg, position, next_comma - 1));
				     revert conversion;
				end;

				else do;
				     addr (input_delays) -> based_fixed (i) =
					cv_dec_check_ (substr (arg, position, next_comma - 1), code);
				     if code ^= 0
				     then go to bad_value;
				end;
			     end;

			     position = position + next_comma;
			end;

			if i > 6 & position <= arglen + 1
			then do;
			     call com_err_ (0, cmd_name, "More than 6 delay values specified.  ^a", arg);
			     return;
			end;

			delay.default = 0;
		     end;

		     delay.version = 1;
		end;

		else if arg = "-input_flow_control" | arg = "-ifc"
		then do;
		     set_ifc_switch = "1"b;
		     call get_next_arg;
		     if code ^= 0
		     then return;
		     if arglen > 2			/* can't be */
		     then do;
			call com_err_ (error_table_$bigarg, cmd_name, "^a", arg);
			return;
		     end;

		     else if arglen = 2
		     then do;
			if substr (arg, 2, 1) = NUL
			then auto_ifc.suspend_seq.count, auto_ifc.resume_seq.count = 0;
			else do;
			     auto_ifc.suspend_seq.count = 1;
			     substr (auto_ifc.suspend_seq.chars, 1, 1) = substr (arg, 1, 1);
			     auto_ifc.resume_seq.count = 1;
			     substr (auto_ifc.resume_seq.chars, 1, 1) = substr (arg, 2, 1);
			end;
			auto_ifc.timeout = "0"b;
		     end;

		     else if arglen = 1
		     then do;
			auto_ifc.suspend_seq.count = 0;
			if arg = NUL
			then do;
			     auto_ifc.resume_seq.count = 0;
			     auto_ifc.timeout = "0"b;
			end;

			else do;
			     auto_ifc.resume_seq.count = 1;
			     substr (auto_ifc.resume_seq.chars, 1, 1) = arg;
			     auto_ifc.timeout = "1"b; /* this follows from lack of suspend char */
			end;
		     end;

		     else do;
			call com_err_ (0, cmd_name,
			     "Null character string specified for input flow control character.");
			return;
		     end;
		end;

		else if arg = "-output_suspend_resume" | arg = "-osr"
		then do;
		     set_osr_switch = "1"b;
		     call get_next_arg;
		     if code ^= 0
		     then return;
		     call check_two_chars;
		     if code ^= 0
		     then return;

		     if substr (arg, 1, 1) = NUL	/* no characters */
		     then auto_ofc.suspend_or_etb_seq.count, auto_ofc.resume_or_ack_seq.count = 0;
		     else do;
			auto_ofc.suspend_or_etb_seq.count = 1;
			auto_ofc.resume_or_ack_seq.count = 1;
			substr (auto_ofc.suspend_or_etb_seq.chars, 1, 1) = substr (arg, 1, 1);
			substr (auto_ofc.resume_or_ack_seq.chars, 1, 1) = substr (arg, 2, 1);
		     end;
		end;

		else if arg = "-output_etb_ack" | arg = "-oea"
		then do;
		     set_oea_switch = "1"b;
		     call get_next_arg;
		     if code ^= 0
		     then return;
		     call check_two_chars;
		     if code ^= 0
		     then return;

		     if substr (arg, 1, 1) = NUL	/* no characters */
		     then auto_ofc.suspend_or_etb_seq.count, auto_ofc.resume_or_ack_seq.count = 0;
		     else do;
			auto_ofc.suspend_or_etb_seq.count = 1;
			auto_ofc.resume_or_ack_seq.count = 1;
			substr (auto_ofc.suspend_or_etb_seq.chars, 1, 1) = substr (arg, 1, 1);
			substr (auto_ofc.resume_or_ack_seq.chars, 1, 1) = substr (arg, 2, 1);
		     end;
		end;

		else if arg = "-buffer_size" | arg = "-bsize"
		then do;
		     set_bsize_switch = "1"b;
		     call get_next_arg;
		     if code ^= 0
		     then return;

		     auto_ofc.buffer_size = cv_dec_check_ (arg, code);
		     if code ^= 0 | auto_ofc.buffer_size <= 0
		     then do;
			call com_err_ (0, cmd_name, "^a is not a valid buffer size.", arg);
			return;
		     end;
		end;

		else if arg = "-print" | arg = "-pr"
		then print_switch = "1"b;

		else if arg = "-brief" | arg = "-bf"
		then brief_switch = "1"b;

		else if arg = "-print_edit" | arg = "-pr_ed"
		then print_edit_switch = "1"b;

		else if arg = "-print_delay" | arg = "-pr_dly"
		then print_delay_switch = "1"b;

		else if arg = "-print_frame" | arg = "-pr_fr"
		then print_frame_switch = "1"b;

		else if arg = "-a" | arg = "-all"
		then print_switch, print_edit_switch, print_delay_switch, print_frame_switch, all_switch = "1"b;

		else go to bad_arg;
	     end;

	     else do;				/* arg doesn't begin with "-" */
bad_arg:
		call com_err_ (error_table_$badopt, cmd_name, "^a", arg);
		return;
	     end;

	end /* end of argument parsing */;

	if brief_switch & ^print_switch
	then do;
	     call com_err_ (error_table_$inconsistent, cmd_name, "-brief and not -print");
	     return;
	end;

/* Get the network id;          */
/* by default we are in MCS NET */

	call iox_$control (iocbp, "get_network_type", addr (network_type), code);
	if code = error_table_$undefined_order_request
	then do;
	     network_type = MCS_NETWORK_TYPE;
	     code = 0;
	end;
          else if code = 0
          then do;
	      if network_type ^= MCS_NETWORK_TYPE &
                   network_type ^= DSA_NETWORK_TYPE &
                   network_type ^= MOWSE_NETWORK_TYPE
                then do;
	         call com_err_ (error_table_$action_not_performed, cmd_name, "Invalid network type.");
	         return;
	      end;
	end;
          else do;
	   call com_err_ (0, cmd_name, "Unable to get network_type.");
	   return;
	end;
       

	t_info.version = terminal_info_version;
	call iox_$control (iocbp, "terminal_info", addr (t_info), code);
	if code ^= 0
	then go to error;

	if t_info.line_type < 0 | t_info.line_type > max_tty_line_type
						/* not a recognizable TTY line type */
	then standard_line_type = "0"b;		/* must not be standard_line_type */

	if type_switch
	then do;					/* handle type argument */
	     stt_info.version = stti_version_1;
	     stt_info.name = typename;
	     string (stt_info.flags) = ""b;
	     stt_info.flags.send_initial_string = standard_line_type;
	     stt_info.flags.set_modes = "1"b;
	     call iox_$control (iocbp, "set_term_type", addr (stt_info), code);
	     if code ^= 0
	     then go to error;
	end;

	else typename = t_info.term_type;		/* remember unchanged terminal type name */

	if reset_switch
	then do;
	     call iox_$control (iocbp, "set_default_modes", null, code);
	     if code ^= 0
	     then go to error;
	end;

	if tab_int_switch
	then do;
	     /*** set the tabulation interval */
	     /*** Only valid in DSA           */
	     if network_type ^= DSA_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		call iox_$control (iocbp, "set_tabulation", addr (tab_int), code);

		if code ^= 0
		then do;
		     call com_err_ (code, cmd_name, "Tabulation interval not set.");
		     tab_int_switch = "0"b;		/* so if "print_all" we'll have to get it */
		end;
	     end;
	end;

	if line_ind_switch
	then do;
	     /*** set the line indicator */
	     /*** Only valid in DSA      */
	     if network_type ^= DSA_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		call iox_$control (iocbp, "set_line_indicator", addr (line_ind), code);

		if code ^= 0
		then do;
		     call com_err_ (code, cmd_name, "Line indicator not set.");
		     line_ind_switch = "0"b;		/* so if "print_all" we'll have to get it */
		end;
	     end;
	end;

	if page_ind_switch
	then do;
	     /*** set the page indicator */
	     /*** Only valid in DSA      */
	     if network_type ^= DSA_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		call iox_$control (iocbp, "set_page_indicator", addr (page_ind), code);

		if code ^= 0
		then do;
		     call com_err_ (code, cmd_name, "Page indicator not set.");
		     page_ind_switch = "0"b;		/* so if "print_all" we'll have to get it */
		end;
	     end;
	end;

/* Set various mode-related characters before the modes themselves */

	if set_ifc_switch
	then do;
	     /*** set the input flow control characters */
	     /*** Only valid in MCS                     */
	     if network_type ^= MCS_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		call iox_$control (iocbp, "input_flow_control_chars", addr (auto_ifc), code);
		if code ^= 0
		then do;
		     set_ifc_switch = "0"b;
		     call com_err_ (code, cmd_name, "Input flow control characters not set.");
		end;
	     end;
	end;

	if set_oea_switch | set_bsize_switch
	then do;
	     /*** set the output block control or size */
	     /*** Only valid in MCS                    */
	     if network_type ^= MCS_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		if set_osr_switch			/* this is invalid combination */
		then do;
		     call com_err_ (error_table_$inconsistent, cmd_name, "No output flow controls set.");
		     set_osr_switch = "0"b;		/* make sure error message is true */
		end;

		else do;
		     auto_ofc.block_acknowledge = (auto_ofc.suspend_or_etb_seq.count ^= 0);
		     auto_ofc.suspend_resume = "0"b;
		     auto_ofc.mbz = "0"b;
		     if ^set_bsize_switch		/* chars only, buffer size already set (or set later) */
		     then auto_ofc.buffer_size = 0;
		     else if ^set_oea_switch
		     then do;
			unspec (auto_ofc.suspend_or_etb_seq) = "0"b;
			unspec (auto_ofc.resume_or_ack_seq) = "0"b;
		     end;

		     call iox_$control (iocbp, "output_flow_control_chars", addr (auto_ofc), code);
		     if code ^= 0
		     then do;
			set_oea_switch, set_bsize_switch = "0"b;
			call com_err_ (code, cmd_name, "Output block control and/or size not set.");
		     end;
		end;
	     end;
	end;

	if set_osr_switch
	then do;
	     /*** set output suspend/resume characters */
	     /*** Only valid in MCS                    */
	     if network_type ^= MCS_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		auto_ofc.suspend_resume = (auto_ofc.suspend_or_etb_seq.count ^= 0);
		auto_ofc.block_acknowledge = "0"b;
		auto_ofc.mbz = "0"b;
		call iox_$control (iocbp, "output_flow_control_chars", addr (auto_ofc), code);
		if code ^= 0
		then do;
		     set_osr_switch = "0"b;
		     call com_err_ (code, cmd_name, "Output suspend/resume characters not set.");
		end;
	     end;
	end;

	if set_frame_switch & standard_line_type
	then do;
	     /*** set framing characters */
	     /*** Only valid in MCS      */
	     if network_type ^= MCS_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		call iox_$control (iocbp, "set_framing_chars", addr (framing_chars), code);
		if code ^= 0
		then do;
		     call com_err_ (code, cmd_name, "Framing characters not set.");
		     set_frame_switch = "0"b;		/* so if "print_frame" we'll get them from ring 0 */
		end;
	     end;
	end;

	if modes_switch
	then do;
	     /*** whether we already set modes or not, we will make */
	     /*** a call for what the user specified explicitly     */

	     call iox_$modes (iocbp, input_modes, out_modes, code);
	     if code ^= 0
	     then if code = error_table_$bad_mode & standard_line_type
		then do;
		     call com_err_ (code, cmd_name, "^a", out_modes);
		     return;
		end;
		else go to error;
	end;

	if initial_string_switch
	then do;					/* set the tabs if possible */
	     call iox_$control (iocbp, "send_initial_string", null, code);
	     if code ^= 0
	     then call com_err_ (code, cmd_name, "^[Tabs not set.^;Initial string not sent.^]", tabs_switch);
	end;

	if set_edit_switch
	then do;
	     /*** MCS: set erase and kill characters            */
	     /*** DSA: set erase, kill and redisplay characters */
						/* Note, however, that even over a DSA network we may have an I/O module
						   that doesn't understand version 3 structure, in which case
						   we will retry with version 2 */

	     if network_type = DSA_NETWORK_TYPE
	     then editing_chars.version, editing_chars_version = 3;
	     else editing_chars.version, editing_chars_version = 2;
RETRY_SET_EDIT:
	     call iox_$control (iocbp, "set_editing_chars", addr (editing_chars), code);

	     if code ^= 0
	     then do;
		if code = error_table_$unimplemented_version & editing_chars_version = 3
		then do;
		     editing_chars.version, editing_chars_version = 2;
		     go to RETRY_SET_EDIT;
		end;

		call com_err_ (code, cmd_name, "Editing characters not set.");
		set_edit_switch = "0"b;		/* so if "print_edit" we'll call ring 0 to get them */
	     end;
	end;

	if set_delay_switch & standard_line_type
	then do;
	     /*** set delay timings */
	     /*** Only valid in MCS */
	     if network_type ^= MCS_NETWORK_TYPE
	     then call com_err_ (error_table_$unsupported_operation, cmd_name);
	     else do;

		if delay.default = 0		/* we're supplying them */
		then do;
		     if unchanged_delays		/* have to get old ones */
		     then do;
			call iox_$control (iocbp, "get_delay", addr (delay), code);
			if code ^= 0
			then go to not_set;

			do i = 1 to 6;
			     if ^substr (unchanged_delays, i, 1)
			     then addr (delay.values) -> based_fixed (i) = addr (input_delays) -> based_fixed (i);
			end;
		     end;

		     else delay.values = input_delays;	/* we have them all */
		end;

		call iox_$control (iocbp, "set_delay", addr (delay), code);

		if code ^= 0
		then do;
not_set:
		     call com_err_ (code, cmd_name, "Delays not set.");
		     set_delay_switch = "0"b;		/* in case we're printing them */
		end;
	     end;
	end;

	if print_switch
	then do;
	     /*** user wants to know what happened */

	     call iox_$modes (iocbp, "", out_modes, code);/* find out what the modes are now */
	     if brief_switch
	     then					/* user wants short modes string */
		call print_bf (out_modes);
	     else call ioa_ ("Type: ^a^/Modes: ^a", typename, out_modes);
	end;

	if print_edit_switch
	then do;
	     /*** wants to know his editing characters */

	     if set_edit_switch			/* we already know them */
		& index (editing_chars.chars, " ") = 0	/* didn't default either one */
	     then code = 0;
	     else do;

		editing_chars.chars = "";

		if editing_chars_version ^= 0
		then editing_chars.version = editing_chars_version;
						/* we've already figured this out, possibly by trial and error */

		else if network_type = DSA_NETWORK_TYPE
		then editing_chars.version, editing_chars_version = 3;
		else				/* MCS_NETWORK_TYPE */
		     editing_chars.version, editing_chars_version = 2;

RETRY_GET_EDIT:
		call iox_$control (iocbp, "get_editing_chars", addr (editing_chars), code);
	     end;

	     if code = 0
	     then do;
		if editing_chars_version = 3 & network_type = DSA_NETWORK_TYPE
		then call ioa_ ("Erase: ^a,  Kill: ^a,  Redisplay: ^a, Quote (unchangeable): \",
			cv_edit_char (substr (editing_chars.chars, 1, 1)),
			cv_edit_char (substr (editing_chars.chars, 2, 1)),
			cv_edit_char (substr (editing_chars.chars, 3, 1)));
		else call ioa_ ("Erase: ^a,  Kill: ^a", cv_edit_char (substr (editing_chars.chars, 1, 1)),
			cv_edit_char (substr (editing_chars.chars, 2, 1)));
	     end;

	     else do;				/* if we hadn't done a set, this might the first time we learned we had the wrong version */
		if code = error_table_$unimplemented_version & editing_chars_version = 3
		then do;
		     editing_chars.version, editing_chars_version = 2;
		     go to RETRY_GET_EDIT;
		end;

		call com_err_ (code, cmd_name, "Cannot print editing characters.");
	     end;
	end;

	if all_switch
	then do;

	     /*** DSA specific */

	     if network_type = DSA_NETWORK_TYPE
	     then do;

		if tab_int_switch			/* we already know it */
		then code = 0;
		else call iox_$control (iocbp, "get_tabulation", addr (tab_int), code);

		if code = 0
		then call ioa_ ("Tab interval  : ^i", tab_int);
		else call com_err_ (code, cmd_name, "Cannot print tab interval.");

		if line_ind_switch			/* we already know it */
		then code = 0;
		else call iox_$control (iocbp, "get_line_indicator", addr (line_ind), code);

		if code = 0
		then call ioa_ ("Line indicator: ^a", line_ind);
		else call com_err_ (code, cmd_name, "Cannot print line indicator.");

		if page_ind_switch			/* we already know it */
		then code = 0;
		else call iox_$control (iocbp, "get_page_indicator", addr (page_ind), code);

		if code = 0
		then call ioa_ ("Page indicator: ^a", page_ind);
		else call com_err_ (code, cmd_name, "Cannot print page indicator.");

	     end;
	end;

	/*** MCS	or MOWSE  specific */
	if network_type = MCS_NETWORK_TYPE | network_type = MOWSE_NETWORK_TYPE
	then do;

	     if print_frame_switch & standard_line_type
	     then do;
		if set_frame_switch			/* we already know the framing chars */
		then code = 0;
		else call iox_$control (iocbp, "get_framing_chars", addr (framing_chars), code);

		if code = 0
		then call ioa_ ("Frame_begin: ^a, Frame_end: ^a", substr (framing_chars, 1, 1),
			substr (framing_chars, 2, 1));

		else call com_err_ (code, cmd_name, "Cannot print framing characters.");
	     end;

	     if print_delay_switch & standard_line_type	/* he wants to know delay times */
	     then do;
		if set_delay_switch & delay.default = 0
		then code = 0;			/* they're what you said */
		else do;
		     delay.version = 1;
		     call iox_$control (iocbp, "get_delay", addr (delay), code);
		end;

		if code = 0
		then call ioa_ (
			"Delays: vert_nl ^d, horz_nl ^6.3f, const_tab ^d, var_tab ^6.3f, backspace ^d, vt_ff ^d",
			delay.values.vert_nl, delay.values.horz_nl, delay.values.const_tab, delay.values.var_tab,
			delay.values.backspace, delay.values.vt_ff);
		else call com_err_ (code, cmd_name, "Cannot print delay values.");
	     end;

	     if all_switch & standard_line_type
	     then do;
		code = 0;
		if ^set_ifc_switch
		then do;
		     call iox_$control (iocbp, "get_ifc_info", addr (auto_ifc), code);
		     if code ^= 0
		     then call com_err_ (code, cmd_name, "Cannot print input flow control information.");
		end;

		if code = 0
		then if auto_ifc.resume_seq.count ^= 0
		     then if auto_ifc.suspend_seq.count = 0
			then call ioa_ ("input resume: ^a, timeout",
				substr (auto_ifc.resume_seq.chars, 1, auto_ifc.resume_seq.count));
			else call ioa_ ("input suspend: ^a; input resume: ^a",
				substr (auto_ifc.suspend_seq.chars, 1, auto_ifc.suspend_seq.count),
				substr (auto_ifc.resume_seq.chars, 1, auto_ifc.resume_seq.count));

		code = 0;
		if ^(set_osr_switch | (set_oea_switch & set_bsize_switch))
						/* some output flow control we didn't set */
		then do;
		     call iox_$control (iocbp, "get_ofc_info", addr (auto_ofc), code);
		     if code ^= 0
		     then call com_err_ (code, cmd_name, "Cannot print output flow control information.");
		end;

		if code = 0
		then if auto_ofc.suspend_resume
		     then call ioa_ ("output suspend: ^a; output resume: ^a",
			     substr (auto_ofc.suspend_or_etb_seq.chars, 1, auto_ofc.suspend_or_etb_seq.count),
			     substr (auto_ofc.resume_or_ack_seq.chars, 1, auto_ofc.resume_or_ack_seq.count));

		     else if auto_ofc.block_acknowledge
		     then call ioa_ ("output end_of_block: ^a; acknowledge: ^a, buffer size = ^d",
			     substr (auto_ofc.suspend_or_etb_seq.chars, 1, auto_ofc.suspend_or_etb_seq.count),
			     substr (auto_ofc.resume_or_ack_seq.chars, 1, auto_ofc.resume_or_ack_seq.count),
			     auto_ofc.buffer_size);
	     end;
	end;

	else do;					/* DSA_NETWORK_TYPE */
	     if (print_frame_switch | print_delay_switch) & ^all_switch
	     then call com_err_ (error_table_$unsupported_operation, "-print_frame or print_delay");
	end;
	return;					/* all done */


error:						/* here if something went mysteriously wrong */
	call com_err_ (code, cmd_name);
	return;

bad_value:
	call com_err_ (0, cmd_name, "^a is not a valid delay value.", substr (arg, position, next_comma - 1));
	return;

cv_edit_char:
     proc (edit_char) returns (char (2) var);

/* convert an editing character in a form understandable by the user */

dcl  edit_char char (1);
dcl  rk fixed bin;

	rk = rank (edit_char);

	if rk < 32
	then return (printable_ctl_char (rk));
	else return (edit_char);

     end;


get_next_arg:
     proc;

/*  This internal procedure is used to get the second argument of a pair */

	iarg = iarg + 1;
	call cu_$arg_ptr (iarg, argptr, arglen, code);
	if code ^= 0
	then call com_err_ (code, cmd_name);
	return;
     end;


check_two_chars:
     proc;

/* This internal procedure checks to make sure that an argument is exactly 2 chars long */

	if arglen ^= 2
	then do;
	     if arglen > 2
	     then code = error_table_$bigarg;
	     else code = error_table_$smallarg;
	     call com_err_ (code, cmd_name, "^a", arg);
	end;
     end;

print_bf:
     proc (sstr);

dcl  sstr char (*),
     tstr char (256) varying,
     sidx fixed bin,
     (notidx, comidx) fixed bin;

	tstr = "";
	sidx = 1;
	comidx = 1;
	notidx = index (sstr, "^");
	do while (notidx ^= 0);
	     if notidx > 1
	     then do;
		tstr = tstr || substr (sstr, sidx, notidx - 1);
		sidx = sidx + notidx;
	     end;
	     comidx = index (substr (sstr, sidx), ",");
	     if comidx = 0
	     then notidx = 0;			/* terminate loop */
	     else do;
		sidx = sidx + comidx;
		notidx = index (substr (sstr, sidx), "^");
	     end;
	end;
	if comidx ^= 0
	then					/* some left, copy it */
	     tstr = tstr || substr (sstr, sidx);
	else if length (tstr) > 0
	then substr (tstr, length (tstr), 1) = ".";
	call ioa_ ("Type: ^a^/Modes: ^a", typename, tstr);
	return;
     end;


     end /* set_tty */;
 



		    timed_io_.pl1                   11/04/82  2006.8rew 11/04/82  1610.8       28539


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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* timed_io_: 1982.09.08 by Richard Lamson					*/
	/*									*/
	/* timed_io_ provides an interface to control orders in I/O modules which allow the	*/
	/* caller to specify that it only wants to wait a certain duration before returning,	*/
	/* whether the I/O has completed or not.					*/
	/*									*/
	/* The following entry points are implemented:					*/
	/*									*/
	/* timed_io_$get_chars (iocbp, timeout, buffer_ptr, buffer_length, chars_read, code);	*/
	/*									*/
	/* timed_io_$get_line  (iocbp, timeout, buffer_ptr, buffer_length, chars_read, code);	*/
	/*									*/
	/* timed_io_$put_chars (iocbp, timeout, buffer_ptr, buffer_length, chars_written, code);	*/
	/*									*/
	/* These entry points perform the same function as the equivalent iox_ entry points,	*/
	/* except that they return in approximately "timeout" microseconds, whether or not their	*/
	/* task is completed.  In the case of put_chars, the number of characters actually	*/
	/* written is returned.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	
timed_io_:
	procedure ();
	return;

timed_io_$get_chars:
	entry (P_iocb_ptr, P_timeout, P_buffer_ptr, P_buffer_length, P_characters_read, P_status);

	control_order = "get_chars_timeout";
	go to get_common;

timed_io_$get_line:
	entry (P_iocb_ptr, P_timeout, P_buffer_ptr, P_buffer_length, P_characters_read, P_status);

	control_order = "get_line_timeout";
get_common:
	input_timeout_data.timeout = P_timeout;
	input_timeout_data.buffer_pointer = P_buffer_ptr;
	input_timeout_data.buffer_length = P_buffer_length;
	call iox_$control (P_iocb_ptr, control_order, addr (input_timeout_data), P_status);
	P_characters_read = input_timeout_data.characters_read;
	return;

timed_io_$put_chars:
	entry (P_iocb_ptr, P_timeout, P_buffer_ptr, P_buffer_length, P_characters_written, P_status);

	control_order = "put_chars_timeout";
	output_timeout_data.timeout = P_timeout;
	output_timeout_data.buffer_pointer = P_buffer_ptr;
	output_timeout_data.buffer_length = P_buffer_length;
	call iox_$control (P_iocb_ptr, control_order, addr (output_timeout_data), P_status);
	P_characters_written = output_timeout_data.characters_written;
	return;

%page;
declare  (P_iocb_ptr, P_buffer_ptr) pointer;
declare	P_timeout fixed binary (71);
declare  (P_buffer_length, P_characters_read, P_characters_written) fixed binary (21);
declare	P_status fixed binary (35);

%include io_timeout_info;
declare 1 input_timeout_data aligned like input_timeout_info;
declare 1 output_timeout_data aligned like output_timeout_info;

declare	iox_$control entry (ptr, char(*), ptr, fixed bin(35));

declare	addr builtin;
declare	control_order character (32);

     end;
 



		    total_output_requests.pl1       11/04/82  2006.8rew 11/04/82  1610.8       94311


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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Names:  total_output_request, tor						*/
	/*									*/
	/*      This command prints a summary of number of entries in various I/O Daemon request	*/
	/* type queues.  When invoked as an active function, it returns the counts for a single	*/
	/* request type.								*/
	/*									*/
	/* Status									*/
	/* 0) Created:    October 5, 1981 by G. C. Dixon					*/
	/* 1) Modified:   April 29, 1982 by G. C. Dixon - to accept eor-defined request types	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

total_output_requests:
tor:	procedure;

     dcl						/*	automatic variables			*/
	Larg			fixed bin(21),	/* length of input argument.	 		*/
	Lret			fixed bin(21),	/* length of output argument.			*/
	Nargs			fixed bin,	/* number of input arguments.			*/
	Parg			ptr,		/* ptr to input argument.			*/
	Pret		 	ptr,		/* ptr to output argument.			*/
	Sall			bit(1),		/* on if in -all mode.			*/
	Sbrief			bit(1),		/* on if in -brief mode.			*/
	Sinhibit_error		bit(1),		/* on if in -inhibit_error mode.		*/
	Sno_rqt			bit(1),		/* on if processing the default print rqt.	*/
	code			fixed bin(35),	/* a status code.				*/
	delim			char(1),		/* delimiter character for output msg.		*/
	dft_q			fixed bin,
         (i, j)			fixed bin,	/* a do-group index.			*/
	long (4)			char(100),
	pic			pic"zzzzz9",
	longest_q_name		fixed bin,
	1 s			aligned,		/* device rqt structure.			*/
	  2 Nrqt		fixed bin,		/*    number of request types.		*/
	  2 rqt (100)		char(32) unal,	/*       rqt name.				*/
	  2 max_q (100)		fixed bin,
	  2 queues (100,4),
	    3 code		fixed bin(35),	/*       status code assoc. with rqt & queue.	*/
	    3 q 			fixed bin;	/*       queue counts for request type's queues.	*/

     dcl						/* 	based variables			*/
	arg			char(Larg) based (Parg),
						/* input argument.				*/
	ret			char(Lret) varying based (Pret);
						/* return argument.				*/

     dcl						/*		builtins			*/
         (dim, index, length, ltrim, max, min, rtrim, sum)
				builtin;

     dcl						/*	entries				*/
	active_fnc_err_		entry options (variable),
	com_err_			entry options (variable),
	convert_status_code_	entry (fixed bin(35), char(8), char(100)),
	cu_$af_arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	dprint_$queue_contents	entry (char(*), fixed bin, fixed bin, fixed bin(35)),
	enter_output_request$default_request_type
				entry (char(*), char(*), fixed bin, fixed bin, fixed bin(35)),
	enter_output_request$request_type
				entry (char(*), char(*), char(*), fixed bin, fixed bin, fixed bin(35)),
	iod_info_$queue_data	entry (char(*), fixed bin, fixed bin, fixed bin(35)),
	iod_info_$rqt_list		entry (char(32) unal, (*) char(32) unal, fixed bin, fixed bin(35)),
         (ioa_, ioa_$nnl)		entry options (variable);

     dcl						/*	static variables			*/
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
         (error_table_$badopt,
	error_table_$bigarg,
	error_table_$id_not_found,
	error_table_$too_many_names,
	error_table_$wrong_no_of_args) fixed bin(35) ext static;

	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;			/* Use special code if invoked as an active fcn	*/
	     ret = "";
	     if Nargs > 1 then go to wnoa;
	     if Nargs = 1 then do;
		call cu_$af_arg_ptr (1, Parg, Larg, code);
		call enter_output_request$request_type (arg, "", s.rqt(1), dft_q, s.max_q(1), code);
		if code ^= 0 then go to af_undefined_request_type;
		end;
	     else do;
		call enter_output_request$default_request_type ("printer", s.rqt(1), dft_q, s.max_q(1), code);
		if code ^= 0 then go to af_bad_default_request_type;
		end;

	     s.max_q(1) = min(s.max_q(1),4);		/* This program only supports up to 4 queues.	*/

	     do i = 1 to s.max_q(1);
		call dprint_$queue_contents (s.rqt(1), i, s.q(1,i), s.code(1,i));
		end;

	     if s.code(1,1) = 0 then do;		/* Got count for queue 1 successfully?		*/
		pic = s.q(1,1);			/*   Yes, return the count.			*/
		ret = ltrim(pic);
		end;
	     else ret = "*";			/*   No, return a star for queue 1 count.	*/

	     do i = 2 to s.max_q(1);
		ret = ret || " ";
		if s.code(1,i) = 0 then do;		/* Do same for counts in other queues.		*/
		     pic = s.q(1,i);
		     ret = ret || ltrim(pic);
		     end;
		else ret = ret || "*";
		end;

	     return;

wnoa:	     call active_fnc_err_ (error_table_$wrong_no_of_args, "total_output_requests",
		"^/Usage:^-[tor  {request_type} ]");
	     return;

af_undefined_request_type:
	     call active_fnc_err_ (code, "total_output_requests", "
Request type ^a undefined.", arg);
	     return;

af_bad_default_request_type:
	     call active_fnc_err_ (code, "total_output_requests", "
Unable to get default printer request type.");
	     return;
	     end;

	else do;					/* Invoked as a command.			*/
	     Sall = FALSE;				/* Prepare to parse arguments.		*/
	     Sbrief = FALSE;
	     Sinhibit_error = FALSE;
	     s.Nrqt = 0;
	     do i = 1 to Nargs;
		call cu_$arg_ptr (i, Parg, Larg, code);
		if index(arg, "-") = 1 then do;
		     if arg = "-brief" | arg = "-bf"
			then Sbrief = TRUE;
		     else if arg = "-long" | arg = "-lg"
			then Sbrief = FALSE;
		     else if arg = "-all" | arg = "-a"
			then Sall = TRUE;
		     else if arg = "-inhibit_error" | arg = "-ihe"
			then Sinhibit_error = TRUE;
		     else go to badopt;
		     end;
		else do;				/* Arg is a request type name.  Save it in array. */
		     if Larg > length(s.rqt(1)) then go to longarg;
		     if s.Nrqt = dim(s.rqt,1) then go to manyarg;
		     j, s.Nrqt = s.Nrqt + 1;
		     call enter_output_request$request_type (arg, "", s.rqt(j), dft_q, s.max_q(j), code);
		     if code ^= 0 then do;
			s.max_q(j) = 1;
			s.code(j,1) = code;
			s.q(j,1) = 0;
			end;
		     else do;
			s.q(j,*) = 0;
			s.code(j,*) = 0;
			end;
		     end;
		end;

	     if s.Nrqt = 0 then			/* No request type names were given?		*/
		if Sall then do;			/*   -all means all known types.  Get the list.	*/
		     Sno_rqt = FALSE;
		     call iod_info_$rqt_list ("", s.rqt, s.Nrqt, code);
		     if code ^= 0 then do;
			call com_err_ (code, "total_output_requests", "
^d request types exist.  Only the first ^d will be printed.", s.Nrqt, dim(s.rqt,1));
			s.Nrqt = dim(s.rqt,1);
			end;
		     s.q(*,*) = 0;
		     s.code(*,*) = 0;
		     do i = 1 to s.Nrqt;
			call iod_info_$queue_data (s.rqt(i), dft_q, s.max_q(i), code);
			if code ^= 0 then do;	/* No data for entire request_type?		*/
			     s.max_q(i) = 1;
			     s.code(i,1) = code;
			     end;
			end;
		     end;
		else do;				/*   Default is to list printer request_type only.*/
		     Sno_rqt = TRUE;
		     s.Nrqt = 1;
		     s.q(1,*) = 0;
		     call enter_output_request$default_request_type ("printer", s.rqt(1), dft_q, s.max_q(1), code);
		     if code ^= 0 then do;
			s.max_q(1) = 1;
			s.code(1,1) = code;
			end;
		     else s.code(1,*) = 0;
		     end;
	     else Sno_rqt = FALSE;			/*   request_type args were given.		*/

	     longest_q_name = 0;			/* Compute length of longest request_type name.	*/
	     do i = 1 to s.Nrqt;
		longest_q_name = max (longest_q_name, length (rtrim (s.rqt(i))));
		end;
	     longest_q_name = longest_q_name + length("  ");

	     do i = 1 to s.Nrqt;			/* Get/print data for each request type. 	*/
		if s.code(i,1) = 0 then
		do j = 1 to s.max_q(i);		/* Get data which  is accessible.		*/
		     call dprint_$queue_contents (s.rqt(i), j, s.q(i,j), s.code(i,j));
		     end;

		if Sno_rqt then do;			/* Neither -all nor request_type names given?	*/
		     if sum(s.code(1,*)) > 0 then	/*   Then suppress request type name unless	*/
			delim = ":";		/*   an error was encountered while listing queues*/
		     else do;
			s.rqt(1) = "";
			delim = "";
			longest_q_name = 1;
			end;
		     end;
		else delim = ":";

		if Sbrief then			/*   Skip request type if no data to print & -bf	*/
		     if sum(s.code(i,*)) + sum(s.q(i,*)) = 0 then
			go to SKIP_DVC;
		if sum(s.code(i,*)) = 0 then		/*   Simple case:  no errors while getting totals.*/
		     call ioa_ ("^a^a^vt^v(^5d ^)^5d",
			s.rqt(i), delim, longest_q_name, s.max_q(i)-1,
			s.q(i,1), s.q(i,2), s.q(i,3), s.q(i,4));
		else do;				/*   Complex case:  errors occurs for some queue. */
		     do j = 1 to s.max_q(i);
			call convert_status_code_ (s.code(i,j), "", long(j));
			end;
		     call ioa_ ("^a^a^vt^v(^[^5d^;^s*****^] ^)^[^5d^;^s*****^] ",
			s.rqt(i), delim, longest_q_name, s.max_q(i)-1,
		         (s.code(i,1) = 0), s.q(i,1),
		         (s.code(i,2) = 0), s.q(i,2),
		         (s.code(i,3) = 0), s.q(i,3),
		         (s.code(i,4) = 0), s.q(i,4));
		     if ^Sinhibit_error then do;
			if s.max_q(i) = 1 & s.code(i,1) = error_table_$id_not_found then
			     call ioa_ ("^-^a  Request type undefined.", long(1));
			else call ioa_$nnl ("^v(^[^-^a  ^a queue ^d.^/^;^3s^]^)",
			     s.max_q(i),
			    (s.code(i,1) ^= 0), long(1), s.rqt(i), 1,
			    (s.code(i,2) ^= 0), long(2), s.rqt(i), 2,
			    (s.code(i,3) ^= 0), long(3), s.rqt(i), 3,
			    (s.code(i,4) ^= 0), long(4), s.rqt(i), 4);
			end;
		     end;
SKIP_DVC:		end;
	     call ioa_ ("");
	     return;

badopt:	     call com_err_ (error_table_$badopt, "total_output_requests", "^a
Usage:	total_output_requests {request_types} {-ctl_args}
ctl_args:	-brief, -bf
	-long, -lg
	-all, -a
	-inhibit_error, -ihe", arg);
	     return;

longarg:	     call com_err_ (error_table_$bigarg, "total_output_requests", "^a
A request type must be ^d characters or less in length.",
		arg, length(s.rqt(1)));
	     return;

manyarg:	     call com_err_ (error_table_$too_many_names, "total_output_requests", "
A maximum of ^d request types may be given.", dim(s.rqt,1));
	     return;
	     end;

	end total_output_requests;
 



		    ttt_info_.pl1                   10/17/88  1106.6rew 10/17/88  1024.2      228033


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


/* A procedure to extract information from the Terminal Type Table (TTT) */


/****^  HISTORY COMMENTS:
  1) change(77-06-13,JStern), approve(), audit(), install():
     Coded by J. Stern 6/13/77
     Modified 5/29/81 by Suzanne Krupp to add ttt_info_$function_key_data entry
        Also to make all entries reject noncurrent version of ttt.
     December 1981, Better update detection -- Benson I. Margulies
  2) change(84-12-17,Negaret), approve(87-07-23,MCR7742),
     audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055):
     Add the support of the entry point dsa_tm_neg_info to obtain the
     negotiation info to open a session on a DSA network.
  3) change(85-11-25,Swenson), approve(87-07-23,MCR7742),
     audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055):
     Fixed misuse of boolean evaluation order in if statement for calculating
     pointer to DSA TM extended table.
  4) change(87-03-10,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-08,MR12.1-1030):
     Support TTT_version_3 which includes the protocol field.
  5) change(88-04-27,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) Remove (translate to spaces) control characters appearing in
         answerback sequences, because of their possible impact on as
         operator terminal. (Answering_Service 406, phx19102)
  6) change(88-09-28,Brunelle), approve(88-01-26,MCR7813),
     audit(88-10-05,Blair), install(88-10-17,MR12.2-1171):
     Upgrade to TTT_version_4 which includes c_chars expansion.
                                                   END HISTORY COMMENTS */


/* format: style2,idind25 */

ttt_info_:
     proc;

/* Parameters */

	dcl     pm_tt_name		   char (*);	/* terminal type name (Input) (Output) */
	dcl     pm_line_type	   fixed bin;	/* line type number (Input) */
	dcl     pm_baud		   fixed bin;	/* baud rate (Input) */
	dcl     pm_ttd_ptr		   ptr;		/* ptr to terminal_type_data structure (Input) */
	dcl     pm_code		   fixed bin (35);	/* status code (Output) */
	dcl     pm_modes		   char (*);	/* mode string (Output) */
	dcl     pm_initial_string	   char (*) varying;/* terminal initialization string (Output) */
	dcl     pm_additional_info	   char (*) varying;/* data provided for IO modules other than tty_ (Output) */
	dcl     pm_answerback	   char (*);	/* terminal answerback string (Input) */
	dcl     pm_id		   char (4);	/* terminal identifier (Output) */
	dcl     pm_ppm_flag		   bit (1);	/* print preaccess message flag (Output) */
	dcl     pm_cpo_flag		   bit (1);	/* conditional printer off flag (Output) */
	dcl     pm_command_name	   char (*);	/* preaccess command name */
	dcl     pm_coded_type	   fixed bin;	/* terminal type code number (Input) (Output) */
	dcl     pm_dname		   char (*);	/* TTT directory pathname */
	dcl     pm_ename		   char (*);	/* TTT entry name */
	dcl     pm_ttyvtblp		   ptr;		/* pointer to a video table */
	dcl     pm_dsatmdevp	   ptr;		/* pointer to a dsatm_device structure */
	dcl     pm_areap		   ptr;		/* pointer to user area for allocating table */
	dcl     pm_function_key_data_ptr ptr;		/* pointer to function key data structure */

/* Automatic */

	dcl     saved_install_time	   fixed bin (71);
	dcl     my_name		   char (32);
	dcl     (i, j)		   fixed bin;
	dcl     (tte_table_array_ptr, ttd_table_array_ptr)
				   ptr;
	dcl     stringp		   ptr;
	dcl     stringl		   fixed bin (21);
	dcl     next_offset		   fixed bin (18);
	dcl     (scanx, defx)	   fixed bin;
	dcl     ab		   char (100) varying;
	dcl     termp		   ptr;
	dcl     key		   char (1) aligned;
	dcl     value		   fixed bin;
	dcl     save_id		   char (4) varying;
	dcl     dname		   char (168);
	dcl     ename		   char (32);
	dcl     ec		   fixed bin (35);
	dcl     re_init_label	   label internal;
	dcl     areap		   ptr;
	dcl     char_time		   float bin;
	dcl     p			   ptr;
	dcl     sourcep		   ptr;
	dcl     targetp		   ptr;

/* Based */

	dcl     tte_table_rp	   (5) fixed bin (18) based (tte_table_array_ptr);
	dcl     ttd_table_ptr	   (5) ptr based (ttd_table_array_ptr);
	dcl     based_string	   char (stringl) based (stringp);
	dcl     user_area		   area based (areap);

	dcl     1 term		   unal based (termp),
		2 key		   char (1) unal,
		2 value		   fixed bin (8) unal,
		2 string		   char (0 refer (term.value));


/* Internal static */

	declare 1 ttt_info_data_	   aligned external,
		2 saved_tttp	   pointer init (null ()),
		2 saved_dname	   char (168) init (">system_control_1") unaligned,
		2 saved_ename	   char (32) init ("ttt") unaligned;

	dcl     capital_letters	   char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	dcl     small_letters	   char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
	dcl     digits		   char (10) int static options (constant) init ("0123456789");


/* External static */

	dcl     dsatm_data_$device_multics_dft
				   ext static aligned;

	dcl     (
	        error_table_$noalloc,
	        error_table_$no_table,
	        error_table_$no_term_type,
	        error_table_$invalid_line_type,
	        error_table_$incompatible_term_type,
	        error_table_$unimplemented_version,
	        error_table_$smallarg,
	        error_table_$improper_data_format,
	        error_table_$invalid_preaccess_command,
	        error_table_$badopt,
	        error_table_$wrong_no_of_args
	        )			   fixed bin (35) external;


/* Conditions */

	dcl     seg_fault_error	   condition;
	dcl     area		   condition;
	dcl     out_of_bounds	   condition;

/* Builtins */

	dcl     (addr, collate, float, index, length, min, null, ptr, rtrim, search, string, substr, translate)
				   builtin;


/* procedures */

	dcl     initiate_file_	   entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     terminate_file_	   entry (ptr, fixed bin (24), bit (*), fixed bin (35));

	dcl     cu_$arg_ptr		   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cu_$arg_count	   entry (fixed bin);
	dcl     expand_pathname_	   entry (char (*), char (*), char (*), fixed bin (35));
	dcl     ioa_		   entry options (variable);
	dcl     com_err_		   entry options (variable);
	dcl     com_err_$suppress_name   entry options (variable);
	dcl     get_system_free_area_	   entry returns (ptr);

terminal_data:
     entry (pm_tt_name, pm_line_type, pm_baud, pm_ttd_ptr, pm_code);

	re_init_label = terminal_data_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
terminal_data_init:
	call initialize;				/* gets install time */
	call find_tte;

	if pm_line_type > 0				/* don't ignore line type */
	then do;					/* make sure term type is compatible with line type */
		if pm_line_type > 72
		then do;
			pm_code = error_table_$invalid_line_type;
			return;
		     end;
		if ^substr (tte.line_types, pm_line_type, 1)
		then do;
			pm_code = error_table_$incompatible_term_type;
			return;
		     end;
	     end;

	ttdp = pm_ttd_ptr;
	if ttdp = null				/* no data wanted */
	then return;

	if terminal_type_data.version > ttd_version_3 | terminal_type_data.version <= 0
	then do;
		pm_code = error_table_$unimplemented_version;
		return;
	     end;

	terminal_type_data.old_type = tte.old_type;
	terminal_type_data.name = tte.name;

	tte_table_array_ptr = addr (tte.tables);
	ttd_table_array_ptr = addr (terminal_type_data.tables);
	do i = 1 to 5;
	     if tte_table_rp (i) = 0
	     then ttd_table_ptr (i) = null;
	     else ttd_table_ptr (i) = addr (ptr (tttp, tte_table_rp (i)) -> table_entry.table);
	end;

	if tte.delay_rp = 0
	then terminal_type_data.delay_ptr = null;
	else do;					/* find delay table for specified baud */
		delay_tablep = ptr (tttp, tte.delay_rp);
		j = 0;
		do i = 1 to delay_table.n_bauds while (delay_table.baud_rate (i) ^= pm_baud);
		     if delay_table.baud_rate (i) = 0	/* matches any baud */
		     then j = i;
		end;
		if i <= delay_table.n_bauds		/* found an exact match */
		then terminal_type_data.delay_ptr = addr (delay_table.version (i));
		else if j ^= 0			/* found a "match any"  */
		then terminal_type_data.delay_ptr = addr (delay_table.version (j));
		else terminal_type_data.delay_ptr = null;
						/* no delay table for specified baud */
	     end;

	terminal_type_data.erase = tte.erase;
	terminal_type_data.kill = tte.kill;
	string (terminal_type_data.framing_chars) = string (tte.framing_chars);
	string (terminal_type_data.flags) = ""b;
	terminal_type_data.keyboard_locking = tte.keyboard_addressing;
	terminal_type_data.line_delimiter = tte.line_delimiter;

	if terminal_type_data.version >= ttd_version_2	/* version 2 stuff */
	then do;
		string (terminal_type_data.flow_control_chars) = string (tte.flow_control_chars);
		terminal_type_data.output_buffer_size = tte.output_buffer_size;
		terminal_type_data.input_timeout = tte.input_timeout;
		terminal_type_data.output_block_acknowledge = tte.output_block_acknowledge;
	     end;

          if terminal_type_data.version = ttd_version_3	/* version 3 stuff */
          then terminal_type_data.protocol = tte.protocol;

	go to EXIT;

modes:
     entry (pm_tt_name, pm_modes, pm_code);

	re_init_label = modes_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
modes_init:
	call initialize;
	call find_tte;

	pm_modes = tte.modes;
	if length (rtrim (tte.modes)) > length (pm_modes)
	then pm_code = error_table_$smallarg;

	go to EXIT;

video_info:
     entry (pm_tt_name, pm_baud, pm_areap, pm_ttyvtblp, pm_code);

	re_init_label = video_infop_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
video_infop_init:
	call initialize;
	call find_tte;

	if tte.extended_tables_rp = 0
	then do;
no_video:
		pm_ttyvtblp = null ();
		pm_code = error_table_$no_table;
		go to EXIT;
	     end;
	extended_tablesp = ptr (tttp, tte.extended_tables_rp);
	if extended_tables.ntables < VIDEO_RP
	then go to no_video;
	if extended_tables.tables_rp (VIDEO_RP) = 0
	then go to no_video;

	if pm_baud > 0
	then char_time = 1.0 / (float (pm_baud) / 10.);
	else char_time = 0.0;

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

	ttyvtblp = ptr (tttp, extended_tables.tables_rp (VIDEO_RP));
	tty_video_table_video_chars_len = tty_video_table.video_chars_len;
	on area call AREA_FULL;
	allocate tty_video_table in (user_area) set (p);
	p -> tty_video_table = tty_video_table;
	ttyvtblp = p;

	do i = 1 to min (N_VIDEO_SEQUENCES, tty_video_table.nseq);
	     ttyvseqp = addr (tty_video_table.sequences (i));
	     if tty_video_seq.present
	     then do;
		     ttyvseqp = addr (tty_video_table.sequences (i));
		     if tty_video_seq.cpad_present & ^tty_video_seq.cpad_in_chars
		     then do;
			     if char_time = 0.0
			     then tty_video_seq.cpad_present = "0"b;
			     else do;
				     tty_video_seq.cpad =
					((float (tty_video_seq.cpad) / 1.0e4) / char_time) + .9999;
				     tty_video_seq.cpad_in_chars = "1"b;
				     if tty_video_seq.cpad = 0
				     then tty_video_seq.cpad_present, tty_video_seq.cpad_in_chars = "0"b;
				end;
			end;
		end;
	end;
	pm_ttyvtblp = ttyvtblp;
	go to EXIT;


function_key_data:
     entry (pm_tt_name, pm_areap, pm_function_key_data_ptr, pm_code);

	re_init_label = function_key_data_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;

function_key_data_init:
	call initialize;
	call find_tte;
	if tte.fkey_rp = 0
	then do;
		pm_function_key_data_ptr = null;
		pm_code = error_table_$no_table;
		goto EXIT;
	     end;
	pm_code = 0;
	fkey_tablep = ptr (tttp, tte.fkey_rp);
	function_key_data_ptr = addr (fkey_table.fkey_data);

	if pm_areap = null
	then areap = get_system_free_area_ ();		/* default area for function_key_data */
	else areap = pm_areap;			/* user specifcied area for function_key_data */

	function_key_data_highest = function_key_data.highest;
	on area call AREA_FULL;
	allocate function_key_data in (user_area) set (pm_function_key_data_ptr);
	pm_function_key_data_ptr -> function_key_data = function_key_data;
	on area call AREA_FULL;
	allocate function_key_seqs in (user_area) set (pm_function_key_data_ptr -> function_key_data.seq_ptr);
	sourcep = ptr (tttp, fkey_table.seq_offset);
	targetp = pm_function_key_data_ptr -> function_key_data.seq_ptr;
	targetp -> function_key_seqs = sourcep -> function_key_seqs;

	go to EXIT;


dsatm_device:
     entry (pm_tt_name, pm_areap, pm_dsatmdevp, pm_code);

	re_init_label = dsatm_device_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
dsatm_device_init:
	call initialize;
	call find_tte;

	if tte.extended_tables_rp = 0
	then dsatmdevp = addr (dsatm_data_$device_multics_dft);

	else do;

		extended_tablesp = ptr (tttp, tte.extended_tables_rp);

		if extended_tables.ntables >= DSATM_DEVICE_RP
		then if extended_tables.tables_rp (DSATM_DEVICE_RP) ^= 0
		     then dsatmdevp = ptr (tttp, extended_tables.tables_rp (DSATM_DEVICE_RP));
		     else dsatmdevp = addr (dsatm_data_$device_multics_dft);
		else dsatmdevp = addr (dsatm_data_$device_multics_dft);
	     end;

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

	on area call AREA_FULL;
	allocate dsatm_device in (user_area) set (p);

	p -> dsatm_device = dsatmdevp -> dsatm_device;
	p -> dsatm_device.terminal_type = pm_tt_name;
	pm_dsatmdevp = p;

	go to EXIT;


preaccess_type:
     entry (pm_command_name, pm_tt_name, pm_code);

	re_init_label = preaccess_type_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
preaccess_type_init:
	call initialize;

	if pm_command_name = "MAP"
	then i = ttt.type_map;
	else if pm_command_name = "963"
	then i = ttt.type_963;
	else if pm_command_name = "029"
	then i = ttt.type_029;
	else do;
		pm_code = error_table_$invalid_preaccess_command;
		return;
	     end;

	if i = 0
	then pm_tt_name = "";
	else pm_tt_name = ttt.tt_entries (i).name;

	go to EXIT;

initial_string:
     entry (pm_tt_name, pm_initial_string, pm_code);

	re_init_label = initial_string_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
initial_string_init:
	call initialize;
	call find_tte;

	if tte.initial_string.offset = 0
	then pm_initial_string = "";
	else do;
		stringp = ptr (tttp, tte.initial_string.offset);
		stringl = tte.initial_string.length;
		pm_initial_string = based_string;
		if stringl > length (pm_initial_string)
		then pm_code = error_table_$smallarg;
	     end;

	go to EXIT;


additional_info:
     entry (pm_tt_name, pm_additional_info, pm_code);

	re_init_label = additional_info_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
additional_info_init:
	call initialize;
	call find_tte;

	if tte.additional_info.offset = 0
	then pm_additional_info = "";
	else do;
		stringp = ptr (tttp, tte.additional_info.offset);
		stringl = tte.additional_info.length;
		pm_additional_info = based_string;
		if stringl > length (pm_additional_info)
		then pm_code = error_table_$smallarg;
	     end;

	go to EXIT;

dialup_flags:
     entry (pm_tt_name, pm_ppm_flag, pm_cpo_flag, pm_code);

	re_init_label = dialup_flags_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
dialup_flags_init:
	call initialize;
	call find_tte;

	pm_ppm_flag = tte.flags.print_preaccess_message;
	pm_cpo_flag = tte.flags.conditional_printer_off;

	go to EXIT;


default_term_type:
     entry (pm_line_type, pm_baud, pm_tt_name, pm_code);

	re_init_label = default_term_type_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
default_term_type_init:
	call initialize;

	pm_tt_name = "";
	if ttt.default_type_offset = 0		/* no default type table */
	then return;
	dfttp = ptr (tttp, ttt.default_type_offset);

/* find matching line type and baud in default type table (0 => "match any") */
	do i = 1 to dftt.dft_count
	     while (
	     ^((dftte (i).line_type = 0 | dftte (i).line_type = pm_line_type)
	     & (dftte (i).baud = 0 | dftte (i).baud = pm_baud)));
	end;
	if i <= dftt.dft_count			/* found a match */
	then pm_tt_name = ttt.tt_entries (dftte (i).term_type_index).name;

	go to EXIT;

decode_answerback:
     entry (pm_answerback, pm_line_type, pm_tt_name, pm_id, pm_code);

	pm_tt_name, pm_id = "";
	if pm_line_type > 72
	then do;
		pm_code = error_table_$invalid_line_type;
		return;
	     end;

	re_init_label = decode_answerback_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
decode_answerback_init:
	call initialize;

	ab = translate (pm_answerback, capital_letters, small_letters);
						/* capitalize all letters */
	if length (ab) = 0
	then return;

	do next_offset = ttt.answerback_offset repeat answerback_entry.next while (next_offset ^= 0);
						/* search thru answerback entries */

	     answerback_entry_ptr = ptr (tttp, next_offset);
	     scanx = 1;				/* init scan index for answerback string */
	     save_id = "";				/* id is null until we discover otherwise */

	     do defx = 1 by 2 to def_string.length;	/* scan the answerback entry definition string */
		termp = addr (def_string.chars (defx)); /* get ptr to next term in definition string */
		key = term.key;			/*  get single-letter keyword symbol */
		value = term.value;			/* get argument to keyword */

		if key = "k"			/* "skip" keyword */
		then do;
			scanx = scanx + value;
			if scanx < 1 | scanx > length (ab)
			then go to next_ab_entry;
			go to next_term;
		     end;

		if scanx > length (ab)		/* end of answerback string */
		then go to next_ab_entry;

		if key = "m"			/* "match" keyword */
		then do;
			if value <= 0
			then do;
				if value = -1	/* match a letter */
				then do;
					if index (capital_letters, substr (ab, scanx, 1)) = 0
					then go to next_ab_entry;
				     end;
				else if value = -2	/* match a digit */
				then do;
					if index (digits, substr (ab, scanx, 1)) = 0
					then go to next_ab_entry;
				     end;
				else go to bad_data;/* illegal value */
				scanx = scanx + 1;
			     end;
			else do;			/* match string */
				if scanx + value - 1 > length (ab)
						/* match string exceeds answerback string */
				then go to next_ab_entry;
				if substr (ab, scanx, value) ^= term.string
				then go to next_ab_entry;
				scanx = scanx + value;
				defx = defx + value;
			     end;
		     end;

		else if key = "s"			/* "search" keyword */
		then do;
			if value <= 0
			then do;
				if value = -1	/* search for a letter */
				then do;
					i = search (substr (ab, scanx), capital_letters);
					if i = 0
					then go to next_ab_entry;
				     end;
				else if value = -2	/* search for a digit */
				then do;
					i = search (substr (ab, scanx), digits);
					if i = 0
					then go to next_ab_entry;
				     end;
				else go to bad_data;/* illegal value */
				scanx = scanx + i;
			     end;
			else do;			/* search for string */
				i = index (substr (ab, scanx), term.string);
				if i = 0
				then go to next_ab_entry;
				scanx = scanx + i + value - 1;
				defx = defx + value;
			     end;
		     end;

		else if key = "i"			/* "id" keyword */
		then do;
			if value = 0		/* rest of answerback is id */
			then do;
				save_id = substr (pm_answerback, scanx);
						/* ID as it actually appeared */
				scanx = length (ab) + 1;
			     end;
			else if value >= 1 & value <= 4
			then do;			/* next 1 to 4 chars of answerback is id */
				if scanx + value - 1 > length (ab)
				then go to next_ab_entry;
				save_id = substr (pm_answerback, scanx, value);
				scanx = scanx + value;
			     end;
			else go to bad_data;	/* illegal value */
		     end;

		else do;				/* unknown key */
bad_data:
			pm_code = error_table_$improper_data_format;
			return;
		     end;

next_term:
	     end;					/* Come here if a matching answerback entry was found */

	     if answerback_entry.term_type_index ^= 0	/* terminal type indicated */
	     then do;
		     ttep = addr (ttt.tt_entries (answerback_entry.term_type_index));
		     if pm_line_type > 0		/* don't ignore line type */
		     then if ^substr (tte.line_types, pm_line_type, 1)
			then go to next_ab_entry;
		     pm_tt_name = tte.name;		/* set terminal type indicated by answerback */
		end;

	     pm_id = translate (save_id, (32)" ", substr (collate (),1,32));
						/* return id without trailing control chars */

	     return;

next_ab_entry:
	end;

	go to EXIT;

encode_type:
     entry (pm_tt_name, pm_coded_type, pm_code);

	re_init_label = encode_type_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
encode_type_init:
	call initialize;
	call find_tte;

	pm_coded_type = tte.coded_type;

	go to EXIT;


decode_type:
     entry (pm_coded_type, pm_tt_name, pm_code);

	re_init_label = decode_type_init;
	on seg_fault_error, out_of_bounds go to RE_INIT;
decode_type_init:
	call initialize;

	do i = 1 to ttt.n_tt_entries;
	     ttep = addr (ttt.tt_entries (i));
	     if tte.coded_type = pm_coded_type
	     then do;
		     pm_tt_name = tte.name;
		     return;
		end;
	end;

	pm_tt_name = "";

	go to EXIT;

set_ttt_path:
     entry options (variable);			/* command to change ttt pathname */

	my_name = "set_ttt_path";
	call cu_$arg_count (i);
	if i ^= 1
	then do;
		call com_err_$suppress_name (error_table_$wrong_no_of_args, my_name,
		     "Usage:  set_ttt_path [path | -reset]");
		return;
	     end;
	call cu_$arg_ptr (1, stringp, stringl, (0));

	if substr (based_string, 1, 1) = "-"
	then if based_string = "-reset" | based_string = "-rs"
	     then do;
		     dname = ">system_control_1";
		     ename = "ttt";
		end;
	     else do;
		     call com_err_ (error_table_$badopt, my_name, based_string);
		     return;
		end;
	else do;					/* not control arg, its a PATH */
		call expand_pathname_ (based_string, dname, ename, ec);
		if ec ^= 0
		then do;
			call com_err_ (ec, my_name, based_string);
			return;
		     end;
	     end;

	call initiate_file_ (dname, ename, R_ACCESS, tttp, (0), ec);
	if tttp = null
	then do;
		call com_err_ (ec, my_name, "^a>^a", dname, ename);
		return;
	     end;

/* Make a plausibility check */

	if ttt.version ^= TTT_version_4
          then do;
	          call com_err_(error_table_$unimplemented_version, my_name, "^/^a>^a is version ^d; the current version is ^d.^/Please recompile your ttf.^/", dname, ename, ttt.version, TTT_version_4);
		return;
                end;

          else if n_tt_entries ^> 0 | total_ttt_size ^> n_tt_entries
	then do;
		call com_err_ (error_table_$improper_data_format, my_name, "^/^a>^a does not appear to be a valid TTT",
		     dname, ename);
		return;
	     end;


	if saved_tttp ^= null
	then call terminate_file_ (saved_tttp, (0), TERM_FILE_TERM, (0));
	saved_tttp = tttp;
	saved_dname = dname;
	saved_ename = ename;

	return;


print_ttt_path:
     entry;

	call ioa_ ("^a>^a", saved_dname, saved_ename);
	return;


ttt_path:
     entry (pm_dname, pm_ename);

	pm_dname = saved_dname;
	pm_ename = saved_ename;

	return;

EXIT:
	if tttp ^= null
	then if ttt.last_install_time ^= saved_install_time
	     then go to re_init_label;		/* Try Again */

	return;

/* Come here on seg_fault_error, out_of_bounds.  Assume that a new TTT was installed. */

RE_INIT:
	if saved_tttp ^= null
	then do;
		call terminate_file_ (saved_tttp, (0), TERM_FILE_TERM, (0));
		saved_tttp = null;			/* forget the old TTT */
	     end;

	revert seg_fault_error, out_of_bounds;		/* ya only go 'round once */
	go to re_init_label;			/* try again */


reset:
     entry;					/* called BEFORE replacing the TTT */

	if saved_tttp ^= null
	then do;
		call terminate_file_ (saved_tttp, (0), TERM_FILE_TERM, (0));
		saved_tttp = null;
		return;
	     end;

initialize:
     proc;					/* gets ptr to the TTT */

	if saved_tttp = null
	then do;
		call initiate_file_ (saved_dname, saved_ename, R_ACCESS, saved_tttp, (0), ec);
		if saved_tttp = null
		then go to EXIT;
	     end;

	tttp = saved_tttp;
	pm_code = 0;

	if ttt.version ^= TTT_version_4
	then do;
		saved_tttp = null;
		pm_code = error_table_$unimplemented_version;
		go to EXIT;
	     end;
	saved_install_time = ttt.last_install_time;	/* p clock */
     end initialize;

find_tte:
     proc;					/* gets a ptr to the tte specified by tt_name */

	dcl     ttex		   fixed bin;

	do ttex = 1 to ttt.n_tt_entries;
	     ttep = addr (ttt.tt_entries (ttex));
	     if tte.name = pm_tt_name			/* found it */
	     then return;
	end;

	pm_code = error_table_$no_term_type;
	go to EXIT;

     end find_tte;

AREA_FULL:
     procedure;
	pm_code = error_table_$noalloc;
	tttp = null;				/* dont bother with change time */
	go to EXIT;
     end AREA_FULL;

%include access_mode_values;

%include author_dcl;

%include dsatm_attn_fcn_info;

%include dsatm_negotiate_info;

%include function_key_data;

%include terminal_type_data;
dcl  ttd_version_2 fixed bin int static options (constant) init (2);

%include terminate_file;

%include ttt;

%include tty_video_tables;

     end ttt_info_;
   



		    write_list_.pl1                 11/04/82  2006.8rew 11/04/82  1631.8      115524


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


/*converted to version 2 pl1 on 11.20.72 by Alan Downing*/
write_list_: proc;

dcl (sp,						/* save ap */
     p,						/* pointer to current argument */
     xptr) ptr,					/* pointer to floating point number */

     packed bit(1) aligned,				/* "1"b if packed argument */
     ndims fixed bin(15),				/* number of dimensions in an array */
     size fixed bin(35),				/* arithemetic precision, string size,
						   or number of structure elements */
     scale fixed bin(15),				/* arithemetic scale */

    (i,j,jj,l,bin_exp,no_of_arg,type) fixed bin(15),
     exponent fixed bin(15),
     number1 fixed bin(35),
    (int2,int_temp) fixed bin(63),
     fractional fixed bin(35),
     fractional2 fixed bin(71),

    (upper,upper_quotient,upper_remainder) fixed bin(35),
    (lower,lower_quotient) fixed bin(50),

     d(25) fixed bin(15),

     x float bin(63),

     bit0 bit(36) aligned int static init("0"b),
     single_p bit(1) aligned,
     dec_bit72 bit(72) aligned,

     based_fix fixed bin(35) based(p),
     based_fix71 fixed bin(71) based(p),
     based_float float bin(27) based(p),
     based_float63 float bin(63) based(p),
     based_bit bit(36) aligned based(p),
     based_bit_string bit(144) based(p),
     based_bit72 bit(72) aligned based(p),

     digit(0: 9) char(1) int static
     init("0","1","2","3","4","5","6","7","8","9"),

     based_char_string char(140) based(p);

dcl 1 arg based(sp) aligned,				/* Multics argument list structure */
    2 (acount,spval,dcount,padding) bit(18) unal,
    2 ptr(1) pointer;				/* argument pointers */

dcl 1 pointer based(p) aligned,			/* PL/1 pointer structure */
    2 (segno,pad,offset) bit(18) unal,
    2 (bit_offset,modifier) bit(9) unal;

dcl  cv_chars char(13) varying aligned,
     ch char(1) aligned;

dcl  suffix char(4) aligned;

dcl  nl_is_required bit(1) aligned;			/* flag to remember if new line char is needed */
dcl nl char(1) init("
");/*new line character*/

dcl  string char(132) aligned varying,
     substring char(132) aligned varying,
     temp_string char(21) aligned;

dcl  proc_name char(12) aligned int static init("write_list_");
dcl  string_no_descrip char(80) aligned int static
     init("No descriptors supplied; delete the declaration of the parameters to write_list_");

dcl  cu_$arg_list_ptr entry(ptr),
     com_err_ entry options(variable),
     convert_binary_integer_$decimal_string entry(fixed bin(35)) returns(char(12) varying),
     convert_binary_integer_$long_decimal_string entry(fixed bin(71)) returns(char(23) varying),
     convert_binary_integer_$octal_string entry(fixed bin(35)) returns(char(13) varying),
     decode_descriptor_ entry(ptr,fixed bin(15),fixed bin(15),bit(1) aligned,
     fixed bin(15),fixed bin(35),fixed bin(15)),
     ios_$write_ptr entry(ptr,fixed bin(35),fixed bin(35));

dcl (abs,addr,addrel,divide,fixed,length,mod,substr,unspec) builtin;

%include dectab;
%include decimal_table;
/*  */
	nl_is_required = "1"b;			/* normal entry adds new line character */
	go to start;

nnl:	entry;					/* entry to suppress new line character */
	nl_is_required = "0"b;

start:	
	call cu_$arg_list_ptr(sp);			/* get a pointer to the argument list */
	if arg.dcount = (18)"0"b			/* error, no descripters */
	then do;
	     call com_err_ (0,proc_name,string_no_descrip);
	     return;
	end;

	no_of_arg = divide(fixed(arg.acount,18),2,15,0);
	string = "";

	do j = 1 to no_of_arg;			/* loop for processing arguments */
	     call decode_descriptor_(sp,j,type,packed,ndims,size,scale);
	     p = arg.ptr(j);			/* get pointer to current argument */

/* Note that when Version II PL/1 comes along, we will have to be very careful
   to obey the "packed" flag for all data items. All packed integers will have
   to be extracted with an adjustable bit string, and their sign bit extended to
   the unpacked representation. Also, we should print out the scale factor for fixed
   point items (345f+6) */


/*  */
	     if type = 1				/* real fixed single */
	     then substring = "  "||convert_binary_integer_$decimal_string(p->based_fix);
						/*  */
	     else if type = 2			/* real fixed double */
	     then substring = "  "||convert_binary_integer_$long_decimal_string(p->based_fix71);

/*  */
	     else if type < 5			/* for real floating point; 3 = single precision,4 = double */
	     then do;
		x = 0e0;
		if type = 3			/* the number is single precision */
		then do;
		     single_p = "1"b;		/* set the single precision flag on */
		     x = p->based_float;		/* pick up a single precision number */
		end;
		else do;				/* the number is double precision */
		     single_p = "0"b;		/* set the single precision flag off */
		     x = p->based_float63;		/* pick up a double precision number */
		end;

		if substr(p->based_bit,9,2) = bit0	/* if the number is zero */
		then do;
		     substring = "  0.00000000e+00";	/* set the answer */
		     go to end_float;
		end;

		if substr(p->based_bit,9,1)		/* if the number is negative */
		then substring = " -0.";		/* set a leading minus sign in answer */
		else substring = "  0.";

		x = abs(x);			/* take the absolute value of the number */

		exponent = 0;			/* initialize the print-out exponent */

		if x>=1.0e-1			/* if the number is > than .1 */
		then do;				/* reduce it so that 0 < number < .1 */
		     do while (x>=1.0e4);
			x = x*(10.0e0**-5);		/* first pull out powers of 10**5 */
			exponent = exponent+5;	/* increment exponent accordingly */
		     end;
		     do while(x>=1.0e0);
			x = x*(10.0e0**-1);		/* then pull out powers of 10 */
			exponent = exponent+1;	/* incrementing the exponent */
		     end;
		end;
		else do;				/* if the number is negative, reverse procedure */
		     do while(x<1.0e-5);		/* while the number is < 10**-5 */
			x = x*(10.0e0**5);		/* multiply by 10**5 */
			exponent = exponent-5;	/* and increment exponent */
		     end;
		     do while(x<1.0e-1);		/* while number is < 10**-1 */
			x = x*(10.0e0**1);		/* multiply by 10 */
			exponent = exponent-1;	/* and increment exponent */
		     end;
		end;

		if exponent>=0			/* set the sign of the exponent */
		then suffix = "e+  ";
		else suffix = "e-  ";

		exponent = abs(exponent);		/* take the absolute value of the exponent */

		xptr = addr(x);
		bin_exp = fixed(substr(xptr->based_bit,1,8),8); /* get binary exponent */

		dec_bit72 = substr(xptr->based_bit72,10,63); /* pick out mantissa */

		if bin_exp^=0 then bin_exp = 256-bin_exp; /* since the number is less than .1, the exponent
						   is <= 0. Take its absolute value */

		if single_p			/* if the number is single precision */
		then do;
		     fractional = 0;		/* initialize fixed point representation */
		     do i = 1 to 27;		/* multiply bits by appropriate exponent */
			if substr(dec_bit72,i,1)
			then fractional = fractional+decimal_table(i+bin_exp);
		     end;				/* fractional is fixed point representation */
		     fractional = fractional+decimal_table(28+bin_exp); /* round-off step */

		     number1 = divide(fractional+50,100,35,0); /* add fifty to force carry
						   if all bits are ones, divide by
						   100 to throw away last two bits */

		     do i = 1 to 7;
			d(i) = mod(number1,10);	/* pull out rightmost digit */
			number1 = divide(number1,10,35,0); /* decrement number */
		     end;

		     if number1 = 10		/* if the result is 10 */
		     then do;			/* put it in a better representation */
			number1 = 1;
			exponent = exponent+1;
		     end;

		     substring = substring||(digit(number1)||digit(d(7))||digit(d(6))||digit(d(5))
		     ||digit(d(4))||digit(d(3))||digit(d(2))||digit(d(1))); /* make up output string */
		end;
		else do;				/* for double precision numbers */
		     fractional2 = 0;		/* initialize fixed point representation */
		     do i = 1 to 63;		/* convert number to fixed point representation */
			if substr(dec_bit72,i,1)
			then fractional2 = fractional2+decimal_table_2(i+bin_exp);
		     end;

		     fractional2 = fractional2+decimal_table_2(64+bin_exp)+54;
						/* 54 is added in order to force a carry
						   if all 63 mantissa bits are one's */

		     upper = addr(fractional2)->based_fix; /* split number into 2 parts */
		     lower = fractional2-68719476736*upper;

		     do i = 1 by 1 while(upper>=134217728); /* reduce upper part to < 2**27 */
			upper_quotient = divide(upper,10,35,0);
			upper_remainder = upper-10*upper_quotient;

			lower = lower+68719476736*upper_remainder;
			lower_quotient = divide(lower,10,50,0);
			d(i) = lower-10*lower_quotient;
			substr(temp_string,22-i,1) = digit(d(i));

			upper = upper_quotient;
			lower = lower_quotient;
		     end;

		     int2 = 68719476736*upper+lower;

		     do i = i to 21;		/* now continue division normally */
			int_temp = divide(int2,10,63,0);
			d(i) = int2-10*int_temp;
			int2 = int_temp;
			substr(temp_string,22-i,1) = digit(d(i));
		     end;

		     substring = substring||substr(temp_string,1,19);
		     if substr(substring,5,1) = "0"	/* round-off */
		     then do;
			substr(substring,5,1) = digit(1);
			exponent = exponent+1;
		     end;
		end;

		substr(suffix,3,2) = digit(divide(exponent,10,15,0))||digit(mod(exponent,10));
		substring = substring||suffix;
end_float:	
	     end;

/*  */

	     else if type = 9 | type = 10		/*  for real decimal; 9 = fixed, 10 = float */
	     then do;
		cv_chars = "";
		size = size + 1;			/* account for leading sign */
		if type = 10
		then do;
		     ch = substr(p->based_char_string,size+1,1); /* pick off exponent from number */
exponent = fixed(unspec(ch),9);
		     if exponent >= 128 then exponent = exponent - 256; /* normalize from 8 bit representation */
		     cv_chars = convert_binary_integer_$decimal_string((exponent));
		     cv_chars = "e"||cv_chars;
		end;
		do jj = 2 to size while(substr(p->based_char_string,jj,1) = "0");
		end;
		if jj = size+1
		then do;
		     jj = size;
		     cv_chars = "";
		end;
		ch = substr(p->based_char_string,1,1);
		if ch ^= "-" then ch = "";
		l = size-jj+1;
		substring = "  "||ch||substr(p->based_char_string,jj,l)||cv_chars;
	     end;
						/*  */
	     else if type = 13			/* pointer datum */
	     then do;
		cv_chars = convert_binary_integer_$octal_string(fixed(pointer.segno,35));
		substring = "  "||cv_chars||"|";
		cv_chars = convert_binary_integer_$octal_string(fixed(pointer.offset,35));
		substring = substring||cv_chars;

		if pointer.bit_offset ^= (9)"0"b	/* add in bit offset if found */
		then do;
		     cv_chars = convert_binary_integer_$decimal_string(fixed(pointer.bit_offset,9));
		     substring = substring||"("||cv_chars||")";
		end;

	     end;

/*  */
	     else if type = 19 | type = 20		/* for bit strings; 19 = fixed length, 20 = varying */
	     then do;
		if type = 20			/* varying string, get current length */
		then l = addrel(p,-1)->based_fix;
		else l = size;			/* fixed string, get length from descriptor */
		substring = "  """;

		do i = 1 to l;
		     if substr(p->based_bit_string,i,1)
		     then substring = substring||"1";
		     else substring = substring||"0";
		end;

		substring = substring||"""b";
	     end;

/*  */
	     else if type = 21 | type = 22		/* for character strings; 21 = fixed length,22 = varying */
	     then do;
		if type = 22			/* varying string, get current length */
		then l = addrel(p,-1)->based_fix;
		else l = size;			/* fixed string, get length from descriptor */

		if l = 0
		then do;
		     substring = "  """"";
		end;
		else do;
		     substring = "  "||substr(p->based_char_string,1,l);
		end;
	     end;

/*  */
	     else do;				/* illegal descripter type */
		call com_err_(0,proc_name,"Unhandled data-type ^d for argument ^d. It will be replaced by XXX",type,j);
		substring = "  XXX";
	     end;

	     if length(string)+length(substring) > 131	/* if length of output string exceeded */
	     then do;
		call ios_$write_ptr(addr(string),0,length(string)); /* write what you've got */
		string = substring;			/* and begin a new output string */
	     end;
	     else do;				/* no overflow, concatenate substring */
		string = string||substring;		/* add argument to print-out string */
	     end;

	end;					/* end of do loop for processing arguments */

	if nl_is_required
	then do;
	string = string || nl;/* add on a new line character*/
	end;

	call ios_$write_ptr(addrel(addr(string),1),0,length(string));

     end write_list_;


		    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