



		    mtape_.alm                      02/16/84  1306.5r w 02/16/84  1249.6        9270



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"	Transfer vector for mtape_
"
"	Modification History:
"
"	Created by J. A. Bush 07/10/83 

	name	mtape_

	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2$&1
	&end

	transfer	mtape_attach,mtape_iox_
	transfer	allocate_buffers,mtape_io_
	transfer	flush_buffers,mtape_io_
	transfer	order,mtape_io_
	transfer	read_block,mtape_io_
	transfer	read_label,mtape_io_
	transfer	set_mode,mtape_io_
	transfer	stop_tape,mtape_io_
	transfer	write_block,mtape_io_
	transfer	write_label,mtape_io_
	transfer	demount,mtape_mount_cntl_
	transfer	mount,mtape_mount_cntl_
	transfer	volume_switch,mtape_mount_cntl_
	transfer	alloc,mtape_util_
	transfer	error,mtape_util_
	transfer	user_query,mtape_util_
	transfer	mtape_cv_apd,mtape_cv_apd

	end




		    mtape_check_status_.pl1         12/01/87  0801.0rew 11/30/87  1323.9       68778



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


/****^  HISTORY COMMENTS:
  1) change(87-08-17,GWMay), approve(87-09-09,MECR0006),
     audit(87-09-04,Farley), install(87-09-09,MR12.1-1101):
     Added checks to return on write errors and reposition the tape on read
     errors.
  2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley),
     install(87-11-30,MR12.2-1006):
     Formally install MECR0006.
                                                   END HISTORY COMMENTS */


mtape_check_status_: proc (arg_mtdp, arg_code);

/* format: style4 */

/* *	This program performs certain "last ditch" exception recovery
   *	functions for mtape_. In particular, automatic recovery from device
   *	attention and power off are attempted from within this module.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 11/11/83
*/

/*		ARGUMENT DATA		*/

dcl  arg_mtdp ptr;					/* Pointer to the mtape data structure */
dcl  arg_code fixed bin (35);				/* Return error code */

/*		AUTOMATIC DATA		*/

dcl  code fixed bin (35);
dcl  1 save_position like mtape_data.position aligned;

/*		CONSTANT DATA		*/

dcl  DEV_ATT_MSG char (64) int static options (constant) init
	("Attempting recovery from device attention condition.");
dcl  PWR_OFF_MSG char (64) int static options (constant) init
	("Attempting recovery from power off condition.");

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$device_attention fixed bin (35) ext static;
dcl  error_table_$device_parity fixed bin (35) ext static;
dcl  error_table_$unable_to_do_io fixed bin (35) ext static;
dcl  mtape_dev_attention_recovery condition;

/*		BUILTIN FUNCTIONS		*/

dcl  null builtin;

/*		EXTERNAL ENTRIES		*/

dcl  mtape_util_$error entry options (variable);
dcl  mtape_mount_cntl_$remount entry (ptr, fixed bin (35));
dcl  mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35));

/*		BASED VARIABLES		*/

dcl  based_area area based (mtape_data.areap);
%page;
/* Beginning of mtape_check_status_ entry */

	mtdp = arg_mtdp;				/* copy args */
	vs_ptr = mtape_data.vs_current;
	mpfmip = mtape_data.pfm_info_ptr;
	moip = mtape_data.open_info_ptr;
						/* save current file and block pos. */
	save_position = mtape_data.position;
						/* allocate area to store status    */
	allocate ths in (based_area) set (ths_ptr);
	mtape_data.last_ur_status_ptr = ths_ptr;
	ths.version = THS_VERSION;

	call tape_ioi_$hardware_status (mtape_data.tioi_id, ths_ptr, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"^/mtape_check_status_: error from tape_ioi_$hardware_status");
	     return;
	end;

	if ths.major = DEVICE_ATTENTION & (ths.minor = HANDLER_IN_STANDBY
	     | ths.minor = NO_SUCH_HANDLER | ths.minor = HANDLER_CHECK)
	     & arg_code ^= error_table_$device_parity then do;
	     call MSG_OUT ("Unrecoverable error");
	     if ths.minor = HANDLER_CHECK then
		arg_code = error_table_$unable_to_do_io;
	     else
		arg_code = error_table_$device_attention;
	end;

	else
						/* if apparent pwr off, see if recoverable recursion not allowed */

	     if ths.major = POWER_OFF then do;
	     if mtape_vol_set.pwr_off_retry then do;
		call mtape_util_$error (mtdp, 0,
		     "^/Recovery of PWR OFF status condition unsuccessful");
		arg_code = error_table_$unable_to_do_io;
	     end;
	     else do;
		mtape_vol_set.pwr_off_retry = "1"b;
		arg_code = error_table_$device_attention;
						/* Tell user and operator about the error and that we are atempting
						   recovery. */
		call MSG_OUT ("Power off condition");
		call mtape_util_$error (mtdp, 0, PWR_OFF_MSG);
		mtape_vol_set.demount_comment = PWR_OFF_MSG;
		call RECOVERY;			/* attempt recovery */
		arg_code = code;
	     end;
	end;
	else
	     if ths.major = DEVICE_ATTENTION &
	     (mtape_open_info.open_mode = Sequential_input
	     | mtape_open_info.open_mode = Stream_input) then do;

	     if mtape_vol_set.dev_att_retry then do;
		call mtape_util_$error (mtdp, 0,
		     "^/Recovery of DEV ATT status condition unsuccessful");
		arg_code = error_table_$unable_to_do_io;
	     end;

	     else do;
						/* protect against recursion */
		mtape_vol_set.dev_att_retry = "1"b;
		mtape_vol_set.demount_comment = DEV_ATT_MSG;

/* Tell user and operator about the error and that we are attempting
   recovery. */
		call MSG_OUT ("Device Attention condition");
		call mtape_util_$error (mtdp, 0, DEV_ATT_MSG);

		call RECOVERY;			/* attempt recovery */
		arg_code = code;

/* should not return here unless recovery unsuccessful */
	     end;
	end;

	else					/* Report it, unless PFM wants it */
	     if ^mtape_pfm_info.extended_error_recovery then do;
	     call MSG_OUT ("Unrecoverable error");
	     arg_code = error_table_$unable_to_do_io;
	end;

	free ths in (based_area);
	mtape_data.last_ur_status_ptr = null;
	return;
%page;
/* RECOVERY - subroutine to attempt recovery from dev attention/pwr off
   condition */

RECOVERY: proc;

	if mtape_vol_set.pwr_off_retry | save_position.phy_file < 3 then do;

	     call mtape_mount_cntl_$remount (mtdp, code);

	     if code ^= 0 then do;
		call mtape_util_$error (mtdp, code,
		     "^/Remount of volume ^a unsuccessful, while attempting error recovery",
		     mtape_vol_set.volume_name);
		arg_code = code;			/* return this error code */
		return;
	     end;

	     mtape_vol_set.demount_comment = "";
						/* Do file position if necessary */
	     if save_position.phy_file ^= 0 then do;
		call mtape_io_$order (mtdp, "fsf", save_position.phy_file, null,
		     code);
		if code ^= 0 then return;
	     end;
						/* Do block position if necessary */
	     if save_position.phy_block ^= 0 then do;
		call mtape_io_$order (mtdp, "fsr", save_position.phy_block, null,
		     code);
		if code ^= 0 then return;
	     end;
	end;

	else do;

/* Move the tape back 2 and forward 2. The effect is to clean the
   fuzz off of the tape heads.  DO NOT EVER REMOVE THIS CODE. */

	     code = 0;
	     call mtape_io_$order (mtdp, "bsf", 2, null, code);
	     if code ^= 0 then return;

	     call mtape_io_$order (mtdp, "fsf", 2, null, code);
	     if code ^= 0 then return;

/* Do block position if necessary */
	     if save_position.phy_block ^= 0 then do;
		call mtape_io_$order (mtdp, "fsr", save_position.phy_block,
		     null, code);
		if code ^= 0 then return;
	     end;
	end;

	signal mtape_dev_attention_recovery;
	return;
     end RECOVERY;

/* MSG_OUT - subroutine to output common formatted error message */

MSG_OUT: proc (preamble);

dcl  preamble char (*);
						/* display common msg format */
	call mtape_util_$error (mtdp, arg_code,
	     "^/^a detected on volume ^a, mounted on device ^a.
Physical position: file # ^d, block # ^d.
Hardware status: ""^a"".", preamble, mtape_vol_set.volume_name,
	     mtape_vol_set.device_name, save_position.phy_file,
	     save_position.phy_block + 1, ths.description);

	return;
     end MSG_OUT;
%page;
%include mtape_data;
%page;
%include mtape_vol_set;
%page;
%include mtape_err_stats;
%page;
%include mtape_constants;
%page;
%include mtape_pfm_info;
%page;
%include mtape_open_close_info;
%page;
%include iox_modes;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_hw_status;

     end mtape_check_status_;




		    mtape_control_.pl1              12/17/86  0925.7r w 12/17/86  0830.0      276624



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
mtape_control_: procedure;

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 10/05/82
   *	Modified by J. A. Bush 12/01/83 to update error statistics before
   *	gathering information for volume_("" set_)status operations.
*/

/*		ARGUMENT DATA		*/

dcl  arg_iocbp ptr;					/* Input IOCB Pointer */
dcl  arg_order_name char (*);				/* Input control order name */
dcl  arg_info_ptr ptr;				/* Input control order info pointer */
dcl  arg_code fixed bin (35);				/* Return error code */

/*		AUTOMATIC DATA		*/

dcl  iocbp ptr;					/* Auto copy of IOCB pointer */
dcl  order_name char (32);				/* Auto copy of control order name */
dcl  info_ptr ptr;					/* Auto copy of control order info pointer */
dcl  code fixed bin (35);
dcl  (cox, i) fixed bin;
dcl  open bit (1) aligned;
dcl  nvp ptr;
dcl  vol_string char (128);
dcl  short_info char (8) aligned;
dcl  long_info char (100) aligned;

/*		CONSTANT DATA		*/

dcl  myname char (6) int static options (constant) init ("mtape_");
dcl  ORDER_NAMES (16) char (19) int static options (constant) init
	("change_module", "cmod",
	"file_set_status", "fsst",
	"file_status", "fst",
	"force_end_of_volume", "feov",
	"hardware_status", "hwst",
	"ring_in", "rin",
	"volume_set_status", "vsst",
	"volume_status", "vst");

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$no_file fixed bin (35) ext static;
dcl  error_table_$no_operation fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$not_closed fixed bin (35) ext static;
dcl  error_table_$not_open fixed bin (35) ext static;

/*		BUILTIN FUNCTIONS		*/

dcl  (addr, convert, hbound, lbound, ltrim, null, rtrim, size, substr, sum, unspec) builtin;

/*		EXTERNAL ENTRIES		*/

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr);
dcl  mtape_util_$error entry options (variable);
dcl  mtape_util_$get_statistics entry (ptr, fixed bin (35));
dcl  mtape_util_$init_pfm entry (ptr, fixed bin (35));
dcl  mtape_mount_cntl_$demount entry (ptr, fixed bin (35));
dcl  mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35));
dcl  iox_$propagate entry (ptr);

/*		BASED STORAGE		*/

dcl  based_area area based (mtape_data.areap);
dcl  order_arg char (32) varying based (info_ptr);
%page;
/* control - entry to implement the iox_$control entry point */

control: entry (arg_iocbp, arg_order_name, arg_info_ptr, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;	/* copy arguments */
	mtdp = iocbp -> iocb.attach_data_ptr;		/* get ptr to our data structure */
	mtape_data.iocb_ptr = iocbp;			/* save our IOCB ptr */
	maip = mtape_data.attach_info_ptr;
	moip = mtape_data.open_info_ptr;
	code, arg_code = 0;				/* Reset return code */
	if arg_order_name = "io_call" then do;		/* execute order on behalf of io_call? */
	     io_call_infop = arg_info_ptr;		/* yes, set info ptr to io_call structure */
	     order_name = io_call_info.order_name;	/* copy target order */
	     if io_call_info.nargs ^= 0 then		/* if target order has args */
		info_ptr = addr (io_call_info.args (1));/* point to first 1 */
	     else info_ptr = null;			/* allocate any structures in my area */
	end;
	else do;					/* not called from io_call */
	     io_call_infop = null;			/* null => not called from io_call */
	     order_name = arg_order_name;
	     info_ptr = arg_info_ptr;
	end;

/* First call the PFM and see if he wants to handle the control order */

	call mtape_data.order (mtdp, order_name, info_ptr, io_call_infop, code);
	if code ^= error_table_$no_operation then	/* he either did it or */
	     go to CONTROL_OP_END;			/* got another error, return */
	code = 0;					/* give mtape_ proper a chance */

/* PFM passed the buck back to us, does it stop here? */

	if iocbp -> iocb.open_descrip_ptr ^= null then	/* is file open now? */
	     open = "1"b;				/* yes, set flag */
	else open = "0"b;				/* no I/O switch is closed */
	do cox = hbound (ORDER_NAMES, 1) to lbound (ORDER_NAMES, 1) by -1 /* find the right control order */
	     while (order_name ^= ORDER_NAMES (cox));
	end;
	go to CONTROL_OP (cox);			/* go process found control operation */

CONTROL_OP (0):					/* unrecognized by mtape_ */
	code = error_table_$no_operation; code = error_table_$no_operation;
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (1):					/* "change_module" operation */
CONTROL_OP (2):					/* "cmod" operation */
	call CHECK_CLOSED;				/* I/O switch must be closed */
	if info_ptr ^= null then do;			/* Non-null means to "push" a new PFM */
	     if mtape_data.saved_pfm_info_ptr = null then do; /* must allocate a structure */
		allocate mtape_saved_pfm_info in (based_area) set (mspfmip);
		mtape_data.saved_pfm_info_ptr = mspfmip;/* save ptr */
		mtape_saved_pfm_info.version = mtape_saved_pfm_info_version_1; /* and set version */
	     end;
	     mtape_saved_pfm_info.pfm_name = mtape_attach_info.pfm_prefix; /* save the old PFM prefix */
	     mtape_saved_pfm_info.old_pfm_entries = mtape_data.pfm_required_entries; /* and PFM entries */
	     mtape_attach_info.pfm_prefix = order_arg;
	end;
	else do;					/* Null info ptr, this is a "POP" request */
	     mspfmip = mtape_data.saved_pfm_info_ptr;	/* get saved info */
	     mtape_attach_info.pfm_prefix = mtape_saved_pfm_info.pfm_name;
	end;
	call mtape_util_$init_pfm (mtdp, code);		/* search for new PFM */
	if code ^= 0 then do;			/* if some error, restore other PFM */
	     mtape_data.pfm_required_entries = mtape_saved_pfm_info.old_pfm_entries;
	     go to CONTROL_OP_END;
	end;
	free mtape_data.tlb -> mtape_label_record in (based_area); /* free up label buffer */
	mtape_data.tlb = null;			/* this causes PFM to go through initialzation properly */
	call mtape_data.pfm_init (mtdp, code);		/* init the new PFM */
	if code ^= 0 then do;			/* couldn't init it */
	     mtape_data.pfm_required_entries = mtape_saved_pfm_info.old_pfm_entries;
	     go to CONTROL_OP_END;
	end;
	mtape_data.first_file = "0"b;			/* reset for consistency checks */
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (3):					/* "file_set_status" operation */
CONTROL_OP (4):					/* "fsst" operation */
	call CHECK_VERSION (fsst_version_1);		/* check version if user allocated structure */
	if mtape_data.fi_head = null then do;		/* never been opened */
	     code = error_table_$no_file;
	     call mtape_util_$error (mtdp, code,
		"^/The file set has not been opened during this attachment");
	     go to CONTROL_OP_END;
	end;
	if info_ptr = null then do;			/* we have to allocate the structure ourselves */
	     mtape_fsst_nfiles = 0;			/* first we have to determine the # of files */
	     do fi_ptr = mtape_data.fi_head repeat mtape_file_info.next_fi_ptr while (fi_ptr ^= null);
		if mtape_file_info.section = 1 then	/* only count whole files */
		     mtape_fsst_nfiles = mtape_fsst_nfiles + 1; /* increment number of files */
	     end;
	     if mtape_fsst_nfiles = 0 then do;		/* no files processed yet */
		code = error_table_$no_file;		/* set real error code later */
		go to CONTROL_OP_END;
	     end;
	     allocate mtape_fsst in (based_area) set (fsst_ptr); /* allocate the structure */
	     mtape_fsst.version = fsst_version_1;	/* set version number */
	end;
	else fsst_ptr = info_ptr;			/* otherwise use user structure */
	mtape_fsst.file_set_id = mtape_data.fi_head -> mtape_file_info.file_set_id; /* set file set id */
	mtape_fsst.file_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */
	mtape_fsst_nfiles = 0;
	do fi_ptr = mtape_data.fi_head repeat mtape_file_info.next_fi_ptr while (fi_ptr ^= null);
	     if mtape_file_info.section = 1 then do;	/* only count whole files */
		mtape_fsst_nfiles = mtape_fsst_nfiles + 1; /* increment number of files */
		f_statp = addr (mtape_fsst.fs_stat (mtape_fsst_nfiles)); /* set file_status ptr */
		call SET_FILE_STATUS;		/* copy the file status for this file */
	     end;
	end;
	mtape_fsst.nfiles = mtape_fsst_nfiles;		/* set number of files for refer extent */
	if io_call_infop ^= null then do;		/* if called from io_call, display the structure */
	     call io_call_info.report ("File Set Status for ""^a"" file set ""^a"", number of files - ^d.",
		Tape_volume_types (mtape_fsst.file_type), mtape_fsst.file_set_id, mtape_fsst.nfiles);
	     do i = 1 to mtape_fsst.nfiles;		/* iterate through each file */
		f_statp = addr (mtape_fsst.fs_stat (i));/* set ptr to current structure */
		call DISPLAY_FILE_STATUS;		/* do the display for each file */
	     end;
	     free mtape_fsst in (based_area);		/* free the file status structure */
	end;
	else if info_ptr = null then			/* if the user let us allocate the structure */
	     arg_info_ptr = fsst_ptr;			/* return pointer to allocated structure */
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (5):					/* "file_status" operation */
CONTROL_OP (6):					/* "fst" operation */
	call CHECK_VERSION (fst_version_1);		/* check version if user allocated structure */
	if mtape_data.fi_current = null then do;	/* never been opened */
	     code = error_table_$no_file;
	     call mtape_util_$error (mtdp, code,
		"^/The file set has not been opened during this attachment");
	     go to CONTROL_OP_END;
	end;
	if info_ptr = null then do;			/* we have to allocate the structure ourselves */
	     allocate mtape_fst in (based_area) set (fst_ptr); /* allocate the structure */
	     mtape_fst.version = fst_version_1;		/* set version number */
	end;
	else fst_ptr = info_ptr;			/* otherwise use user structure */
	mtape_fst.file_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */
	fi_ptr = mtape_data.fi_current;		/* set up for current file */
	f_statp = addr (mtape_fst.f_stat);		/* set file_status ptr */
	call SET_FILE_STATUS;			/* copy the file status for this file */
	if io_call_infop ^= null then do;		/* if called from io_call, display the structure */
	     call io_call_info.report ("Status of current File for ""^a"" file set",
		Tape_volume_types (mtape_fst.file_type));
	     call DISPLAY_FILE_STATUS;		/* do the display for each file */
	     free mtape_fst in (based_area);		/* free the file status structure */
	end;
	else if info_ptr = null then			/* if the user let us allocate the structure */
	     arg_info_ptr = fst_ptr;			/* return pointer to allocated structure */
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (7):					/* "force_end_of_volume" operation */
CONTROL_OP (8):					/* "feov" operation */
	if ^open |				/* I/O switch must be open for output */
	     (open & mtape_open_info.open_mode ^= Sequential_output &
	     mtape_open_info.open_mode ^= Stream_output) then do;
	     code = error_table_$not_open;		/* set an appropriate error code */
	     call mtape_util_$error (mtdp, code,
		"^/The ""^a"" control operation requires that the I/O switch be open for output",
		order_name);
	end;
	else do;
	     mtape_data.force_end_of_volume = "1"b;	/* simulate EOT marker */
	     mtape_data.arg_buf_ptr = null;		/* set up to flush buffers */
	     mtape_data.arg_buf_len = 0;
	     call mtape_data.write (mtdp, code);	/* flush out buffers, and do volume switch */
	end;
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (9):					/* "hardware_status" operation */
CONTROL_OP (10):					/* "hwst" operation */
	call CHECK_VERSION (hwst_version_1);		/* check version if user allocated structure */
	if info_ptr = null then do;			/* we have to allocate the structure ourselves */
	     allocate mtape_hardware_status in (based_area) set (hwst_ptr); /* allocate the structure */
	     mtape_hardware_status.version = hwst_version_1; /* set version number */
	end;
	else hwst_ptr = info_ptr;			/* otherwise use user structure */
	call SET_HARDWARE_STATUS;			/* copy the hardware status */
	if io_call_infop ^= null then do;		/* if called from io_call, display the structure */
	     call DISPLAY_HARDWARE_STATUS;		/* display last hardware status */
	     free mtape_hardware_status in (based_area);	/* free the file status structure */
	end;
	else if info_ptr = null then			/* if the user let us allocate the structure */
	     arg_info_ptr = hwst_ptr;			/* return pointer to allocated structure */
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (11):					/* "ring_in" operation */
CONTROL_OP (12):					/* "rin" operation */
	call CHECK_CLOSED;				/* I/O switch must be closed */
	if ^mtape_attach_info.ring then do;		/* if a ring already in, this is a NOP */
	     call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, size (mtape_data) * 4, mtape_data.cmtdp);
	     mtape_data.cmtdp -> mtape_data = mtape_data; /* allocate and copy control structure */
	     mtdp, iocbp -> iocb.attach_data_ptr = mtape_data.cmtdp; /* use copy */
	     call iox_$propagate (iocbp);		/* let iox_ know about iocb change */
	     nvp = mtape_data.vs_current;		/* save current volume ptr */
	     do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null);
		if mtape_vol_set.mounted then do;	/* if volume currently mounted... */
		     mtape_data.vs_current = vs_ptr;	/* set current volume set ptr */
		     mtape_data.tioi_id = mtape_vol_set.tioi_id; /* just to be sure */
		     call mtape_io_$order (mtdp, "rwnw", 0, null, code); /* rewind volume */
		     call mtape_mount_cntl_$demount (mtdp, code); /* demount the volume */
		end;
	     end;
	     code = 0;
	     mtape_data.lab_bufp = null;		/* avoid invalid ptrs */
	     mtape_data.tioi_id = "0"b;		/* reset this constant */
	     mtape_data.vs_current = nvp;		/* restore current volume ptr */
	     mtape_attach_info.ring = "1"b;		/* and set the write ring flag */
	end;
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (13):					/* "volume_set_status" operation */
CONTROL_OP (14):					/* "vsst" operation */
	call CHECK_VERSION (vsst_version_1);		/* check version if user allocated structure */
	if info_ptr = null then do;			/* we have to allocate the structure ourselves */
	     mtape_vsst_nvolumes = 0;			/* vsrst we have to determine the # of volumes */
	     do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null);
		mtape_vsst_nvolumes = mtape_vsst_nvolumes + 1; /* increment number of volumes */
	     end;
	     if mtape_vsst_nvolumes = 0 then do;	/* no volumes processed yet */
		code = error_table_$no_operation;	/* set real error code later */
		go to CONTROL_OP_END;
	     end;
	     allocate mtape_vsst in (based_area) set (vsst_ptr); /* allocate the structure */
	     mtape_vsst.version = vsst_version_1;	/* set version number */
	end;
	else vsst_ptr = info_ptr;			/* otherwise use user structure */
	mtape_vsst.volume_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */
	mtape_vsst_nvolumes = 0;
	do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null);
	     mtape_vsst_nvolumes = mtape_vsst_nvolumes + 1; /* increment number of volumes */
	     v_statp = addr (mtape_vsst.vs_stat (mtape_vsst_nvolumes)); /* set volume status ptr */
	     call SET_VOLUME_STATUS;			/* copy the volume status for this volume */
	end;
	mtape_vsst.nvolumes = mtape_vsst_nvolumes;	/* set number of volumes for refer extent */
	if io_call_infop ^= null then do;		/* if called from io_call, display the structure */
	     call io_call_info.report ("Volume Set Status for ""^a"" volume set, number of volumes - ^d.",
		Tape_volume_types (mtape_vsst.volume_type), mtape_vsst.nvolumes);
	     do i = 1 to mtape_vsst.nvolumes;		/* iterate through each volume */
		v_statp = addr (mtape_vsst.vs_stat (i));/* set ptr to current structure */
		call DISPLAY_VOLUME_STATUS;		/* do the display for each volume */
	     end;
	     free mtape_vsst in (based_area);		/* free the volume status structure */
	end;
	else if info_ptr = null then			/* if the user let us allocate the structure */
	     arg_info_ptr = vsst_ptr;			/* return pointer to allocated structure */
	go to CONTROL_OP_END;			/* take common exit */

CONTROL_OP (15):					/* "volume_status" operation */
CONTROL_OP (16):					/* "vst" operation */
	call CHECK_VERSION (vst_version_1);		/* check version if user allocated structure */
	if info_ptr = null then do;			/* we have to allocate the structure ourselves */
	     allocate mtape_vst in (based_area) set (vst_ptr); /* allocate the structure */
	     mtape_vst.version = vst_version_1;		/* set version number */
	end;
	else vst_ptr = info_ptr;			/* otherwise use user structure */
	mtape_vst.volume_type = mtape_data.vs_head -> mtape_vol_set.volume_type; /* set volume type */
	vs_ptr = mtape_data.vs_current;		/* set up for current volume */
	v_statp = addr (mtape_vst.v_stat);		/* set volume_status ptr */
	call SET_VOLUME_STATUS;			/* copy the volume status for this volume */
	if io_call_infop ^= null then do;		/* if called from io_call, display the structure */
	     call io_call_info.report ("Status of current Volume for ""^a"" volume set",
		Tape_volume_types (mtape_vst.volume_type));
	     call DISPLAY_VOLUME_STATUS;		/* do the display for each volume */
	     free mtape_vst in (based_area);		/* free the volume status structure */
	end;
	else if info_ptr = null then			/* if the user let us allocate the structure */
	     arg_info_ptr = vst_ptr;			/* return pointer to allocated structure */

CONTROL_OP_END:
	arg_code = code;				/* return error code */
	return;
%page;
/* CHECK_VERSION - internal procedure to check the structure version number for user allocated structures */

CHECK_VERSION: proc (req_version);

dcl  req_version char (8);
dcl  1 version_check based (info_ptr) aligned,		/* generic structure to check version number */
       2 version char (8);

	if info_ptr ^= null then			/* if user has allocated his own structure */
	     if version_check.version ^= req_version then do; /* but the version number is wrong */
		code = error_table_$unimplemented_version; /* set appropriate error code */
		go to CONTROL_OP_END;		/* take non-local goto to error return */
	     end;

     end CHECK_VERSION;

/* CHECK_CLOSED - internal procedure to verify that I/O switch is closed */

CHECK_CLOSED: proc;

	if open then do;				/* can't be open */
	     code = error_table_$not_closed;
	     call mtape_util_$error (mtdp, code,
		"^/The ""^a"" control operation requires that the I/O switch be closed.", order_name);
	     go to CONTROL_OP_END;			/* take non-local goto and return */
	end;

     end CHECK_CLOSED;
%page;
/* DISPLAY_HARDWARE_STATUS - internal procedure to display hardware status for io_call */

DISPLAY_HARDWARE_STATUS: proc;

	call io_call_info.report ("^/Last reported hardware status; Description:^/^a",
	     mtape_hardware_status.description);
	call io_call_info.report ("^/I/O Status Words:^-^12.3b  ^12.3b",
	     substr (mtape_hardware_status.iom_status, 1, 36), substr (mtape_hardware_status.iom_status, 37, 36));
	call io_call_info.report ("List Pointer Words:^-^12.3b  ^12.3b",
	     substr (mtape_hardware_status.iom_lpw, 1, 36), substr (mtape_hardware_status.iom_lpw, 37, 36));

     end DISPLAY_HARDWARE_STATUS;
%page;
/* DISPLAY_FILE_STATUS - internal procedure to display file status for each file */

DISPLAY_FILE_STATUS: proc;

dcl  i fixed bin;

	call io_call_info.report ("^/File Number:^-^d", file_status.file_seq);
	call io_call_info.report ("File Name:^-^a", file_status.file_id);
	call io_call_info.report ("File State:^-^[Never opened^;Not open^;Open^;Open with error^]",
	     file_status.file_state + 1);
	if file_status.error_code ^= 0 then do;
	     call convert_status_code_ (file_status.error_code, short_info, long_info);
	     call io_call_info.report ("File Code:^-^w (^a)", file_status.error_code, long_info);
	end;
	vol_string = "";				/* clear out volume name string */
	i = 0;
	do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (i < file_status.end_vol_index);
	     i = i + 1;				/* increment volume index */
	     if i >= file_status.begin_vol_index then do; /* at beginning volume of file? */
		if mtape_vol_set.volume_id ^= "" then	/* if volume id has been set */
		     vol_string = rtrim (vol_string) || " " || mtape_vol_set.volume_id;
		else vol_string = rtrim (vol_string) || " " || mtape_vol_set.volume_name;
	     end;
	end;
	vol_string = ltrim (vol_string);		/* trim off leading white space */
	call io_call_info.report ("File Sections:^-^d", file_status.file_sections);
	call io_call_info.report ("On Volume^[s^]:^-^a", (file_status.file_sections > 1), vol_string);
	if file_status.generation > 0 then		/* if a gereration number exists */
	     call io_call_info.report ("Generation:^-^d^[; Generation Version:^-^d^;^1s^]",
		file_status.generation, (file_status.gen_version > 0), file_status.gen_version);
	if file_status.creation ^= " 00000" then	/* if creation date exists.. */
	     call io_call_info.report ("Creation Date:^-^a", CV_DATE (file_status.creation));
	if file_status.expiration ^= " 00000" then	/* if expiration date exists.. */
	     call io_call_info.report ("Expiration Date:^-^a", CV_DATE (file_status.expiration));
	call io_call_info.report ("File Format:^-^a", file_status.file_format);
	call io_call_info.report ("Block Length:^-^d", file_status.block_len);
	call io_call_info.report ("Record Length:^-^d", file_status.reclen);
	call io_call_info.report ("Recording Mode:^-^a", file_status.recording_mode);
	if file_status.block_count ^= 0 then
	     call io_call_info.report ("Block Count:^-^d", file_status.block_count);
	call io_call_info.report ("Read Errors:^-^d", file_status.read_errors);
	call io_call_info.report ("Write Errors:^-^d", file_status.write_errors);

     end DISPLAY_FILE_STATUS;
%page;
/* SET_FILE_STATUS - internal procedure to  copy the file status for this file */

SET_FILE_STATUS: proc;

dcl  i fixed bin;

	unspec (file_status) = "0"b;			/* clear the structure first */
	file_status.file_id = mtape_file_info.file_id;	/* set appropriate fields */
	file_status.file_seq = mtape_file_info.seq_number;
	file_status.generation = mtape_file_info.generation;
	file_status.gen_version = mtape_file_info.gen_version;
	file_status.creation = mtape_file_info.creation_date;
	file_status.expiration = mtape_file_info.expiration_date;
	file_status.file_format = mtape_file_info.file_code;
	file_status.block_len = mtape_file_info.block_size;
	file_status.reclen = mtape_file_info.record_size;
	file_status.block_count = mtape_file_info.block_count;
	file_status.read_errors = mtape_file_info.read_errors;
	file_status.write_errors = mtape_file_info.write_errors;
	if mtape_file_info.conversion = MTAPE_CV_EBCDIC then /* set proper recording mode */
	     file_status.recording_mode = "EBCDIC";
	else if mtape_file_info.conversion = MTAPE_CV_BCD then
	     file_status.recording_mode = "BCD";
	else if mtape_file_info.conversion = MTAPE_NO_CONVERSION & mtape_file_info.hdw_mode = MTAPE_HWM_NINE then
	     file_status.recording_mode = "ASCII";
	else if mtape_file_info.hdw_mode = MTAPE_HWM_BIN then
	     file_status.recording_mode = "BINARY";
	else file_status.recording_mode = "******";
	i = 0;					/* reset volume count */
	do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (file_status.end_vol_index = 0);
	     i = i + 1;				/* increment volume index */
	     if vs_ptr = mtape_file_info.begin_vs_ptr then
		file_status.begin_vol_index = i;
	     if file_status.begin_vol_index ^= 0 then
		file_status.file_sections = file_status.file_sections + 1;
	     if vs_ptr = mtape_file_info.end_vs_ptr then
		file_status.end_vol_index = i;
	end;
	if mtape_file_info.position_within_file = NOT_POSITIONED_IN_FILE then
	     file_status.file_state = 1;
	else if ^open then
	     file_status.file_state = 1;
	else if mtape_data.error_lock ^= 0 then		/* if an error lock exists.. */
	     file_status.file_state = 3;
	else file_status.file_state = 2;
	file_status.error_code = mtape_data.error_lock;

     end SET_FILE_STATUS;
%page;
/* DISPLAY_VOLUME_STATUS - internal procedure to display volume status for each volume */

DISPLAY_VOLUME_STATUS: proc;

	call io_call_info.report ("^/Volume Name:^-^a", volume_status.volume_name);
	call io_call_info.report ("Volume ID:^-^a", volume_status.volume_id);
	call io_call_info.report ("Mounted:^2-^[Yes^;No^]", volume_status.mounted);
	if volume_status.device_name ^= "" then
	     call io_call_info.report ("On Device:^-^a", volume_status.device_name);
	call io_call_info.report ("Volume Sequence:^-^d", volume_status.volume_index);
	if volume_status.mounts > 0 then do;		/* if volume has ever been mounted */
	     if volume_status.mounts > 1 | ^volume_status.mounted then do; /* if not currently mounted | > 1 mount */
		call io_call_info.report ("Total Volume Error Statistics^[ Across ^d Volume Mounts^;^1s^]:^/",
		     (volume_status.mounts > 1), volume_status.mounts);
		call REPORT_ERR_STATS (addr (volume_status.tot_error_stats));
	     end;
	     if volume_status.mounted then do;		/* if volume currently mounted */
		call io_call_info.report ("Volume Error Statistics For Current Mount:^/");
		call REPORT_ERR_STATS (addr (volume_status.rel_error_stats));
	     end;
	end;

     end DISPLAY_VOLUME_STATUS;
%page;
/* SET_VOLUME_STATUS - internal procedure to  copy the volume status for this volume */

SET_VOLUME_STATUS: proc;

	volume_status.volume_name = mtape_vol_set.volume_name; /* copy volume info */
	volume_status.volume_id = mtape_vol_set.volume_id;
	volume_status.mounted = mtape_vol_set.mounted;
	volume_status.volume_index = mtape_vol_set.volume_index;
	volume_status.device_name = mtape_vol_set.device_name;
	volume_status.mounts = mtape_vol_set.mounts;
	if open & mtape_data.tioi_id = mtape_vol_set.tioi_id then do; /* update error stats */
	     if mtape_open_info.open_mode = Sequential_output |
		mtape_open_info.open_mode = Stream_output then do; /* currently open for output */
		mtape_data.arg_buf_ptr = null;	/* set up to flush out buffers */
		mtape_data.arg_buf_len = 0;
		call mtape_data.write (mtdp, code);	/* flush out buffers */
	     end;
	     call mtape_util_$get_statistics (mtdp, code);/* update error stats */
	end;
	volume_status.tot_error_stats = mtape_vol_set.tot_error_stats;
	volume_status.rel_error_stats = mtape_vol_set.rel_error_stats;

     end SET_VOLUME_STATUS;

/* REPORT_ERR_STATS - internal procedure to format error statistics for io_call */

REPORT_ERR_STATS: proc (esp);

dcl  esp ptr;
dcl  i fixed bin;

	es_ptr = esp;
	call io_call_info.report ("Operation^20tNumber Processed^40tErrors^/");
	if mtape_err_stats.read.operations > 0 then	/* Where any reads done? */
	     call io_call_info.report ("Read^20t^d^40t^d",
		mtape_err_stats.read.operations, mtape_err_stats.read.errors);
	if mtape_err_stats.write.operations > 0 then	/* Where any writes done? */
	     call io_call_info.report ("Write^20t^d^40t^d",
		mtape_err_stats.write.operations, mtape_err_stats.write.errors);
	if mtape_err_stats.orders.operations > 0 then	/* Where any orders done? */
	     call io_call_info.report ("Non-data Xfer Cmds^20t^d^40t^d",
		mtape_err_stats.orders.operations, mtape_err_stats.orders.errors);
	if sum (mtape_err_stats.successful_retry) > 0 then do; /* Do not display unless we have some */
	     call io_call_info.report ("^/Successful Read Error Recovery Stratagy^/");
	     call io_call_info.report ("IDCW Chn Cmd^20tSuccessful Recoverys^/");
	     do i = hbound (mtape_err_stats.successful_retry, 1);
		if mtape_err_stats.successful_retry (i) > 0 then /* only display case if retrys */
		     call io_call_info.report ("^5x3^d^20t^d", i, mtape_err_stats.successful_retry (i));
	     end;
	end;

     end REPORT_ERR_STATS;
%page;
/* SET_HARDWARE_STATUS - internal procedure to obtain last hardware status from
   tape_ioi_ and fill in mtape_hardware_status structure */

SET_HARDWARE_STATUS: proc;

	allocate ths in (based_area) set (ths_ptr);	/* allocate tape_ioi_ status structure */
	ths.version = THS_VERSION_1;			/* set proper version number */
	call tape_ioi_$hardware_status (mtape_data.tioi_id, ths_ptr, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code, "Error from tape_ioi_$hardware_status.");
	     go to CONTROL_OP_END;
	end;
	mtape_hardware_status.description = ths.description; /* now fill in our structure */
	mtape_hardware_status.iom_status = ths.iom;
	mtape_hardware_status.iom_lpw = ths.lpw;
	free ths in (based_area);			/* free up tape_ioi_ structure */

     end SET_HARDWARE_STATUS;
%page;
/* CV_DATE - function to convert julian date (yyddd) to month/day/year */

CV_DATE: proc (julian) returns (char (10) aligned);

dcl  julian char (6) aligned;				/* date in form: " yyddd" */

dcl  clock fixed bin (71),
     (month, day, year) fixed bin,
     (Cmonth, Cday, Cyear) pic "99",
     date_time char (10) aligned,
     code fixed bin (35);

dcl  decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
	fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)),
     encode_clock_value_$offsets entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
	fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (71), fixed bin (35));

	year = convert (year, substr (julian, 2, 2));
	day = convert (day, substr (julian, 4, 3));
	call encode_clock_value_$offsets (0, 0, day - 1, year - 1, 0, 0, 0, 0, 0, "gmt", clock, code);
	if code ^= 0 then return ("unknown");
	call decode_clock_value_$date_time (clock, month, day, year, 0, 0, 0, 0, 0, "gmt", code);
	if code ^= 0 then return ("unknown");
	Cmonth = month;
	Cday = day;
	Cyear = year - 1900;
	date_time = Cmonth || "/" || Cday || "/" || Cyear;
	return (date_time);

     end CV_DATE;
%page;
%include iocb;
%page;
%include mtape_data;
%page;
%include mtape_attach_info;
%page;
%include mtape_open_close_info;
%page;
%include mtape_file_info;
%page;
%include mtape_vol_set;
%page;
%include io_call_info;
%page;
%include rcp_volume_formats;

%include mtape_saved_pfm_info;
%page;
%include mtape_file_status;
%page;
%include mtape_volume_status;

%include mtape_err_stats;
%page;
%include mtape_hardware_status;

%include iox_modes;
%page;
%include mtape_label_record;
%page;
%include mtape_constants;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_hw_status;

     end mtape_control_;




		    mtape_cv_apd.rd                 03/17/86  1519.4r w 03/17/86  1430.1      436653



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

/* DESCRIPTION:

   This command takes an argument processing definition (APD)
   from a source file and translates the information specified
   by that source into a form readily useable by the argument
   processing routine process_arguments_.  The result, called
   a print vector array, is stored into a value segment
   specified by the user.

   The information in the source file must be specified in the
   APD language whose grammar is described elsewhere.

   The syntax of the command is as follows:

        mtape_cv_apd {-source} path {{-target} path} {-control_arg}

   where -control_arg may be -replace or -no_replace and designates
   whether or not to replace the APD if it already exists in the
   target database.

   The source file must have the "mapd" suffix and the target file
   must be a value segment with the "value" suffix.

   The result print_vector_array contains print_vectors of the following 
   composition:

        1) Initial vector:  definition order *
		        command name *
		        default linear form
		        initial implied option
		        explanation
		        validate result
		        validate result explanation

        2) Option vector:  definition order *
		       command name *
		       option *
		       initial argument
		       next implied option
		       excluded option
		       unexcluded option
		       presence required		/~* takes no value *~/

        3) Option name vector:  definition order *
		            command name *
		            option *
		            synonym *
		            negative form		/~* takes no value *~/

        4) Argument vector:  definition order *
		         command name *
		         option *
		         argument *
		         next argument
		         presence required		/~* takes no value *~/
		         validation string
		         default value
		         negative value
		         explanation

		  
      *  Required dimensions

   Note that this program does no validity or consistency checking of the
   info that the user feeds it.  This should be added in the future.

*/

/* HISTORY:

Written by S. Krupp, 03/01/83.
Modified:
07/25/83 by Lindsey Spratt:  Changed to put the definition in  a value segment
	  instead of a vector db.  The default linear form is now stored
	  separately in the value seg, rather than as part of the definition
	  pva.
08/05/83 by S. Krupp:  Changed name from cvapd to mtape_cv_apd.  Changed
            source segment suffix from "cvapd" to "mapd".

08/26/83 by S. Krupp:  Added the "Force_literal" and "Validate_explanation"
	  statements.
*/

%page;
/*++

INCLUDE NEXT_STMT \
INCLUDE ERROR \

BEGIN
initial_definition
          / Program_name :
	     / LEX(2) PUSH(initial_stmt_list)
	     / program_name_stmt                         \
          / <any-token>
               / ERROR(2) NEXT_STMT
	     / initial_stmt_list                         \
          / <no-token>
               / ERROR(3)
	     / error_return                              \

initial_stmt_list
          / Explanation :
	     / LEX(2) PUSH(initial_stmt_list)
               / explanation_stmt                          \
          / Default_linear_form :
               / LEX(2) PUSH(initial_stmt_list)
	     / default_linear_form_stmt                  \
          / Initial_implied_option :
               / LEX(2) PUSH(initial_stmt_list)
	     / initial_implied_option_stmt               \
          / Validate_result :
               / LEX(2) PUSH(initial_stmt_list)
	     / validate_result_stmt                      \
          / Validate_result_explanation :
               / LEX(2) PUSH(initial_stmt_list)
	     / validate_result_explanation_stmt          \
          / <any-token>
               /
	     / end_or_opt                                \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

end_or_opt
          / End ;
               / NEXT_STMT
	     / return                                    \
          / Option :
	     /
	     / option_definition                         \
          / <any-token>
               / ERROR(10) NEXT_STMT
               / initial_stmt_list                         \

option_definition
          / Option :
               / LEX(2) PUSH(per_option_stmt_list)
	     / option_stmt                               \

per_option_stmt_list
          / Option_name :
               / LEX(2) PUSH(per_option_stmt_list)
	     / option_name_stmt                          \
          / First_argument :
               / LEX(2) PUSH(per_option_stmt_list)
	     / first_argument_stmt                       \
          / Antonym :
               / LEX(2) PUSH(per_option_stmt_list)
	     / antonym_stmt                              \
          / Explanation :
               / LEX(2) PUSH(per_option_stmt_list)
	     / explanation_stmt                          \
          / Exclude :
               / LEX(2) PUSH(per_option_stmt_list)
               / exclude_stmt                              \
          / Unexclude :
               / LEX(2) PUSH(per_option_stmt_list)
	     / unexclude_stmt                            \
          / Presence :
               / LEX(2) PUSH(per_option_stmt_list)
	     / presence_stmt                             \
          / Next_implied_option :
               / LEX(2) PUSH(per_option_stmt_list)
	     / next_implied_option_stmt                  \
          / <any-token>
               /
	     / per_opt_end_or_opt_or_arg                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

per_opt_end_or_opt_or_arg
          / End ;
               / [if default_exclude_myself
	        then call add_to_vector(option, EXCLUDED_OPTION)]
	       NEXT_STMT
	     / return                                    \
          / Option :
               / [if default_exclude_myself
	        then call add_to_vector(option, EXCLUDED_OPTION)]
	     / option_definition                         \
          / Argument :
               / [if default_exclude_myself
	        then call add_to_vector(option, EXCLUDED_OPTION)]
	     / argument_definition                       \
          / <any-token>
               / ERROR(11) NEXT_STMT
	     / per_option_stmt_list                      \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

argument_definition
          / Argument :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / argument_stmt                             \

per_argument_stmt_list
          / Validate :
	     / LEX(2) PUSH(per_argument_stmt_list)
	     / validate_stmt                             \
          / Validate_explanation :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / validate_explanation_stmt                 \
          / Default_value :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / default_value_stmt                        \
          / Antonym_value :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / antonym_value_stmt                        \
          / Presence :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / presence_stmt                             \
          / Next_argument :
               / LEX(2) PUSH(per_argument_stmt_list)
               / next_argument_stmt                        \
          / Explanation :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / explanation_stmt                          \
          / Force_literal :
               / LEX(2) PUSH(per_argument_stmt_list)
	     / force_literal_stmt                        \
          / <any-token>
               /
	     / per_arg_end_or_opt_or_arg                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

per_arg_end_or_opt_or_arg
          / End ;
               / NEXT_STMT
	     / return                                    \
          / Option :
               /
	     / option_definition                         \
          / Argument :
               /
	     / argument_definition                       \
          / <any-token>
               / ERROR(13) NEXT_STMT
	     / per_argument_stmt_list                    \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

cum_quoted_comma_list
cum_quoted_comma_list_next
          / ,
	     / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
          / ;
               / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \
          / <quoted-string>
               / append_to_str(token_value, expanded_token_len, expanded_token_ptr)
	       LEX(1)
	     / cum_quoted_comma_list_punc                \
          / <any-token>
               / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
  cum_quoted_comma_list_punc
          / ,
               / LEX(1)
	     / cum_quoted_comma_list_next                \
          / ;
               / [if list_dim = DEFAULT_LINEAR_FORM
	        then call set_name (expanded_token, default_linear_form_length,
		   default_linear_form_ptr);
	        else call add_to_vector(expanded_token, list_dim);
	        call reset_name(expanded_token_len, expanded_token_ptr)]
                 NEXT_STMT
               / STACK_POP                                 \
          / <any-token>
               / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

comma_list
comma_list_next
          / ,
               / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
          / ;
               / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \
          / <any-token>
               / add_to_vector(token_value, list_dim) LEX(1)
	     /                                           \
          / ,
               / LEX(1)
	     / comma_list_next                           \
          / ;
               / NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(12) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

return
          / <any-token>
               / ERROR(5)
	     / RETURN                                    \
          / <no-token>
               /
	     / RETURN                                    \

error_return
          / <any-token>
               /
	     / RETURN                                    \
          / <no-token>
               /
	     / RETURN                                    \

stmts
program_name_stmt
          / <any-token> ;
               / [call set_name(token_value, command_name_len, command_name_ptr);
	        call start_vector(INITIAL_VECTOR)] NEXT_STMT
               / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

explanation_stmt
          / <any-token>
               / [list_dim = EXPLANATION]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

default_linear_form_stmt
          / <any-token>
               / [list_dim = DEFAULT_LINEAR_FORM]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

initial_implied_option_stmt
          / <any-token> ;
               / add_to_vector(token_value, INITIAL_IMPLIED_OPTION) NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

option_stmt
          / <any-token> ;
               / [call set_name(token_value, option_len, option_ptr);
	        call reset_name(argument_len, argument_ptr);
	        call start_vector(OPTION_VECTOR);
	        default_exclude_myself = "1"b]
	       NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

option_name_stmt
          / <any-token>
               / [list_dim = SYNONYM]
	     / comma_list                                \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

first_argument_stmt
          / <any-token> ;
               / add_to_vector(token_value, INITIAL_ARGUMENT) NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

antonym_stmt
          / <any-token>
               / [list_dim = NEGATIVE_FORM]
	     / comma_list                                \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

exclude_stmt
          / <any-token>
               / [list_dim = EXCLUDED_OPTION]
	     / comma_list                                \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

unexclude_stmt
          / <any-token>
               / [list_dim = UNEXCLUDED_OPTION]
	     / comma_list                                \
          / <no-token>
               / ERROR(4)
               / error_return                              \

presence_stmt
          / required ;
               / add_to_vector(token_value, PRESENCE_REQUIRED) NEXT_STMT
	     / STACK_POP                                 \
          / literal_required ;
               / add_to_vector(token_value, PRESENCE_REQUIRED) NEXT_STMT
	     / STACK_POP                                 \
          / optional ;
               / NEXT_STMT
	     / STACK_POP                                 \
          / <decimal-integer> ;
               / add_to_vector(token_value, PRESENCE_REQUIRED) NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

next_implied_option_stmt
          / <any-token> ;
               / add_to_vector(token_value, NEXT_IMPLIED_OPTION) NEXT_STMT
               / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

argument_stmt
          / <any-token> ;
               / [call set_name(token_value, argument_len, argument_ptr);
	        call start_vector(ARGUMENT_VECTOR)] NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

validate_stmt
          / <any-token>
               / [list_dim = VALIDATION_STRING]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \


default_value_stmt
          / <any-token>
               / [list_dim = DEFAULT_VALUE]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

antonym_value_stmt
          / <any-token>
               / [list_dim = NEGATIVE_VALUE]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

next_argument_stmt
          / <any-token> ;
               / add_to_vector(token_value, NEXT_ARGUMENT) NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
               / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

validate_result_stmt
          / <any-token>
               / [list_dim = VALIDATE_RESULT]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

validate_result_explanation_stmt
          / <any-token>
               / [list_dim = VALIDATE_RESULT_EXPLANATION]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

validate_explanation_stmt
          / <any-token>
	     / [list_dim = VALIDATE_EXPLANATION]
	     / cum_quoted_comma_list                     \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

force_literal_stmt
          / ;
	     / add_to_vector("", FORCE_LITERAL) NEXT_STMT
	     / STACK_POP                                 \
          / <any-token>
	     / ERROR(1) NEXT_STMT
	     / STACK_POP                                 \
          / <no-token>
               / ERROR(4)
	     / error_return                              \

++*/
%page;
mtape_cv_apd: proc ();

/* Automatic */

	dcl     answer		 char (3) var;
	dcl     area_ptr		 ptr;
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     argument_len	 fixed bin (21);
	dcl     argument_ptr	 ptr;
	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     command_name_len	 fixed bin (21);
	dcl     command_name_ptr	 ptr;
	dcl     created_value_seg	 bit (1) aligned init ("0"b);
	dcl     default_exclude_myself bit (1) aligned;
	dcl     default_linear_form_length fixed bin (21) init (0);
	dcl     default_linear_form_ptr ptr init (null);
	dcl     default_linear_form_value_name char (128) varying init ("");
	dcl     definition_exists	 bit (1) aligned init ("0"b);
	dcl     definition_order	 pic "999";
	dcl     definition_string_length fixed bin (35) init (0);
	dcl     definition_string_ptr	 ptr init (null);
          dcl     dlf_var_length	 fixed bin(21);
          dcl     dlf_var_ptr		 ptr;
	dcl     definition_value_name	 char (128) varying init ("");
	dcl     error_code_array	 (1) fixed bin (35);
	dcl     expanded_token_len	 fixed bin (21);
	dcl     expanded_token_ptr	 ptr;
	dcl     i			 fixed bin;
	dcl     list_dim		 fixed bin;
	dcl     main_pv_num		 fixed bin;
	dcl     main_pv_type	 fixed bin;
	dcl     n_definition_order	 fixed bin;
	dcl     nargs		 fixed bin;
	dcl     option_len		 fixed bin (21);
	dcl     option_ptr		 ptr;
	dcl     Pfirst_stmt_desc	 ptr;
	dcl     Pfirst_token_desc	 ptr;
	dcl     replace		 bit (1) aligned;
	dcl     sdname		 char (168);
	dcl     seg_len		 fixed bin (21);
	dcl     seg_ptr		 ptr;
	dcl     sename		 char (32);
	dcl     source_rpath_len	 fixed bin (21);
	dcl     source_rpath_ptr	 ptr;
	dcl     synonym_len		 fixed bin (21);
	dcl     synonym_ptr		 ptr;
	dcl     target_rpath_len	 fixed bin (21);
	dcl     target_rpath_ptr	 ptr;
	dcl     tdname		 char (168);
	dcl     temp_seg_ptr	 ptr;
	dcl     tename		 char (32);
	dcl     value_defined	 (22) bit (1);	/* *** True means that DIMENSIONS(i) in the current */
						/* print_vector has a value. */
	dcl     value_seg_ptr	 ptr init (null);

	dcl     1 auto_area_info	 like area_info;
	dcl     1 auto_query_info	 like query_info;

/* Based */

	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     argument		 char (argument_len) based (argument_ptr);
	dcl     based_area		 area based (area_ptr);
	dcl     command_name	 char (command_name_len) based (command_name_ptr);
	dcl     default_linear_form_string char (default_linear_form_length) based (default_linear_form_ptr);
          dcl     dlf_var                char(dlf_var_length) var based(dlf_var_ptr);
	dcl     expanded_token	 char (expanded_token_len) based (expanded_token_ptr);
	dcl     option		 char (option_len) based (option_ptr);
	dcl     source_rpath	 char (source_rpath_len) based (source_rpath_ptr);
	dcl     synonym		 char (synonym_len) based (synonym_ptr);
	dcl     target_rpath	 char (target_rpath_len) based (target_rpath_ptr);

/* Builtin */

	dcl     (addr, after, dimension, divide, empty, length,
	        null, reverse, rtrim, string, unspec) builtin;

/* Entries */

	dcl     command_query_	 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     com_err_		 entry () options (variable);
	dcl     define_area_	 entry (ptr, fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_wdir_		 entry () returns (char (168));
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
	dcl     initiate_file_$create	 entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var,
				 char (*) var, char (*) var, char (*) var);
	dcl     lex_string_$lex	 entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*),
				 char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35));
	dcl     suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));
	dcl     term_$seg_ptr	 entry (ptr, fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     translator_temp_$get_next_segment entry (ptr, ptr, fixed bin (35));
	dcl     translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35));
	dcl     translator_temp_$release_all_segments entry (ptr, fixed bin (35));
	dcl     value_$get_data	 entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed
				 bin (18), fixed bin (35));
	dcl     value_$init_seg	 entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
	dcl     value_$set_data	 entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18),
				 fixed bin (35));
	dcl     value_$delete_data	 entry (ptr, bit (36) aligned, char (*), fixed bin (35));

/* Static */

/* Things marked *** are all related to the dimensions contained in the
     print_vector_array.  If the dimensions change, all of these things should
     be looked at for possible changes.
  */

	dcl     (COMMENT_CLOSE	 char (2) init ("*/"),
	        COMMENT_OPEN	 char (2) init ("/*"),
	        CVAPD_VERSION	 fixed bin init (1),
	        FATAL_ERROR		 fixed bin init (3),
	        FATAL_ERROR_MSG	 char (45) init ("Fatal error has occured.  Translation failed."),
	        FREE_OLD_PV_ARRAY	 bit (1) aligned init ("1"b),
	        IGNORED_INPUT_LEN	 fixed bin (21) init (0),
	        MAX_DIM_NAME_LEN	 fixed bin init (32),    /* *** */
	        MAX_NUM_OF_ARGS	 fixed bin init (5),
	        MIN_NUM_OF_ARGS	 fixed bin init (1),
	        ME		 char (12) init ("mtape_cv_apd"),
	        ME_UPPER		 char (12) init ("MTAPE_CV_APD"),
	        N_INCREMENTAL_PV_SLOTS fixed bin init (10),
	        N_INITIAL_PV_SLOTS	 fixed bin (35) init (10),
	        N_PV_DIMS		 fixed bin init (22), /* *** */
	        NEW_VECTOR		 fixed bin init (-1),
	        NO_COPY		 fixed bin (2) init (1),
	        QUOTE_CLOSE		 char (1) init (""""),
	        QUOTE_OPEN		 char (1) init (""""),
	        SINIT		 bit (2) init ("10"b),
	        SLEX		 bit (4) init ("1000"b),
	        SOURCE_SUFFIX	 char (4) init ("mapd"),
	        STMT_DELIM		 char (1) init (";"),
	        STOP_ON_DUPLICATION	 bit (1) aligned init ("1"b),
	        STOP_ON_ERROR	 bit (1) aligned init ("1"b),
	        USAGE_MSG		 char (66) init ("Usage: mtape_cv_apd {-source} path {{-target} path} {-control_arg}"),
	        VALUE_SUFFIX	 char (5) init ("value")
	        )			 internal static options (constant);

	dcl     (INITIAL_VECTOR	 init (1),
	        OPTION_VECTOR	 init (2),
	        OPTION_NAME_VECTOR	 init (3),
	        ARGUMENT_VECTOR	 init (4),
	        BASIC_VECTOR	 init (5),
	        NEGATIVE_FORM_VECTOR	 init (6)
	        )			 fixed bin internal static options (constant);

	dcl     BYTES_PER_WORD	 init (4) fixed bin internal static options (constant);

	dcl     CAN_HAVE_VALUE	 (22) bit (1) aligned /* *** */
				 init ((11) ("1"b), (1) ("0"b), (9) ("1"b), (1) ("0"b))
				 internal static options (constant);

	dcl     CAN_HAVE_MULTIPLE_DEFINITIONS (22) bit (1) aligned /* *** */
				 init ((9) ("0"b), (3) ("1"b), (5) ("0"b), (3) ("1"b), (2) ("0"b))
				 internal static options (constant);

	dcl     DIMENSIONS		 (22) char (32) var                /* *** */
				 init ("definition order",         /* 1 */
				 "command name",	               /* 2 */
				 "default linear form",            /* 3 */
				 "initial implied option",         /* 4 */
				 "explanation",	               /* 5 */
				 "option",	               /* 6 */
				 "initial argument",               /* 7 */
				 "next implied option",            /* 8 */
				 "presence required",              /* 9 */
				 "excluded option",                /* 10 */
				 "synonym",	               /* 11 */
				 "negative form",	               /* 12 */
				 "argument",	               /* 13 */
				 "next argument",	               /* 14 */
				 "validation string",              /* 15 */
				 "default value",	               /* 16 */
				 "negative value",	               /* 17 */
				 "unexcluded option",              /* 18 */
				 "validate result",                /* 19 */
				 "validate result explanation",    /* 20 */
				 "validate explanation",	     /* 21 */
				 "force literal"		     /* 22 */
				 ) internal static options (constant);

	dcl     (DEFINITION_ORDER	       init (1),	/* *** */
	        COMMAND_NAME	       init (2),
	        DEFAULT_LINEAR_FORM	       init (3),
	        INITIAL_IMPLIED_OPTION       init (4),
	        EXPLANATION		       init (5),
	        OPTION		       init (6),
	        INITIAL_ARGUMENT	       init (7),
	        NEXT_IMPLIED_OPTION	       init (8),
	        PRESENCE_REQUIRED	       init (9),
	        EXCLUDED_OPTION	       init (10),
	        SYNONYM		       init (11),
	        NEGATIVE_FORM	       init (12),
	        ARGUMENT		       init (13),
	        NEXT_ARGUMENT	       init (14),
	        VALIDATION_STRING	       init (15),
	        DEFAULT_VALUE	       init (16),
	        NEGATIVE_VALUE	       init (17),
	        UNEXCLUDED_OPTION	       init (18),
	        VALIDATE_RESULT	       init (19),
	        VALIDATE_RESULT_EXPLANATION  init (20),
	        VALIDATE_EXPLANATION	       init (21),
	        FORCE_LITERAL	       init (22)
	        )			       fixed bin internal static options (constant);

	dcl     PERMANENT_VALUE	 init ("01"b) bit (36) aligned internal static options (constant);
	dcl     PERMANENT_VALUE_SEG_TYPE init (0) fixed bin internal static options (constant);

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

	dcl     (error_table_$bad_arg,
	        error_table_$empty_file,
	        error_table_$noarg,
	        error_table_$oldnamerr,
	        error_table_$segknown,
	        error_table_$wrong_no_of_args,
	        error_table_$zero_length_seg
	        )			 fixed bin (35) ext static;

	dcl     (lex_control_chars,
	        lex_delims
	        )			 char (128) var init ("") int static;

	dcl     (cleanup, size)	 condition;

	dcl     BREAK_CHARS		 char (5) var init (":, 	
")
				 internal static options (constant); /* ":", ",", SPACE, TAB, NL */
	dcl     IGNORED_BREAK_CHARS	 char (3) var init (" 	
")
				 internal static options (constant); /* SPACE, TAB, NL */

	dcl     1 error_control_table	 (13) int static options (constant) unaligned,
		2 severity	 fixed bin (17) init ((4) (3), /* 1 - 3 */
				 2, 4, 1, 4, 4,	/* 4 - 8 */
				 (4) (3)),	/* 9 - 13 */
		2 Soutput_stmt	 bit (1) init ((13) ("1"b)),
		2 message		 char (256) var init (
				 "Error in statement.", /* 1 */
				 "Unrecognized statement.  Looking for program_name statement.", /* 2 */
				 "Source file is empty.", /* 3 */
				 "Source file ends unexpectedly.", /* 4 */
				 "Text after end statement.", /* 5 */
				 "Could not append a print vector to the print vector array.", /* 6 */
				 "This value has already been defined.  Ignoring value.", /* 7 */
				 "Could not append a dimension to a print vector.", /* 8 */
				 "Reference made to unknown vector type.", /* 9 */
				 "Unrecognized statement in initial statement list.", /* 10 */
				 "Unrecognized statement in option statement list.", /* 11 */
				 "Bad syntax in list.", /* 12 */
				 "Unrecognized statement in argument statement list."), /* 13 */
		2 brief_message	 char (256) var init ((13) (""));

%page;
/* Include */

%include access_mode_values;
%page;
%include pa_value_names;
%page;
%include vu_print_vector_array;
%page;
%include vu_entry_dcls;
%page;
%include area_info;
%page;
%include terminate_file;
%page;
%include query_info;
%page;
/* Main Procedure */


	call initialize_translator_values ();

	on cleanup call cleanup_trans ();

	call cu_$arg_count (nargs, code);
	if code ^= 0
	then call abort (code, "");

	if nargs = 0
	then call abort (0, USAGE_MSG);

	if nargs < MIN_NUM_OF_ARGS | nargs > MAX_NUM_OF_ARGS
	then call abort (error_table_$wrong_no_of_args, "");

	source_rpath_ptr, target_rpath_ptr = null;
	source_rpath_len, target_rpath_len = 0;
	replace = "0"b;
	i = 1;

	do while (i <= nargs);
	     call get_arg (i, arg_ptr, arg_len);
	     if arg = "-source"
	     then call get_arg (i, source_rpath_ptr, source_rpath_len);
	     else if arg = "-target"
	     then call get_arg (i, target_rpath_ptr, target_rpath_len);
	     else if arg = "-replace" | arg = "-rp"
	     then replace = "1"b;
	     else if arg = "-no_replace" | arg = "-nrp"
	     then replace = "0"b;
	     else if source_rpath_ptr = null
	     then do;
		     source_rpath_ptr = arg_ptr;
		     source_rpath_len = arg_len;
		end;
	     else if target_rpath_ptr = null
	     then do;
		     target_rpath_ptr = arg_ptr;
		     target_rpath_len = arg_len;
		end;
	     else call abort (error_table_$bad_arg, """" || arg || """");
	end;

	if source_rpath_ptr = null
	then call abort (error_table_$noarg, "Source pathname.");

	call expand_pathname_$add_suffix (source_rpath, SOURCE_SUFFIX, sdname, sename, code);
	if code ^= 0
	then call abort (code, """" || source_rpath || """");

	if target_rpath_ptr ^= null
	then do;
		call expand_pathname_$add_suffix (target_rpath, VALUE_SUFFIX, tdname, tename, code);
		if code ^= 0
		then call abort (code, """" || target_rpath || """");
	     end;
	else do;
		tdname = get_wdir_ ();
		call suffixed_name_$new_suffix (sename, SOURCE_SUFFIX, VALUE_SUFFIX, tename, code);
		if code ^= 0 then call abort (code, "Unable to convert the source entry name into a target value segment entry name.");
	     end;

	call hcs_$initiate_count (sdname, sename, "", bit_count, NO_COPY, seg_ptr, code);
	if code = error_table_$segknown
	then code = 0;
	else if code ^= 0
	then call abort (code, rtrim (sdname) || ">" || rtrim (sename));

	seg_len = divide (bit_count + 8, 9, 21, 0);

	call ioa_ ("^a ^3.1f", ME_UPPER, CVAPD_VERSION);

	call translator_temp_$get_segment ((ME), temp_seg_ptr, code);
	if code ^= 0
	then call abort (code, "");

	call translator_temp_$get_next_segment (temp_seg_ptr, area_ptr, code);
	if code ^= 0
	then call abort (code, "");

	call translator_temp_$get_next_segment (area_ptr, definition_string_ptr, code);
	if code ^= 0 then call abort (code, "");
	definition_string_length = sys_info$max_seg_size * 4;

	unspec (auto_area_info) = "0"b;

	auto_area_info.version = 1;
	auto_area_info.extend = "1"b;
	auto_area_info.zero_on_alloc = "1"b;
	auto_area_info.zero_on_free = "0"b;
	auto_area_info.dont_free = "0"b;
	auto_area_info.no_freeing = "0"b;
	auto_area_info.system = "1"b;
	auto_area_info.owner = ME;
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.areap = area_ptr;

	call define_area_ (addr (auto_area_info), code);
	if code ^= 0
	then call abort (code, "");

	call vector_util_$init_print_vector_array (area_ptr, N_INITIAL_PV_SLOTS, N_PV_DIMS, MAX_DIM_NAME_LEN, print_vector_array_ptr, code);
	if code ^= 0
	then call abort (code, "");

	print_vector_array.dimension_table.name = DIMENSIONS;

	if lex_delims = ""
	then call lex_string_$init_lex_delims (QUOTE_OPEN, QUOTE_CLOSE,
		COMMENT_OPEN, COMMENT_CLOSE, STMT_DELIM, SINIT,
		BREAK_CHARS, IGNORED_BREAK_CHARS, lex_delims, lex_control_chars);

	call lex_string_$lex (seg_ptr, seg_len, IGNORED_INPUT_LEN,
	     temp_seg_ptr, SLEX, QUOTE_OPEN, QUOTE_CLOSE,
	     COMMENT_OPEN, COMMENT_CLOSE, STMT_DELIM,
	     BREAK_CHARS, IGNORED_BREAK_CHARS, lex_delims, lex_control_chars,
	     Pfirst_stmt_desc, Pfirst_token_desc, code);
	if code = error_table_$zero_length_seg
	then call abort (code, rtrim (sdname) || ">" || rtrim (sename));
	else if code ^= 0
	then do;
		code = 0;
		MERROR_SEVERITY = FATAL_ERROR;
	     end;

	Pthis_token = Pfirst_token_desc;

	call SEMANTIC_ANALYSIS ();

	if MERROR_SEVERITY >= FATAL_ERROR
	then call abort (0, FATAL_ERROR_MSG);

	call initiate_file_$create (tdname, tename, RW_ACCESS, value_seg_ptr, created_value_seg, (0), code);
	if value_seg_ptr = null
	then call abort (code, rtrim (tdname) || ">" || rtrim (tename));

	if created_value_seg
	then do;
		call value_$init_seg (value_seg_ptr, PERMANENT_VALUE_SEG_TYPE, null, 0, code);
		if code ^= 0 then call abort (code, rtrim (tdname) || ">" || rtrim (tename));
	     end;

	definition_value_name = DEFINITION_PREFIX || "." || command_name;
	default_linear_form_value_name = DEFAULT_LINEAR_FORM_PREFIX || "." || command_name;

	if ^replace
	then do;

		call value_$get_data (value_seg_ptr, PERMANENT_VALUE, (definition_value_name), area_ptr, (null ()), (0), code);


		if code = 0 then definition_exists = "1"b;
		else if code = error_table_$oldnamerr then definition_exists = "0"b;
		else call abort (code, "Searching for " || command_name || " definition in value segment.");

		if definition_exists
		then do;
			call command_query_ (addr (auto_query_info), answer, ME,
			     "A definition for ^a exists^/   in the value segment ^a>^a.^/Do you want to replace it?",
			     command_name, tdname, tename);
			if answer = "no" | answer = "n"
			then call abort (0, "Definition not replaced.");
			else do;
				replace = "1"b;
				call com_err_ (0, ME, "Definition will be replaced.");
			     end;
		     end;
	     end;

	if replace
	then do;
		call value_$delete_data (value_seg_ptr, PERMANENT_VALUE, (definition_value_name), code);
		if code = error_table_$empty_file | code = error_table_$oldnamerr
		then call com_err_ ((0), ME, "No old definition of ^a in value segment.  Adding definition.", command_name);
		else if code ^= 0
		then call abort (code, "Cannot replace " || command_name || " definition in value segment.");

		call value_$delete_data (value_seg_ptr, PERMANENT_VALUE, (default_linear_form_value_name), code);
		if code = error_table_$empty_file | code = error_table_$oldnamerr
		then call com_err_ ((0), ME, "No old default linear form of ^a in value segment.  Adding definition.", command_name);
		else if code ^= 0
		then call abort (code, "Cannot replace " || command_name || " definition in value segment.");

	     end;

	call vector_util_$cv_pva_to_string (print_vector_array_ptr, definition_string_ptr, definition_string_length, code);

	if code ^= 0
	then call abort (code, "");

	call value_$set_data (value_seg_ptr, PERMANENT_VALUE, (definition_value_name), definition_string_ptr, divide (definition_string_length, BYTES_PER_WORD, 18, 0), (null ()), (null ()), (0), code);
	if code ^= 0
	then call abort (code, "");

          dlf_var_length = default_linear_form_length;
          allocate dlf_var in(based_area) set(dlf_var_ptr);
          dlf_var = default_linear_form_string;

	call value_$set_data (value_seg_ptr, PERMANENT_VALUE, (default_linear_form_value_name), dlf_var_ptr, divide(dlf_var_length + 3, BYTES_PER_WORD, 17, 0) + 1, (null ()), (null ()), (0), code);
	if code ^= 0
	then call abort (code, "");

RETURN:

	call cleanup_trans ();
	return;

ERROR_RETURN:

	return;

%page;

/* Translation and Utility Routines */

/*
   This subroutine adds the specified string (usually the current token)
   to a print vector in the print vector array we are building.
   The string becomes the value of the dimension specified by dim_num.
   If necessary, this subroutine adds a new print vector
   (in special cases) to accommodate the new dimension value (token).
*/

add_to_vector: proc (str, dim_num);

/* Automatic */

	dcl     vector_num		 fixed bin;

/* Parameter */

	dcl     dim_num		 fixed bin;
	dcl     str		 char (*);

	if MERROR_SEVERITY >= FATAL_ERROR		/* Quit if hopeless. */
	then return;

	if value_defined (dim_num) & ^CAN_HAVE_MULTIPLE_DEFINITIONS (dim_num)
	then do;
		call ERROR (7);
		return;
	     end;

	if (dim_num = EXCLUDED_OPTION | dim_num = UNEXCLUDED_OPTION) & str = option
	then default_exclude_myself = "0"b;		/* Don't need default exclusion anymore. */

	if dim_num = SYNONYM			/* Special, we need a SYNONYM print vector. */
	then do;
		call set_name (str, synonym_len, synonym_ptr);
		call append_vector (OPTION_NAME_VECTOR, vector_num, code);
		if code ^= 0
		then do;
			call ERROR (6);
			return;
		     end;
	     end;
	else if dim_num = NEGATIVE_FORM		/* Special, we need a NEGATIVE_FORM print vector. */
						/* Really a SYNONYM vector plus NEGATIVE_FORM dim. */
	then do;
		call set_name (str, synonym_len, synonym_ptr);
		call append_vector (NEGATIVE_FORM_VECTOR, vector_num, code);
		if code ^= 0
		then do;
			call ERROR (6);
			return;
		     end;
	     end;
	else do;					/* Nonspecial, try adding to current print vector. */
		vector_num = main_pv_num;
		if value_defined (dim_num) & CAN_HAVE_MULTIPLE_DEFINITIONS (dim_num)
		then do;
			call append_vector (main_pv_type, vector_num, code);
			if code ^= 0
			then do;
				call ERROR (6);
				return;
			     end;
		     end;
		if CAN_HAVE_VALUE (dim_num)
		then call add_dim (dim_num, str, vector_num, code);
		else call add_dim (dim_num, "", vector_num, code);
		if code ^= 0
		then do;
			call ERROR (8);
			return;
		     end;
	     end;

	value_defined (dim_num) = "1"b;

     end add_to_vector;

%page;

/*
   Sets up a print vector with all the mandatory information for
   the specified vector type.  Sets the current print vector to this one.
*/

start_vector: proc (vector_type);

/* Parameter */

	dcl     vector_type		 fixed bin;

/* Automatic */

	dcl     vector_num		 fixed bin;

	if MERROR_SEVERITY >= FATAL_ERROR
	then return;

	value_defined (*) = "0"b;

	call append_vector (vector_type, vector_num, code);
	if code ^= 0
	then do;
		call ERROR (6);
		return;
	     end;

	main_pv_num = vector_num;
	main_pv_type = vector_type;

     end start_vector;

%page;

/*
   This routine can be called to initialize different types of print vectors
   given the type wanted.  The input information is vector type.
   The output information is the vector_num of the new vector.
   Before calling this procedure, the caller must
   make sure that all necessary information for that particular
   print vector has been set.  For example, the OPTION print vector
   needs to have then command_name and option variables set.
*/

append_vector: proc (vector_type, vector_num, code);

/* Parameter */

	dcl     code		 fixed bin (35);
	dcl     vector_num		 fixed bin;
	dcl     vector_type		 fixed bin;

	code = 0;
	n_definition_order = n_definition_order + 1;
	call set_definition_order (n_definition_order, definition_order);

	if vector_type = OPTION_VECTOR
	then do;
		call vector_util_$append_general_print_vector
		     (area_ptr, N_INCREMENTAL_PV_SLOTS,
		     FREE_OLD_PV_ARRAY, NEW_VECTOR,
		     DIMENSIONS (DEFINITION_ORDER), definition_order,
		     DIMENSIONS (COMMAND_NAME), command_name,
		     DIMENSIONS (OPTION), option,
		     print_vector_array_ptr, code);
		if code ^= 0
		then return;
	     end;
	else if vector_type = ARGUMENT_VECTOR
	then do;
		call vector_util_$append_general_print_vector
		     (area_ptr, N_INCREMENTAL_PV_SLOTS,
		     FREE_OLD_PV_ARRAY, NEW_VECTOR,
		     DIMENSIONS (DEFINITION_ORDER), definition_order,
		     DIMENSIONS (COMMAND_NAME), command_name,
		     DIMENSIONS (OPTION), option,
		     DIMENSIONS (ARGUMENT), argument,
		     print_vector_array_ptr, code);
		if code ^= 0
		then return;
	     end;
	else if vector_type = INITIAL_VECTOR | vector_type = BASIC_VECTOR
	then do;
		call vector_util_$append_general_print_vector
		     (area_ptr, N_INCREMENTAL_PV_SLOTS,
		     FREE_OLD_PV_ARRAY, NEW_VECTOR,
		     DIMENSIONS (DEFINITION_ORDER), definition_order,
		     DIMENSIONS (COMMAND_NAME), command_name,
		     print_vector_array_ptr, code);
		if code ^= 0
		then return;
	     end;
	else if vector_type = OPTION_NAME_VECTOR
	then do;
		call vector_util_$append_general_print_vector
		     (area_ptr, N_INCREMENTAL_PV_SLOTS,
		     FREE_OLD_PV_ARRAY, NEW_VECTOR,
		     DIMENSIONS (DEFINITION_ORDER), definition_order,
		     DIMENSIONS (COMMAND_NAME), command_name,
		     DIMENSIONS (OPTION), option,
		     DIMENSIONS (SYNONYM), synonym,
		     print_vector_array_ptr, code);
		if code ^= 0
		then return;
	     end;
	else if vector_type = NEGATIVE_FORM_VECTOR
	then do;
		call vector_util_$append_general_print_vector
		     (area_ptr, N_INCREMENTAL_PV_SLOTS,
		     FREE_OLD_PV_ARRAY, NEW_VECTOR,
		     DIMENSIONS (DEFINITION_ORDER), definition_order,
		     DIMENSIONS (COMMAND_NAME), command_name,
		     DIMENSIONS (OPTION), option,
		     DIMENSIONS (SYNONYM), synonym,
		     DIMENSIONS (NEGATIVE_FORM), "",
		     print_vector_array_ptr, code);
		if code ^= 0
		then return;
	     end;
	else do;
		code = error_table_$bad_arg;
		return;
	     end;

	vector_num = print_vector_array.number_of_vectors;

     end append_vector;

%page;

/*
   This routine adds a dimension value to a specified print vector.
   If the print vector is specified by a -1, a new print vector
   is created to hold the dimension value.  The number of the
   new print vector is returned in that case.
*/

add_dim: proc (dim_num, dim_value, vector_num, code);

/* Parameter */

	dcl     code		 fixed bin (35);
	dcl     dim_num		 fixed bin;
	dcl     dim_value		 char (*);
	dcl     vector_num		 fixed bin;

	call vector_util_$append_general_print_vector
	     (area_ptr, N_INCREMENTAL_PV_SLOTS,
	     FREE_OLD_PV_ARRAY, vector_num,
	     DIMENSIONS (dim_num), dim_value,
	     print_vector_array_ptr, code);

     end add_dim;

%page;

/*
   This routine sets the character representation of the definition order.
*/

(size):
set_definition_order: proc (arg_n_definition_order, arg_definition_order);

/* Parameter */

	dcl     arg_n_definition_order fixed bin;
	dcl     arg_definition_order	 pic "999";

	on size begin;
		call com_err_ (0, ME, "The size of your definition is too large."
		     );
		call abort (0, "It has caused the definition_order dimension to overflow.");
	     end;

	arg_definition_order = arg_n_definition_order;

     end set_definition_order;

%page;

/*
   This routine is used to set information we must keep around
   (i.e., the command_name, option, argument variables).
   It sets the specified based variable to be the specified string
   (usually the current token).
*/

set_name: proc (arg_str, arg_name_len, arg_name_ptr);

/* Based */

	dcl     name		 char (arg_name_len) based (arg_name_ptr);

/* Parameter */

	dcl     arg_name_len	 fixed bin (21);
	dcl     arg_name_ptr	 ptr;
	dcl     arg_str		 char (*);

	if arg_name_ptr ^= null
	then free arg_name_ptr -> name;

	arg_name_len = length (arg_str);
	allocate name in (based_area) set (arg_name_ptr);

	name = arg_str;

     end set_name;

%page;

/* This routine "resets" a specified based character string variable by
     freeing it and setting the length to 0 and setting the ptr to null.
  */

reset_name: proc (arg_name_len, arg_name_ptr);

/* Based */

	dcl     name		 char (arg_name_len) based (arg_name_ptr);

/* Parameter */

	dcl     arg_name_len	 fixed bin (21);
	dcl     arg_name_ptr	 ptr;

	if arg_name_ptr ^= null
	then free arg_name_ptr -> name;

	arg_name_len = 0;
	arg_name_ptr = null;

     end reset_name;

%page;

/*
   This routine initializes some global variables used by
   the translator.  Some of these variables must be set immediately
   on invocation not only for the translator can clean up properly,
   but to start proper "running" values.
*/

initialize_translator_values: proc ();

	n_definition_order = 0;

	command_name_ptr, option_ptr, argument_ptr = null;
	command_name_len, option_len, argument_len = 0;

	synonym_ptr = null;
	synonym_len = 0;

	expanded_token_ptr = null;
	expanded_token_len = 0;

	seg_ptr = null;
	temp_seg_ptr, area_ptr = null;

	unspec (auto_query_info) = "0"b;
	auto_query_info.version = query_info_version_5;
	auto_query_info.yes_or_no_sw = "1"b;
	auto_query_info.question_iocbp = null;
	auto_query_info.answer_iocbp = null;
	auto_query_info.explanation_ptr = null;

     end initialize_translator_values;

%page;

/* Gets arg(arg_num) from the command's argument list.
     increments arg_num by 1.  If an error happens getting the arg,
     we call abort directly, we don't return from here.
  */

get_arg: proc (arg_num, arg_ptr, arg_len);

/* Parameter */

	dcl     arg_len		 fixed bin (21);
	dcl     arg_num		 fixed bin;
	dcl     arg_ptr		 ptr;

/* Automatic */

	dcl     code		 fixed bin (35);

	call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code);
	if code ^= 0
	then call abort (code, "");

	arg_num = arg_num + 1;

     end get_arg;

%page;

/*
   This routine cleans up the user environment after an
   invocation of the translator.
*/

cleanup_trans: proc ();

	if seg_ptr ^= null
	then call term_$seg_ptr (seg_ptr, code);

	if temp_seg_ptr ^= null
	then call translator_temp_$release_all_segments (temp_seg_ptr, code);

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

     end cleanup_trans;

%page;

/* This routine prints an error message, cleans up the environment and then
   aborts the invocation of mtape_cv_apd. */


abort: proc (code, msg);

/* Parameter */

	dcl     code		 fixed bin (35);
	dcl     msg		 char (*);

	call com_err_ (code, ME, msg);
	call cleanup_trans ();
	goto ERROR_RETURN;

     end abort;

%page;

/* This routine takes a based character string variable,
     and appends the given string to it (reallocating the based variable
     for more storage if necessary).
  */

append_to_str: proc (str_to_append, str_len, str_ptr);

/* Automatic */

	dcl     temp_str_len	 fixed bin (21);
	dcl     temp_str_ptr	 ptr;

/* Based */

	dcl     str		 char (str_len) based (str_ptr);
	dcl     temp_str		 char (temp_str_len) based (temp_str_ptr);

/* Parameter */

	dcl     str_len		 fixed bin (21);
	dcl     str_ptr		 ptr;
	dcl     str_to_append	 char (*);

	if str_ptr = null
	then do;
		str_len = length (str_to_append);
		allocate str in (based_area) set (str_ptr);
		str = str_to_append;
		return;
	     end;

	temp_str_len = length (str_to_append) + str_len;
	allocate temp_str in (based_area) set (temp_str_ptr);
	temp_str = str || str_to_append;
	free str_ptr -> str;
	str_ptr = temp_str_ptr;
	str_len = temp_str_len;

     end append_to_str;




		    mtape_delete_defaults.pl1       04/10/85  0831.6r w 04/08/85  1129.0       76806



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */
mtape_delete_defaults: proc ();

     /* DESCRIPTION:

        This command deletes default arguments that have been set
        by the mtape_set_defaults command.  It deletes the
        defaults associated with a particular tape processing operation
        and volume type.  The default arguments are deleted
        from the value segment that the user specifies.

     */

     /* HISTORY:

        Written 09/13/83 by S. Krupp.
     */

     /* START OF DECLARATIONS */

     /* Automatic */

          dcl arg_list_ptr ptr;
          dcl code fixed bin(35);
	dcl db_entryname char(32);
	dcl db_dirname char(168);
	dcl db_full_pathname char(168) var;
	dcl db_rel_pathname char(168) var;
	dcl found_option bit(3);
	dcl idx fixed bin;
          dcl nargs fixed bin;
	dcl operation char(32) var;
	dcl program_name char(64) var;
	dcl result_ptr ptr;
          dcl value_seg_ptr ptr;
	dcl volume_type char(32) var;

	dcl 1 auto_area_info like area_info;

     /* Based */

          dcl found_option_array(3) bit(1) unaligned based(addr(found_option));

     /* Builtin */

          dcl (addr, hbound, null, unspec) builtin;

     /* Condition */

          dcl cleanup condition;

     /* Entries */

          dcl com_err_ entry() options(variable);
          dcl cu_$arg_count entry(fixed bin, fixed bin(35));
          dcl cu_$arg_list_ptr entry (ptr);
          dcl define_area_ entry (ptr, fixed bin(35));
	dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
	dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl ioa_$rsnnl entry() options(variable);
	dcl pathname_ entry (char(*), char(*)) returns(char(168));
	dcl process_arguments_$argument_list entry(char(*), fixed bin, ptr, fixed bin, ptr, ptr, ptr, fixed bin(35));
	dcl process_arguments_$get_option_value entry() options(variable);
	dcl release_area_ entry (ptr);
	dcl term_$seg_ptr entry (ptr, fixed bin(35));
          dcl value_$delete_data entry(ptr, bit(36) aligned, char(*), fixed bin(35));

     /* Static */

          dcl (ARG_PROCESSING_MODE init(0),
	     FIRST_ARG_TO_PROCESS init(1)
	    ) fixed bin internal static options(constant);

          dcl (MYNAME init("mtape_delete_defaults"),
	     PROGRAM_NAME_PREFIX init("mtape_")
	    ) char(32) var internal static options(constant);

	dcl (OPERATION_OPTION_IDX init(1),
	     VOLUME_TYPE_OPTION_IDX init(2),
	     PATHNAME_OPTION_IDX init(3)
	    ) fixed bin internal static options(constant);

          dcl PERMANENT_VALUE bit(2) aligned init("01"b) internal static options(constant);
	dcl VALUE_SUFFIX char(5) init("value") internal static options(constant);

          dcl (OPERATION_OPTION_NAME init("operation"),
	     VOLUME_TYPE_OPTION_NAME init("volume_type"),
	     PATHNAME_OPTION_NAME init("pathname")
	    ) char(32) var internal static options(constant);

          dcl LONG_OPTION_REFNAME(3) char(32) var int static options(constant)
	    init("operation", "-volume_type", "-pathname");

          dcl (ATTACH_IDX init(1),
	     OPEN_IDX init(2),
	     CLOSE_IDX init(3),
	     DETACH_IDX init(4)
	    ) fixed bin internal static options(constant);

          dcl OPERATIONS(4) char(6) internal static options(constant)
	   init("attach", "open", "close", "detach");

          dcl VOLUME_TYPES(2) char(32) var internal static options(constant)
             init("ansi", "ibm");

          dcl (error_table_$bad_arg,
	     error_table_$noarg,
	     error_table_$oldnamerr
	    )fixed bin(35) ext static;

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

     /* Include */

%page;
%include access_mode_values;
%page;
%include area_info;
%page;
%include pa_value_names;

     /* END OF DECLARATIONS */
%page;

     /* Main Procedure */

     /* Initialize */

          value_seg_ptr = null;

	unspec (auto_area_info) = "0"b;
	auto_area_info.version = area_info_version_1;
	auto_area_info.areap = null;
	auto_area_info.owner = MYNAME;
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.zero_on_alloc = "1"b;
	auto_area_info.extend = "1"b;

          call cu_$arg_count(nargs, code);
          if code ^= 0
          then call ABORT(code, "Could not get the argument count.", "");

          if nargs = 0
          then call ABORT(0, "Usage ""mtape_delete_defaults OPERATION {-control_args}""", "");

	on cleanup call CLEANUP();

	call define_area_(addr(auto_area_info), code);
	if code ^= 0
	then call ABORT(code, "Unable to allocate a work area.", "");

  /* Get mtape_delete_default's argument list. */

          call cu_$arg_list_ptr(arg_list_ptr);

  /* Process mtape_delete_defaults's arguments. */

          call process_arguments_$argument_list((MYNAME), ARG_PROCESSING_MODE,
	   arg_list_ptr, FIRST_ARG_TO_PROCESS, null, auto_area_info.areap,
	   result_ptr, code);
          if code ^= 0
	then call ABORT_SILENT();			/* Error msg already printed. */

  /* Get information needed to locate the arguments that are the
     subject of the command line (i.e., the arguments that are
     the defaults for the specified tape processing operation and
     volume type). */

          call process_arguments_$get_option_value(result_ptr,
	   auto_area_info.areap, found_option, OPERATION_OPTION_NAME,
	   operation, VOLUME_TYPE_OPTION_NAME, volume_type,
	   PATHNAME_OPTION_NAME, db_rel_pathname);

          if ^found_option_array(OPERATION_OPTION_IDX)
          then call ABORT(error_table_$noarg, "Missing ""^a"" option.",
	   (LONG_OPTION_REFNAME(OPERATION_OPTION_IDX)));

         do idx = 1 to hbound(OPERATIONS, 1) while(OPERATIONS(idx) ^= operation);
	end;

	if idx > hbound(OPERATIONS, 1)
	then call ABORT(error_table_$bad_arg, "Unknown operation specified:  ""^a"".", (operation));

	if found_option_array(VOLUME_TYPE_OPTION_IDX)
          then do;
               do idx = 1 to hbound(VOLUME_TYPES, 1) while(VOLUME_TYPES(idx) ^= volume_type);
               end;

               if idx > hbound(VOLUME_TYPES, 1)
               then call ABORT(error_table_$bad_arg, "Unknown volume type specified:  ""^a"".", (volume_type));

               if operation = OPERATIONS(ATTACH_IDX) | operation = OPERATIONS(DETACH_IDX)
               then call ABORT(error_table_$bad_arg, "Cannot specify the volume type """ ||
                  volume_type || """ with the ""^a"" operation.", (operation));
          end;

  /* Build the program name from the specified tape processing operation and
     volume type. */
 
          call ioa_$rsnnl("^a.^a^[.^a^;^]", program_name, (0), PROGRAM_NAME_PREFIX,
	   operation, found_option_array(VOLUME_TYPE_OPTION_IDX), volume_type);

  /* Now we locate the value segment and delete the default arguments
     if they are in there. */

          call expand_pathname_$add_suffix((db_rel_pathname), VALUE_SUFFIX, db_dirname, db_entryname, code);
	if code ^= 0
	then call ABORT(code, "^a", (db_rel_pathname));

	db_full_pathname = pathname_(db_dirname, db_entryname);

	call initiate_file_(db_dirname, db_entryname, RW_ACCESS, value_seg_ptr, (0), code);
	if code ^= 0
	then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname));

          call value_$delete_data(value_seg_ptr, (PERMANENT_VALUE), DEFAULT_LINEAR_FORM_PREFIX ||
             "." || program_name, code);
          if code = error_table_$oldnamerr
	then call ABORT((0), "There are no corresponding default arguments^/in ^a.", (db_full_pathname));
           else if code ^= 0
	then call ABORT(code, "Unable to delete the default arguments from ^a.", (db_full_pathname));

          call CLEANUP();

RETURN:

          return;
%page;
CLEANUP: proc();

          if auto_area_info.areap ^= null
	then call release_area_(auto_area_info.areap);

	if value_seg_ptr ^= null
	then call term_$seg_ptr(value_seg_ptr, code);

     end CLEANUP;


ABORT: proc (code, msg, msg_arg);

     /* Parameter */

	dcl code fixed bin (35);
	dcl msg char (*);
	dcl msg_arg char (*);

	call com_err_ (code, MYNAME, msg, msg_arg);
	call CLEANUP();

	goto RETURN;

     end ABORT;


ABORT_SILENT: proc();

          call CLEANUP();

	goto RETURN;

     end ABORT_SILENT;

     end mtape_delete_defaults;




		    mtape_get_defaults.pl1          04/10/85  0831.6r w 04/08/85  1129.0       96129



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */
mtape_get_defaults: proc ();

     /* DESCRIPTION:

        This command prints out default arguments that have been set
        by the mtape_set_defaults command.  It prints out the
        defaults associated with a particular tape processing operation
        and volume type.  It can print out either the default linear
        form or the defaults from a specified value segment.

        The default linear form is the final set of defaults that
        apply after all of the applicable defaults have been
        gathered from the search list and processed.  We don't
        have to worry about constructing the default linear form
        because there is an entry in the mtape_ argument processing
        routine that does this.

     */

     /* HISTORY:

        Written 09/13/83 by S. Krupp.
     */

     /* START OF DECLARATIONS */

     /* Automatic */

          dcl arg_list_ptr ptr;
	dcl based_varying_char_ptr ptr;
          dcl code fixed bin(35);
	dcl db_entryname char(32);
	dcl db_dirname char(168);
	dcl db_full_pathname char(168) var;
	dcl db_rel_pathname char(168) var;
	dcl default_linear_form char(4096) var;
	dcl definition_ptr ptr;
	dcl found_option bit(4);
	dcl idx fixed bin;
	dcl n_data_words fixed bin(18);
          dcl nargs fixed bin;
	dcl operation char(32) var;
	dcl program_name char(64) var;
	dcl result_ptr ptr;
	dcl use_search_list bit(1) aligned;
          dcl value_seg_ptr ptr;
	dcl volume_type char(32) var;

	dcl 1 auto_area_info like area_info;

     /* Based */

          dcl based_varying_char char(sys_info$max_seg_size) var based(based_varying_char_ptr);
          dcl found_option_array(4) bit(1) unaligned based(addr(found_option));

     /* Builtin */

          dcl (addr, hbound, null, unspec) builtin;

     /* Condition */

          dcl cleanup condition;

     /* Entries */

          dcl com_err_ entry() options(variable);
          dcl cu_$arg_count entry (fixed bin, fixed bin(35));
          dcl cu_$arg_list_ptr entry (ptr);
          dcl define_area_ entry (ptr, fixed bin(35));
	dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
	dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
          dcl ioa_ entry() options(variable);
	dcl ioa_$rsnnl entry() options(variable);
	dcl pathname_ entry (char(*), char(*)) returns(char(168));
	dcl process_arguments_$argument_list entry(char(*), fixed bin, ptr, fixed bin, ptr, ptr, ptr, fixed bin(35));
	dcl process_arguments_$cv_result_to_linear_form entry(ptr, ptr, char(*) varying, fixed bin(35));
	dcl process_arguments_$get_option_value entry() options(variable);
	dcl release_area_ entry (ptr);
	dcl term_$seg_ptr entry (ptr, fixed bin(35));
	dcl value_$get_data entry (ptr, bit(36) aligned, char(*), ptr, ptr, fixed bin(18), fixed bin(35));

     /* Static */

          dcl (ARG_PROCESSING_MODE init(0),
	     FIRST_ARG_TO_PROCESS init(1)
	    ) fixed bin internal static options(constant);

          dcl (MYNAME init("mtape_get_defaults"),
	     PROGRAM_NAME_PREFIX init("mtape_")
	    ) char(32) var internal static options(constant);

	dcl (OPERATION_OPTION_IDX init(1),
	     VOLUME_TYPE_OPTION_IDX init(2),
	     PATHNAME_OPTION_IDX init(3),
	     USE_SEARCH_LIST_OPTION_IDX init(4)
	    ) fixed bin internal static options(constant);

          dcl PERMANENT_VALUE bit(2) aligned init("01"b) internal static options(constant);
	dcl VALUE_SUFFIX char(5) init("value") internal static options(constant);

          dcl (OPERATION_OPTION_NAME init("operation"),
	     VOLUME_TYPE_OPTION_NAME init("volume_type"),
	     PATHNAME_OPTION_NAME init("pathname"),
	     USE_SEARCH_LIST_OPTION_NAME init("user_search_list")
	    ) char(32) var internal static options(constant);

          dcl LONG_OPTION_REFNAME(4) char(32) var int static options(constant)
	    init("operation", "-volume_type", "-pathname", "-use_search_list");

          dcl (ATTACH_IDX init(1),
	     OPEN_IDX init(2),
	     CLOSE_IDX init(3),
	     DETACH_IDX init(4)
	    ) fixed bin internal static options(constant);

          dcl OPERATIONS(4) char(6) internal static options(constant)
	   init("attach", "open", "close", "detach");

          dcl VOLUME_TYPES(2) char(32) var internal static options(constant)
             init("ansi", "ibm");

          dcl (error_table_$bad_arg,
	     error_table_$noarg,
	     error_table_$oldnamerr
	    )fixed bin(35) ext static;

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

     /* Include */

%page;
%include access_mode_values;
%page;
%include area_info;
%page;
%include pa_value_names;

     /* END OF DECLARATIONS */
%page;

     /* Main Procedure */

     /* Initialize */

          value_seg_ptr = null;

	unspec (auto_area_info) = "0"b;
	auto_area_info.version = area_info_version_1;
	auto_area_info.areap = null;
	auto_area_info.owner = MYNAME;
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.zero_on_alloc = "1"b;
	auto_area_info.extend = "1"b;

          call cu_$arg_count(nargs, code);
          if code ^= 0
          then call ABORT(code, "Could not get the argument count.", "");

          if nargs = 0
          then call ABORT(0, "Usage ""mtape_get_defaults OPERATION {-control_args}""", "");

	on cleanup call CLEANUP();

	call define_area_(addr(auto_area_info), code);
	if code ^= 0
	then call ABORT(code, "Unable to allocate a work area.", "");

  /* Get mtape_get_default's argument list. */

          call cu_$arg_list_ptr(arg_list_ptr);

  /* Process mtape_get_defaults's arguments. */

          call process_arguments_$argument_list((MYNAME), ARG_PROCESSING_MODE,
	   arg_list_ptr, FIRST_ARG_TO_PROCESS, null, auto_area_info.areap,
	   result_ptr, code);
          if code ^= 0
	then call ABORT_SILENT();			/* Error msg already printed. */

  /* Get information needed to locate the arguments that are the
     subject of the command line (i.e., the arguments that are
     the defaults for the specified tape processing operation and
     volume type). */

          call process_arguments_$get_option_value(result_ptr,
	   auto_area_info.areap, found_option, OPERATION_OPTION_NAME,
	   operation, VOLUME_TYPE_OPTION_NAME, volume_type,
	   PATHNAME_OPTION_NAME, db_rel_pathname, USE_SEARCH_LIST_OPTION_NAME,
	   use_search_list);

          if ^found_option_array(OPERATION_OPTION_IDX)
          then call ABORT(error_table_$noarg, "Missing ""^a"" option.",
	   (LONG_OPTION_REFNAME(OPERATION_OPTION_IDX)));

         do idx = 1 to hbound(OPERATIONS, 1) while(OPERATIONS(idx) ^= operation);
	end;

	if idx > hbound(OPERATIONS, 1)
	then call ABORT(error_table_$bad_arg, "Unknown operation specified:  ""^a"".", (operation));

	if found_option_array(VOLUME_TYPE_OPTION_IDX)
          then do;
               do idx = 1 to hbound(VOLUME_TYPES, 1) while(VOLUME_TYPES(idx) ^= volume_type);
               end;

               if idx > hbound(VOLUME_TYPES, 1)
               then call ABORT(error_table_$bad_arg, "Unknown volume type specified:  ""^a"".", (volume_type));

               if operation = OPERATIONS(ATTACH_IDX) | operation = OPERATIONS(DETACH_IDX)
               then call ABORT(error_table_$bad_arg, "Cannot specify the volume type """ ||
               volume_type || """ with the ""^a"" operation.", (operation));
          end;

  /* Build the program name from the specified tape processing operation and
     volume type. */
 
          call ioa_$rsnnl("^a.^a^[.^a^;^]", program_name, (0), PROGRAM_NAME_PREFIX,
	   operation, found_option_array(VOLUME_TYPE_OPTION_IDX), volume_type);

  /* Now we either search a value seg for defaults or we call the mtape_
     argument processing routine to construct the default linear form. */

          if found_option_array(PATHNAME_OPTION_IDX)
	then do;
               call expand_pathname_$add_suffix((db_rel_pathname), VALUE_SUFFIX, db_dirname, db_entryname, code);
	     if code ^= 0
	     then call ABORT(code, "^a", (db_rel_pathname));

	     db_full_pathname = pathname_(db_dirname, db_entryname);

	     call initiate_file_(db_dirname, db_entryname, R_ACCESS, value_seg_ptr, (0), code);
	     if code ^= 0
	     then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname));

	     call value_$get_data(value_seg_ptr, (PERMANENT_VALUE), DEFAULT_LINEAR_FORM_PREFIX ||
	        "." || program_name, auto_area_info.areap, based_varying_char_ptr, n_data_words, code);
               if code = error_table_$oldnamerr
	     then call ABORT((0), "There are no corresponding default arguments^/in ^a.", (db_full_pathname));
               else if code ^= 0
	     then call ABORT(code, "Unable to get the default arguments from ^a.", (db_full_pathname));
          end;
          else do;
               definition_ptr = null;

	     call process_arguments_$argument_list((program_name), ARG_PROCESSING_MODE,
	        null, (0), definition_ptr, auto_area_info.areap, result_ptr, code);
	     if code ^= 0
	     then call ABORT_SILENT();		/* Error msg printed already. */

	     call process_arguments_$cv_result_to_linear_form(definition_ptr, result_ptr, default_linear_form, code);
               if code ^= 0
	     then call ABORT(code, "Unable to convert the result of processing to a default linear form.", "");

	     based_varying_char_ptr = addr(default_linear_form);
	end;

          call ioa_("^/Operation:  ^a^[^/Volume type:  ^a^;^]", operation,
	   (found_option_array(VOLUME_TYPE_OPTION_IDX)), volume_type);
 
          if found_option_array(PATHNAME_OPTION_IDX)
	then call ioa_("Pathname:  ^a^/Default arguments:  ^a^/", db_full_pathname, based_varying_char);
	else call ioa_("Default linear form:  ^a^/", based_varying_char);


          call CLEANUP();

RETURN:

          return;
%page;
CLEANUP: proc();

          if auto_area_info.areap ^= null
	then call release_area_(auto_area_info.areap);

	if value_seg_ptr ^= null
	then call term_$seg_ptr(value_seg_ptr, code);

     end CLEANUP;


ABORT: proc (code, msg, msg_arg);

     /* Parameter */

	dcl code fixed bin (35);
	dcl msg char (*);
	dcl msg_arg char (*);

	call com_err_ (code, MYNAME, msg, msg_arg);
	call CLEANUP();

	goto RETURN;

     end ABORT;


ABORT_SILENT: proc();

          call CLEANUP();

	goto RETURN;

     end ABORT_SILENT;

     end mtape_get_defaults;




		    mtape_io_.pl1                   10/10/88  1026.2rew 10/10/88  1025.0      353790



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


/****^  HISTORY COMMENTS:
  1) change(87-08-17,GWMay), approve(87-09-09,MECR0006),
     audit(87-09-04,Farley), install(87-09-09,MR12.1-1101):
     Added cleanup handlers and code check returns.
  2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley),
     install(87-11-30,MR12.2-1006):
     Formally install MECR0006.
  3) change(88-06-28,Farley), approve(88-10-06,MCR7938),
     audit(88-10-06,Fawcett), install(88-10-10,MR12.2-1152):
     Modified buffer allocation to only allocate one I/O buffer when
     reading in large records (> 4096 words).  Having more than one will
     allow tape_ioi_ to attempt chained I/O, which can result in a hardware
     channel error of "Incorrect DCW during list service"..
                                                   END HISTORY COMMENTS */


mtape_io_: procedure;

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system.
   *	This module implements the physical tape interface for the Per-Format
   *	modules.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 10/05/82
   *	Modified by J. A. Bush 12/01/83 for performance improvements
*/

/*		ARGUMENT DATA		*/

dcl  arg_mtdp ptr;					/* Pointer to the mtape data structure */
dcl  arg_code fixed bin (35);				/* Return error code */
dcl  arg_lr_ptr ptr;				/* Pointer to current label record structure */
dcl  arg_buf_size fixed bin (21);			/* Requested length of users buffer */
dcl  arg_order char (*);				/* Control order mnemonic */
dcl  arg_mode char (*);				/* Mode mnemonic for set_mode entry */
dcl  arg_index fixed bin;				/* Mode index for set_mode entry */
dcl  arg_repeat_cnt fixed bin;			/* Control order repeat count */
dcl  arg_infop ptr;					/* Control order info pointer */
dcl  arg_mode_ptr ptr;				/* Mode info ptr for set_mode entry */

/*		AUTOMATIC DATA		*/

dcl  (infop, mode_ptr) ptr;
dcl  (label_len, act_length) fixed bin (21);
dcl  (code, scode, unr_code) fixed bin (35);
dcl  (oidx, rx, req_buffers, repeat_cnt, descrep_cnt, act_cnt, i, n_rdy_bufs, n_qed_bufs, alloc_tries) fixed bin;
dcl  spec_status bit (36) aligned;
dcl  order char (4);
dcl  1 auto_ths like ths aligned;

/*		CONSTANT DATA		*/

dcl  LC char (26) int static options (constant) init
	("abcdefghijklmnopqrstuvwxyz");
dcl  UC char (26) int static options (constant) init
	("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl  HDW_MODE_STR (6) char (4) int static options (constant) init
	("bin", "tap9", "bcd", "asc", "ebc", "a/e");
dcl  WRITE_IO fixed bin int static options (constant) init (2);
dcl  BYTES_PER_DCW fixed bin int static options (constant) init (4 * 4096);
dcl  BYTES_PER_WORD fixed bin int static options (constant) init (4);
dcl  LENGTH_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b);
dcl  ALIGN_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b);
dcl  RECOVERY_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b);
dcl  WAIT_MODES (0:1) bit (1) aligned int static options (constant) init ("0"b, "1"b);
dcl  (WAIT init ("1"b),				/* wait for order to complete */
     NO_WAIT init ("0"b),				/* do not wait for order to complete */
     FORWARD init ("1"b),				/* space files/blocks forward */
     BACKWARD init ("0"b)				/* space files/blocks backward */
     ) bit (1) aligned int static options (constant);

dcl  order_mnemonics (0:22) char (4) static options (constant)
	init ("bsf", "bsr", "fsf", "fsr", "eof", "ers", "dse", "rew", "run", "lod", "rqs",
	"rss", "rqd", "rsd", "den", "per", "pro", "rsv", "rel", "rcr", "wcr", "rwnw", "runw");

dcl  mode_mnemonics (0:6) char (8) static options (constant) init
	("data", "length", "align", "recovery", "wait", "event", "cif");

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$end_of_info fixed bin (35) ext static;
dcl  error_table_$eov_on_write fixed bin (35) ext static;
dcl  error_table_$buffer_big fixed bin (35) ext static;
dcl  error_table_$device_not_active fixed bin (35) ext static;
dcl  error_table_$nine_mode_parity fixed bin (35) ext static;
dcl  error_table_$positioned_on_bot fixed bin (35) ext static;
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  mtape_dev_attention_recovery condition;
dcl  cleanup condition;

/*		BUILTIN FUNCTIONS		*/

dcl  (addr, copy, divide, hbound, lbound, mod, null, translate) builtin;

/*		EXTERNAL ENTRIES		*/

dcl  ascii_to_ebcdic_ entry (char (*), char (*));
dcl  ebcdic_to_ascii_ entry (char (*), char (*));
dcl  ascii_to_bcd_ entry (char (*), bit (*));
dcl  bcd_to_ascii_ entry (bit (*), char (*));
dcl  mtape_util_$error entry options (variable);
dcl  mtape_mount_cntl_$mount entry (ptr, fixed bin (35));
dcl  mtape_check_status_ entry (ptr, fixed bin (35));

/*		BASED VARIABLES		*/

dcl  based_label char (label_len) based (mtape_label_record.lab_ptr);
dcl  based_bits bit (label_len * 6) based;
dcl  based_area area based (mtape_data.areap);
dcl  blk_pad char (mtape_data.remain) based (addr (tape_blk (mtape_data.processed + 1))) unaligned;
%page;
/* read_block - entry to read the next block from the tape */

read_block: entry (arg_mtdp, arg_code);

	call SETUP;				/* setup our enviornment */
	call UNLOAD_LREC_CNT;			/* Update block/lrec history */
	on mtape_dev_attention_recovery begin;		/* set up condition handler */
	     call tape_ioi_$read (mtape_data.tioi_id, mtape_data.cur_buf_ptr, mtape_data.length, rx, code);
	     call CHECK_RX;				/* go check result index */
	     if code = 0 then do;			/* if no error.. */
		call mtape_util_$error (mtdp, 0, "^[Device Attention^;Power Off^] recovery successful.",
		     mtape_vol_set.dev_att_retry);
		mtape_vol_set.pwr_off_retry, mtape_vol_set.dev_att_retry = "0"b; /* reset flags */
	     end;
	     go to continue_read;			/* take non-local goto to get out of condition */
	end;
	call tape_ioi_$read (mtape_data.tioi_id, mtape_data.cur_buf_ptr, mtape_data.length, rx, code);
	call CHECK_RX;				/* go check result index */
continue_read:					/* target of non-local goto */
	if code = 0 then do;			/* if no error.. */
	     if mtape_data.length > mtape_data.block_size then /* eliminate obvious padding */
		mtape_data.length = mtape_data.block_size;
	     mtape_data.position.phy_block = mtape_data.position.phy_block + 1; /* increment block number */
	     mtape_data.processed = mtape_data.buffer_offset; /* prime buffer variables */
	     mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1));
	     mtape_data.remain = mtape_data.length - mtape_data.processed;
	end;

	arg_code = code;				/* return error code */
	return;
%page;
/* write_block - entry to write the current block to tape */

write_block: entry (arg_mtdp, arg_code);

	call SETUP;				/* setup our environment */
	mtape_data.position.phy_block = mtape_data.position.phy_block + 1; /* increment block number */
	call UNLOAD_LREC_CNT;			/* save block/log record history */
	if mtape_data.hdw_mode = MTAPE_HWM_BIN then do;	/* if writing in binary, must pad mod 4 */
	     mtape_data.remain = mod (mtape_data.processed, BYTES_PER_WORD);
	     if mtape_data.remain ^= 0 then do;		/* Have to pad block? */
		mtape_data.remain = BYTES_PER_WORD - mtape_data.remain; /* get bytes to add */
		blk_pad = copy (mtape_data.padding_char, mtape_data.remain); /* yes, do it */
		mtape_data.processed = mtape_data.processed + mtape_data.remain;
	     end;
	end;
	if ^mtape_data.run then do;			/* if no I/O currently queued */
	     mtape_data.buf_len (mtape_data.cur_buf_idx) = mtape_data.processed; /* copy length to be written */
	     mtape_data.cur_buf_idx = mtape_data.cur_buf_idx + 1; /* increment buffer index */
	     if mtape_data.cur_buf_idx > mtape_data.bufs_per_subset then do; /* its time to write the subset */
		do i = lbound (mtape_data.buf_ptrs, 1) to mtape_data.bufs_per_subset; /* queue half of the buffers */

		     call tape_ioi_$queue_write (mtape_data.tioi_id, mtape_data.buf_ptrs (i),
			mtape_data.buf_len (i), code);
		     if code ^= 0 then do;		/* error from queue_write */
			call mtape_util_$error (mtdp, code, /* report it */
			     "Error from tape_ioi_$queue_write (^run) queuing buffer ^p, length ^d",
			     mtape_data.buf_ptrs (i), mtape_data.buf_len (i));
			go to write_block_return;	/* return on error */
		     end;
		end;
		call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, n_rdy_bufs, code);
		if code ^= 0 then do;		/* error from list_buffers */
		     call mtape_util_$error (mtdp, code,/* report it */
			"Error from tape_ioi_$list_buffers");
		     go to write_block_return;
		end;
		mtape_data.run = "1"b;		/* We now have I/O going */
		mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1);
	     end;
	     mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (mtape_data.cur_buf_idx); /* set for current buffer */
	end;
	else do;					/* buffers have been queued and are running */
	     call tape_ioi_$queue_write (mtape_data.tioi_id, mtape_data.cur_buf_ptr, mtape_data.processed, code);
	     if code ^= 0 then do;
		call mtape_util_$error (mtdp, code,
		     "Error from tape_ioi_$queue_write (run mode), queueing buffer at ^p, length ^d",
		     mtape_data.cur_buf_ptr, mtape_data.processed);
		go to write_block_return;
	     end;
	     call tape_ioi_$list_buffers (mtape_data.tioi_id, QUEUED_STATE, mtape_data.buf_ptrs, n_qed_bufs, code);
	     if code ^= 0 then do;			/* error from list_buffers */
		call mtape_util_$error (mtdp, code,	/* report it */
		     "Error from tape_ioi_$list_buffers (QUEUED_STATE).");
		go to write_block_return;
	     end;
	     if n_qed_bufs < mtape_data.nbufs then do;	/* all buffers not full? */
		call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, n_rdy_bufs, code);
		if code ^= 0 then do;		/* error from list_buffers */
		     call mtape_util_$error (mtdp, code,/* report it */
			"Error from tape_ioi_$list_buffers (READY_STATE).");
		     go to write_block_return;
		end;
	     end;
	     else do;				/* all buffers full, check oldest */

/* Establish condition handler for recovery of DEV ATTENTION and PWR OFF statuses */

		on mtape_dev_attention_recovery go to feov_target; /* take non-local goto to flush out buffers */

		call tape_ioi_$check_write (mtape_data.tioi_id, mtape_data.buf_ptrs (1), rx, code);
		if rx ^= 0 then do;
		     call CHECK_RX;
		     go to write_block_return;
		end;
	     end;
	     mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (1); /* let user fill this one */
	end;
	mtape_data.processed = mtape_data.buffer_offset;	/* prime buffer variables */
	mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1));
	mtape_data.remain = mtape_data.buf_size - mtape_data.processed;
	if mtape_data.force_end_of_volume then		/* if feov cntl op has been executed.. */
	     go to feov_target;			/* take non-local goto to flush buffers entry */

write_block_return:
	arg_code = code;				/* return error code */
	return;
%page;
/* flush_buffers - entry to queue up and wait for all buffers to be written out */

flush_buffers: entry (arg_mtdp, arg_code);

	call SETUP;				/* set up our environment */
	if ^mtape_vol_set.volume_end then		/* if we havn't reached end of volume yet, */
	     if mtape_data.nbufs > 0 then do;		/* and we have allocated buffers */
		on mtape_dev_attention_recovery go to feov_target;
feov_target:					/* target of non-local goto */
						/* the recovery may fail so return here on nz code */

		if code ^= 0 then
		     go to flush_bufs_return;

		if mtape_data.cur_buf_idx > lbound (mtape_data.buf_ptrs, 1) then /* if we have un-queued buffers */
		     do i = lbound (mtape_data.buf_ptrs, 1) to mtape_data.cur_buf_idx - 1; /* do it now */
		     call tape_ioi_$queue_write (mtape_data.tioi_id, all_buf_ptrs (i), all_buf_lens (i), code);
		     if code ^= 0 then do;		/* error from queue_write */
			call mtape_util_$error (mtdp, code, /* report it */
			     "Error from tape_ioi_$queue_write (flush) queuing buffer ^p, length ^d",
			     all_buf_ptrs (i), all_buf_lens (i));
			go to flush_bufs_return;	/* return on error */
		     end;
		end;
		rx, code = 0;
		do while (code = 0 & rx = 0);		/* do until no more buffers */
		     call tape_ioi_$check_write (mtape_data.tioi_id, null, rx, code);
		end;
		if code = error_table_$device_not_active then /* all I/O is finished */
		     code, rx = 0;
		else call CHECK_RX;			/* otherwise check the error */
		if code = 0 then do;		/* if no error */
		     mtape_data.run = "0"b;		/* I/O no longer in progress */
		     if mtape_data.phy_block = 0 then	/* called to wrt blks after volume switch */
			mtape_data.phy_block = mtape_data.cur_buf_idx - 1; /* set blocks written */
		     call tape_ioi_$list_buffers (mtape_data.tioi_id,
			READY_STATE, mtape_data.buf_ptrs, n_rdy_bufs, code);
		     if code ^= 0 then do;		/* error from list_buffers */
			call mtape_util_$error (mtdp, code, /* report it */
			     "Error from tape_ioi_$list_buffers (flush)");
			go to flush_bufs_return;
		     end;
		     mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1); /* reset buffer index */
		     mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (1); /* let user fill this one */
		     mtape_data.processed = mtape_data.buffer_offset; /* prime buffer variables */
		     mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1));
		     mtape_data.remain = mtape_data.buf_size - mtape_data.processed;
		     if mtape_vol_set.pwr_off_retry | mtape_vol_set.dev_att_retry then do;
			call mtape_util_$error (mtdp, 0, "^[Device Attention^;Power Off^] recovery successful.",
			     mtape_vol_set.dev_att_retry);
			mtape_vol_set.pwr_off_retry, mtape_vol_set.dev_att_retry = "0"b; /* reset flags */
		     end;
		     if mtape_data.force_end_of_volume then do; /* but feov order executed */
			mtape_data.force_end_of_volume = "0"b; /* reset flag */
			rx = TAPE_IO_EOT;		/* simulate EOT */
			call CHECK_RX;
		     end;
		end;
	     end;
flush_bufs_return:
	arg_code = code;
	return;
%page;
/* allocate_buffers - entry to allocate data buffers to read or write tape blocks from/to */

allocate_buffers: entry (arg_mtdp, arg_buf_size, arg_code);

	call SETUP;				/* set up our environment */
	req_buffers = hbound (mtape_data.buf_ptrs, 1) * 2;/* request 2 subsets of max size */
	if arg_buf_size > BYTES_PER_DCW then		/* if large records */
	     if mtape_data.last_io ^= WRITE_IO then	/* and reading tape */
		req_buffers = 1;			/* only ask for one */
	code = error_table_$buffer_big;		/* set code for at least one loop */
	do alloc_tries = 1 to 2 while (code = error_table_$buffer_big);
	     call tape_ioi_$allocate_buffers (mtape_data.tioi_id, arg_buf_size, req_buffers,
		act_length, mtape_data.nbufs, all_buf_ptrs, code);
	     if code = error_table_$buffer_big then	/* if he can't fit req buffs */
		req_buffers = 0;			/* let him decide */
	end;
	if code ^= 0 then				/* problem allocating buffers */
	     go to allocate_buffers_return;		/* let caller handle it */
	if act_length < arg_buf_size then do;		/* can't allow this */
	     code = error_table_$buffer_big;
	     go to allocate_buffers_return;
	end;
	mtape_data.buf_size = act_length;		/* save allocated buffer length */
	mtape_data.bufs_per_subset = divide (mtape_data.nbufs, 2, 17, 0); /* subset is <= 1/2 of buffers */
	if mtape_data.bufs_per_subset = 0 then		/* but we must have at least 1 buffer */
	     mtape_data.bufs_per_subset = 1;
	mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1);
	mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (mtape_data.cur_buf_idx);
	call set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set desired HW mode */
	if code = 0 then
	     call set_mode (mtdp, "length", mtape_data.length_mode, null, code); /* and length mode */
allocate_buffers_return:
	arg_code = code;				/* return error code */
	return;
%page;
/* write_label - entry to copy contents of label record to an ioi_ buffer and initiate a sync write */

write_label: entry (arg_mtdp, arg_lr_ptr, arg_code);

	call SETUP;				/* set up our environment */
	mtape_data.last_io = 0;			/* indicates not data I/O */
	lr_ptr = arg_lr_ptr;

	if mtape_data.lab_bufp = null then do;		/* first label I/O? */
	     call ALLOCATE_LABEL_BUFFER (mtape_label_record.lab_length); /* yes, get one allocated */
	     if code ^= 0 then			/* if fatal error.. */
		go to write_label_return;		/* let caller handle it */
	end;
	label_len = mtape_label_record.lab_length;	/* copy length */
	if mtape_label_record.conversion = MTAPE_CV_UC_ASCII | /* if label to be converted to upper case */
	     mtape_label_record.conversion = MTAPE_CV_UC_EBCDIC then /* convert in place */
	     based_label = translate (based_label, UC, LC);
	on mtape_dev_attention_recovery go to wcopy_label_end;
	go to wcopy_label (mtape_label_record.conversion);/* copy label and convert if neccessary */

wcopy_label (1):					/* No conversion, copy as is */
wcopy_label (4):					/* Convert to upper case ASCII */
	mtape_data.lab_bufp -> based_label = based_label;
	go to wcopy_label_end;
wcopy_label (2):					/* Copy and convert to EBCDIC */
wcopy_label (5):					/* Copy and convert to upper case EBCDIC */
	call ascii_to_ebcdic_ (based_label, mtape_data.lab_bufp -> based_label);
	go to wcopy_label_end;
wcopy_label (3):					/* Copy and convert to BCD */
	call ascii_to_bcd_ (based_label, mtape_data.lab_bufp -> based_bits);
	label_len = divide (label_len * 6, 9, 21, 0);	/* recompute length */
wcopy_label_end:
	on mtape_dev_attention_recovery goto wcopy_label_retry;

wcopy_label_retry:
	call set_mode (mtdp, "data", mtape_label_record.mode, null, code); /* make sure we are writing in right mode */
	if code ^= 0 then				/* if fatal error let user handle it */
	     go to write_label_return;
	call tape_ioi_$queue_write (mtape_data.tioi_id, mtape_data.lab_bufp, label_len, code);
	if code = 0 then do;			/* if everything ok.. */
	     call tape_ioi_$check_write (mtape_data.tioi_id, mtape_data.lab_bufp, rx, code);
	     call CHECK_RX;				/* go check result index */
	     if code = 0 then
		mtape_data.phy_block = mtape_data.phy_block + 1; /* increment block number */
	end;
write_label_return:
	arg_code = code;
	return;					/* return to caller */
%page;
/* read_label - entry to initiate a sync read for a label record and put it into the indicated buffer,
   converted if necessary */

read_label: entry (arg_mtdp, arg_lr_ptr, arg_code);

	call SETUP;				/* set up our environment */
	mtape_data.last_io = 0;			/* indicates not data I/O */
	lr_ptr = arg_lr_ptr;
	if mtape_data.lab_bufp = null then do;		/* first label I/O? */
	     call ALLOCATE_LABEL_BUFFER (mtape_label_record.lab_length); /* yes, get one allocated */
	     if code ^= 0 then			/* if fatal error.. */
		go to read_label_return;		/* let caller handle it */
	end;
	on mtape_dev_attention_recovery go to read_label_retry;
read_label_retry:
	call set_mode (mtdp, "data", mtape_label_record.mode, null, code); /* make sure we are reading in right mode */
	if code ^= 0 then				/* if fatal error.. */
	     go to read_label_return;			/* let caller handle it */
	call tape_ioi_$queue_read (mtape_data.tioi_id, mtape_data.lab_bufp, code);
	if code ^= 0 then				/* if fatal error.. */
	     go to read_label_return;			/* let caller handle it */
	call tape_ioi_$check_read (mtape_data.tioi_id, mtape_data.lab_bufp, label_len, rx, code);
	call CHECK_RX;
	if code ^= 0 then				/* if some error */
	     go to read_label_return;			/* let caller handle it */
	mtape_data.phy_block = mtape_data.phy_block + 1;	/* increment block number */
	go to rcopy_label (mtape_label_record.conversion);/* convert label if necessary */

rcopy_label (1):					/* No conversion */
rcopy_label (4):					/* convert to upper case ASCII (write only) */
	based_label = mtape_data.lab_bufp -> based_label; /* copy directly */
	go to rcopy_label_end;
rcopy_label (2):					/* convert EBCDIC to ASCII */
rcopy_label (5):					/* convert to upper case ASCII (write only) */
	call ebcdic_to_ascii_ (mtape_data.lab_bufp -> based_label, based_label);
	go to rcopy_label_end;
rcopy_label (3):					/* convert BCD to ASCII */
	call bcd_to_ascii_ (mtape_data.lab_bufp -> based_bits, based_label);
	label_len = divide (label_len * 9, 6, 21, 0);	/* adjust label length */
rcopy_label_end:
	mtape_label_record.lab_length = label_len;	/* set length of label */
read_label_return:
	arg_code = code;
	return;
%page;
/* order - entry to issue tape control orders (e.g. positioning commands),
   on behalf of the Per-Format modules */

order: entry (arg_mtdp, arg_order, arg_repeat_cnt, arg_infop, arg_code);

	call SETUP;				/* set up our environment */
	order = arg_order;				/* copy the rest of the arguments */
	repeat_cnt = arg_repeat_cnt;
	infop = arg_infop;
	do oidx = hbound (order_mnemonics, 1) to lbound (order_mnemonics, 1) by -1
	     while (order_mnemonics (oidx) ^= arg_order); /* get the order index */
	end;
	go to PROC_ORDER (oidx);			/* and go process it */

PROC_ORDER (-1):					/* unknown order */
	code = error_table_$bad_arg;			/* set appropriate error code */
	go to order_return;

PROC_ORDER (0):					/* backspace file */
	call SPACE_FILE (BACKWARD);			/* correct for position and do the order */
	go to order_return;

PROC_ORDER (1):					/* backspace record (block) */
	call SPACE_BLOCK (BACKWARD);			/* correct for position and do the order */
	go to order_return;

PROC_ORDER (2):					/* forward space file */
	call SPACE_FILE (FORWARD);			/* correct for position and do the order */
	go to order_return;

PROC_ORDER (3):					/* forward space record (block) */
	call SPACE_BLOCK (FORWARD);			/* correct for position and do the order */
	go to order_return;

PROC_ORDER (4):					/* write end of file mark */
	on mtape_dev_attention_recovery go to RETRY_WEOF; /* establis condition handler */
	do while (repeat_cnt > 0);			/* write requested EOFs */
	     call tape_ioi_$order (mtape_data.tioi_id, order, repeat_cnt, null, act_cnt, rx, code);
	     mtape_data.phy_file = mtape_data.phy_file + act_cnt; /* increment file count */
	     repeat_cnt = repeat_cnt - act_cnt;
	     call CHECK_RX;				/* go check the result index */
	     if code ^= 0 then			/* if error */
		if code ^= error_table_$eov_on_write then /* if not EOT */
		     go to order_return;		/* return the error */
		else code = 0;			/* EOT is not error in this case */
RETRY_WEOF:
	end;
	mtape_data.phy_block = 0;			/* reset block position to 0 */
	go to order_return;

PROC_ORDER (5):					/* erase */
PROC_ORDER (6):					/* data security erase */
	call RESOLVE_POSITION;			/* make sure we are positioned where we think we are */
	if code = 0 then				/* if no error yet */
	     call DO_ORDER (order, repeat_cnt);		/* do the requested order */
	go to order_return;

PROC_ORDER (7):					/* rewind */
PROC_ORDER (8):					/* rewind unload */
	call REWIND_PROC (order, WAIT);		/* do it all from this subroutine */
	go to order_return;

PROC_ORDER (21):					/* "rwnw", rewind no wait */
	call REWIND_PROC ("rew", NO_WAIT);		/* do it all from this subroutine */
	go to order_return;

PROC_ORDER (22):					/* "runw", rewind unload no wait */
	call REWIND_PROC ("run", NO_WAIT);		/* do it all from this subroutine */
	go to order_return;

PROC_ORDER (14):					/* set density */
	call REWIND_PROC ("rew", WAIT);		/* rewind the tape first */
	if code = 0 then				/* if no error on rewind.. */
	     call DO_ORDER (order, repeat_cnt);		/* go do the density order */
	go to order_return;

/* The following control orders require no special action, except that the tape must be stopped first */

PROC_ORDER (9):					/* load tape */
PROC_ORDER (10):					/* request status */
PROC_ORDER (11):					/* reset status */
PROC_ORDER (12):					/* request device status */
PROC_ORDER (13):					/* reset device status */
PROC_ORDER (15):					/* set file protect */
PROC_ORDER (16):					/* set file permit */
PROC_ORDER (17):					/* reserve device */
PROC_ORDER (18):					/* release device */
PROC_ORDER (19):					/* read control registers */
PROC_ORDER (20):					/* write control registers */
	call STOP_TAPE;				/* stop the tape drive */
	if code = 0 then				/* if no errors stopping the tape */
	     call DO_ORDER (order, repeat_cnt);		/* then do the control order */

order_return:
	arg_code = code;
	return;
%page;
/* set_mode - entry to allow PFMs to set tape_ioi_ modes */

set_mode: entry (arg_mtdp, arg_mode, arg_index, arg_mode_ptr, arg_code);

	call SETUP;				/* set up our enviornment */
	mode_ptr = arg_mode_ptr;
	arg_code = 0;
	do oidx = hbound (mode_mnemonics, 1) to lbound (mode_mnemonics, 1) by -1
	     while (mode_mnemonics (oidx) ^= arg_mode);	/* get the mode index */
	end;
	go to PROC_MODE (oidx);			/* go process correct mode */

PROC_MODE (-1):					/* unknown mode */
	arg_code = error_table_$bad_arg;
	return;

PROC_MODE (0):					/* set data mode */
	mode_ptr = addr (HDW_MODE_STR (arg_index));	/* set desired data mode */
	go to PROC_MODE_END;

PROC_MODE (1):					/* set length mode */
	mode_ptr = addr (LENGTH_MODES (arg_index));
	go to PROC_MODE_END;

PROC_MODE (2):					/* set alignment mode */
	mode_ptr = addr (ALIGN_MODES (arg_index));
	go to PROC_MODE_END;

PROC_MODE (3):					/* set data recovery mode */
	mode_ptr = addr (RECOVERY_MODES (arg_index));
	go to PROC_MODE_END;

PROC_MODE (4):					/* set wait mode */
	mode_ptr = addr (WAIT_MODES (arg_index));
	go to PROC_MODE_END;

PROC_MODE (5):					/* set event channel, mode_ptr already set */
PROC_MODE (6):					/* set recovery channel instruction field */
PROC_MODE_END:
	call tape_ioi_$set_mode (mtape_data.tioi_id, arg_mode, mode_ptr, arg_code); /* set the mode */
	return;
%page;
/* stop_tape - entry to stop tape motion and syncronize position */

stop_tape: entry (arg_mtdp, arg_code);

	call SETUP;				/* set up our enviornment */
	if mtape_data.nbufs > 0 & (mtape_file_info.position_within_file = AT_BOFD |
	     mtape_file_info.position_within_file = AT_IFD) then do; /* don't bother if buffers not allocated */
	     call STOP_TAPE;			/* stop the tape and get the last status */
	     if ths.major = END_OF_FILE & descrep_cnt > 0 then do; /* if end of file status */
		mtape_data.position.phy_file = mtape_data.position.phy_file + 1; /* increment file # */
		mtape_data.position.phy_block = 0;	/* and zero out block number */
		mtape_file_info.position_within_file = AT_BOFT;
	     end;
	     else mtape_data.position.phy_block = mtape_data.position.phy_block + descrep_cnt;
	end;
	return;
%page;
/* ALLOCATE_LABEL_BUFFER - internal procedure to allocate and reserve a sync buffer for reading and writing labels */

ALLOCATE_LABEL_BUFFER: proc (buf_len);

dcl  buf_len fixed bin;
dcl  act_length fixed bin (21);
dcl  act_number fixed bin;
dcl  lbuf_arrayp (1) ptr;

	call tape_ioi_$allocate_buffers (mtape_data.tioi_id, (buf_len), 1, act_length, act_number, lbuf_arrayp, code);
	if code ^= 0 then return;			/* return on fatal error */
	call tape_ioi_$reserve_buffer (mtape_data.tioi_id, lbuf_arrayp (1), code); /* reserve the buffer */
	if code ^= 0 then return;			/* return on fatal error */
	mtape_data.lab_bufp = lbuf_arrayp (1);		/* copy label buffer ptr */
	mtape_data.lab_buf_len = buf_len;		/* set label buffer length */

     end ALLOCATE_LABEL_BUFFER;
%page;
/* RESOLVE_POSITION - subroutine to correct position resulting from reading ahead/writing behind */

RESOLVE_POSITION: proc;

	if mtape_data.nbufs > 0 then do;		/* don't bother if buffers not allocated */
	     call STOP_TAPE;			/* stop the tape and get the last status */
	     if ths.major = END_OF_FILE then do;	/* if end of file status */
		descrep_cnt = descrep_cnt - 1;	/* decrease descrepency count */
		call DO_ORDER ("bsf", 1);		/* and backspace across file mark */
	     end;
	     if descrep_cnt > 0 then			/* if we are not already where we should be */
		call DO_ORDER ("bsr", descrep_cnt);	/* backspace this many blocks */
	end;

     end RESOLVE_POSITION;
%page;
/* REWIND_PROC - subroutine to stop tape, rewind tape and wait for special */

REWIND_PROC: proc (rew_order, wait);

dcl  rew_order char (4);				/* either "rew" or "run" */
dcl  wait bit (1) aligned;

	mtape_data.phy_file, mtape_data.phy_block = 0;	/* reset position */
	on mtape_dev_attention_recovery go to WAIT_FOR_REWIND; /* wait for special on recovery */

	on cleanup begin;
	     call tape_ioi_$order (mtape_data.tioi_id, "rdy", 0, addr (spec_status), act_cnt, rx, code);
	     call CHECK_RX;				/* if already rewinding, wait until complete */
	end;

	call tape_ioi_$stop_tape (mtape_data.tioi_id, descrep_cnt, rx, code); /* stop the tape first */
	call CHECK_RX;				/* check the result index */
	if code ^= 0 then				/* if error */
	     return;
	call tape_ioi_$order (mtape_data.tioi_id, "rdy", 0, addr (spec_status), act_cnt, rx, code);
	call CHECK_RX;				/* if already rewinding, wait until complete */
	if code ^= 0 then				/* if error */
	     return;
	call tape_ioi_$order (mtape_data.tioi_id, rew_order, 0, null, act_cnt, rx, code); /* issue rewind order */
	call CHECK_RX;				/* check the result index */
	if code ^= 0 then				/* if error */
	     return;
	mtape_vol_set.volume_end = "0"b;		/* reset EOV flag in vol set structure */
	if wait then do;				/* user wants to wait for rewind to complete */
WAIT_FOR_REWIND:
	     call tape_ioi_$order (mtape_data.tioi_id, "rdy", 0, addr (spec_status), act_cnt, rx, code);
	     call CHECK_RX;				/* wait for special interrupt & check the result index */
						/* set the density after rewind.    */
	     if vs_ptr ^= null then do;
		infop = addr (mtape_vol_set.volume_density);
		call DO_ORDER ("den", 1);
	     end;
	end;
	return;

     end REWIND_PROC;
%page;
/* SPACE_FILE - subroutine to correct position when forward/backspacing files  */

SPACE_FILE: proc (direction);

dcl  direction bit (1) aligned;			/* "1"b => forward space; "0"b => backspace */

	if mtape_data.nbufs > 0 then do;		/* don't bother if buffers not allocated */
	     call STOP_TAPE;			/* stop the tape and get the last status */

/* if EOF status & we were not already stopped, must correct for async position */

	     if ths.major = END_OF_FILE & descrep_cnt > 0 then do;
		if direction = FORWARD then		/* forward */
		     repeat_cnt = repeat_cnt - 1;	/* decrease repeat count by 1 */
		else repeat_cnt = repeat_cnt + 1;	/* backspacing, must backspace 1 more */

	     end;
	end;
	mtape_data.position.phy_block = 0;		/* reset block position */

/* Note that block position is undefined if backspacing files */

	if repeat_cnt = 0 then do;			/* if position adjusted to 0 .. */
	     mtape_data.position.phy_file = mtape_data.position.phy_file + 1; /* increment file position */
	     return;				/* don't do the order, we are already where we should be */
	end;

	call DO_ORDER (order, repeat_cnt);		/* do the order */
	if code = error_table_$end_of_info then code = 0; /* ignore EOF status */
	if direction = FORWARD then			/* if spacing forward */
	     mtape_data.position.phy_file = mtape_data.position.phy_file + act_cnt; /* add files spaced */
	else mtape_data.position.phy_file = mtape_data.position.phy_file - act_cnt; /* back, subtract files spaced */

     end SPACE_FILE;
%page;
/* SPACE_BLOCK - subroutine to correct position when forward/backspacing records (blocks)  */

SPACE_BLOCK: proc (direction);

dcl  direction bit (1) aligned;			/* "1"b => forward space; "0"b => backspace */

	if mtape_data.nbufs > 0 then do;		/* don't bother if buffers not allocated */
	     call STOP_TAPE;			/* stop the tape and get the last status */
	     if ths.major = END_OF_FILE & descrep_cnt > 0 then do; /* if end of file status */
		if direction = FORWARD then		/* forward spacing? */
		     if repeat_cnt >= descrep_cnt then do; /* farther than we can go */
			mtape_data.position.phy_block = 0; /* correct position */
			mtape_data.position.phy_file = mtape_data.position.phy_file + 1;
			code = error_table_$end_of_info; /* return EOF status to caller */
			return;
		     end;
		call DO_ORDER ("bsf", 1);		/* must backspace across file mark */
		descrep_cnt = descrep_cnt - 1;	/* correct descrepency count */
	     end;
	     if direction = FORWARD then		/* if forward spacing */
		if descrep_cnt > repeat_cnt then do;	/* but actual position is beyond desired position */
		     order = "bsr";			/* we will actually have to backspace */
		     repeat_cnt = (descrep_cnt - repeat_cnt) + 1; /* this many blocks to get to desired position */
		end;
		else repeat_cnt = repeat_cnt - descrep_cnt; /* forward, desired position is beyond actual position */
	     else repeat_cnt = repeat_cnt + descrep_cnt;	/* backward, adjust position */
	end;
	call DO_ORDER (order, repeat_cnt);		/* execute the control order */
	if code = 0 then do;
	     if direction = FORWARD then		/* spacing forward */
		mtape_data.position.phy_block = mtape_data.position.phy_block + arg_repeat_cnt;
	     else mtape_data.position.phy_block = mtape_data.position.phy_block - arg_repeat_cnt;
	end;

     end SPACE_BLOCK;
%page;
/* CHECK_RX - internal procedure to check the result index returned by tape_ioi_ and take appropriate action */

CHECK_RX: proc;

	if rx = TAPE_IO_SUCCESS then			/* if no problems */
	     return;
	mtape_data.run = "0"b;			/* anything else has stopped I/O */
	go to RX_ACTION (rx);			/* otherwise take appropriate action */


RX_ACTION (-1):					/* TAPE_IO_BLOCK, we should never have to go blocked */
RX_ACTION (1):					/* TAPE_IO_USER_PROGRAM_ERROR */
RX_ACTION (3):					/* TAPE_IO_RECOVERABLE_IO_ERROR, error code set */
RX_ACTION (7):					/* TAPE_IO_RECOVERABLE_IO_ERROR_AND_EOT, will lose EOT stat */
	return;

RX_ACTION (4):					/* TAPE_IO_EOF, encountered EOF mark */
	mtape_data.position.phy_file = mtape_data.position.phy_file + 1; /* increment file number */
	mtape_data.position.phy_block = 0;		/* reset block number */
	code = error_table_$end_of_info;		/* set appropriate error code */
	return;

RX_ACTION (5):					/* TAPE_IO_EOT, EOT foil detected */
	mtape_vol_set.volume_end = "1"b;		/* set EOV flag in vol set structure */
	call SYNC_POSITION;				/* correct block count */
	code = error_table_$eov_on_write;		/* set appropriate error code */
	return;

RX_ACTION (6):					/* TAPE_IO_BOT, backspaced into BOT */
	code = error_table_$positioned_on_bot;		/* set appropriate error code */
	return;

RX_ACTION (8):					/* TAPE_IO_CODE_ALERT */
	code = error_table_$nine_mode_parity;		/* set appropriate error code */

RX_ACTION (2):					/* TAPE_IO_UNRECOVERABLE_IO_ERROR, error code set */
	unr_code = code;				/* save error code */
	call SYNC_POSITION;				/* correct the block count */
	if mtape_data.last_io = WRITE_IO then		/* if we are writing data */
	     mtape_data.phy_block = mtape_data.phy_block - 1; /* subtract current buffer */
	call mtape_check_status_ (mtdp, unr_code);	/* go check the error */
	code = unr_code;				/* copy returned error code */

     end CHECK_RX;
%page;
/* UNLOAD_LREC_CNT - internal procedure to increment the logical record round robin counter */

UNLOAD_LREC_CNT: proc;

	mtape_data.tot_lrec = mtape_data.tot_lrec + mtape_data.log_record; /* increment total */
	mtape_data.blk_rrrc (mtape_data.blk_rrcx) = mtape_data.log_record; /* save lrecs in last block */
	mtape_data.log_record = 0;			/* reset inter-block rec count */
	mtape_data.blk_rrcx = mtape_data.blk_rrcx + 1;	/* increment index for next block */
	if mtape_data.blk_rrcx > hbound (mtape_data.blk_rrrc, 1) then /* if at end of RRC */
	     mtape_data.blk_rrcx = 0;			/* reset it to top of RRC */

     end UNLOAD_LREC_CNT;

/* GET_HDW_STATUS - internal procedure to get the current hardware status from tape_ioi_ */

GET_HDW_STATUS: proc;

	ths_ptr = addr (auto_ths);			/* set pointer to auto structure */
	ths.version = THS_VERSION;			/* set version */
	call tape_ioi_$hardware_status (mtape_data.tioi_id, ths_ptr, scode); /* get status */

     end GET_HDW_STATUS;

/* STOP_TAPE - subroutine to stop the tape and get the last hardware status */

STOP_TAPE: proc;

	code = 0;
	call tape_ioi_$stop_tape (mtape_data.tioi_id, descrep_cnt, rx, code);
	call CHECK_RX;				/* check result index */
	call GET_HDW_STATUS;			/* get the current hardware status */

     end STOP_TAPE;
%page;
/* DO_ORDER - subroutine to execute a control order */

DO_ORDER: proc (order, arg_repeat_cnt);

dcl  order char (4);
dcl  (arg_repeat_cnt, repeat_cnt) fixed bin;

	code = 0;
	repeat_cnt = arg_repeat_cnt;

/* establish conditon handler */

	on mtape_dev_attention_recovery go to REPEAT_ORDER;

	do while (repeat_cnt > 0 & code = 0);		/* do requested orders */

	     call tape_ioi_$order (mtape_data.tioi_id, order, repeat_cnt,
		infop, act_cnt, rx, code);
	     repeat_cnt = repeat_cnt - act_cnt;
	     call CHECK_RX;				/* go check the result index */
REPEAT_ORDER:
	end;

	if code ^= 0 then do;
	     if code = error_table_$end_of_info then
		code = 0;
	     else
		call mtape_util_$error (mtdp, code,
		     "While attempting a ^a control order.", order);
	end;

	return;

     end DO_ORDER;

/* SYNC_POSITION - internal procedure to syncronize the position after a write err */

SYNC_POSITION: proc;

dcl  susp_smple (1) ptr;
dcl  n_susp_bufs fixed bin;

	call tape_ioi_$list_buffers (mtape_data.tioi_id, SUSPENDED_STATE, susp_smple, n_susp_bufs, code);
	if code ^= 0 then do;			/* error from list_buffers */
	     call mtape_util_$error (mtdp, code,	/* report it */
		"Error from tape_ioi_$list_buffers");
	     return;
	end;
	mtape_data.position.phy_block = mtape_data.position.phy_block - n_susp_bufs;

     end SYNC_POSITION;
%page;
/* SETUP - internal procedure to set up environment for the external entries */

SETUP: proc;

	mtdp = arg_mtdp;				/* get pointers to pertinent data */
	vs_ptr = mtape_data.vs_current;
	fi_ptr = mtape_data.fi_current;
	if mtape_data.tioi_id = "0"b then do;		/* should only happen if "ring_in" order executed */
	     call mtape_mount_cntl_$mount (mtdp, code);	/* get the volume mounted */
	     if code ^= 0 then do;
		call mtape_util_$error (mtdp, code,
		     "^/Attempting to mount volume ^a following ""ring_in"" control operation",
		     mtape_vol_set.volume_name);
		go to ERROR_RETURN;			/* take non_local goto */
	     end;
	     arg_mtdp = mtdp;			/* reset callers control structure ptr */
	     free mtape_data.cmtdp -> mtape_data in (based_area); /* free the old structure */
	     mtape_data.cmtdp = null;
	end;
	rx, arg_code, code = 0;			/* and reset error codes */

     end SETUP;

ERROR_RETURN:					/* target of non-local gotos */
	arg_code = code;				/* copy return code */
	return;					/* return to caller */
%page;
%include mtape_data;
%page;
%include mtape_vol_set;
%page;
%include mtape_label_record;

%include mtape_err_stats;
%page;
%include mtape_file_info;
%page;
%include mtape_constants;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_buffer_status;
%page;
%include tape_ioi_result_indexes;
%include tape_ioi_hw_status;

     end mtape_io_;




		    mtape_iox_.pl1                  12/01/87  0801.0rew 11/30/87  1323.7      311769



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


/****^  HISTORY COMMENTS:
  1) change(87-08-17,GWMay), approve(87-09-09,MECR0006),
     audit(87-09-04,Farley), install(87-09-09,MR12.1-1101):
     Added more complete setting of the iocb.  Return on tape errors.
  2) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley),
     install(87-11-30,MR12.2-1006):
     Formally install MECR0006.
                                                   END HISTORY COMMENTS */


mtape_iox_: procedure;

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system. This
   *	program implements most of the entries called through iox_ for
   *	mtape_.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 10/05/82
   *	Modified by J. A. Bush 12/01/83 for performance improvements
*/

/*		ARGUMENT DATA		*/

dcl  arg_iocbp ptr;					/* (Input) Pointer to the I/O control block */
dcl  arg_options (*) char (*) varying;			/* (Input) Attach options from attach description. */
dcl  arg_com_err_flag bit (1) aligned;			/* (Input) "1"b => call com_err_ on attach errors */
dcl  arg_extend_flag bit (1);
dcl  arg_open_mode fixed bin;				/* Opening mode */
dcl  arg_buf_ptr ptr;				/* Pointer to users buffer to read into/write from */
dcl  arg_buf_len fixed bin (21);			/* Length of users buffer/bytes to be read */
dcl  arg_rec_len fixed bin (21);			/* Length of record/number of bytes read */
dcl  arg_code fixed bin (35);				/* (Output) Standard system error code */

/*		AUTOMATIC DATA		*/

dcl  iocbp ptr;					/* pointer to our IOCB */
dcl  com_err_flag bit (1) aligned;			/* "1"b => call com_err_ on attach errors */
dcl  (output, com_sent) bit (1) aligned;
dcl  (i, nsusp_bufs) fixed bin;
dcl  ips_mask bit (36) aligned;
dcl  desc_len fixed bin (21);
dcl  (code, iox_code) fixed bin (35);			/* error code value */
dcl  1 auto_mtd like mtape_data aligned;		/* temporary auto copy of mtape_ data base */
dcl  1 ai like area_info aligned;

/*		CONSTANT DATA		*/

dcl  myname char (6) int static options (constant) init ("mtape_");
dcl  null_options (1) char (1) varying int static options (constant) init ("");
dcl  READ_IO fixed bin int static options (constant) init (1);
dcl  WRITE_IO fixed bin int static options (constant) init (2);

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$no_operation fixed bin (35) ext static;
dcl  error_table_$not_detached fixed bin (35) ext static;
dcl  error_table_$bad_mode fixed bin (35) ext static;
dcl  error_table_$bad_label fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  error_table_$long_record fixed bin (35) ext static;
dcl  sys_info$max_seg_size fixed bin (35) ext static;

/*		BUILTIN FUNCTIONS		*/

dcl  (addr, hbound, lbound, length, null, unspec) builtin;

/*		EXTERNAL ENTRIES		*/

dcl  (ioa_, com_err_) entry options (variable);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  user_info_$process_type entry (fixed bin);
dcl  mtape_util_$error entry options (variable);
dcl  mtape_util_$get_statistics entry (ptr, fixed bin (35));
dcl  mtape_util_$init_pfm entry (ptr, fixed bin (35));
dcl  mtape_util_$user_query entry (ptr, fixed bin, fixed bin (35));
dcl  mtape_parse_$attach entry (ptr, (*) char (*) varying, fixed bin (35));
dcl  mtape_parse_$open entry (ptr, (*) char (*) varying, fixed bin, fixed bin (35));
dcl  mtape_parse_$close entry (ptr, (*) char (*) varying, fixed bin (35));
dcl  mtape_parse_$detach entry (ptr, (*) char (*) varying, fixed bin (35));
dcl  mtape_mount_cntl_$mount entry (ptr, fixed bin (35));
dcl  mtape_mount_cntl_$demount entry (ptr, fixed bin (35));
dcl  mtape_iox_$open entry options (variable);
dcl  mtape_iox_$open_file entry options (variable);
dcl  mtape_iox_$close entry options (variable);
dcl  mtape_iox_$close_file entry options (variable);
dcl  mtape_iox_$detach entry options (variable);
dcl  mtape_iox_$detach_iocb entry options (variable);
dcl  mtape_control_$control entry options (variable);
dcl  mtape_position_ entry options (variable);
dcl  mtape_position_$read_length entry options (variable);
dcl  mtape_io_$allocate_buffers entry (ptr, fixed bin (21), fixed bin (35));
dcl  mtape_io_$set_mode entry (ptr, char (*), fixed bin, ptr, fixed bin (35));
dcl  mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35));
dcl  mtape_io_$stop_tape entry (ptr, fixed bin (35));
dcl  mtape_iox_$write entry options (variable);
dcl  mtape_iox_$read entry options (variable);
dcl  iox_$propagate entry (ptr);
dcl  iox_$err_not_open entry () options (variable);
dcl  iox_$err_not_closed entry () options (variable);
dcl  iox_$err_not_attached entry () options (variable);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  release_area_ entry (ptr);
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));

/*		BASED STORAGE		*/

dcl  desc_string char (desc_len) varying based;
dcl  based_area area based (mtape_data.areap);

/* CONDITIONS */

dcl  (any_other, cleanup) condition;
%page;
mtape_attach: entry (arg_iocbp, arg_options, arg_com_err_flag, arg_code);

/* *	This entry is called to attach a tape volume or volume set to the
   *	users process through the specified I/O switch. The major tasks
   *	performed by this entry are as follows:
   *
   *	1. Parsing and validation of the options array, which iox_ generated
   *	   from the users attach description.
   *	2. Initialization of the mtape_ environment, including allocation of
   *	   1 volume set structure for each volume set member specified in
   *	   the options array and initialization of the global default values
   *	   from the users default value_seg (this includes creation of the
   *	   global default values on first reference).
   *	3. Requesting the mount of the first volume in the volume set via
   *	   RCP.
   *	4. Establishing the tape_ioi_ activation.
   *	5. Selection of the appropriate "Per-Format" module, based on
   *	   information returned from RCP in conjuction with any "-label" and
   *	   "-no_labels" information specified by the user in the attach
   *	   description and/or the current value of the "mtape_.global.label"
   *	   default value.
   *	6. Perform a search for the selected per-format module via the
   *	   search path  mechanism to verify its existence.
   *	7. Fill in the standard fields of the I/O control block to indicate
   *	   I/O switch attachment complete, ready for opening.
*/

	iocbp = arg_iocbp;				/* copy arguments */
	com_err_flag = arg_com_err_flag;
	mtdp = null;				/* make this ptr consistent for first possible error msg */
	if iocbp -> iocb.attach_data_ptr ^= null then do; /* If aready attached.. */
	     call ATTACH_ERROR (error_table_$not_detached, (iocbp -> iocb.name)); /* complain and let user call */
	     return;				/* again until he gets it right */
	end;

	on cleanup call CLEANUP;

	call INIT_ENVIRONMENT;			/* Initialize working environment */
	if arg_code ^= 0 then			/* quit if some problem */
	     return;
	call mtape_parse_$attach (mtdp, arg_options, code); /* parse the attach options */
	if code ^= 0 then do;			/* return to user if unrecoverable error */
	     arg_code = code;
	     call CLEANUP;				/* undo everything we have done so far */
	     return;
	end;
	com_err_flag = com_err_flag | mtape_data.display_errors; /* error messages if either one */
	if mtape_attach_info.display then do;		/* user wants to see attach description */
	     desc_len = length (mtape_data.atdp -> desc_string); /* set the length */
	     call ioa_ ("^/ATTACH DESCRIPTION:^/^a^/", mtape_data.atdp -> desc_string); /* display it */
	end;

	call mtape_mount_cntl_$mount (mtdp, code);	/* get the first volume mounted */
	if code ^= 0 then do;			/* return to user if unrecoverable error */
	     arg_code = code;
	     call CLEANUP;				/* undo everything we have done so far */
	     return;
	end;

	call mtape_util_$init_pfm (mtdp, code);		/* perform the Per-Format module selection */
	if code ^= 0 then do;			/* if we can't find it, bail out */
	     call CLEANUP;
	     arg_code = code;
	     return;
	end;
	call mtape_data.pfm_init (mtdp, code);		/* Let PFM initialize and check volume label */
	if code ^= 0 then do;
	     arg_code = code;
	     call CLEANUP;
	     return;
	end;
	if (^mtape_attach_info.labeled & ^mtape_pfm_info.no_labels_ok) then do; /* illegal combo */
	     arg_code = error_table_$inconsistent;
	     call mtape_util_$error (mtdp, arg_code,
		"^/The ^a Per-Format module does not support unlabeled volumes", mtape_pfm_info.module_id);
	     return;
	end;

/* The attachment is now complete. We must now fill in the IOCB with
   appropriate information and propagate it. */

	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	iocbp -> iocb.attach_descrip_ptr = mtape_data.atdp;
	iocbp -> iocb.attach_data_ptr = mtdp;
	iocbp -> iocb.detach_iocb = mtape_iox_$detach_iocb;
	iocbp -> iocb.detach = mtape_iox_$detach;
	iocbp -> iocb.open = mtape_iox_$open;
	iocbp -> iocb.open_file = mtape_iox_$open_file;
	iocbp -> iocb.close = iox_$err_not_open;
	iocbp -> iocb.close_file = iox_$err_not_open;
	iocbp -> iocb.control = mtape_control_$control;

	call iox_$propagate (iocbp);			/* propagate this IOCB */
	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	return;					/* thats all folks */
%page;
/* open - entry to open the I/O switch */

open: entry (arg_iocbp, arg_open_mode, arg_extend_flag, arg_code);

/* this entry merely passes control to the open_file entry with a null option array */

	call open_file_int (arg_iocbp, arg_open_mode, null_options, arg_extend_flag, arg_code);

	return;

/* open_file - entry to open an I/O switch with open arguments passed in the open argument array */

open_file: open_file_int: entry (arg_iocbp, arg_open_mode, arg_options, arg_extend_flag, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;	/* copy argument */
	code, arg_code = 0;				/* reset return code */
	mtdp = iocbp -> iocb.attach_data_ptr;		/* get our working storage pointer */
	mtape_data.iocb_ptr = iocbp;			/* save our IOCB ptr */
	maip = mtape_data.attach_info_ptr;
	moip = mtape_data.open_info_ptr;
	mpfmip = mtape_data.pfm_info_ptr;
	mspfmip = mtape_data.saved_pfm_info_ptr;
	vs_ptr = mtape_data.vs_current;		/* get vol set structure ptr */
	do i = 1 to hbound (mtape_pfm_info.open_modes_allowed, 1) /* check open mode legality */
	     while (arg_open_mode ^= mtape_pfm_info.open_modes_allowed (i));
	end;
	if i > hbound (mtape_pfm_info.open_modes_allowed, 1) then do; /* can't open for this mode */
	     code = error_table_$bad_mode;		/* set appropriate error code */
	     call mtape_util_$error (mtdp, code,
		"Open mode of ^d is invalid for the selected Per-Format module", arg_open_mode);
	     go to OPEN_EXIT;
	end;
	if arg_open_mode = Stream_input | arg_open_mode = Sequential_input then /* input mode? */
	     output = "0"b;
	else output = "1"b;				/* no output type mode */
	if output & ^mtape_attach_info.ring then do;	/* if output mode and no write ring */
	     code = error_table_$bad_mode;
	     call mtape_util_$error (mtdp, code,
		"Opening for ""^a"" requires the presence of a write ring.^/^a^/^a", iox_modes (arg_open_mode),
		"Either detach and reattach with a ""-ring"" attach description argument,",
		"or use the ""ring_in"" control order.");
	     go to OPEN_EXIT;
	end;
	if ^mtape_data.first_file then		/* if the first opening */
	     if output then do;			/* opening for output */
		mtape_vol_set.volume_density = mtape_attach_info.density;

		if mtape_vol_set.volume_check = RECOG_FORMAT_VOLUME | /* query user before destroying */
		     (mtape_vol_set.volume_check < BLANK_VOLUME & ^mtape_attach_info.labeled) then do;
		     call mtape_util_$user_query (mtdp, Q_LABELED_VOLUME, code);
		     if code ^= 0 then go to OPEN_EXIT;
		end;
	     end;
	     else do;				/* opening for input */
		if mtape_vol_set.volume_check > NON_MULT_VOLUME & /* trying to read is clearly wrong */
		     ^(mtape_pfm_info.no_labels_ok & mtape_vol_set.volume_check = UNLABELED_VOLUME) then do;
		     code = error_table_$bad_label;	/* set appropriate error code */
		     call mtape_util_$error (mtdp, code,/* and report error */
			"^/Attempting to open a file for ^a on a volume ^[(^a) ^;^1s^]which has an ^a label",
			iox_modes (arg_open_mode), (mtape_vol_set.volume_check = RECOG_FORMAT_VOLUME),
			mtape_vol_set.volume_id, Tape_volume_types (mtape_vol_set.volume_type));
		end;
		else if (mtape_vol_set.volume_check < BLANK_VOLUME & ^mtape_attach_info.labeled) then do;
		     call mtape_util_$error (mtdp, 0,
			"Volume ^a will be processed as a standard ^a labeled tape. ^a.",
			mtape_vol_set.volume_id, mtape_pfm_info.module_id,
			"The ""-no_labels"" attach description argument will be ignored");
		     mtape_attach_info.labeled = "1"b;	/* make it a labeled tape */
		end;
		else if (mtape_vol_set.volume_check = UNLABELED_VOLUME & mtape_pfm_info.no_labels_ok) then
		     if mtape_attach_info.labeled then do; /* go ahead and process as unlabeled */
			call mtape_util_$error (mtdp, 0, "Volume ^a will be processed as an ^a unlabeled volume",
			     mtape_vol_set.volume_name, mtape_pfm_info.module_id);
			mtape_attach_info.labeled = "0"b; /* force the unlabeled attribute */
		     end;
	     end;
	if code ^= 0 then				/* if some problem up above */
	     go to OPEN_EXIT;			/* bail out now */
	call mtape_parse_$open (mtdp, arg_options, arg_open_mode, code); /* go parse the open options */
	if code ^= 0 then go to OPEN_EXIT;
	if mtape_open_info.display then do;		/* user wants to see open description */
	     desc_len = length (mtape_data.opdp -> desc_string); /* set the length */
	     call ioa_ ("^/OPEN DESCRIPTION:^/^a^/", mtape_data.opdp -> desc_string); /* display it */
	end;
	call mtape_data.file_open (mtdp, code);		/* let the PFM do his thing */
	if code ^= 0 then go to OPEN_EXIT;
	mtape_data.error_lock = 0;			/* reset data error lock */
	if mspfmip ^= null then			/* if we have done a change_module control OP */
	     if output then				/* and this is an output type opening */
		if mtape_saved_pfm_info.open_mode = 0 then /* and first output */
		     mtape_saved_pfm_info.open_mode = arg_open_mode; /* save this one */
	fi_ptr = mtape_data.fi_current;
	mtape_data.char_size = mtape_file_info.char_size; /* copy required info into mtape_data */
	mtape_data.length_mode = mtape_file_info.length_mode;
	mtape_data.hdw_mode = mtape_file_info.hdw_mode;
	mtape_data.conversion = mtape_file_info.conversion;
	mtape_data.buffer_offset = mtape_file_info.buffer_offset;
	mtape_data.block_size, mtape_data.length = mtape_file_info.block_size;
	mtape_data.record_size = mtape_file_info.record_size;
	mtape_data.native_file = mtape_file_info.native_file;
	if mtape_file_info.file_format > 4 then do;	/* set adjusted format code */
	     mtape_data.ad_file_format = mtape_file_info.file_format - 3;
	     mtape_data.file_blocked = "1"b;		/* set switch for blocked file */
	end;
	else do;					/* not a blocked file */
	     mtape_data.ad_file_format = mtape_file_info.file_format;
	     mtape_data.file_blocked = "0"b;
	end;
	mtape_data.tot_bytes_processed, mtape_data.last_io, mtape_data.prev_block_no = 0;
	mtape_data.write_after_read, mtape_data.run = "0"b;
	mtape_data.first_file = "1"b;
	if mtape_data.nbufs > 0 then			/* buffers already allocated? */
	     if mtape_data.buf_size ^= mtape_data.block_size then do;
		call tape_ioi_$deallocate_buffers (mtape_data.tioi_id, code);
		if code ^= 0 then go to OPEN_EXIT;
		mtape_data.nbufs = 0;		/* set indicator to reallocate buffers */
	     end;
	     else do;				/* buffers allocated and of right size */
		call tape_ioi_$list_buffers (mtape_data.tioi_id, READY_STATE, mtape_data.buf_ptrs, nsusp_bufs, code);
		if code ^= 0 then go to OPEN_EXIT;
	     end;
	if mtape_data.nbufs = 0 then do;		/* If we don't already have buffers */
	     call mtape_io_$allocate_buffers (mtdp, mtape_data.block_size, code); /* allocate them */
	     if code ^= 0 then go to OPEN_EXIT;
	end;
	call mtape_io_$set_mode (mtdp, "data", mtape_data.hdw_mode, null, code); /* set desired HW mode */
	if code = 0 then
	     call mtape_io_$set_mode (mtdp, "length", mtape_data.length_mode, null, code); /* and length mode */
	if code ^= 0 then go to OPEN_EXIT;
	mtape_data.cur_buf_idx = lbound (mtape_data.buf_ptrs, 1);
	mtape_data.cur_buf_ptr = mtape_data.buf_ptrs (mtape_data.cur_buf_idx);
	mtape_data.cur_block.length = mtape_data.buf_size;/* set up for max length */
	mtape_data.processed = mtape_data.buffer_offset;	/* skip over  any buffer offset */
	if output then				/* if writing, set remaining bytes */
	     mtape_data.remain = mtape_data.cur_block.length - mtape_data.processed;
	else mtape_data.remain = 0;			/* if reading, must read first block */
	mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1)); /* set initial lrec ptr */
	mtape_data.buf_len (*) = 0;
	if mtape_open_info.comment ^= "" then		/* user wants to see comment */
	     call ioa_ ("^/OPEN COMMENT:^/^a^/", mtape_open_info.comment);

/* opened ok, now fill in IOCB */

	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	iocbp -> iocb.open_descrip_ptr = mtape_data.opdp;
	iocbp -> iocb.open = iox_$err_not_closed;
	iocbp -> iocb.open_file = iox_$err_not_closed;
	iocbp -> iocb.detach_iocb = iox_$err_not_closed;
	iocbp -> iocb.detach = iox_$err_not_closed;
	iocbp -> iocb.close = mtape_iox_$close;
	iocbp -> iocb.close_file = mtape_iox_$close_file;
	if arg_open_mode = Sequential_output then
	     iocbp -> iocb.write_record = mtape_iox_$write;
	else if arg_open_mode = Stream_output then
	     iocbp -> iocb.put_chars = mtape_iox_$write;
	else if arg_open_mode = Sequential_input then do;
	     iocbp -> iocb.read_record = mtape_iox_$read;
	     iocbp -> iocb.position = mtape_position_;
	     iocbp -> iocb.read_length = mtape_position_$read_length;
	end;
	else if arg_open_mode = Stream_input then do;
	     iocbp -> iocb.get_chars = mtape_iox_$read;
	     iocbp -> iocb.position = mtape_position_;
	end;
	else if arg_open_mode = Sequential_input_output then do;
	     iocbp -> iocb.read_record = mtape_iox_$read;
	     iocbp -> iocb.write_record = mtape_iox_$write;
	     iocbp -> iocb.position = mtape_position_;
	     iocbp -> iocb.read_length = mtape_position_$read_length;
	end;
	else do;					/* Steam_input_output */
	     iocbp -> iocb.get_chars = mtape_iox_$read;
	     iocbp -> iocb.put_chars = mtape_iox_$write;
	     iocbp -> iocb.position = mtape_position_;
	end;
	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

OPEN_EXIT:
	arg_code = code;
	return;
%page;
/* close - entry to close the I/O switch */

close: entry (arg_iocbp, arg_code);

/* this entry merely passes control to the close_file entry with a null option array */

	call close_file_int (arg_iocbp, null_options, arg_code);

	return;

/* close_file - entry to close an I/O switch with close arguments passed in the close argument array */

close_file: close_file_int: entry (arg_iocbp, arg_options, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;	/* copy argument */
	arg_code = 0;				/* reset return code */
	mtdp = iocbp -> iocb.attach_data_ptr;		/* get our working storage pointer */
	mtape_data.iocb_ptr = iocbp;			/* save our IOCB ptr */
	vs_ptr = mtape_data.vs_current;		/* get vol set structure ptr */
	maip = mtape_data.attach_info_ptr;
	moip = mtape_data.open_info_ptr;
	mcip = mtape_data.close_info_ptr;
	mpfmip = mtape_data.pfm_info_ptr;
	call mtape_parse_$close (mtdp, arg_options, code);/* go parse the close description */
	if code ^= 0 then go to CLOSE_EXIT;
	if mtape_close_info.display then do;		/* user wants to see close description */
	     desc_len = length (mtape_data.cldp -> desc_string); /* set the length */
	     call ioa_ ("^/CLOSE DESCRIPTION:^/^a^/", mtape_data.cldp -> desc_string); /* display it */
	end;
	call mtape_data.file_close (mtdp, code);	/* let the PFM do his thing */
	if mtape_data.fi_current ^= null then		/* if we were actually processing file */
	     call mtape_io_$stop_tape (mtdp, code);	/* get the tape stopped & buffers rdyed */
	call mtape_util_$get_statistics (mtdp, code);	/* update error stats */
	mtape_data.error_lock = 0;			/* reset data error lock */
	mtape_data.cur_block.length, mtape_data.cur_block.processed,
	     mtape_data.cur_block.remain, mtape_data.cur_block.log_record = 0;
	mtape_data.last_io, mtape_data.lrec_rrcx = 0;
	mtape_data.lrec_rrc (*).block_no, mtape_data.lrec_rrc (*).abs_byte,
	     mtape_data.lrec_rrc (*).byte_offset = 0;
	if mtape_close_info.comment ^= "" then		/* user wants to see comment */
	     call ioa_ ("^/CLOSE COMMENT:^/^a^/", mtape_close_info.comment);

/* closed ok, now reset pertinent IOCB entries */

	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	iocbp -> iocb.detach_iocb = mtape_iox_$detach_iocb;
	iocbp -> iocb.detach = mtape_iox_$detach;
	iocbp -> iocb.open = mtape_iox_$open;
	iocbp -> iocb.open_file = mtape_iox_$open_file;
	iocbp -> iocb.control = mtape_control_$control;
	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.put_chars = iox_$err_not_open;
	iocbp -> iocb.get_chars = iox_$err_not_open;
	iocbp -> iocb.write_record = iox_$err_not_open;
	iocbp -> iocb.read_record = iox_$err_not_open;
	iocbp -> iocb.read_length = iox_$err_not_open;
	iocbp -> iocb.position = iox_$err_not_open;
	iocbp -> iocb.close = iox_$err_not_open;
	iocbp -> iocb.close_file = iox_$err_not_open;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (ips_mask, ips_mask);

CLOSE_EXIT:
	arg_code = code;
	return;
%page;
/* detach_iocb - entry to detach the I/O switch */

detach_iocb: entry (arg_iocbp, arg_code);

/* this entry merely passes control to the detach entry with a null option array */

	call detach_int (arg_iocbp, null_options, arg_code);

	return;

/* detach - entry to detach an I/O switch with detach arguments passed in the detach argument array */

detach: detach_int: entry (arg_iocbp, arg_options, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;	/* copy argument */
	arg_code = 0;				/* reset return code */
	mtdp = iocbp -> iocb.attach_data_ptr;		/* get our root pointer */
	mtape_data.iocb_ptr = iocbp;			/* save our IOCB ptr */
	mdip = mtape_data.detach_info_ptr;		/* set this ptr */
	call mtape_parse_$detach (mtdp, arg_options, code); /* parse detach options */
	if code ^= 0 then
	     go to DETACH_EXIT;
	if mtape_detach_info.display then do;		/* user wants to see detach description */
	     desc_len = length (mtape_data.dtdp -> desc_string); /* set the length */
	     call ioa_ ("^/DETACH DESCRIPTION:^/^a^/", mtape_data.dtdp -> desc_string); /* display it */
	end;
	auto_mtd = mtape_data;			/* copy mtape_data back to auto storage */
	mtdp = addr (auto_mtd);			/* now we can deallocate our work area */

/* Now go through the entire volume set and demount all volumes */
	com_sent = "0"b;
	do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null);
	     if mtape_vol_set.mounted then do;		/* if volume currently mounted... */
		mtape_data.vs_current = vs_ptr;	/* set current volume set ptr */
		mtape_data.tioi_id = mtape_vol_set.tioi_id; /* just to be sure */
		if mtape_detach_info.comment ^= "" then /* if we have a demount comment */
		     if ^com_sent then do;		/* and it hasn't already been seen */
			com_sent = "1"b;		/* set flag so we want send it again */
			mtape_vol_set.demount_comment = mtape_detach_info.comment; /* copy the comment */
		     end;
		if mtape_detach_info.unload then	/* if user wants volume unloaded */
		     call mtape_io_$order (mtdp, "runw", 0, null, code); /* unload volume */
		else call mtape_io_$order (mtdp, "rwnw", 0, null, code); /* rewind volume */
		call mtape_mount_cntl_$demount (mtdp, code); /* demount the volume */
	     end;
	end;

	call release_area_ (mtape_data.areap);		/* we can free up our area now */
	if mtape_data.mount_echan ^= 0 then		/* if we created mount event channel.. */
	     call ipc_$delete_ev_chn (mtape_data.mount_echan, code); /* delete it */
	if mtape_data.io_echan ^= 0 then		/* if we created io event channel.. */
	     call ipc_$delete_ev_chn (mtape_data.io_echan, code); /* delete it */
	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	iocbp -> iocb.attach_data_ptr = null;
	iocbp -> iocb.attach_descrip_ptr = null;
	iocbp -> iocb.open = iox_$err_not_attached;
	iocbp -> iocb.open_file = iox_$err_not_attached;
	iocbp -> iocb.close = iox_$err_not_attached;
	iocbp -> iocb.close_file = iox_$err_not_attached;
	iocbp -> iocb.detach = iox_$err_not_attached;
	iocbp -> iocb.detach_iocb = iox_$err_not_attached;
	call iox_$propagate (iocbp);			/* wipe us out as far as iox_ is concerned */

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

DETACH_EXIT:
	arg_code = code;				/* copy return code */

	return;
%page;
/* read - This entry implements the iox_$read_record entry for sqi and sqio openings,
   and the iox_$get_chars entry for si and sio openings */

read: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_rec_len, arg_code);

	mtdp = arg_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get ptr to our control structure */
	mtape_data.iocb_ptr = arg_iocbp -> iocb.actual_iocb_ptr; /* save IOCB ptr */
	mtape_data.arg_buf_ptr = arg_buf_ptr;		/* save iox_ args for PFM */
	mtape_data.arg_buf_len = arg_buf_len;
	if mtape_data.error_lock ^= 0 then do;		/* if a previous error exists.. */
	     arg_rec_len = 0;			/* can't read anymore */
	     arg_code = mtape_data.error_lock;		/* give user back same error */
	     return;
	end;
	if mtape_data.last_io = WRITE_IO then do;	/* Read after write a no-no */
	     iox_code = error_table_$no_operation;	/* set error code */
	     call mtape_util_$error (mtdp, code, "Attempting forward read after write.");
	     go to read_return;
	end;
	mtape_data.last_io = READ_IO;			/* set for next operation check */
	call RECORD_HISTORY;			/* update record history counters */
	call mtape_data.read (mtdp, iox_code);		/* let the PFM do the work */
	arg_rec_len = mtape_data.arg_rec_len;		/* copy record length for user */
	if iox_code ^= 0 then			/* if we had an error */
	     if iox_code ^= error_table_$long_record then do; /* and not a long record */
		mtape_data.error_lock = iox_code;	/* set the error lock */
		go to read_return;
	     end;
	mtape_data.log_record = mtape_data.log_record + 1;/* increment log records, this block */
read_return:
	arg_code = iox_code;			/* return error code */
	return;
%page;
/* write - This entry implements the iox_$write_record entry for sqo and sqio openings,
   and the iox_$put_chars entry for so and sio openings */

write: entry (arg_iocbp, arg_buf_ptr, arg_buf_len, arg_code);

	mtdp = arg_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get ptr to our control structure */
	mtape_data.iocb_ptr = arg_iocbp -> iocb.actual_iocb_ptr; /* save IOCB ptr */
	mtape_data.arg_buf_ptr = arg_buf_ptr;		/* copy iox_ args for PFM */
	mtape_data.arg_buf_len = arg_buf_len;
	if mtape_data.error_lock ^= 0 then do;		/* if a previous error exists.. */
	     arg_code = mtape_data.error_lock;		/* give user back same error */
	     return;
	end;
	if mtape_data.last_io = READ_IO then		/* nothing wrong with this for input/output openings */
	     mtape_data.write_after_read = "1"b;	/* But flag it */
	mtape_data.last_io = WRITE_IO;
	call RECORD_HISTORY;			/* increment record history counters */
	call mtape_data.write (mtdp, iox_code);		/* let the PFM do the work */
	if iox_code ^= 0 then			/* if we had an error */
	     if iox_code ^= error_table_$long_record then do; /* and not a long record */
		mtape_data.error_lock = iox_code;	/* set the error lock */
		go to write_return;
	     end;
	mtape_data.log_record = mtape_data.log_record + 1;/* increment log record counter */
write_return:
	arg_code = iox_code;			/* return error code */
	return;
%page;
/* ATTACH_ERROR - internal procedure to handle errors encountered during the attach call. */

ATTACH_ERROR: procedure (ecode, msg);

dcl  ecode fixed bin (35);
dcl  msg char (*);

	arg_code = ecode;				/* return error code to user */
	if com_err_flag then
	     call com_err_ (ecode, myname, "^a", msg);

     end ATTACH_ERROR;

/* CLEANUP - internal procedure to clean up the mtape_ environment  on an attach error */

CLEANUP: procedure;

	if mtdp ^= null then do;			/* if we have a structure already */
	     if mtape_data.vs_current ^= null then	/* if we have a volume set */
		if mtape_data.vs_current -> mtape_vol_set.mounted then do; /* and a volume is mounted */
		     auto_mtd = mtape_data;		/* copy mtape_ data out of work area */
		     mtdp = addr (auto_mtd);		/* and set ptr to it */
		     call mtape_mount_cntl_$demount (mtdp, (0)); /* demount it */
		end;

	     call release_area_ (mtape_data.areap);	/* release our area */
	     mtdp = null;				/* set pointer to null */
	end;

     end CLEANUP;

/* RECORD_HISTORY - internal procedure to record logical record history */

RECORD_HISTORY: proc;

	mtape_data.lrec_rrc (mtape_data.lrec_rrcx).block_no = mtape_data.phy_block;
	mtape_data.lrec_rrc (mtape_data.lrec_rrcx).block_len = mtape_data.length;
	mtape_data.lrec_rrc (mtape_data.lrec_rrcx).lrec_no = mtape_data.log_record;
	mtape_data.lrec_rrc (mtape_data.lrec_rrcx).abs_byte = mtape_data.tot_bytes_processed;
	mtape_data.lrec_rrc (mtape_data.lrec_rrcx).byte_offset = mtape_data.processed + 1;
	mtape_data.lrec_rrcx = mtape_data.lrec_rrcx + 1;	/* increment history index */
	if mtape_data.lrec_rrcx > hbound (mtape_data.lrec_rrc.block_no, 1) then /* if at the top of RRC */
	     mtape_data.lrec_rrcx = lbound (mtape_data.lrec_rrc.block_no, 1); /* reset for bottom */

     end RECORD_HISTORY;
%page;
/* INIT_ENVIRONMENT - internal procedure to initialize the mtape_ working environment */

INIT_ENVIRONMENT: procedure;

	mtdp = addr (auto_mtd);			/* put data in temporary auto copy for now */
	unspec (auto_mtd) = "0"b;			/* Initialize structure */
	mtape_data.version = mtape_data_version_1;	/* set version */
	mtape_data.areap = null;			/* Now set some required fields */
	mtape_data.iocb_ptr = iocbp;			/* save IOCB ptr */
	mtape_data.atdp, mtape_data.opdp, mtape_data.cldp, mtape_data.dtdp, mtape_data.cmtdp = null;
	mtape_data.vs_head, mtape_data.vs_tail, mtape_data.vs_current = null;
	mtape_data.fi_head, mtape_data.fi_tail, mtape_data.fi_current = null;
	mtape_data.vs_mounted_tail, mtape_data.tape_infop, mtape_data.tlb = null;
	mtape_data.buf_ptrs (*), mtape_data.saved_pfm_info_ptr, mtape_data.last_ur_status_ptr = null;
	mtape_data.lab_bufp, mtape_data.cur_buf_ptr, mtape_data.log_record_ptr = null;
	mtape_data.pfm_name, mtape_data.abs_ans = "";
	call user_info_$process_type (i);		/* What kind of user is this anyway? */
	if i ^= 2 then				/* if not absentee.... */
	     mtape_data.user_type = "1"b;		/* set bit for interactive user */

	unspec (ai) = "0"b;				/* clear out area info */
	ai.version = area_info_version_1;		/* set up area info block */
	ai.control.extend = "1"b;
	ai.control.zero_on_alloc = "1"b;
	ai.owner = myname;
	ai.size = sys_info$max_seg_size;
	ai.version_of_area = area_info_version_1;
	ai.areap = null;
	call define_area_ (addr (ai), code);		/* get an area, for general use */
	if code ^= 0 then do;
	     call ATTACH_ERROR (code, "from define_area_");
	     return;
	end;
	mtape_data.areap = ai.areap;			/* copy area pointer */

/* Now allocate assorted info structures */

	allocate mtape_attach_info in (based_area) set (maip); /* allocate attach info structure */
	allocate mtape_open_info in (based_area) set (moip); /* allocate open info structure */
	allocate mtape_close_info in (based_area) set (mcip); /* allocate close info structure */
	allocate mtape_detach_info in (based_area) set (mdip); /* allocate detach info structure */
	allocate mtape_pfm_info in (based_area) set (mpfmip); /* allocate pfm info structure */

/* and do any necessary initialization */

	mtape_attach_info.version = mtape_attach_info_version_1; /* Set proper structure version */
	mtape_attach_info.version = mtape_attach_info_version_1;
	mtape_open_info.version = mtape_open_info_version_1;
	mtape_close_info.version = mtape_close_info_version_1;
	mtape_open_info.cs_ptr, mtape_close_info.cs_ptr = null;
	mtape_open_info.cal_ptr, mtape_close_info.cal_ptr = null;
	mtape_open_info.so_ptr, mtape_close_info.so_ptr = null;
	mtape_detach_info.version = mtape_detach_info_version_1;
	mtape_pfm_info.version = mtape_pfm_info_version_1;
	mtape_data.attach_info_ptr = maip;		/* Record ptrs in root structure */
	mtape_data.open_info_ptr = moip;
	mtape_data.close_info_ptr = mcip;
	mtape_data.detach_info_ptr = mdip;
	mtape_data.pfm_info_ptr = mpfmip;
	mtape_pfm_info.module_id = "";		/* Do any necessary blank filling */
	mtape_pfm_info.pfm_open_options.pfm_opt_flags (*).flag_name = "";
	mtape_pfm_info.pfm_open_options.pfm_opt_flags (*).flag_ant_name = "";
	mtape_pfm_info.pfm_open_options.pfm_opt_value_name (*) = "";
	mtape_pfm_info.pfm_open_options.pfm_opt_str_name (*) = "";
	mtape_pfm_info.pfm_close_options.pfm_opt_flags (*).flag_name = "";
	mtape_pfm_info.pfm_close_options.pfm_opt_flags (*).flag_ant_name = "";
	mtape_pfm_info.pfm_close_options.pfm_opt_value_name (*) = "";
	mtape_pfm_info.pfm_close_options.pfm_opt_str_name (*) = "";
	mtape_attach_info.pfm_prefix, mtape_attach_info.default_pfm_prefix = "";

     end INIT_ENVIRONMENT;
%page;
%include iocb;
%page;
%include mtape_data;
%page;
%include mtape_attach_info;

%include mtape_detach_info;

%include mtape_saved_pfm_info;
%page;
%include mtape_open_close_info;
%page;
%include mtape_pfm_info;

%include mtape_err_stats;
%page;
%include mtape_vol_set;
%page;
%include mtape_file_info;
%page;
%include mtape_constants;
%page;
%include area_info;
%page;
%include rcp_volume_formats;
%page;
%include iox_modes;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_buffer_status;

     end mtape_iox_;




		    mtape_mount_cntl_.pl1           12/01/87  0801.0rew 11/30/87  1323.7      236529



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




/****^  HISTORY COMMENTS:
  1) change(82-10-05,Bush), approve(), audit(), install():
     Created.
  2) change(83-12-01,Bush), approve(), audit(), install():
     Modified for performance improvements.
  3) change(85-10-03,GWMay), approve(85-10-03,MCR7282), audit(85-12-16,GDixon),
     install(85-12-17,MR12.0-1001):
     Added history comments in required format.  Modified the display that
     tells the recording density of the requested tape.  It was printing "CPI"
     instead of "BPI".
  4) change(87-08-17,GWMay), approve(87-09-09,MECR0006),
     audit(87-09-04,Farley), install(87-09-09,MR12.1-1101):
     Simplified the code that determines the type of tape being read.
     Added interrupt masking while modifying the iocb.
  5) change(87-10-19,GWMay), approve(87-10-19,MCR7779), audit(87-11-02,Farley),
     install(87-11-30,MR12.2-1006):
     Formally install MECR0006.
                                                   END HISTORY COMMENTS */


mtape_mount_cntl_: procedure;

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system. This
   *	module implements the mtape_ interface to RCP for mounting,
   *	demounting and volume switching tape volumes.
   *
*/

/*		ARGUMENT DATA		*/

dcl  arg_mtdp ptr;					/* Input pointer to the mtape_data structure */
dcl  arg_code fixed bin (35);				/* Return error code */
dcl  vs_arg_mtdp ptr;				/* Input pointer to the mtape_data structure */
dcl  vs_arg_code fixed bin (35);			/* Return error code */
dcl  vs_arg_volp ptr;				/* Pointer to VS structure of volume to mount */

/*		AUTOMATIC DATA		*/

dcl  (req_work_area_len, act_work_area_len, ws_max) fixed bin (19);
dcl  (rcp_state, ioi_id, err_count, num_waits) fixed bin;
dcl  ips_mask bit (36) aligned;
dcl  to_max fixed bin (71);
dcl  (code, vs_code, max_buf_len) fixed bin (35);
dcl  (dl, act_len) fixed bin (21);
dcl  susp_buf_ptrs (16) ptr;
dcl  lbuf_arrayp (1) ptr;
dcl  (i, j, n_susp_bufs, act_num) fixed bin;
dcl  (wa_ptr, tptr, volp) ptr;
dcl  rcp_comment char (256);
dcl  Stape_is_readable bit (1) aligned;
dcl  1 auto_tioi_info aligned like tioi_info;
dcl  1 auto_err_count aligned like tec;
dcl  1 atbs aligned like tbs;
dcl  1 event_info aligned like event_wait_info;

/*		CONSTANT DATA		*/

dcl  myname char (6) int static options (constant) init ("mtape_");
dcl  DISPOSITION bit (1) int static options (constant) init ("0"b);
dcl  SAVE_CUR_BUF bit (1) int static options (constant) init ("1"b);
dcl  DONT_SAVE_CUR_BUF bit (1) int static options (constant) init ("0"b);
dcl  WRITE_IO fixed bin int static options (constant) init (2);

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$resource_unavailable fixed bin (35) ext static;
dcl  error_table_$resource_reserved fixed bin (35) ext static;
dcl  error_table_$area_too_small fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;

/*		BUILTIN FUNCTIONS		*/

dcl  (addr, null, size, unspec) builtin;
dcl  (any_other, cleanup) condition;

/*		EXTERNAL ENTRIES		*/
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr);
dcl  mtape_util_$error entry options (variable);
dcl  mtape_util_$get_statistics entry (ptr, fixed bin (35));
dcl  mtape_util_$user_query entry (ptr, fixed bin, fixed bin (35));
dcl  mtape_io_$allocate_buffers entry (ptr, fixed bin (21), fixed bin (35));
dcl  mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35));
dcl  hcs_$assign_channel entry (fixed bin (71), fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  rcp_$attach entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl  rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin,
	fixed bin (19), fixed bin (71), fixed bin, fixed bin (35));
dcl  rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));

/*		BASED DATA		*/

dcl  1 save_wks based (tptr) aligned,			/* structure to save workspace */
       2 smtd like mtape_data,			/* for copying mtape_data structure out */
       2 n_susp_buffers fixed bin,			/* number of suspended buffers to copy out */
       2 susp_buffers (mtape_data.nbufs),
         3 stbs like tbs,				/* for the suspended buffers status */
         3 buffer char (max_buf_len) unaligned;		/* buffer data */

dcl  based_buffer char (dl) based;
%page;
/* mount - entry to mount a volume from the volume set */

mount: entry (arg_mtdp, arg_code);

	mtdp = arg_mtdp;				/* copy argument */
	maip = mtape_data.attach_info_ptr;
	arg_code, code = 0;				/* Reset return error code */
	if mtape_data.tape_infop = null then do;	/* if rcp data block not allocated.. */
	     call INIT_RCP_DATA;			/* do it now */
	     if code ^= 0 then
		go to mount_return;
	end;

	tape_info_ptr = mtape_data.tape_infop;		/* set tape info pointer */
	vs_ptr = mtape_data.vs_current;		/* get pointer to this volumes VS structure */
	tape_info.device_name = "";			/* set tape info that changes */
	tape_info.model = 0;
	tape_info.write_flag = mtape_attach_info.ring;
	tape_info.speed = mtape_attach_info.speed;
	if mtape_attach_info.density = 1600 then	/* set density */
	     tape_info.density = "00010"b;
	else if mtape_attach_info.density = 6250 then
	     tape_info.density = "00001"b;
	else if mtape_attach_info.density = 800 then
	     tape_info.density = "00100"b;
	else if mtape_attach_info.density = 556 then	/* MUST CHECK THESE *** */
	     tape_info.density = "01000"b;
	else tape_info.density = "10000"b;		/* 200 BPI */

	tape_info.volume_name = mtape_vol_set.volume_name;/* copy volume name */

	call ioa_ ("Mounting volume ""^a"" with ^[a^;no^] write ring", /* Let user know whats going on */
	     mtape_vol_set.volume_name, mtape_attach_info.ring);

/* Now request the volume mount from RCP */

	call rcp_$attach (DEVICE_TYPE (TAPE_DRIVE_DTYPEX), tape_info_ptr, mtape_data.mount_echan,
	     (mtape_vol_set.mount_comment), mtape_vol_set.rcp_id, code);
	if code ^= 0 then do;			/* some problem */
	     call mtape_util_$error (mtdp, code, "Error from rcp_$attach");
	     go to mount_return;
	end;

/* Now wait for the mount to complete */

	event_wait_channel.channel_id (1) = mtape_data.mount_echan;
	num_waits = 0;				/* initialize wait loop counter */
	rcp_state = 1;				/* set state to go through loop once */
	on cleanup call DETACH_ON_CLEANUP;		/* in case user does not want to wait.. */

	do while (rcp_state ^= 0);			/* do until mounted, or mount timer running */
	     rcp_comment = "";			/* initialize comment */
	     call rcp_$check_attach (mtape_vol_set.rcp_id, tape_info_ptr, rcp_comment, ioi_id,
		ws_max, to_max, rcp_state, code);
	     if rcp_comment ^= "" then		/* if we got something to report from RCP.. */
		call mtape_util_$error (mtdp, 0, "RCP comment: ^a", rcp_comment);
	     go to ATTACH_STATE (rcp_state);		/* do appropriate processing */

ATTACH_STATE (2):					/* long wait */
	     code = error_table_$resource_unavailable;	/* set appropriate error code */
ATTACH_STATE (3):					/* fatal error */
	     if mtape_attach_info.wait then		/* if we will wait for attachment */
		if (code = error_table_$resource_unavailable | /* and one of these */
		     code = error_table_$resource_reserved) then
		     if num_waits <= mtape_attach_info.wait_time then do; /* wait for 1 minute */
			call SLEEP;
			go to ATTACH_STATE (0);
		     end;
		     else do;			/* wait time exceeded */
			call mtape_util_$error (mtdp, code,
			     "Mount wait time of ^d minutes exceeded", mtape_attach_info.wait_time);
			go to mount_return;
		     end;
	     call mtape_util_$error (mtdp, code, "Error from rcp_$check_attach, while waiting for tape mount");
	     go to mount_return;

ATTACH_STATE (1):					/* short wait, go blocked */
	     call ipc_$block (addr (event_wait_channel), addr (event_info), code);
	     if code ^= 0 then do;			/* error from block */
		call mtape_util_$error (mtdp, code, "Error from ipc_$block, while waiting for tape mount");
		go to mount_return;
	     end;
ATTACH_STATE (0):					/* mount complete */
	end;

	revert cleanup;
	mtape_vol_set.mounts = mtape_vol_set.mounts + 1;	/* increment number of times mounted */
	if (tape_info.volume_type = Volume_blank |
	     tape_info.volume_type = Volume_unreadable) then do;
	     Stape_is_readable = "0"b;
	     mtape_vol_set.volume_density = mtape_attach_info.density;
	end;
	else do;
	     Stape_is_readable = "1"b;
	     mtape_vol_set.volume_density =
		MTAPE_VALID_DENSITIES (tape_info.volume_density);
	end;

	mtape_vol_set.volume_type = tape_info.volume_type;

	call ioa_ ("Mounted ^a volume ""^a"" ^[(recorded at ^d BPI), ^;^1s^]on device ^a",
	     Tape_volume_types (tape_info.volume_type),
	     tape_info.volume_name,
	     Stape_is_readable,
	     mtape_vol_set.volume_density,
	     tape_info.device_name);

	mtape_vol_set.device_name = tape_info.device_name;/* copy values from the tape_info structure */
	if Stape_is_readable then			/* only copy if valid name */
	     mtape_vol_set.volume_id = tape_info.volume_name;
	mtape_vol_set.mounted, mtape_vol_set.ever_mounted = "1"b; /* set mounted flags */
	if mtape_data.vs_mounted_tail ^= null then	/* thread in MRM chain, if possible */
	     mtape_data.vs_mounted_tail -> mtape_vol_set.mrm_vs_ptr = vs_ptr;
	mtape_vol_set.lrm_vs_ptr = mtape_data.vs_mounted_tail; /* thread the LRM chain */
	mtape_data.vs_mounted_tail = vs_ptr;
	mtape_vol_set.auth_required = tape_info.opr_auth;
	mtape_data.drives_in_use = mtape_data.drives_in_use + 1; /* one more drive used */
	call INIT_TIOI;				/* activate tape_ioi_ for this volume */
mount_return:
	arg_code = code;
	return;
%page;
/* demount - entry to demount the current volume of the volume set */

demount: entry (arg_mtdp, arg_code);

	mtdp = arg_mtdp;				/* copy argument */
	arg_code = 0;				/* reset return error code */
	vs_ptr = mtape_data.vs_current;		/* set the volume set members ptr */

/* Update error stats and deactivate tape_ioi_. Note: suspended buffers/work area have already been copied out */

	call mtape_util_$get_statistics (mtdp, code);	/* update error stats */
	tape_ioi_error_counts_ptr = addr (auto_err_count);
	tec.version = TEC_VERSION_1;			/* set version number */
	call tape_ioi_$deactivate (mtape_vol_set.tioi_id, tape_ioi_error_counts_ptr, code);
	err_count = mtape_vol_set.rel_error_stats.read.errors + mtape_vol_set.rel_error_stats.write.errors +
	     mtape_vol_set.rel_error_stats.orders.errors; /* RCP S/B changed to get all stats */

/* Now detach the device */

	call rcp_$detach (mtape_vol_set.rcp_id, DISPOSITION, err_count, (mtape_vol_set.demount_comment), code);
	mtape_vol_set.mounted = "0"b;			/* volume is no longer mounted */
	mtape_vol_set.device_name = "";		/* its no longer on a device */
	mtape_vol_set.rcp_id, mtape_vol_set.tioi_id = "0"b; /* Not needed now */
	mtape_data.drives_in_use = mtape_data.drives_in_use - 1; /* 1 less drive in use */
	unspec (mtape_vol_set.rel_error_stats) = "0"b;	/* init error stats, this mount */

/* Now thread this volume set member out of LRM and MRM chains */

	if mtape_vol_set.lrm_vs_ptr ^= null then do;
	     if mtape_vol_set.mrm_vs_ptr ^= null then	/* if in middle of mounted list.. */
		mtape_vol_set.mrm_vs_ptr -> mtape_vol_set.lrm_vs_ptr = mtape_vol_set.lrm_vs_ptr;
	end;
	else do;					/* lrm_vs_ptr = null => this was first vol mounted */
	     if mtape_vol_set.mrm_vs_ptr ^= null then	/* if there is a next volume */
		mtape_vol_set.mrm_vs_ptr -> mtape_vol_set.lrm_vs_ptr = null; /* make it first mounted */
	end;
	if mtape_vol_set.mrm_vs_ptr ^= null then do;
	     if mtape_vol_set.lrm_vs_ptr ^= null then	/* if in middle of mounted list.. */
		mtape_vol_set.lrm_vs_ptr -> mtape_vol_set.mrm_vs_ptr = mtape_vol_set.mrm_vs_ptr;
	end;
	else do;					/* mrm_vs_ptr = null => this was last vol mounted */
	     mtape_data.vs_mounted_tail = mtape_vol_set.lrm_vs_ptr;
	     if mtape_vol_set.lrm_vs_ptr ^= null then	/* if there is a previous volume.. */
		mtape_vol_set.lrm_vs_ptr -> mtape_vol_set.mrm_vs_ptr = null; /* make it last mounted */
	end;
	mtape_vol_set.lrm_vs_ptr, mtape_vol_set.mrm_vs_ptr = null;

	arg_code = code;

	return;
%page;
/* volume_switch - entry to perform volume switching on demand */

volume_switch: entry (vs_arg_mtdp, vs_arg_volp, vs_arg_code);

	mtdp = vs_arg_mtdp;				/* copy args */
	maip = mtape_data.attach_info_ptr;
	volp = vs_arg_volp;
	vs_arg_code = 0;
	if volp = null then do;			/* No vol_set structure */
	     call mtape_util_$user_query (mtdp, Q_NO_NEXT_VOLUME, vs_code); /* ask user for new volume */
	     if vs_code ^= 0 then			/* user did not want new volume */
		go to vs_return;
	     volp = mtape_data.vs_tail;		/* this will be the last allocated */
	end;
	if volp -> mtape_vol_set.version ^= mtape_vs_version_1 then do; /* is it a vol_set structure? */
	     vs_code = error_table_$unimplemented_version;/* no, set error code */
	     go to vs_return;
	end;
	vs_ptr = mtape_data.vs_current;		/* set for current volume */
	call mtape_io_$order (mtdp, "rwnw", 0, null, vs_code); /* rewind old volume */
	if vs_code ^= 0 then			/* can't win no_how */
	     go to vs_return;
	call SAVE_ACTIVATION (DONT_SAVE_CUR_BUF);	/* go save suspended buffers etc. */
	if vs_code ^= 0 then go to vs_return;
	if volp -> mtape_vol_set.mounted then do;	/* if required tape volume already mounted */
	     vs_ptr = volp;				/* set vol set for new volume */
	     call tape_ioi_$allocate_work_area (mtape_vol_set.tioi_id, size (mtape_data),
		act_work_area_len, wa_ptr, vs_code);
	     wa_ptr -> mtape_data = mtape_data;		/* move mtape_data to new work area */
	     mtdp = wa_ptr;				/* and reset pointer to same */
	     mtape_data.tioi_id = mtape_vol_set.tioi_id;	/* copy tape_ioi_ activation ID into work area */
	     mtape_data.vs_current = vs_ptr;		/* set current vs ptr */
	     call mtape_io_$order (mtdp, "rew", 0, null, vs_code); /* make sure he is rewound */
	     if vs_code ^= 0 then			/* can't win no_how */
		go to vs_return;
	end;
	else do;					/* volume not mounted */
	     if mtape_data.drives_in_use = mtape_attach_info.ndrives then do; /* must demount one first */
		call FIND_DEMOUNT_CANDIDATE;		/* go find volume to demount */
		call demount (mtdp, vs_code);		/* demount it */
		if vs_code ^= 0 then go to vs_return;
	     end;
	     mtape_data.vs_current = volp;		/* set current volume set ptr */
	     call mount (mtdp, vs_code);		/* go mount the requested volume */
	     if vs_code ^= 0 then go to vs_return;
	end;
	call RESTORE_ACTIVATION;			/* copy suspended buffers back in etc */
	if vs_code ^= 0 then go to vs_return;
	call mtape_data.pfm_init (mtdp, vs_code);	/* Go read the volume labels */

vs_return:
	vs_arg_code = vs_code;			/* copy return code */
	vs_arg_mtdp = mtdp;				/* reset value of mtdp */
	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	mtape_data.iocb_ptr -> iocb.attach_data_ptr = mtdp; /* and reset IOCB */
	call iox_$propagate (mtape_data.iocb_ptr);	/* propagate the IOCB change */
	call hcs_$reset_ips_mask (ips_mask, ips_mask);
	return;					/* and return to caller */
%page;
/* remount - external entry for remounting same volume after device attention condition */

remount: entry (arg_mtdp, vs_arg_code);

	mtdp = arg_mtdp;
	maip = mtape_data.attach_info_ptr;
	vs_ptr = mtape_data.vs_current;
	vs_arg_code = 0;

	call SAVE_ACTIVATION (SAVE_CUR_BUF);		/* save suspended buffers etc. */
	if vs_code ^= 0 then			/* quit on error */
	     go to remount_return;
	call demount (mtdp, vs_code);			/* demount current volume */
	if vs_code = 0 then				/* if all ok */
	     call mount (mtdp, vs_code);		/* remount the volume */
	if vs_code ^= 0 then
	     go to remount_return;
	call RESTORE_ACTIVATION;			/* copy suspended buffers back in */

remount_return:
	vs_arg_code = vs_code;			/* copy return code */
	vs_arg_mtdp = mtdp;				/* reset value of mtdp */
	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	mtape_data.iocb_ptr -> iocb.attach_data_ptr = mtdp; /* and reset IOCB */
	call iox_$propagate (mtape_data.iocb_ptr);	/* propagate the IOCB change */
	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	return;					/* and return to caller */
%page;
/* INIT_RCP_DATA - procedure to set up the tape_info structure */

INIT_RCP_DATA: proc;

	call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, size (tape_info) * 4, mtape_data.tape_infop);
	tape_info_ptr = mtape_data.tape_infop;
	tape_info.version_num = tape_info_version_3;	/* set version number */
	tape_info.tracks = mtape_attach_info.tracks;	/* set constant data */
	tape_info.system_flag = mtape_attach_info.system;

/* Create an event channel for mount requests */

	if mtape_data.mount_echan = 0 then do;		/* Only create if we hav'nt already */
	     call ipc_$create_ev_chn (mtape_data.mount_echan, code);
	     if code ^= 0 then do;			/* we loose altogether */
		call mtape_util_$error (mtdp, code, "Can't create ipc wait channel for mount requests.");
		return;
	     end;
	end;

     end INIT_RCP_DATA;

/* SLEEP - internal procedure to go to sleep for 1 minute and incrment the sleep loop counter */

SLEEP: proc;

	call timer_manager_$sleep (60, "11"b);		/* Wait for one minute. */
	num_waits = num_waits + 1;			/* increment number of loops */

     end SLEEP;

/* DETACH_ON_CLEANUP - int procedure to detach tape when cleanup condition is raised */

DETACH_ON_CLEANUP: proc;

dcl  clean_code fixed bin (35);

	call rcp_$detach (mtape_vol_set.rcp_id, "0"b, (0), "", clean_code); /* no frills */
	if clean_code ^= 0 then ;

     end DETACH_ON_CLEANUP;
%page;
/* INIT_TIOI - internal procedure to activate tape_ioi_ and create a work area */

INIT_TIOI: proc;

/* On first call, create a fast event channel for doing I/O if possible, if not create regular one */

	if mtape_data.io_echan = 0 then do;		/* if not already there create one */
	     call hcs_$assign_channel (mtape_data.io_echan, code);
	     if code ^= 0 then do;			/* if we didn't get fast channel... */
		call ipc_$create_ev_chn (mtape_data.io_echan, code);
		if code ^= 0 then do;		/* we loose altogether */
		     call mtape_util_$error (mtdp, code, "Can't create ipc wait channel for doing I/O.");
		     return;
		end;
	     end;
	end;

	tioi_info_ptr = addr (auto_tioi_info);		/* initialize the tape_ioi_ info structure */
	tioi_info.version = tioi_info_version_1;
	tioi_info.ioi_index = ioi_id;
	tioi_info.timeout_max = to_max;
	tioi_info.event_id = mtape_data.io_echan;
	tioi_info.workspace_max = ws_max;

	call tape_ioi_$activate (tape_info_ptr, tioi_info_ptr, mtape_vol_set.tioi_id, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code, "Calling tape_ioi_$activate");
	     return;
	end;

/*        Get workspace for permanent mtape_data storage. */

	req_work_area_len = size (mtape_data);

	call tape_ioi_$allocate_work_area (mtape_vol_set.tioi_id, req_work_area_len, act_work_area_len, wa_ptr, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code, "Calling tape_ioi_$allocate_work_area");
	     return;
	end;
	if act_work_area_len ^= req_work_area_len then do;
	     code = error_table_$area_too_small;	/* A different code should be used. */
	     call mtape_util_$error (mtdp, code,
		"Can't get a big enough work area, need ^d words, tape_ioi_ will give us ^d words.",
		req_work_area_len, act_work_area_len);
	     return;
	end;
	wa_ptr -> mtape_data = mtape_data;		/* copy the data into the work area */
	mtdp, arg_mtdp = wa_ptr;			/* now everyone will look in work area */
	mtape_data.tioi_id = mtape_vol_set.tioi_id;	/* copy for fast reference */

	ips_mask = ""b;
	on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
	call hcs_$set_ips_mask ("0"b, ips_mask);

	mtape_data.iocb_ptr -> iocb.attach_data_ptr = mtdp; /* reset iocb */
	call iox_$propagate (mtape_data.iocb_ptr);	/* let iox_ know about iocb change */

	call hcs_$reset_ips_mask (ips_mask, ips_mask);
	return;

     end INIT_TIOI;
%page;
/* FIND_DEMOUNT_CANDIDATE - subroutine to find a volume to demount on a LRU basis */

FIND_DEMOUNT_CANDIDATE: proc;

	if mtape_attach_info.ndrives = 1 then		/* if we have only 1 tape drive, must demount */
	     return;				/* current volume. mtape_data.vs_current already set */
	fi_ptr = mtape_data.fi_current;		/* get current file_info  pointer */

/* Now thread the LRM chain until we find the head */

	do vs_ptr = mtape_data.vs_mounted_tail repeat mtape_vol_set.lrm_vs_ptr
	     while (mtape_vol_set.lrm_vs_ptr ^= null);
	end;
	if vs_ptr = mtape_file_info.begin_vs_ptr then	/* if the selected volume is 1st file section */
	     if mtape_vol_set.mrm_vs_ptr ^= null then	/* and there is a more recent mount */
		vs_ptr = mtape_vol_set.mrm_vs_ptr;	/* use the next LRU volume */
	mtape_data.vs_current = vs_ptr;		/* finished, he is the guy to demount */

     end FIND_DEMOUNT_CANDIDATE;
%page;
/* SAVE_ACTIVATION - internal procedure to save suspended buffers, deallocate buffers and work area */

SAVE_ACTIVATION: proc (cur_buf_disp);

dcl  cur_buf_disp bit (1);

	call get_temp_segment_ (myname, tptr, vs_code);	/* get temp seg to copy stuff into */
	if vs_code ^= 0 then			/* can't get it, give up */
	     return;
	save_wks.smtd = mtape_data;			/* copy the mtape_data structure out */
	mtdp = addr (save_wks.smtd);			/* and switch pointer */
	max_buf_len = mtape_data.block_size;		/* set the max buffer size */
	atbs.version = TBS_VERSION_1;			/* set version */
	if cur_buf_disp = SAVE_CUR_BUF & mtape_data.last_io = WRITE_IO then do;
	     call tape_ioi_$list_buffers (mtape_vol_set.tioi_id, READY_STATE, susp_buf_ptrs, n_susp_bufs, vs_code);
	     if vs_code ^= 0 then
		return;
	     call tape_ioi_$buffer_status (mtape_vol_set.tioi_id, susp_buf_ptrs (n_susp_bufs), addr (atbs), vs_code);
	     if vs_code ^= 0 then return;
	     save_wks.susp_buffers (1).stbs = atbs;	/* save buffer status */
	     dl = atbs.data_len;			/* set data length */
	     save_wks.susp_buffers (1).buffer = susp_buf_ptrs (n_susp_bufs) -> based_buffer; /* and data */
	     j = 1;				/* set offset */
	end;
	else j = 0;
	call tape_ioi_$list_buffers (mtape_vol_set.tioi_id, SUSPENDED_STATE, susp_buf_ptrs, n_susp_bufs, vs_code);
	if vs_code ^= 0 then
	     return;
	save_wks.n_susp_buffers = n_susp_bufs + j;
	if n_susp_bufs ^= 0 then do;			/* if we have suspended buffers, copy them out too */
	     do i = 1 to n_susp_bufs;
		j = j + 1;			/* increment saved buffer index */
		call tape_ioi_$buffer_status (mtape_vol_set.tioi_id, susp_buf_ptrs (i), addr (atbs), vs_code);
		if vs_code ^= 0 then return;
		save_wks.susp_buffers (j).stbs = atbs;	/* save buffer status */
		dl = atbs.data_len;			/* set data length */
		save_wks.susp_buffers (j).buffer = susp_buf_ptrs (i) -> based_buffer; /* and data */
		call tape_ioi_$set_buffer_ready (mtape_vol_set.tioi_id, susp_buf_ptrs (i), vs_code);
		if vs_code ^= 0 then return;
	     end;
	end;
	call mtape_util_$get_statistics (mtdp, vs_code);	/* update error stats */
	call tape_ioi_$deallocate (mtape_vol_set.tioi_id, vs_code); /* deallocate all buffers and work area */
	all_buf_ptrs (*) = null;			/* reset buffer pointers */
	all_buf_lens (*) = 0;			/* and buffer lengths */
	mtape_data.lab_bufp = null;			/* set label buffer to null too */
	mtape_data.phy_file, mtape_data.phy_block = 0;	/* reset position counters */

     end SAVE_ACTIVATION;
%page;
/* RESTORE_ACTIVATION - internal procedure to allocate buffers and copy suspended buffers to new buffers. */

RESTORE_ACTIVATION: proc;

	call tape_ioi_$allocate_buffers (mtape_data.tioi_id, /* allocate and reserve a label buffer */
	     mtape_data.lab_buf_len, 1, act_len, act_num, lbuf_arrayp, vs_code);
	if vs_code ^= 0 then return;
	call tape_ioi_$reserve_buffer (mtape_data.tioi_id, lbuf_arrayp (1), vs_code); /* reserve the buffer */
	if vs_code ^= 0 then return;
	mtape_data.lab_bufp = lbuf_arrayp (1);		/* copy label buffer ptr */

/* Allocate data buffers and copy any suspended buffers back in 1 at a time */

	if mtape_data.nbufs > 0 then do;		/* if we had buffers allocated before, do it now */
	     call mtape_io_$allocate_buffers (mtdp, mtape_data.block_size, vs_code);
	     if vs_code ^= 0 then return;
	     if save_wks.n_susp_buffers ^= 0 then do;
		do i = 1 to save_wks.n_susp_buffers;	/* do each buffer */
		     tbs_ptr = addr (susp_buffers (i).stbs);
		     all_buf_lens (i), dl = tbs.data_len; /* copy length */
		     all_buf_ptrs (i) -> based_buffer = addr (susp_buffers (i).buffer) -> based_buffer; /* copy data */

		end;
		mtape_data.cur_buf_idx = save_wks.n_susp_buffers + 1; /* set up the current buffer index */
	     end;
	end;
	call release_temp_segment_ (myname, tptr, (0));	/* release our temp segment */

     end RESTORE_ACTIVATION;
%page;
%include mtape_data;
%page;
%include mtape_attach_info;

%include mtape_detach_info;
%page;
%include mtape_vol_set;
%page;
%include mtape_file_info;
%page;
%include mtape_err_stats;

%include tape_ioi_info;
%page;
%include rcp_tape_info;
%include rcp_volume_formats;
%page;
%include mtape_constants;
%include rcp_resource_types;
%page;
%include event_wait_channel;
%include event_wait_info;
%page;
%include iocb;
%page;
%include tape_ioi_dcls;
%include tape_ioi_error_counts;
%page;
%include tape_ioi_buffer_status;

     end mtape_mount_cntl_;




		    mtape_parse_.pl1                12/17/86  0925.7r w 12/17/86  0830.0      353619



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
mtape_parse_: procedure;

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 10/05/82
   *	Modified by J. A. Bush 6/15/83 to use process_arguments_ for parsing
   *	Modified by J. A. Bush 11/06/83 to fix bug causing inconsistent
   *	opening modes in mtape_ and the selected PFM.
   *	Modified: October 1984 by Greg Texada for basic gullibility checking of the open description.
   *      Modified: November 1984 by Greg Texada to enforce data set naming specs for ANSI/IBM.
*/

/*		ARGUMENT DATA		*/

dcl  arg_mtdp ptr;					/* Pointer to mtape_data */
dcl  arg_options (*) char (*) varying;			/* Input options array */
dcl  arg_open_mode fixed bin;				/* Opening mode */
dcl  arg_code fixed bin (35);				/* Return error code */

/*		AUTOMATIC DATA		*/

dcl  code fixed bin (35);
dcl  (vname, cname, cspeed, cpos, ulab_name) char (32);
dcl  (pos_ref_name, neg_ref_name, vol_ref_name) char (32) varying;
dcl  (rpvap, ap_areap, ad_cs_ptr, def_ptr, desc_ptr, cvlp, saved_opt_ptr) ptr;
dcl  (i, j, vx, nxt_vx, cvx, str_len, spos, cs, all_len, open_mode) fixed bin;
dcl  opn_desc_len fixed bin (21);
dcl  term bit (1) aligned;
dcl  found_opts bit (36) aligned;
dcl  1 ai like area_info aligned;

/*		CONSTANT DATA		*/

dcl  myname char (6) int static options (constant) init ("mtape_");

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$bad_name fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;
dcl  sys_info$max_seg_size fixed bin (35) ext static;

/*		BUILTIN FUNCTIONS		*/

dcl  (addr, char, copy, hbound, index, length, ltrim, mod, null, rtrim, search, substr, unspec, verify) builtin;

/*		EXTERNAL ENTRIES		*/

dcl  resource_info_$canonicalize_name entry (char (*), char (*), char (*), fixed bin (35));
dcl  mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr);
dcl  mtape_util_$error entry options (variable);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  process_arguments_$argument_array entry (char (*), fixed bin, (*) char (*) varying,
	ptr, ptr, ptr, fixed bin (35));
dcl  process_arguments_$get_option_value entry options (variable);
dcl  process_arguments_$cv_result_to_linear_form entry (ptr, ptr, char (*) varying, fixed bin (35));
dcl  process_arguments_$get_definition entry (char (*) varying, ptr, ptr, fixed bin (35));
dcl  process_arguments_$get_reference_name entry (ptr, char (*) varying, char (*) varying, char (*) varying);
dcl  process_arguments_$free_print_vector_array entry (ptr);
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  release_area_ entry (ptr);
dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);

/*		BASED DATA		*/

dcl  based_area area based (mtape_data.areap);
dcl  ap_area area based (ap_areap);
dcl  desc_string char (1024) varying based (desc_ptr);
dcl  open_desc char (mtape_data.opd_len) varying based (mtape_data.opdp);
dcl  vb_str char (128) varying based;

dcl  1 saved_options aligned based (saved_opt_ptr),	/* template for allocation of last saved option array */
       2 nopts fixed bin,				/* number of options in array */
       2 saved_option (all_len refer (saved_options.nopts)) char (32) varying;
%page;
/*	mtape_parse_$attach - entry to parse up the attach options list
   *
   *	Usage:
   *
   *	dcl mtape_parse_$attach entry (ptr, (*) char (*) varying, fixed bin (35));
   *	call mtape_parse_$attach (mtdp, options, code);
   *
   *	where:
   *	1. mtdp
   *	     is a pointer to the mtape_data structure defined by
   *	     mtape_data.incl.pl1. (INPUT)
   *	2. options
   *	     is the array of attach options received from
   *	     iox_$attach_(name ptr). (INPUT)
   *	3. code
   *	     is a standard system error code. (OUTPUT)
*/

attach: entry (arg_mtdp, arg_options, arg_code);

	call SETUP;				/* go setup our enviornment */
	call ALLOCATE_AP_AREA;			/* allocate area for process_arguments_ to use */
	call PROC_ARGS (myname || ".attach", ad_cs_ptr);	/* Let process_arguments_ do the work */

/* Now lets get the option values */

	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
	     DISPLAY, mtape_attach_info.display, ERROR, mtape_data.display_errors,
	     LABEL, mtape_attach_info.labeled, RING, mtape_attach_info.ring,
	     SYSTEM, mtape_attach_info.system, WAIT, mtape_attach_info.wait); /* get the switch flags first */

	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
	     DEFAULT_VOL_TYPE, mtape_attach_info.default_pfm_prefix,
	     DENSITY, mtape_attach_info.density, DEVICE, mtape_attach_info.ndrives,
	     TRACK, mtape_attach_info.tracks, VOL_TYPE, mtape_attach_info.pfm_prefix,
	     WAIT_TIME, mtape_attach_info.wait_time);	/* get other options */

	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
	     SPEED, cspeed);			/* get the speed values if any */
	if found_opts ^= "0"b then do;		/* if some speeds specified */
	     term = "0"b;
	     spos = 1;
	     str_len = length (rtrim (cspeed));
	     do while (^term);
		cs = search (substr (cspeed, spos), ","); /* more than one specified */
		if cs = 0 then do;			/* last one */
		     term = "1"b;
		     cs = (str_len - spos) + 1;	/* set for end of string */
		end;
		else cs = cs - 1;
		if substr (cspeed, spos, cs) = "75" then/* 75 IPS specified */
		     mtape_attach_info.speed = mtape_attach_info.speed | "100"b;
		else if substr (cspeed, spos, cs) = "125" then /* 125 IPS specified */
		     mtape_attach_info.speed = mtape_attach_info.speed | "010"b;
		else if substr (cspeed, spos, cs) = "200" then /* 200 IPS specified */
		     mtape_attach_info.speed = mtape_attach_info.speed | "001"b;
		spos = spos + cs + 1;		/* increment for next search */
	     end;
	end;

/* Now lets get the volume sequence list and any mount comments */

	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
	     VOLUME, option_value_list_ptr, COMMENT, cvlp);

	if ^substr (found_opts, 1, 1) then do;		/* need at least one volume */
	     code = error_table_$noarg;
	     call mtape_util_$error (mtdp, code,
		"At least one volume name must be specified");
	     go to non_local_return;			/* abort attachment */
	end;
	do i = 1 to option_value_list.number_of_values;	/* process all volumes */
	     vname = option_value_list.value (i).ptr -> vb_str; /* get volume name */
	     vx = option_value_list.value (i).vector_idx; /* and index into the rpva */
	     if i = option_value_list.number_of_values then /* if at end */
		nxt_vx = -1;			/* indicate so */
	     else nxt_vx = option_value_list.value (i + 1).vector_idx; /* not end get next index */
	     call resource_info_$canonicalize_name (VOLUME_TYPE (TAPE_VOL_VTYPEX), vname, cname, code);
	     if code ^= 0 then do;			/* bad volume name */
		call mtape_util_$error (mtdp, code,
		     "Cannot canonicalize volume name ""^a""", vname);
		arg_code = code;			/* save code, but continue to check description */
		go to vol_end;			/* get the next argument */
	     end;
	     call mtape_util_$alloc (mtdp, MTAPE_ALLOC_VS, mtape_data.vs_tail, 0, vs_ptr);
	     mtape_data.vs_tail = vs_ptr;		/* Link this VS structure in */
	     if mtape_data.vs_head = null then		/* if this is first volume set member */
		mtape_data.vs_current, mtape_data.vs_head = vs_ptr; /* set the link head too */
	     mtape_vol_set.volume_name = cname;		/* set the canonical volume name */
	     if substr (found_opts, 2, 1) then do;	/* if we have some comments */
		term = "0"b;
		do j = 1 to cvlp -> option_value_list.number_of_values while (^term);
		     cvx = cvlp -> option_value_list.value (j).vector_idx; /* get option index */
		     if cvx > vx then		/* check position of comment */
			if (nxt_vx ^= -1 & cvx < nxt_vx) | nxt_vx = -1 then do;
			     term = "1"b;		/* set terminate condition and copy comment */
			     mtape_vol_set.mount_comment = cvlp -> option_value_list.value (j).ptr -> vb_str;
			end;
		end;
	     end;
vol_end:
	end;
%page;
/* Now build a printable attach description, get volume sequence list first */

	desc_string = myname;			/* start off the attach description with I/O module name */
	vol_ref_name = GET_REF_NAME (VOLUME);		/* get the volume option ref name */
	do vs_ptr = mtape_data.vs_head repeat mtape_vol_set.next_vs_ptr while (vs_ptr ^= null);
	     if substr (mtape_vol_set.volume_name, 1, 1) = "-" then /* if volume name begins with "-" */
		desc_string = rtrim (desc_string) || " " || vol_ref_name; /* add volume qualifier */
	     desc_string = rtrim (desc_string) || " " || mtape_vol_set.volume_name;
	end;

/* now add control args with values */

	desc_string = rtrim (desc_string) || " " || GET_REF_NAME (DENSITY);
	desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.density));
	desc_string = rtrim (desc_string) || " " || GET_REF_NAME (TRACK);
	desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.tracks));
	if mtape_attach_info.speed ^= "0"b then do;	/* only display speed if one specified */
	     desc_string = rtrim (desc_string) || " " || GET_REF_NAME (SPEED);
	     desc_string = rtrim (desc_string) || " " || cspeed;
	end;
	desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (RING, mtape_attach_info.ring);
	desc_string = rtrim (desc_string) || " " || GET_REF_NAME (DEVICE);
	desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.ndrives));
	desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (LABEL, mtape_attach_info.labeled);
	if mtape_attach_info.pfm_prefix ^= "" then do;	/* put in PFM prefix only if given by user */
	     desc_string = rtrim (desc_string) || " " || GET_REF_NAME (VOL_TYPE);
	     desc_string = rtrim (desc_string) || " " || mtape_attach_info.pfm_prefix;
	end;
	desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (WAIT, mtape_attach_info.wait);
	if mtape_attach_info.wait then do;		/* if we are waiting, put in wait time too */
	     desc_string = rtrim (desc_string) || " " || GET_REF_NAME (WAIT_TIME);
	     desc_string = rtrim (desc_string) || " " || ltrim (char (mtape_attach_info.wait_time));
	end;
	desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (DISPLAY, mtape_attach_info.display);
	desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (SYSTEM, mtape_attach_info.system);
	desc_string = rtrim (desc_string) || " " || GET_BIN_REF_NAME (ERROR, mtape_data.display_errors);

	call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, length (desc_string) + 4, mtape_data.atdp);
	mtape_data.atdp -> desc_string = desc_string;	/* move attach description to perm storage */

non_local_return:					/* target of non-local gotos */
	if arg_code = 0 then			/* if previous error was not saved */
	     arg_code = code;
	if ap_areap ^= null then			/* if arg processing area defined.. */
	     call release_area_ (ap_areap);		/* release it */
	if ad_cs_ptr ^= null then			/* if attach/detach control print_vector allocated */
	     call process_arguments_$free_print_vector_array (ad_cs_ptr); /* free it */
	return;					/* end of attach entry */
%page;
/* open - entry to parse open description */

open: entry (arg_mtdp, arg_options, arg_open_mode, arg_code);

	call SETUP;				/* go setup our enviornment */
	open_mode = arg_open_mode;			/* copy opening mode arg */
	call OPTIMIZE_PARSE (mtape_open_info.so_ptr);	/* Do we have to call process_arguments_? */
	call ALLOCATE_AP_AREA;			/* yes, allocate area for process_arguments_ to use */
	unspec (mtape_open_info.init_to_zero) = "0"b;	/* initialize open info structure */
	mtape_open_info.comment, mtape_open_info.expiration, mtape_open_info.file_format = "";
	mtape_open_info.recording_mode, mtape_open_info.file_name, mtape_open_info.replace_id = "";
	mtape_open_info.pfm_opt_str (*) = "";
	ulab_name = "";
	mtape_open_info.open_mode = open_mode;		/* copy opening mode */

/* Let process_arguments_ do the work */

	call PROC_ARGS (myname || ".open." || mtape_attach_info.pfm_prefix, mtape_open_info.cs_ptr);
	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts, /* get option values */
	     COMMENT, mtape_open_info.comment, DISPLAY, mtape_open_info.display,
	     BLOCK, mtape_open_info.block_length, RECORD, mtape_open_info.record_length,
	     NUMBER, mtape_open_info.seq_number, REPLACE, mtape_open_info.replace_id,
	     NAME, mtape_open_info.file_name, MODE, mtape_open_info.recording_mode,
	     FORMAT, mtape_open_info.file_format, EXPIRES, mtape_open_info.expiration,
	     DEFAULT_SPAN_RLEN, mtape_open_info.default_span_rlen,
	     DEFAULT_VAR_RLEN, mtape_open_info.default_var_rlen,
	     DEFAULT_FIX_RLEN, mtape_open_info.default_fix_rlen,
	     APPEND, mtape_open_info.append, EXTEND, mtape_open_info.extend,
	     FORCE, mtape_open_info.force, LAST_FILE, mtape_open_info.last_file,
	     NEXT_FILE, mtape_open_info.next_file, MODIFY, mtape_open_info.modify,
	     LABEL_ENTRY, ulab_name);
	if ulab_name ^= "" then do;			/* if user label reoutine specified, convert it */
	     mtape_open_info.user_label = cv_entry_ (ulab_name, null, code);
	     if code ^= 0 then do;
		call mtape_util_$error (mtdp, code,
		     "^/Attempting to convert the user label entry ""^a"".", ulab_name);
		go to non_local_return;
	     end;
	     mtape_open_info.label_entry_present = "1"b;	/* set flag for PFM */
	end;

/* Now let's look at the open info and check some basic requirements.					*/

	if mtape_attach_info.pfm_prefix = "ibm" then do;
	     if ^(valid_IBM_open_args ()) then goto non_local_return;
	end;
	else if mtape_attach_info.pfm_prefix = "ansi" then do;
	     if ^(valid_ANSI_open_args ()) then goto non_local_return;
	end;


/* Now lets get PFM dependent options */

	call GET_PFM_OPTIONS (addr (mtape_open_info.pfm_args), addr (mtape_pfm_info.pfm_open_options));

/* generate printable open description and move it to perm storage */

	call process_arguments_$cv_result_to_linear_form (def_ptr, rpvap, desc_string, code);
	if mtape_data.opdp ^= null then do;		/* must free desc. first */
	     free open_desc in (based_area);
	     mtape_data.opdp = null;
	end;
	mtape_data.opd_len = length (desc_string) + 64;
	call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, mtape_data.opd_len, mtape_data.opdp);
	open_desc = rtrim (iox_modes (mtape_open_info.open_mode)) || " " || desc_string;
	call SAVE_OPTIONS (mtape_open_info.so_ptr);	/* save current option array */
	if ap_areap ^= null then			/* if arg processing area defined.. */
	     call release_area_ (ap_areap);		/* release it */

	return;
%page;
/* close - entry to parse close description */

close: entry (arg_mtdp, arg_options, arg_code);

	call SETUP;				/* set up our enviornment */
	open_mode = 0;				/* indicate not open entry to optimize routine */
	call OPTIMIZE_PARSE (mtape_close_info.so_ptr);	/* Do we have to call process_arguments_? */
	call ALLOCATE_AP_AREA;			/* yes, allocate area for process_arguments_ to use */
	unspec (mtape_close_info.init_to_zero) = "0"b;	/* initialize close info structure */
	mtape_close_info.comment, mtape_close_info.pfm_opt_str (*) = "";

/* Let process_arguments_ do the work */

	call PROC_ARGS (myname || ".close." || mtape_attach_info.pfm_prefix, mtape_close_info.cs_ptr);

/* Now lets get the option values */

	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
	     COMMENT, mtape_close_info.comment, DISPLAY, mtape_close_info.display,
	     CLOSE_POSITION, cpos);
	if cpos = BOF then				/* position to beginning of file on closing */
	     mtape_close_info.position = 1;
	else if cpos = EOF then			/* position to end of file on closing */
	     mtape_close_info.position = 2;
	else if cpos = LEAVE then			/* leave the tape positioned where it is */
	     mtape_close_info.position = 0;

/* Now lets get PFM dependent options */

	call GET_PFM_OPTIONS (addr (mtape_close_info.pfm_args), addr (mtape_pfm_info.pfm_close_options));

/* generate printable close description and move it to perm storage */

	call process_arguments_$cv_result_to_linear_form (def_ptr, rpvap, desc_string, code);
	call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, length (desc_string) + 4, mtape_data.cldp);
	mtape_data.cldp -> desc_string = desc_string;
	call SAVE_OPTIONS (mtape_close_info.so_ptr);	/* save current option array */
	if ap_areap ^= null then			/* if arg processing area defined.. */
	     call release_area_ (ap_areap);		/* release it */

	return;
%page;
/* detach - entry to parse detach description */

detach: entry (arg_mtdp, arg_options, arg_code);

	call SETUP;				/* go setup our enviornment */
	call ALLOCATE_AP_AREA;			/* allocate area for process_arguments_ to use */
	mdip = mtape_data.detach_info_ptr;		/* set detach info ptr also */
	unspec (mtape_detach_info) = "0"b;		/* initialize detach info structure */
	mtape_detach_info.version = mtape_detach_info_version_1; /* set proper version */
	mtape_detach_info.comment = "";

	call PROC_ARGS (myname || ".detach", ad_cs_ptr);	/* Let process_arguments_ do the work */

/* Now lets get the option values */

	call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
	     COMMENT, mtape_detach_info.comment, DISPLAY, mtape_detach_info.display,
	     REWIND, mtape_detach_info.unload);
	mtape_detach_info.unload = ^mtape_detach_info.unload; /* invert flag for correct meaning */

/* generate printable detach description and move it to perm storage */

	call process_arguments_$cv_result_to_linear_form (def_ptr, rpvap, desc_string, code);
	call mtape_util_$alloc (mtdp, MTAPE_ALLOC_STR, null, length (desc_string) + 4, mtape_data.dtdp);
	mtape_data.dtdp -> desc_string = desc_string;
	if ap_areap ^= null then			/* if arg processing area defined.. */
	     call release_area_ (ap_areap);		/* release it */

	return;
%page;
/* OPTIMIZE_PARSE - internal procedure to determine if open and close descriptions
   really need to be passed by process_arguments_. If one open or close description has
   already been parsed, and if the arg_option array passed by iox_ is exactly the same or
   if the only difference is the "-name" or "-number" arg then do not expend the
   overhead to call process_arguments_. Instead use the already initialized
   open or close info structure, changing the file_name and/or seq_number args as
   is appropriate */

OPTIMIZE_PARSE: proc (sop);

dcl  sop ptr;
dcl  (saved_name, saved_number) char (32);
dcl  i fixed bin;

	if sop = null then				/* if first open or close, */
	     return;				/* must call process_arguments_ */
	saved_opt_ptr = sop;			/* get ptr to allocated saved_options */
	if hbound (arg_options, 1) ^= saved_options.nopts then /* if differenct number of opts.. */
	     return;				/* call process_arguments_ */
	if open_mode ^= 0 then			/* if parsing open description */
	     if open_mode ^= mtape_open_info.open_mode then /* but not opeing for same mode */
		return;				/* let process_arguments_ handle it */
	saved_name, saved_number = "";		/* init key variables */
	term = "0"b;
	do i = 1 to hbound (arg_options, 1) while (^term);/* go through all options */
	     if arg_options (i) ^= saved_options.saved_option (i) then /* if options not equal */
		if arg_options (i - 1) = "-name" |	/* if current option is file name arg */
		     arg_options (i - 1) = "-nm" then
		     saved_name = arg_options (i);	/* save the name */
		else if arg_options (i - 1) = "-number" | /* if current option is file seq number */
			arg_options (i - 1) = "-nb" then
		     saved_number = arg_options (i);	/* save the file seq number */
		else term = "1"b;			/* otherwise, found real mismatch */
	end;
	if term then				/* if we found mismatch, */
	     return;				/* call process_arguments_ */
	if saved_name ^= "" then do;
	     mtape_open_info.file_name = saved_name;	/* copy file name */
	     call INSERT_STRING ("-name", "-nm", saved_name); /* update open description */
	end;
	if saved_number ^= "" then do;		/* if we found different seq number */
	     mtape_open_info.seq_number = cv_dec_check_ (saved_number, code);
	     if code ^= 0 then			/* if invalid number */
		return;				/* let process_arguments_ put out diagnostic */
	     if mtape_open_info.seq_number > 9999 then	/* if seq number to large */
		return;				/* let process_arguments_ put out diagnostic */
	     call INSERT_STRING ("-number", "-nb", saved_number); /* update open description */
	end;

	go to non_local_return;			/* optimization worked, arg processing complete */

     end OPTIMIZE_PARSE;
%page;
/* SAVE_OPTIONS - internal procedure to save current iox_ open array for open and close */

SAVE_OPTIONS: proc (sop);

dcl  sop ptr;

	if sop ^= null then				/* if we had a saved option array before */
	     free sop -> saved_options in (based_area);	/* free it first */
	all_len = hbound (arg_options, 1);		/* get number of options to allocate */
	allocate saved_options in (based_area) set (saved_opt_ptr);
	saved_options.saved_option = arg_options;	/* copy them in */
	sop = saved_opt_ptr;			/* and set the pointer */

     end SAVE_OPTIONS;

/* INSERT_STRING - internal procedure  to update open description with new values */

INSERT_STRING: proc (prim_ref, alt_ref, ins_str);

dcl  (prim_ref, alt_ref, ins_str) char (*);
dcl  (ref_pos, arg_start, arg_len, ins_str_len) fixed bin;

	opn_desc_len = length (open_desc);		/* set open desc length variable */
	ins_str_len = length (rtrim (ins_str));		/* get string length to insert */
	ref_pos = index (open_desc, prim_ref);		/* get start position of reference name */
	if ref_pos = 0 then do;			/* couldn't find primary ref name */
	     ref_pos = index (open_desc, alt_ref);	/* try alternate */
	     if ref_pos = 0 then return;		/* could not find it either, forget it */
	     ref_pos = ref_pos + length (alt_ref);	/* go to end of ref name */
	end;
	else ref_pos = ref_pos + length (prim_ref);	/* go to end of ref name */
	arg_start = verify (substr (open_desc, ref_pos), " "); /* find beginning of arg */
	arg_start = (arg_start + ref_pos) - 1;		/* make it absolute position */
	arg_len = search (substr (open_desc, arg_start), " "); /* get length */
	if arg_len = 0 then				/* if at end of string */
	     arg_len = (opn_desc_len - arg_start) + 1;	/* figure length to end of string */
	else arg_len = arg_len - 1;
	if arg_start = opn_desc_len then do;		/* if appending to end of string */
	     if ins_str_len > arg_len then		/* if new string is longer than old */
		open_desc = open_desc || copy (" ", ins_str_len - arg_len); /* grow string length */
	     substr (open_desc, arg_start) = rtrim (ins_str);
	end;
	else substr (open_desc, arg_start) = rtrim (ins_str) || substr (open_desc, arg_start + arg_len);

     end INSERT_STRING;
%page;
/* PROC_ARGS - internal procedure to get arg processing definition ptr and call in to process the args */

PROC_ARGS: proc (def_name, ctl_ptr);

dcl  def_name char (*) varying;
dcl  ctl_ptr ptr;					/* ptr to arg processing control structure */

	if ctl_ptr = null then do;			/* if first time, get ctl structure */
	     call process_arguments_$get_definition (def_name, mtape_data.areap, ctl_ptr, code); /* get ptr to definition */
	     if code ^= 0 then			/* can't find it */
		go to non_local_return;		/* take non-local goto and return */
	end;
	def_ptr = ctl_ptr;				/* save the ctl ptr */
	call process_arguments_$argument_array ((def_name), 0, arg_options, def_ptr, ap_areap, rpvap, code);
	if code ^= 0 then				/* if error */
	     go to non_local_return;			/* take non-local goto and return */

     end PROC_ARGS;

/* GET_REF_NAME - internal procedure to return an options reference name, given the option name */

GET_REF_NAME: proc (opt_name) returns (char (32) varying);

dcl  opt_name char (*) varying;

	call process_arguments_$get_reference_name (def_ptr, opt_name, pos_ref_name, neg_ref_name);
	return (pos_ref_name);			/* return name to caller */

     end GET_REF_NAME;

/* GET_BIN_REF_NAME - internal procedure to return a binary options positive or negative reference name,
   given the option name and the binary state of the option */

GET_BIN_REF_NAME: proc (opt_name, bin_state) returns (char (32) varying);

dcl  opt_name char (*) varying;
dcl  bin_state bit (1) aligned;

	call process_arguments_$get_reference_name (def_ptr, opt_name, pos_ref_name, neg_ref_name);
	if bin_state then				/* if option is "on" */
	     return (pos_ref_name);			/* return positive name to caller */
	else return (neg_ref_name);			/* switch is off, return neg name */

     end GET_BIN_REF_NAME;
%page;
/* SETUP - internal procedure to set up our enviornment */

SETUP: proc;

	mtdp = arg_mtdp;
	maip = mtape_data.attach_info_ptr;		/* get info ptrs set up */
	moip = mtape_data.open_info_ptr;
	mcip = mtape_data.close_info_ptr;
	mpfmip = mtape_data.pfm_info_ptr;
	arg_code, code = 0;
	rpvap, ad_cs_ptr, ap_areap = null;

     end SETUP;

/* ALLOCATE_AP_AREA - internal procedure to allocate temp area for process_arguments_ */

ALLOCATE_AP_AREA: proc;

	unspec (ai) = "0"b;				/* clear out area info */
	ai.version = area_info_version_1;		/* set up area info block */
	ai.control.extend = "1"b;
	ai.control.zero_on_alloc = "1"b;
	ai.owner = myname;
	ai.size = sys_info$max_seg_size;
	ai.version_of_area = area_info_version_1;
	ai.areap = null;
	call define_area_ (addr (ai), code);		/* get an area, for arg processing use */
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code, "Error from define_area_");
	     go to non_local_return;
	end;
	ap_areap = ai.areap;			/* copy area pointer */
	allocate desc_string in (ap_area) set (desc_ptr); /* allocate storage for description */

     end ALLOCATE_AP_AREA;
%page;
/* GET_PFM_OPTIONS - internal procedure to get PFM dependent options */

GET_PFM_OPTIONS: proc (pavp, pop);

dcl  (pavp, pop) ptr;

	do i = 1 to hbound (PFM_OPT_SW, 1);
	     call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
		PFM_OPT_SW (i), pavp -> pfm_arg_values.pfm_opt_sw (i));
	     if found_opts ^= "0"b then do;		/* if option exists.. */
		pop -> pfm_options.pfm_opt_flags (i).flag_name = GET_REF_NAME (PFM_OPT_SW (i));
		pop -> pfm_options.pfm_opt_flags (i).flag_ant_name = neg_ref_name;
	     end;
	end;

	do i = 1 to hbound (PFM_OPT_VALUE, 1);
	     call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
		PFM_OPT_VALUE (i), pavp -> pfm_arg_values.pfm_opt_value (i));
	     if found_opts ^= "0"b then		/* if option exists.. */
		pop -> pfm_options.pfm_opt_value_name (i) = GET_REF_NAME (PFM_OPT_VALUE (i));
	end;

	do i = 1 to hbound (PFM_OPT_STR, 1);
	     call process_arguments_$get_option_value (rpvap, mtape_data.areap, found_opts,
		PFM_OPT_STR (i), pavp -> pfm_arg_values.pfm_opt_str (i));
	     if found_opts ^= "0"b then		/* if option exists.. */
		pop -> pfm_options.pfm_opt_str_name (i) = GET_REF_NAME (PFM_OPT_STR (i));
	end;

     end GET_PFM_OPTIONS;
%page;

/* valid_IBM_open_args - internal proc to perform some basic checking of format
   vis-a-vis block and record sizes. */

valid_IBM_open_args: proc () returns (bit (1));

	if (valid_ibm_file_name (rtrim (mtape_open_info.file_name))) then ;
	else do;
	     code = error_table_$bad_name;
	     call mtape_util_$error (mtdp, code,
		"The data set name ^a does not meet the IBM specifications.", mtape_open_info.file_name);
	     return ("0"b);
	end;

	if mtape_open_info.file_format = "f" then do;	/* fixed format				*/
	     if mtape_open_info.block_length ^= 0 then do;
						/* if it's specified, it better equal the record length */
		if mtape_open_info.block_length ^= mtape_open_info.record_length then do;
		     code = error_table_$inconsistent;
		     call mtape_util_$error (mtdp, code,
			"^/Fixed format requires that record and block lengths be equal.");
		     return ("0"b);
		end;
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "fb" then do; /* fixed block				*/
	     if mtape_open_info.block_length = 0 then do; /* must be specified			*/
		code = error_table_$noarg;
		call mtape_util_$error (mtdp, code,
		     "^/Fixed block format requires a ""-block"" size.");
		return ("0"b);
	     end;
	     if mtape_open_info.record_length = 0 then do;
						/* this must be there too...			*/
		code = error_table_$noarg;
		call mtape_util_$error (mtdp, code,
		     "^/""-record"" argument not specified.");
		return ("0"b);
	     end;
	     if mod (mtape_open_info.block_length, mtape_open_info.record_length) ^= 0 then do;
						/* and they must be mod 0			*/
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block size must be a mod 0 of the record size.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "v" then do;/* v format				*/
	     if mtape_open_info.block_length ^= 0 then do;/* if there, it MUST be record length + 4	*/
		if mtape_open_info.block_length ^= mtape_open_info.record_length + 4 then do;
		     code = error_table_$inconsistent;
		     call mtape_util_$error (mtdp, code,
			"^/The specified block length MUST be record_length + 4.");
		     return ("0"b);
		end;
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "vb" then do;
						/* vb format				*/
	     if mtape_open_info.block_length = 0 then do;
		code = error_table_$noarg;
		call mtape_util_$error (mtdp, code,
		     "^/No ""-block"" specified.");
		return ("0"b);
	     end;
	     if mtape_open_info.block_length >= mtape_open_info.record_length + 4 then ;
	     else do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block length must be greater than or equal to the record_length + 4.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "vs" then do;
	     if (mtape_open_info.block_length < 20) |
		(mtape_open_info.block_length > 32760) then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/Format ""vs"" requires that the block length be >= 20 and <= 32760 characters.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "vbs" then do;
	     if (mtape_open_info.block_length < 20) |
		(mtape_open_info.block_length > 32760) then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/Format ""vbs"" requires that the block length be >= 20 and <= 32760 characters.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;

	else if mtape_open_info.file_format = "u" then do;/* u format				*/
	     if mtape_open_info.record_length ^= 0 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/Format u and ""-record"".");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	code = error_table_$inconsistent;
	call mtape_util_$error (mtdp, code,
	     "^/Didn't recognize format ^a.", mtape_open_info.file_format);
	return ("0"b);
     end valid_IBM_open_args;
%page;

/* valid_ANSI_open_args - Like for IBM above, but using ANSI laws...					*/

valid_ANSI_open_args: proc () returns (bit (1));

	if (valid_ansi_file_name (rtrim (mtape_open_info.file_name))) then ;
	else do;
	     code = error_table_$bad_name;
	     call mtape_util_$error (mtdp, code,
		"The file name ^a does not meet the ANSI specifications.", mtape_open_info.file_name);
	     return ("0"b);
	end;

	if mtape_open_info.file_format = "f" then do;	/* fixed format				*/
	     if mtape_open_info.block_length ^= 0 then do;
						/* if it's specified, it better equal the record length */
		if mtape_open_info.block_length ^= mtape_open_info.record_length then do;
		     code = error_table_$inconsistent;
		     call mtape_util_$error (mtdp, code,
			"^/Fixed format requires that record and block lengths be equal.");
		     return ("0"b);
		end;
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "fb" then do; /* fixed block				*/
	     if mtape_open_info.block_length = 0 then do; /* must be specified			*/
		code = error_table_$noarg;
		call mtape_util_$error (mtdp, code,
		     "^/Fixed block format requires a ""-block"" size.");
		return ("0"b);
	     end;
	     if mtape_open_info.record_length = 0 then do;
						/* this must be there too...			*/
		code = error_table_$noarg;
		call mtape_util_$error (mtdp, code,
		     "^/""-record"" argument not specified.");
		return ("0"b);
	     end;
	     if mod (mtape_open_info.block_length, mtape_open_info.record_length) ^= 0 then do;
						/* and they must be mod 0			*/
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block size must be mod 0 the record size.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "d" then do;/* v format				*/
	     if mtape_open_info.block_length ^= 0 then do;
		if mtape_open_info.block_length ^= mtape_open_info.record_length then do;
		     code = error_table_$inconsistent;
		     call mtape_util_$error (mtdp, code,
			"^/Format ""d"" requires that block and record sizes be equal.");
		     return ("0"b);
		end;
	     end;
	     if mtape_open_info.record_length > 9996 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The maximum record length for format ""d"" is 9996 bytes to allow for the record control word.");
		return ("0"b);
	     end;

	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "db" then do; /* vb format				*/
	     if mtape_open_info.block_length < mtape_open_info.record_length then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block size must not be less than the record size.");
		return ("0"b);
	     end;
	     if mtape_open_info.record_length > 9996 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The maximum record length for format ""db"" is 9996 bytes to allow for the record control word.");
		return ("0"b);
	     end;

	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "s" then do;
	     if mtape_open_info.record_length > 1044480 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The record length must be <= 1044480 characters.");
		return ("0"b);
	     end;
	     if (mtape_open_info.block_length < 18) |
		(mtape_open_info.block_length > 99996) then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block length must be >= 18 and <= 99996 characters.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "sb" then do;
	     if mtape_open_info.record_length > 1044480 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The record length must be <= 1044480 characters.");
		return ("0"b);
	     end;
	     if (mtape_open_info.block_length < 18) |
		(mtape_open_info.block_length > 99996) then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block length must be >= 18 and <= 99996 characters.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else if mtape_open_info.file_format = "u" then do;
	     if mtape_open_info.record_length ^= 0 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/Format ""u"" does not allow the ""-record"" control argument.");
		return ("0"b);
	     end;
	     if mtape_open_info.block_length > 32760 then do;
		code = error_table_$inconsistent;
		call mtape_util_$error (mtdp, code,
		     "^/The block length must not be greater than 32760 characters.");
		return ("0"b);
	     end;
	     return ("1"b);
	end;
	else do;
	     code = error_table_$inconsistent;
	     call mtape_util_$error (mtdp, code,
		"^/Did not recognize ANSI formt ^a.", mtape_open_info.file_format);
	     return ("0"b);
	end;
     end valid_ANSI_open_args;
%page;
valid_ibm_file_name:
     proc (namein) returns (bit (1));

dcl  namein char (*),
     (first_dot, begin_next_dot, next_dot) fixed bin (24) init (0),
     valid_ibm_first_chars char (29) int static options (constant) init (
	"ABCDEFGHIJKLMNOPQRSTUVWXYZ#@$"),
     valid_ibm_rest_chars char (10) int static options (constant) init ("1234567890"),
     ibm_name_seperator char (1) int static options (constant) init ("."),
     ibm_name_max_length fixed bin int static options (constant) init (44),
     ibm_name_indiv_len fixed bin int static options (constant) init (8);

	if (mtape_open_info.open_mode = 2 | mtape_open_info.open_mode = 5) then ;
	else return ("1"b);				/* for input ignoe nameing specs		*/
	if namein = "" then return ("1"b);		/* FUDGE					*/
	if length (namein) > ibm_name_max_length then return ("0"b);
	if length (namein) <= ibm_name_indiv_len then do;
	     if verify (substr (namein, 1, 1), valid_ibm_first_chars) > 0 then return ("0"b);
	     else do;
		if verify (namein, valid_ibm_first_chars || valid_ibm_rest_chars) > 0 then return ("0"b);
		else return ("1"b);			/* finished here				*/
	     end;
	end;
	if verify (namein, valid_ibm_first_chars || valid_ibm_rest_chars || ibm_name_seperator) > 0 then return ("0"b);
	first_dot = index (namein, ibm_name_seperator);
	if first_dot > ibm_name_indiv_len + 1 then return ("0"b);
						/* needs to be there			*/
	begin_next_dot = first_dot + 1;		/* ok, cut up the simple names		*/
	do while ("1"b);
	     if verify (substr (namein, begin_next_dot, 1), valid_ibm_first_chars) > 0 then return ("0"b);
						/* check first chars of each name		*/
	     next_dot = index (substr (namein, begin_next_dot), ibm_name_seperator);
	     if next_dot > ibm_name_indiv_len + 1 then return ("0"b);
	     if next_dot = 0 then return ("1"b);
	     begin_next_dot = begin_next_dot + next_dot;
	     if begin_next_dot >= length (namein) then return ("1"b);
	end;
	return ("1"b);
     end valid_ibm_file_name;

valid_ansi_file_name:
     proc (namein) returns (bit (1));

dcl  namein char (*),
     valid_ansi_chars char (56) int static options (constant) init (
	"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 !""%&'()*+,-./:;<=>?");


	if (mtape_open_info.open_mode = 2 | mtape_open_info.open_mode = 5) then ;
	else return ("1"b);				/* for input ignoe nameing specs		*/
	if length (namein) > 17 then return ("0"b);	/* max len is 17				*/
	if verify (namein, valid_ansi_chars) = 0 then return ("1"b);
	else return ("0"b);
     end valid_ansi_file_name;

%page;
%include mtape_data;
%page;
%include mtape_vol_set;
%page;
%include mtape_attach_info;

%include mtape_detach_info;
%page;
%include mtape_open_close_info;
%page;
%include mtape_pfm_info;

%include mtape_err_stats;
%page;
%include mtape_option_names;
%page;
%include mtape_constants;
%page;
%include rcp_resource_types;
%page;
%include rcp_volume_formats;
%page;
%include area_info;
%page;
%include iox_modes;
%page;
%include pa_option_value_list;

     end mtape_parse_;




		    mtape_position_.pl1             06/11/85  1409.7r w 06/11/85  1244.4       86535



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
mtape_position_: procedure (arg_iocbp, arg_type, arg_n, arg_code);

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system.
   *	This program contains the entries necessary to implement the
   *	iox_$position and iox_$read_length entries for the mtape_ I/O module.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 12/13/82
   *	Modified by J. A. Bush 12/01/83 for performance improvements
*/

/*		ARGUMENT DATA		*/

dcl  arg_iocbp ptr;					/* Pointer to our IOCB */
dcl  arg_type fixed bin;				/* Type of positioning to be done */
dcl  arg_n fixed bin (21);				/* Number of elements to position, or the length of record */
dcl  arg_code fixed bin (35);				/* Return error code */

/*		AUTOMATIC DATA		*/

dcl  code fixed bin (35);
dcl  (i, tot_rcds, fwd_rcds, n_its, n_chars, n, rcd_len) fixed bin (21);
dcl  (j, idx) fixed bin;
dcl  found bit (1) aligned;

/*		EXTERNAL STATIC DATA	*/

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

/*		BUILTIN FUNCTIONS		*/

dcl  (abs, addr, hbound, lbound, null, sum) builtin;

/*		EXTERNAL ENTRIES		*/

dcl  mtape_io_$order entry (ptr, char (*), fixed bin, ptr, fixed bin (35));
dcl  mtape_io_$read_block entry (ptr, fixed bin (35));

/*		BASED DATA		*/

%page;
/* Start of the mtape_position_ entry. This implements the iox_$position entry */

	call SETUP;				/* get things set up */
	if arg_type < -1 | arg_type > 3 |
	     (arg_type = 3 & mtape_open_info.open_mode ^= Stream_input) then do; /* Invalid type? */
	     arg_code = error_table_$no_operation;	/* yes, can't do this type of positioning */
	     return;
	end;
	n = abs (arg_n);				/* get the absolute value of arg_n */
	go to action (arg_type);			/* go do appropriate positioning */

action (-1):					/* Position to beginning of file */
	mtape_close_info.position = 1;		/* simulate closing the file, and position  to BOF */
	call mtape_data.file_close (mtdp, code);	/* call the PFM entry to close the file */
	go to position_exit;

action (+1):					/* Position to end of file */
	mtape_close_info.position = 2;		/* simulate closing the file, and position  to EOF */
	call mtape_data.file_close (mtdp, code);	/* call the PFM entry to close the file */
	go to position_exit;

action (0):					/* Position fwd or backward arg_n records  */
	if mtape_open_info.open_mode = Stream_input | mtape_open_info.open_mode = Stream_input_output then do;
	     code = error_table_$no_operation;		/* Type 0 not supported for Stream I/O */
	     go to position_exit;
	end;
	if arg_n = 0 then				/* if nothing to do, return */
	     go to position_exit;
	if arg_n > 0 then				/* position fwd n records  */
	     call FORWARD_SPACE (n);
	else call BACKSPACE (n);			/* backspace n records  */
	go to position_exit;

action (2):					/* position to absolute record or character */
	if n = mtape_data.tot_lrec then ;		/* we are there now */
	else if n > mtape_data.tot_lrec then do;	/* position forward from this point */
	     fwd_rcds = n - mtape_data.tot_lrec;
	     call FORWARD_SPACE (fwd_rcds);		/* go forward delta amount */
	end;
	else do;					/* must backspace to get there */
	     n = mtape_data.tot_lrec - n;		/* adjust count */
	     call BACKSPACE (n);			/* and backup this many records */
	end;
	go to position_exit;

action (3):					/* position fwd arg_n characters (stream_input only) */
	call FORWARD_SPACE (n);			/* this should do it */

position_exit:
	arg_code = code;				/* copy return error code */
	return;
%page;
/* The following entry implements the iox_$read_length entry for mtape_ */

read_length: entry (arg_iocbp, arg_n, arg_code);

	call SETUP;				/* get things set up */
	mtape_data.arg_buf_ptr = null;		/* don't have a buffer */
	mtape_data.arg_buf_len = 0;
	call mtape_data.read (mtdp, code);		/* read the next logical record */
	arg_n = mtape_data.arg_rec_len;		/* copy length for user */
	if code = 0 then				/* only reposition if no error */
	     call BACKSPACE (1);			/* yes, must backspace a block */
	arg_code = code;				/* copy return error code */
	return;
%page;
/* SETUP - internal procedure to initialize our processing enviornment */

SETUP: proc;

	mtdp = arg_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get ptr to our control structure */
	fi_ptr = mtape_data.fi_current;		/* and pointer to our current file structure */
	moip = mtape_data.open_info_ptr;
	mcip = mtape_data.close_info_ptr;
	code = 0;					/* reset error code */

     end SETUP;

/* FORWARD_SPACE - internal procedure to position forward desired records or chars */

FORWARD_SPACE: proc (fn);

dcl  fn fixed bin (21);

	if mtape_open_info.open_mode = Sequential_input | mtape_open_info.open_mode = Sequential_input_output then do;
	     n_its = fn;				/* reading records, set number of iterations */
	     mtape_data.arg_buf_len = 0;		/* and characters to read to 0 */
	end;
	else do;					/* Stream_input or Stream_input_output */
	     n_its = 1;				/* set iterations to 1 and */
	     mtape_data.arg_buf_len = fn;		/* characters to read forward */
	end;
	mtape_data.arg_buf_ptr = null;		/* We don't have a buffer for data */
	do i = 1 to n_its while (code = 0);		/* go forward desired number of records */
	     call mtape_data.read (mtdp, code);
	end;

     end FORWARD_SPACE;
%page;
/* BACKSPACE - internal procedure to position backwards desired records or chars */

BACKSPACE: proc (bn);

dcl  bn fixed bin (21);

	if bn <= hbound (mtape_data.lrec_rrc.block_no, 1) + 1 then do; /*  Record in lrec history? */
	     idx = mtape_data.lrec_rrcx - 1;		/* yes, repostion to apropriate log record */
	     do i = 1 to bn;
		if i ^= bn then do;
		     idx = idx - 1;
		     if idx < lbound (mtape_data.lrec_rrc.block_no, 1) then /* if we have reached the bottom */
			idx = hbound (mtape_data.lrec_rrc.block_no, 1); /* reset to top */
		end;
	     end;
	     if mtape_data.lrec_rrc (idx).block_no < mtape_data.phy_block then do;
		j = mtape_data.phy_block - mtape_data.lrec_rrc (idx).block_no + 1; /* we have to bks "j" blocks */
		call mtape_io_$order (mtdp, "bsr", j, null, code);
		if code ^= 0 then return;
		mtape_data.prev_block_no = mtape_data.prev_block_no - (j - 1); /* correct prev block */
		call mtape_io_$read_block (mtdp, code);
		if code ^= 0 then return;
	     end;
	     mtape_data.log_record_ptr = addr (tape_blk (mtape_data.lrec_rrc (idx).byte_offset));
	     mtape_data.processed = mtape_data.lrec_rrc (idx).byte_offset - 1;
	     mtape_data.length = mtape_data.lrec_rrc (idx).block_len;
	     mtape_data.log_record = mtape_data.lrec_rrc (idx).lrec_no;
	     mtape_data.remain = mtape_data.length - mtape_data.processed;
	     mtape_data.lrec_rrcx = idx;		/* reset lrec history index */
	end;
	else do;					/* no, is it in the block history? */
	     if bn <= mtape_data.log_record then do;	/* reposition within current block */
		fwd_rcds = mtape_data.log_record - bn;	/* compute rcds fwd from 1st rcd in blk */
		mtape_data.log_record = 0;		/* reset logical records in this blk */
		mtape_data.processed = mtape_data.buffer_offset;
		mtape_data.remain = mtape_data.length - mtape_data.processed;
		mtape_data.log_record_ptr = addr (tape_blk (mtape_data.processed + 1));
		mtape_data.tot_lrec = mtape_data.tot_lrec - bn; /* adjust total log records */
	     end;

	     else if bn <= sum (mtape_data.blk_rrrc) then do; /* repositon by backspacing blocks */
		idx = mtape_data.blk_rrcx - 1;	/* start from last block stored */
		if idx < lbound (mtape_data.blk_rrrc, 1) then /* if at bottom of queue.. */
		     idx = hbound (mtape_data.blk_rrrc, 1); /* go to top */
		tot_rcds = mtape_data.log_record;	/* preload total with count of current blk */
		j = 1;				/* initialize blocks to backspace (including current) */
		found = "0"b;
		do i = idx by -1 while (^found);	/* scan the queue */
		     j = j + 1;			/* increment blocks to backspace */
		     tot_rcds = tot_rcds + mtape_data.blk_rrrc (i); /* increment total */
		     mtape_data.blk_rrrc (i) = 0;	/* clear this position */
		     if bn <= tot_rcds then
			found = "1"b;		/* found the right block */
		     else if i - 1 < lbound (mtape_data.blk_rrrc, 1) then /* if at bottom of queue.. */
			i = hbound (mtape_data.blk_rrrc, 1) + 1; /* set for the top */
		end;
		mtape_data.blk_rrcx = i + 1;		/* reset block index */
		fwd_rcds = tot_rcds - bn;		/* compute the number of rcds forward */
		call mtape_io_$order (mtdp, "bsr", j, null, code); /* backspace j blocks */
		if code ^= 0 then return;		/* bad error return */
		mtape_data.log_record_ptr = null;	/* force block read */
		mtape_data.remain = 0;
		mtape_data.tot_lrec = mtape_data.tot_lrec - bn; /* adjust total log records */
	     end;
	     else do;				/* must go to beginning  of file */
		fwd_rcds = mtape_data.tot_lrec - bn;	/* get number forward */
		mtape_close_info.position = 3;	/* position to beginning of file section */
		call mtape_data.file_close (mtdp, code);/* simulate closing */
		if code ^= 0 then return;
	     end;
	     call FORWARD_SPACE (fwd_rcds);		/* now position forward for indicated records */
	end;

     end BACKSPACE;
%page;
%include iocb;
%page;
%include mtape_data;
%page;
%include mtape_open_close_info;
%page;
%include mtape_file_info;
%page;
%include iox_modes;

     end mtape_position_;




		    mtape_set_defaults.pl1          04/10/85  0831.6r w 04/08/85  1129.0      119421



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,inddcls,^ifthendo,^indproc,indcom,^indblkcom,declareind8,dclind4 */
mtape_set_defaults: proc ();

     /* DESCRIPTION:

        This command sets default arguments used by the mtape_ I/O module.
        The default arguments, specified in the command line, for a
        particular tape operation and (perhaps) volume type are processed by
        the mtape_ argument processing routine (process_arguments_ for now)
        and are converted to a string representation which is stored in
        the data space of a specified value segment.

     */

     /* HISTORY:

        Written 09/13/83 by S. Krupp.
     */

     /* START OF DECLARATIONS */

     /* Automatic */

          dcl answer char(3) var;
          dcl arg_array_max_length fixed bin(21);
	dcl arg_array_ptr ptr;
          dcl arg_array_size fixed bin;
          dcl arg_list_ptr ptr;
	dcl arg_str_length fixed bin(21);
	dcl arg_str_ptr ptr;
	dcl based_varying_char_ptr ptr;
          dcl code fixed bin(35);
	dcl db_dirname char(168);
	dcl db_entryname char(32);
	dcl db_full_pathname char(168) var;
	dcl db_rel_pathname char(168) var;
	dcl default_arguments_ptr ptr;
	dcl definition_ptr ptr;
	dcl found_option bit(4);
	dcl idx fixed bin;
          dcl nargs fixed bin;
	dcl operation char(32) var;
	dcl program_name char(64) var;
	dcl result_ptr ptr;
          dcl value_seg_ptr ptr;
	dcl volume_type char(32) var;

          dcl 1 auto_area_info like area_info;
	dcl 1 auto_query_info like query_info;

     /* Based */

          dcl arg_array(arg_array_size) char(arg_array_max_length) var based(arg_array_ptr);
	dcl arg_str char(arg_str_length) var based(arg_str_ptr);
	dcl based_varying_char char(sys_info$max_seg_size) var based(based_varying_char_ptr);
          dcl found_option_array(4) bit(1) unaligned based(addr(found_option));
	dcl work_area area based(auto_area_info.areap);

     /* Builtin */

          dcl (addr, divide, hbound, length, max, null, search, unspec) builtin;

     /* Condition */

          dcl cleanup condition;

     /* Entries */

          dcl com_err_ entry() options(variable);
          dcl command_query_ entry() options(variable);
          dcl cu_$arg_count entry (fixed bin, fixed bin(35));
          dcl cu_$arg_list_ptr entry (ptr);
          dcl define_area_ entry (ptr, fixed bin(35));
	dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
	dcl hcs_$append_branch entry (char(*), char(*), fixed bin(5), fixed bin(35));
	dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl ioa_ entry() options(variable);
	dcl ioa_$rsnnl entry() options(variable);
	dcl pathname_ entry (char(*), char(*)) returns(char(168));
	dcl process_arguments_$argument_array entry(char(*), fixed bin, (*) char(*) var, ptr, ptr, ptr, fixed bin(35));
	dcl process_arguments_$argument_list entry(char(*), fixed bin, ptr, fixed bin, ptr, ptr, ptr, fixed bin(35));
	dcl process_arguments_$get_option_value entry options(variable);
	dcl release_area_ entry (ptr);
	dcl requote_string_ entry (char(*)) returns(char(*));
	dcl term_$seg_ptr entry (ptr, fixed bin(35));
	dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin(19), fixed bin(35));
	dcl value_$set_data entry (ptr, bit(36) aligned, char(*), ptr, fixed bin(18), ptr, ptr, fixed bin(18), fixed bin(35));

     /* Static */

          dcl (MYNAME init("mtape_set_defaults"),
	     PROGRAM_NAME_PREFIX init("mtape_"),
	     RESERVED_CHARS init(" 	
"";[]()|")					/* SPACE || TAB || NEWLINE || """;[]()|" */
              ) char(32) var int static options(constant);

          dcl (ARG_PROCESSING_MODE init(0),
	     FIRST_ARG_TO_PROCESS init(1)
	    ) fixed bin int static options(constant);

          dcl BIN_PERMANENT_VALUE fixed bin init(0) internal static options(constant);
          dcl PERMANENT_VALUE bit(2) aligned init("01"b) internal static options(constant);
	dcl VALUE_SUFFIX char(5) init("value") internal static options(constant);
	dcl VALUE_SEG_SIZE fixed bin(19) init(0) internal static options(constant);

          dcl (OPERATION_OPTION_IDX init(1),
	     VOLUME_TYPE_OPTION_IDX init(2),
	     PATHNAME_OPTION_IDX init(3),
	     DEFAULT_ARGUMENTS_OPTION_IDX init(4)
             ) fixed bin int static options(constant);

          dcl (OPERATION_OPTION_NAME init("operation"),
	     VOLUME_TYPE_OPTION_NAME init("volume_type"),
	     PATHNAME_OPTION_NAME init("pathname"),
               DEFAULT_ARGUMENTS_OPTION_NAME init("default_arguments")
              ) char(32) var int static options(constant);

          dcl LONG_OPTION_REFNAME(4) char(32) var int static options(constant)
	    init("operation", "-volume_type", "-pathname", "-arguments");

          dcl (ATTACH_IDX init(1),
               OPEN_IDX init(2),
               CLOSE_IDX init(3),
               DETACH_IDX init(4)
              ) fixed bin internal static options(constant);

          dcl OPERATIONS(4) char(6) internal static options(constant)
              init("attach", "open", "close", "detach");

          dcl VOLUME_TYPES(2) char(32) internal static options(constant)
             init("ansi", "ibm");

          dcl (error_table_$bad_arg,
	     error_table_$noarg,
	     error_table_$noentry
	    ) fixed bin(35) ext static;

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

     /* Include */

%page;
%include access_mode_values;
%page;
%include area_info;
%page;
%include pa_option_value_list;
%page;
%include pa_value_names;
%page;
%include query_info;

     /* END OF DECLARATIONS */
%page;

     /* Main Procedure */

     /* Initialize */

          value_seg_ptr = null;

	unspec (auto_area_info) = "0"b;
	auto_area_info.version = area_info_version_1;
	auto_area_info.areap = null;
	auto_area_info.owner = MYNAME;
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.zero_on_alloc = "1"b;
	auto_area_info.extend = "1"b;

          call cu_$arg_count(nargs, code);
          if code ^= 0
          then call ABORT(code, "Could not get the argument count.", "");

          if nargs = 0
          then call ABORT(0, "Usage ""mtape_set_defaults OPERATION {-control_args} -ag ARGS""", "");

	unspec(auto_query_info) = "0"b;
	auto_query_info.version = query_info_version_5;
	auto_query_info.yes_or_no_sw = "1"b;
	auto_query_info.question_iocbp = null;
	auto_query_info.answer_iocbp = null;
	auto_query_info.explanation_ptr = null;

	on cleanup call CLEANUP();

	call define_area_(addr(auto_area_info), code);
	if code ^= 0
	then call ABORT(code, "Unable to allocate a work area.", "");

  /* Get mtape_set_default's argument list. */

          call cu_$arg_list_ptr(arg_list_ptr);

  /* Process mtape_set_defaults's arguments. */

          call process_arguments_$argument_list((MYNAME), ARG_PROCESSING_MODE,
	   arg_list_ptr, FIRST_ARG_TO_PROCESS, null, auto_area_info.areap,
	   result_ptr, code);
          if code ^= 0
	then call ABORT_SILENT();			/* Error msg already printed. */

  /* Get information needed to process the arguments that are the
     subject of the command line (i.e., the arguments that are
     the defaults for the specified tape processing operation and
     volume type). */

          call process_arguments_$get_option_value(result_ptr,
	   auto_area_info.areap, found_option, OPERATION_OPTION_NAME,
	   operation, VOLUME_TYPE_OPTION_NAME, volume_type,
	   PATHNAME_OPTION_NAME, db_rel_pathname, DEFAULT_ARGUMENTS_OPTION_NAME,
	   default_arguments_ptr);

          if ^found_option_array(OPERATION_OPTION_IDX)
          then call ABORT(error_table_$noarg, "Missing ""^a"" option.",
	   (LONG_OPTION_REFNAME(OPERATION_OPTION_IDX)));

         do idx = 1 to hbound(OPERATIONS, 1) while(OPERATIONS(idx) ^= operation);
          end;

          if idx > hbound(OPERATIONS, 1)
          then call ABORT(error_table_$bad_arg, "Unknown operation specified:  ""^a"".", (operation));

	if ^found_option_array(DEFAULT_ARGUMENTS_OPTION_IDX)
	then call ABORT(error_table_$noarg, "Missing ""^a"" option.",
	   (LONG_OPTION_REFNAME(DEFAULT_ARGUMENTS_OPTION_IDX)));

	if found_option_array(VOLUME_TYPE_OPTION_IDX)
          then do;
               do idx = 1 to hbound(VOLUME_TYPES, 1) while(VOLUME_TYPES(idx) ^= volume_type);
               end;

               if idx > hbound(VOLUME_TYPES, 1)
               then call ABORT(error_table_$bad_arg, "Unknown volume type specified:  ""^a"".", (volume_type));

               if operation = OPERATIONS(ATTACH_IDX) | operation = OPERATIONS(DETACH_IDX)
               then call ABORT(error_table_$bad_arg, "Cannot specify the volume type """ ||
                  volume_type || """ with the ""^a"" operation.", (operation));
          end;

  /* Build the program name from the specified tape processing operation and
     volume type. */
 
          call ioa_$rsnnl("^a.^a^[.^a^;^]", program_name, (0), PROGRAM_NAME_PREFIX,
	   operation, found_option_array(VOLUME_TYPE_OPTION_IDX), volume_type);

  /* Transfer program_name's arguments to an array for processing
     by the mtape_ argument processing routine (process_arguments_). */

          arg_array_size = default_arguments_ptr->option_value_list.number_of_values;
	arg_array_max_length = 0;
	arg_str_length = 0;

	do idx = 1 to arg_array_size;
	     based_varying_char_ptr = default_arguments_ptr->option_value_list.value(idx).ptr;
	     arg_array_max_length = max(arg_array_max_length, length(based_varying_char));
	     if idx ^= 1
	     then arg_str_length = arg_str_length + 1;
	     if search(based_varying_char, RESERVED_CHARS) > 0
	     then arg_str_length = arg_str_length + length(requote_string_((based_varying_char)));
	     else arg_str_length = arg_str_length + length(based_varying_char);
	end;

	alloc arg_array in (work_area) set (arg_array_ptr);
	alloc arg_str in(work_area) set(arg_str_ptr);
	arg_str = "";

	do idx = 1 to arg_array_size;
	     based_varying_char_ptr = default_arguments_ptr->option_value_list.value(idx).ptr;
	     arg_array(idx) = based_varying_char;
	     if idx ^= 1
	     then arg_str = arg_str || " ";
	     if search(based_varying_char, RESERVED_CHARS) > 0
	     then arg_str = arg_str || requote_string_((based_varying_char));
	     else arg_str = arg_str || (based_varying_char);
	end;

  /* Process program_name's arguments. */

          definition_ptr = null;

	call process_arguments_$argument_array((program_name), ARG_PROCESSING_MODE,
	   arg_array, definition_ptr, auto_area_info.areap, result_ptr, code);
	if code ^= 0
	then call ABORT_SILENT();			/* Error msg already printed. */

  /* Now check out the value seg where we will store the user specified
     default arguments.  Create it if necessary. */

          call expand_pathname_$add_suffix((db_rel_pathname), VALUE_SUFFIX, db_dirname, db_entryname, code);
	if code ^= 0
	then call ABORT(code, "^a", (db_rel_pathname));

	db_full_pathname = pathname_(db_dirname, db_entryname);

	call initiate_file_(db_dirname, db_entryname, RW_ACCESS, value_seg_ptr, (0), code);
	if code = error_table_$noentry
	then do;
	     call command_query_(addr(auto_query_info), answer, MYNAME,
	        "The value segment ""^a""^/does not exist." ||
	        "Do you wish to create it?", (db_full_pathname));
	     if answer = "no" | answer = "n"
	     then call ABORT(code, "^a", (db_full_pathname));
	     else call ioa_("Creating ^a.", db_full_pathname);
	     call hcs_$append_branch(db_dirname, db_entryname, RW_ACCESS_BIN, code);
	     if code ^= 0
	     then call ABORT(code, "While creating ^a.", (db_full_pathname));
	     call initiate_file_(db_dirname, db_entryname, RW_ACCESS, value_seg_ptr, (0), code);
	     if code ^= 0
	     then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname));
	     call value_$init_seg(value_seg_ptr, BIN_PERMANENT_VALUE, null, VALUE_SEG_SIZE, code);
	     if code ^= 0
	     then call ABORT(code, "While initiating ^a as a value segment.", (db_full_pathname));
	end;
	else if code ^= 0
	then call ABORT(code, "Unable to initiate ^a.", (db_full_pathname));

  /* Store the linear form (arg_str). */

          call value_$set_data(value_seg_ptr, (PERMANENT_VALUE), DEFAULT_LINEAR_FORM_PREFIX ||
	   "." || program_name, addr(arg_str), divide(length(arg_str) + 3, 4, 17, 0) + 1,
	   null, (null), (0), code);
	if code ^= 0
	then call ABORT(code, "Unable to store the default arguments in ^a", (db_full_pathname));

          call CLEANUP();

RETURN:

          return;
%page;
CLEANUP: proc();

          if auto_area_info.areap ^= null
	then call release_area_(auto_area_info.areap);

	if value_seg_ptr ^= null
	then call term_$seg_ptr(value_seg_ptr, code);

     end CLEANUP;


ABORT: proc (code, msg, msg_arg);

     /* Parameter */

	dcl code fixed bin (35);
	dcl msg char (*);
	dcl msg_arg char (*);

	call com_err_ (code, MYNAME, msg, msg_arg);
	call CLEANUP();

	goto RETURN;

     end ABORT;


ABORT_SILENT: proc();

          call CLEANUP();

	goto RETURN;

     end ABORT_SILENT;

     end mtape_set_defaults;




		    mtape_util_.pl1                 12/17/86  0925.7r w 12/17/86  0830.0      234360



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
mtape_util_: procedure;

/* format: style4 */

/* *	This program is part of the mtape_ I/O module and as such is not
   *	called directly by users, but through the iox_ I/O system.  This
   *	program implements several common subroutines.
   *
   *	Modification History:
   *
   *	Created by J. A. Bush 10/05/82
   *	Modified by J. A. Bush 01/09/84 to enable referencing dir search rule
   *	 when searching for Per-Format modules
*/

/*		ARGUMENT DATA		*/

dcl  arg_mtdp ptr;					/* Pointer to mtape_data */
dcl  arg_alloc_type fixed bin;			/* Type of structure to allocate */
dcl  arg_prev_ptr ptr;				/* Pointer to previously allocated structure */
dcl  arg_length fixed bin (21);			/* Length of string to allocate */
dcl  arg_return_ptr ptr;				/* Pointer to allocated storage */
dcl  arg_code fixed bin (35);				/* Return error code */
dcl  arg_qcode fixed bin;				/* User query index */

/*		AUTOMATIC DATA		*/

dcl  (prev_ptr, temp_ptr, argp, qep, ep) ptr;
dcl  pfmn char (32);
dcl  (str_length, rs_len) fixed bin (21);
dcl  (alloc_type, i, cdx) fixed bin;
dcl  explain_str char (1024);
dcl  rs_emess char (512);
dcl  answer char (128);
dcl  code fixed bin (35);
dcl  invert_qsw bit (1) aligned;
dcl  1 atec aligned like tec;

/*		CONSTANT DATA		*/

dcl  myname char (6) int static options (constant) init ("mtape_");
dcl  1 EXPLAIN_NO_NEXT_VOLUME int static options (constant),
       2 n_lines fixed bin init (5),
       2 text (5) char (71) unaligned init
	  ("Physical end of volume has been detected on a multi-volume file, but",
	  "no volumes remain in the volume sequence list.  A ""yes"" answer will",
	  "lock the file such that no further I/O operations are possible (i.e.",
	  "the file may only be closed).  A ""no"" answer will cause a further",
	  "query for the next volume name.");

dcl  1 EXPLAIN_LABELED_VOLUME int static options (constant),
       2 n_lines fixed bin init (9),
       2 text (9) char (71) unaligned init
	  ("The indicated volume requires initialization but contains a valid",
	  "volume label of some other type not recognized by the Per Format",
	  "module currently in control.  A ""yes"" answer will cause the volume",
	  "to be initialized with the volume label sequence of the Per-Format",
	  "module in control.  A ""no"" answer will cause one of the following",
	  "actions.  If this is the initial file opening, then the opening will",
	  "be aborted.  If this condition was detected on a subsequent volume",
	  "switch of a multi-volume file, then the file will be locked such that",
	  "further I/O operations are not possible.");

dcl  1 EXPLAIN_UNEXPIRED_VOLUME int static options (constant),
       2 n_lines fixed bin init (4),
       2 text (4) char (71) unaligned init
	  ("It has been determined that the indicated volume must be initialized",
	  "but its first file contains an expiration date which is in the future.",
	  "A ""yes"" answer will allow processing to continue.",
	  "A ""no"" answer will abort the opening.");

dcl  1 EXPLAIN_INCORRECT_VOLUME int static options (constant),
       2 n_lines fixed bin init (6),
       2 text (6) char (71) unaligned init
	  ("The volume name specified by the user and the volume name recorded on",
	  "the indicated volume do not agree. If opening for output, a ""yes""",
	  "answer will cause the volume to be initialized with the volume name",
	  "specified by the user.  If opening for input, a ""yes"" answer will",
	  "cause the descrepency to be ignored and processing will continue.  A",
	  """no"" answer will cause the opening to be aborted.");

dcl  1 EXPLAIN_UNEXPIRED_FILE int static options (constant),
       2 n_lines fixed bin init (5),
       2 text (5) char (71) unaligned init
	  ("The file that is being opened currently exists and must be replaced,",
	  "modified or extended but the recorded files expiration date is in the",
	  "future.  A ""yes"" answer will cause the file labels to be overwritten",
	  "and processing will continue.  A ""no"" answer will abort the file",
	  "opening.");

dcl  1 EXPLAIN_ABORT_FILE int static options (constant),
       2 n_lines fixed bin init (6),
       2 text (6) char (71) unaligned init
	  ("Unrecoverable tape errors have ocurred while attempting to write file",
	  "headers, trailers or tape marks, thus invalidating the file-set",
	  "structure. A ""yes"" answer causes an attempt to be made to delete",
	  "the defective file section.  A ""no"" answer will cause no action",
	  "to be taken.  In either case, the file is locked and no further",
	  "I/O is possible.");

dcl  1 EXPLAIN_NEW_VOLUME int static options (constant),
       2 n_lines fixed bin init (4),
       2 text (4) char (71) unaligned init
	  ("The user is requested to supply the volume name of a new volume",
	  "following a ""no"" answer from a previous ""no_next_volume"" query.",
	  "An optional mount comment may also be supplied.  The expected user",
	  "response must be in the form: ""volume_name -comment STR"".");
dcl  NL char (1) int static options (constant) init ("
");

/*		EXTERNAL STATIC DATA	*/

dcl  error_table_$no_next_volume fixed bin (35) ext static;
dcl  error_table_$uninitialized_volume fixed bin (35) ext static;
dcl  error_table_$unexpired_volume fixed bin (35) ext static;
dcl  error_table_$unexpired_file fixed bin (35) ext static;
dcl  error_table_$file_aborted fixed bin (35) ext static;

/*		BUILTIN FUNCTIONS		*/

dcl  (addr, codeptr, hbound, index, length, ltrim, null, rtrim, substr, translate) builtin;

/*		EXTERNAL ENTRIES		*/

dcl  tape_ioi_$get_statistics entry (bit (36) aligned, ptr, fixed bin (35));
dcl  tape_ioi_$reset_statistics entry (bit (36) aligned, fixed bin (35));
dcl  mtape_util_$error entry options (variable);
dcl  canon_for_volume_label_ entry (char (*), char (*), char (*) aligned, fixed bin, fixed bin (35));
dcl  ioa_$rsnnl entry () options (variable);
dcl  com_err_ entry () options (variable);
dcl  command_query_ entry () options (variable);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35));
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));

/*		BASED STORAGE		*/

dcl  based_str char (str_length) based;
dcl  based_area area based (mtape_data.areap);

dcl  1 query_explanation based (qep),			/* command query explanation template */
       2 n_lines fixed bin,				/* number of lines in the explanation text */
       2 text (12) char (71) unaligned;			/* message text array */
%page;
/* alloc - entry to allocate storage for various structures
   *
   *	Usage:
   *
   *	dcl mtape_util_$alloc entry (ptr, fixed bin, ptr, fixed bin (21), ptr);
   *	call mtape_util_$alloc (mtdp, alloc_type, prev_ptr, str_length, return_ptr);
   *
   *	where:
   *	1. mtdp
   *	     is a pointer to the mtape_data structure defined by
   *	     mtape_data.incl.pl1. (INPUT)
   *	2. alloc_type
   *	     is the structure type to be allocated, defined in
   *	     mtape_constants.incl.pl1. (INPUT)
   *	3. prev_ptr
   *	     is a pointer to the previous structure of this type, for types
   *	     1 - 3. If non-null, the previous and next pointers in the
   *	     respective structures will be linked. (INPUT)
   *	4. str_length
   *	     is the string length in characters to be allocated for type 4
   *	     allocation. The parameter is ignored for other allocation types.
   *	     (INPUT)
   *	5. return_ptr
   *	     is a pointer to the allocated storage. (OUTPUT)
*/

alloc: entry (arg_mtdp, arg_alloc_type, arg_prev_ptr, arg_length, arg_return_ptr);
	mtdp = arg_mtdp;				/* copy arguments */
	alloc_type = arg_alloc_type;
	prev_ptr = arg_prev_ptr;
	go to alloc_storage (alloc_type);		/* go do the appropriate allocation */


alloc_storage (1):					/* allocate a volume set structure */
	allocate mtape_vol_set in (based_area) set (temp_ptr); /* that should do it */
	vs_ptr = temp_ptr;				/* initialize the structure */
	mtape_vol_set.version = mtape_vs_version_1;
	mtape_vol_set.mrm_vs_ptr, mtape_vol_set.lrm_vs_ptr = null;
	mtape_vol_set.first_vl_ptr, mtape_vol_set.last_vl_ptr = null;
	mtape_vol_set.volume_name, mtape_vol_set.volume_id = "";
	mtape_vol_set.mount_comment, mtape_vol_set.device_name = "";
	mtape_vol_set.demount_comment = "";
	mtape_vol_set.next_vs_ptr = null;		/* link the structures if possible */
	mtape_vol_set.prev_vs_ptr = prev_ptr;
	if prev_ptr ^= null then do;			/* if user supplied valid prev ptr.. */
	     prev_ptr -> mtape_vol_set.next_vs_ptr = vs_ptr; /* link the previous volume set */
	     mtape_vol_set.volume_index = prev_ptr -> mtape_vol_set.volume_index + 1; /* increment vol sequence */
	end;
	else mtape_vol_set.volume_index = 1;		/* first volume, set to 1 */
	go to alloc_end;

alloc_storage (2):					/* allocate a label record structure */
	allocate mtape_label_record in (based_area) set (temp_ptr); /* that should do it */
	lr_ptr = temp_ptr;				/* initialize the structure */
	mtape_label_record.version = mtape_lr_version_1;
	mtape_label_record.lab_ptr = null;
	mtape_label_record.next_lab_ptr = null;		/* link the structures if possible */
	mtape_label_record.prev_lab_ptr = prev_ptr;
	if prev_ptr ^= null then			/* if user supplied valid prev ptr.. */
	     prev_ptr -> mtape_label_record.next_lab_ptr = lr_ptr; /* link the previous label record */
	go to alloc_end;

alloc_storage (3):					/* allocate a file info structure */
	allocate mtape_file_info in (based_area) set (temp_ptr); /* that should do it */
	fi_ptr = temp_ptr;				/* initialize structure */
	mtape_file_info.version = mtape_fi_version_1;
	mtape_file_info.first_file_lab_ptr, mtape_file_info.last_file_lab_ptr = null;
	mtape_file_info.first_file_trail_ptr, mtape_file_info.last_file_trail_ptr = null;
	mtape_file_info.first_file_section_ptr = null;
	mtape_file_info.begin_vs_ptr, mtape_file_info.end_vs_ptr = null;
	mtape_file_info.file_id, mtape_file_info.file_set_id = "";
	mtape_file_info.creation_date, mtape_file_info.expiration_date = "";
	mtape_file_info.pfm_opt_str (*) = "";
	mtape_file_info.char_size = 9;		/* until told otherwise */
	mtape_file_info.next_fi_ptr = null;		/* link the structures if possible */
	mtape_file_info.prev_fi_ptr = prev_ptr;
	if prev_ptr ^= null then			/* if user supplied valid prev ptr.. */
	     prev_ptr -> mtape_file_info.next_fi_ptr = fi_ptr; /* link the previous file structure */
	go to alloc_end;

alloc_storage (4):					/* allocate storage for a string of bytes */
	str_length = arg_length;			/* copy the length */
	allocate based_str in (based_area) set (temp_ptr);/* that should do it */
	go to alloc_end;

alloc_end:
	arg_return_ptr = temp_ptr;			/* copy the pointer for the user */
	return;					/* thats all folks */
%page;
/* error - entry to display error messages */

error: entry (arg_mtdp, arg_code);			/* externally declared as options (variable) */

	if arg_mtdp -> mtape_data.display_errors then do; /* only display errors if he wants us to */
	     rs_emess = "";				/* pad the message first */
	     call cu_$arg_list_ptr (argp);		/* get ptr to our argument list */
	     call ioa_$general_rs (argp, 3, 4, rs_emess, rs_len, "1"b, "0"b); /* format message */
	     call com_err_ (arg_code, myname, rs_emess);	/* display message */
	end;

	return;
%page;
/* get_statistics - entry to update error statistics counters in vol_set and file_info structures */

get_statistics: entry (arg_mtdp, arg_code);

	mtdp = arg_mtdp;				/* copy args */
	vs_ptr = mtape_data.vs_current;
	fi_ptr = mtape_data.fi_current;

	code, arg_code = 0;
	tape_ioi_error_counts_ptr = addr (atec);	/* set ptr to auto structure */
	tec.version = TEC_VERSION_1;			/* set structure version */
	call tape_ioi_$get_statistics (mtape_data.tioi_id, tape_ioi_error_counts_ptr, code);
	if code ^= 0 then do;			/* if error, probably wrong version */
	     call mtape_util_$error (mtdp, code, "Error from tape_ioi_$get_statistics");
	     go to gs_return;
	end;
	call tape_ioi_$reset_statistics (mtape_data.tioi_id, code); /* reset tape_ioi_ error counters */
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code, "Error from tape_ioi_$reset_statistics");
	     go to gs_return;
	end;

/* Now that we have the current error stats, merge them in with vol_set and file_info structures */

	mtape_vol_set.tot_error_stats.read.errors =
	     mtape_vol_set.tot_error_stats.read.errors + tec.reads.errors;
	mtape_vol_set.tot_error_stats.read.operations =
	     mtape_vol_set.tot_error_stats.read.operations + tec.reads.total;
	mtape_vol_set.tot_error_stats.write.errors =
	     mtape_vol_set.tot_error_stats.write.errors + tec.writes.errors;
	mtape_vol_set.tot_error_stats.write.operations =
	     mtape_vol_set.tot_error_stats.write.operations + tec.writes.total;
	mtape_vol_set.tot_error_stats.orders.errors =
	     mtape_vol_set.tot_error_stats.orders.errors + tec.orders.errors;
	mtape_vol_set.tot_error_stats.orders.operations =
	     mtape_vol_set.tot_error_stats.orders.operations + tec.orders.total;

	mtape_vol_set.rel_error_stats.read.errors =
	     mtape_vol_set.rel_error_stats.read.errors + tec.reads.errors;
	mtape_vol_set.rel_error_stats.read.operations =
	     mtape_vol_set.rel_error_stats.read.operations + tec.reads.total;
	mtape_vol_set.rel_error_stats.write.errors =
	     mtape_vol_set.rel_error_stats.write.errors + tec.writes.errors;
	mtape_vol_set.rel_error_stats.write.operations =
	     mtape_vol_set.rel_error_stats.write.operations + tec.writes.total;
	mtape_vol_set.rel_error_stats.orders.errors =
	     mtape_vol_set.rel_error_stats.orders.errors + tec.orders.errors;
	mtape_vol_set.rel_error_stats.orders.operations =
	     mtape_vol_set.rel_error_stats.orders.operations + tec.orders.total;
	do i = 1 to hbound (mtape_vol_set.tot_error_stats.successful_retry, 1);
	     mtape_vol_set.tot_error_stats.successful_retry (i) = mtape_vol_set.tot_error_stats.successful_retry (i)
		+ tec.successful_retry_strategy (i);
	     mtape_vol_set.rel_error_stats.successful_retry (i) = mtape_vol_set.rel_error_stats.successful_retry (i)
		+ tec.successful_retry_strategy (i);
	end;
	if fi_ptr ^= null then do;			/* update file error statistics? */
	     mtape_file_info.read_errors = mtape_file_info.read_errors + tec.reads.errors;
	     mtape_file_info.write_errors = mtape_file_info.write_errors + tec.writes.errors;
	end;

gs_return:
	arg_code = code;
	return;
%page;
/* init_pfm - entry to select the appropriate Per-Format module and check it for existence and access */

init_pfm: entry (arg_mtdp, arg_code);

	mtdp = arg_mtdp;				/* copy args */
	vs_ptr = mtape_data.vs_current;
	maip = mtape_data.attach_info_ptr;
	code, arg_code = 0;

	if mtape_attach_info.pfm_prefix ^= "" then	/*  if a "-vt" specified by the user */
	     pfmn = mtape_attach_info.pfm_prefix;	/* use user specifed prefix */
	else do;					/* otherwise check RCP designation */
	     if mtape_vol_set.volume_type = Volume_multics_tape | /* is tape one we recognize? */
		mtape_vol_set.volume_type = Volume_gcos_tape |
		mtape_vol_set.volume_type = Volume_ibm_tape |
		mtape_vol_set.volume_type = Volume_ansi_tape then
		pfmn = Tape_volume_types (mtape_vol_set.volume_type); /* yes, form prefix directly */
	     else if mtape_vol_set.volume_type = Volume_unknown_format then /* if readable but unrecognized.. */
		pfmn = "raw";			/* set prefix for the "raw" PFM */
	     else pfmn = mtape_attach_info.default_pfm_prefix; /* Use default prefix */
	end;
	pfmn = translate (pfmn, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* Make it LC */
	mtape_attach_info.pfm_prefix = pfmn;		/* save the PFM prefix */
	if index (pfmn, "_tape_io_") = 0 then		/* if user didn't already do it.. */
	     pfmn = rtrim (pfmn) || "_tape_io_";	/*  complete PFM name */

/* Locate the Per-Format module, using the standard object search rules */

	call hcs_$make_ptr (codeptr (mtape_util_), pfmn, "", ep, code);
	if ep = null then do;			/* if we can't find it complain */
	     call mtape_util_$error (mtdp, code, "Can't find the ""^a"" Per-Format module.", pfmn);
	     arg_code = code;
	     return;
	end;
	mtape_data.pfm_name = pfmn;			/* success, save the PFM name */

/* Make sure all required entry points are there */

	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "pfm_init", mtape_data.pfm_init, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""pfm_init"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "file_open", mtape_data.file_open, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""file_open"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "file_close", mtape_data.file_close, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""file_close"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "read", mtape_data.read, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""read"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "write", mtape_data.write, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""write"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "order", mtape_data.order, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""order"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "decode_file_labels", mtape_data.decode_file_labels, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""decode_file_labels"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;
	call hcs_$make_entry (codeptr (mtape_util_), pfmn, "encode_file_labels", mtape_data.encode_file_labels, code);
	if code ^= 0 then do;
	     call mtape_util_$error (mtdp, code,
		"Could not find the ""encode_file_labels"" entry point for the ""^a"" Per-Format module.", pfmn);
	     call SAVE_CODE;			/* set return code (if not already set ) */
	end;

	return;
%page;
/* user_query - entry to generate standard user queries for various information */

user_query: entry (arg_mtdp, arg_qcode, arg_code);

	mtdp = arg_mtdp;				/* copy args */
	vs_ptr = mtape_data.vs_current;
	fi_ptr = mtape_data.fi_current;
	maip = mtape_data.attach_info_ptr;
	moip = mtape_data.open_info_ptr;
	mpfmip = mtape_data.pfm_info_ptr;
	rs_emess, answer = "";			/* pad message and answer with blanks */
	invert_qsw = "0"b;				/* yes answer is positive for most */
	arg_code = 0;				/* clear return code for positive response */
	query_info.version = query_info_version_6;	/* set version number */
	query_info.yes_or_no_sw = "1"b;		/* set yes or no switch */
	query_info.prompt_after_explanation = "1"b;
	go to U_QUERY (arg_qcode);			/* ask the right question */

U_QUERY (1):					/* Q_NO_NEXT_VOLUME */
	qep = addr (EXPLAIN_NO_NEXT_VOLUME);		/* set the explaination ptr */
	code = error_table_$no_next_volume;		/* set appropriate error code */
	invert_qsw = "1"b;				/* no answer is the positive in this case */
	call ioa_$rsnnl ("Reached the end of volume on volume ^a.
Do you wish to terminate processing of this volume-set?",
	     rs_emess, rs_len, mtape_vol_set.volume_id);

	go to U_QUERY_COM;

U_QUERY (2):					/* Q_LABELED_VOLUME */
	qep = addr (EXPLAIN_LABELED_VOLUME);		/* set the explaination ptr */
	code = error_table_$uninitialized_volume;	/* set appropriate error code */
	query_info.query_code = 2;			/* set query code of command_question handlers */
	call ioa_$rsnnl ("Volume ^a has a valid ^a volume label.
Do you want to ^[initialize it with a standard ^a volume label^;^1suse this volume for unlabeled output^]? ",
	     rs_emess, rs_len, mtape_vol_set.volume_id, Tape_volume_types (mtape_vol_set.volume_type),
	     mtape_attach_info.labeled, mtape_pfm_info.module_id);
	go to U_QUERY_COM;

U_QUERY (3):					/* Q_UNEXPIRED_VOLUME */
	qep = addr (EXPLAIN_UNEXPIRED_VOLUME);		/* set the explaination ptr */
	code = error_table_$unexpired_volume;		/* set appropriate error code */
	call ioa_$rsnnl ("Volume ^a requires initialization, but contains an unexpired file.
Do you want to initialize it?",
	     rs_emess, rs_len, mtape_vol_set.volume_name);
	go to U_QUERY_COM;

U_QUERY (4):					/* Q_INCORRECT_VOLUME */
	qep = addr (EXPLAIN_INCORRECT_VOLUME);		/* set the explaination ptr */
	code = error_table_$uninitialized_volume;	/* set appropriate error code */
	query_info.query_code = 3;			/* set query code of command_question handlers */
	call ioa_$rsnnl ("Warning: Label for volume ^a contains identifier ^a instead.
Do you want to ^[continue processing^;re-initialize it as the desired volume^]?",
	     rs_emess, rs_len,
	     mtape_vol_set.volume_name, mtape_vol_set.volume_id, (mtape_open_info.open_mode = Sequential_input));
	go to U_QUERY_COM;

U_QUERY (5):					/* Q_UNEXPIRED_FILE */
	qep = addr (EXPLAIN_UNEXPIRED_FILE);		/* set the explaination ptr */
	code = error_table_$unexpired_file;		/* set appropriate error code */
	call ioa_$rsnnl ("Do you want to overwrite the unexpired file ""^a""?",
	     rs_emess, rs_len, mtape_file_info.file_id);
	go to U_QUERY_COM;

U_QUERY (6):					/* Q_ABORT_FILE */
	qep = addr (EXPLAIN_ABORT_FILE);		/* set the explaination ptr */
	code = error_table_$file_aborted;		/* set appropriate error code */
	call ioa_$rsnnl ("Error while writing labels of file ""^a"", section ^d.
The defective file section invalidates the structure of the entire file set.
Do you want to delete the defective section?", rs_emess, rs_len,
	     mtape_file_info.file_id, mtape_file_info.section);
	go to U_QUERY_COM;

U_QUERY_COM:
	query_info.status_code = code;		/* set error code */
	call SET_EXPLANATION;			/* set up the explanation string */
	call command_query_ (addr (query_info), answer, myname, rtrim (rs_emess)); /* ask question */
	if (answer = "no" & ^invert_qsw) | (answer = "yes" & invert_qsw) then
	     arg_code = code;			/* answer was negative, return code */
	else if arg_qcode = Q_NO_NEXT_VOLUME then do;	/* must get new volume name */
	     call alloc (mtdp, MTAPE_ALLOC_VS, mtape_data.vs_tail, 0, vs_ptr); /* allocate vol_set struct. */
	     mtape_data.vs_tail = vs_ptr;
	     answer = "";				/* initialize answer */
	     query_info.yes_or_no_sw = "0"b;		/* not a yes/no answer */
	     query_info.suppress_name_sw = "0"b;
	     query_info.status_code, query_info.query_code = 0;
	     qep = addr (EXPLAIN_NEW_VOLUME);		/* set the explaination ptr */
	     call SET_EXPLANATION;			/* set up the explanation string */
	     code = 1;				/* go through loop at least once */
	     do while (code ^= 0);			/* do it until user gets it right */
		call command_query_ (addr (query_info), answer, myname,
		     "^[(""^a"" incorrect)^/^;^1s^]Enter volume name of next volume (and optional comment).^/",
		     (answer ^= ""), answer);
		if answer ^= "" then do;		/* if we have some answer */
		     cdx = index (answer, " ") - 1;	/* index to end of volume name */
		     if cdx < 0 then		/* if no comment given */
			cdx = length (rtrim (answer));
		     call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), substr (answer, 1, cdx),
			mtape_vol_set.volume_name, 0, code);
		     if code ^= 0 then		/* if error from canonicalize */
			query_info.status_code = code;
		     else do;			/* now check for comment */
			answer = ltrim (substr (answer, cdx + 1)); /* remove volume name */
			if answer ^= "" then do;	/* we have some comment */
			     if substr (answer, 1, 8) = "-comment" | substr (answer, 1, 4) = "-com" then
				answer = substr (answer, index (answer, " ") + 1); /* strip off control arg */
			     mtape_vol_set.mount_comment = answer; /* copy the mount comment */
			end;
		     end;
		end;
	     end;
	end;
	return;
%page;
/* SET_EXPLANATION - internal procedure to set up the command_query_ explanation string and pointer */

SET_EXPLANATION: proc;

dcl  i fixed bin;

	explain_str = "";
	do i = 1 to query_explanation.n_lines;
	     explain_str = rtrim (explain_str) || query_explanation.text (i) || NL;
	end;
	query_info.explanation_ptr = addr (explain_str);
	query_info.explanation_len = length (rtrim (explain_str));

     end SET_EXPLANATION;

/* SAVE_CODE - internal procedure to set the return error code if not already set */

SAVE_CODE: proc;

	if arg_code = 0 then			/* set return code only if not already set */
	     arg_code = code;

     end SAVE_CODE;
%page;
%include mtape_data;
%page;
%include mtape_attach_info;
%page;
%include mtape_open_close_info;
%page;
%include mtape_pfm_info;
%page;
%include mtape_vol_set;
%page;
%include mtape_label_record;

%include mtape_err_stats;
%page;
%include mtape_file_info;
%page;
%include mtape_constants;
%page;
%include query_info;
%page;
%include rcp_resource_types;
%page;
%include rcp_volume_formats;

%include tape_ioi_error_counts;
%page;
%include iox_modes;

     end mtape_util_;




		    pa_cv_result_to_lf.pl1          02/16/84  1306.5r w 02/16/84  1249.8      112518



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
pa_cv_result_to_lf:
   proc (p_definition_ptr, p_result_ptr, p_linear_form, p_code);

/* DESCRIPTION:

         This entry converts a result pva into a linear form.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 07/05/83.
Modified:
07/06/83 by Lindsey L. Spratt:  Fixed setting of is_arg_dimension array to set
            "0"b for dimensions which aren't arg_dimensions.
07/08/83 by Lindsey L. Spratt:  Fixed to prefix option values which start with
            "-" with a "-quote ".  Fixed to requote all option values.
08/26/83 by S. Krupp: Changed to only requote option values that don't
            contain reserved command line characters.  Changed to prefix
	  only non-literal option values with "-quote".
09/13/83 by S. Krupp: Commented out -quote facility due to problems
            in making it compatible with the Force_literal facility.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_definition_ptr       ptr;		/*is a pointer to the definition
                                       print_vector_array for the command
                                       named in the result pva.  If this
                                       pointer is null, then a definition is
                                       found by searching the
                                       process_arguments search list.*/
      dcl	    p_result_ptr	       ptr;		/*is a pointer to a result
                                       print_vector_array.*/
      dcl	    p_linear_form	       char (*) varying;	/*is the linear form converted from*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system error code.*/

/* Automatic */

      dcl	    (command_name_id, option_name_identifier, instance_identifier, pv_idx)
			       fixed bin init (-1);
      dcl	    (option_name, instance_count, old_instance_count)
			       char (64) varying init ("");
      dcl	    current_linear_form    char (1024) varying;
      dcl	    result_command_name    char (32) varying init ("");
      dcl	    definition_ptr	       ptr init (null);
      dcl	    work_area_ptr	       ptr init (null);


/* Based */


/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("pa_cv_result_to_lf") char (32) varying internal static options (constant);
      dcl	    UNDEFINED_DIMENSION    init (-1) fixed bin internal static options (constant);
      dcl	    (
	    SPACE_CHAR	       init (" "),
	    TAB_CHAR	       init ("	"),
	    NEWLINE_CHAR	       init ("
")
	    )		       char (1) internal static options (constant);

/* Entry */

      dcl	    process_arguments_$get_definition
			       entry (char (*) var, ptr, ptr, fixed bin (35));
      dcl	    process_arguments_$get_reference_name
			       entry (ptr, char (*) var, char (*) var, char (*) var);

      dcl	    get_system_free_area_  entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);
      dcl	    requote_string_	       entry (char (*)) returns (char (*));

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;
      dcl	    (
	    error_table_$unimplemented_version,
	    error_table_$bad_arg
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_linear_form = "";
      definition_ptr = p_definition_ptr;
      on cleanup call FINISH;
      if work_area_ptr = null
      then work_area_ptr = get_system_free_area_ ();
      call CHECK_VERSION (p_result_ptr -> print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array");

      call SET_ID_REQUIRED (p_result_ptr, COMMAND_NAME_DIM_NAME, command_name_id);
      call GET_VALUE (p_result_ptr -> print_vector_array.vector_slot (1), command_name_id, result_command_name);

      if definition_ptr = null
      then
         do;
	  call process_arguments_$get_definition (result_command_name, work_area_ptr, definition_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN;
         end;
      call
         CHECK_VERSION (definition_ptr -> print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array");

      call SET_ID_REQUIRED (p_result_ptr, OPTION_NAME_DIM_NAME, option_name_identifier);
      call SET_ID_REQUIRED (p_result_ptr, INSTANCE_DIM_NAME, instance_identifier);

BUILD_LINEAR_FORM_BLOCK:
      begin;
         dcl     blfb_is_arg_dimension	(p_result_ptr -> print_vector_array.number_of_dimensions) bit (1) aligned;

         call FIND_ARG_DIMENSIONS (p_result_ptr, blfb_is_arg_dimension);

BLFB_PRINT_VECTOR_LOOP:
         do pv_idx = 1 to p_result_ptr -> print_vector_array.number_of_vectors;
	  print_vector_ptr = p_result_ptr -> print_vector_array.vector_slot (pv_idx);
	  old_instance_count = instance_count;
	  call GET_VALUE (print_vector_ptr, option_name_identifier, option_name);
	  call GET_VALUE (print_vector_ptr, instance_identifier, instance_count);
	  if instance_count = old_instance_count
	  then call GET_ARG_VALUES (blfb_is_arg_dimension, print_vector_ptr, current_linear_form);
	  else call GET_REFNAME_AND_VALUES (blfb_is_arg_dimension, print_vector_ptr, option_name, current_linear_form);
	  p_linear_form = p_linear_form || " " || current_linear_form;
         end BLFB_PRINT_VECTOR_LOOP;
      end BUILD_LINEAR_FORM_BLOCK;
      call FINISH;
MAIN_RETURN:
      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
SET_ID:
   proc (si_p_pva_ptr, si_p_dim_name, si_p_dim_id);
      dcl	    si_p_pva_ptr	       ptr parameter;
      dcl	    si_p_dim_name	       char (*) varying parameter;
      dcl	    si_p_dim_id	       fixed bin parameter;

      dcl	    si_dim_is_required     bit (1) aligned init ("0"b);

      dcl	    requote_string_	       entry (char (*)) returns (char (*));
      goto SI_JOIN;

SET_ID_REQUIRED:
   entry (si_p_pva_ptr, si_p_dim_name, si_p_dim_id);
      si_dim_is_required = "1"b;

SI_JOIN:
      do si_p_dim_id = 1 to si_p_pva_ptr -> print_vector_array.number_of_dimensions
         while (si_p_pva_ptr -> print_vector_array.dimension_table (si_p_dim_id).name ^= si_p_dim_name);
      end;
      if si_p_dim_id > si_p_pva_ptr -> print_vector_array.number_of_dimensions
      then if si_dim_is_required
	 then call
	         sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0,
	         "^/The argument processing definition structure must have a ^a dimension in it,
but the one provided does not.", requote_string_ ((si_p_dim_name)));
	 else si_p_dim_id = UNDEFINED_DIMENSION;

   end SET_ID;
%page;
GET_DIM_IDX:
   proc (gdi_p_pv_ptr, gdi_p_identifier, gdi_p_dim_idx);
      dcl	    gdi_p_pv_ptr	       ptr;
      dcl	    gdi_p_identifier       fixed bin;
      dcl	    gdi_p_dim_idx	       fixed bin;

      do gdi_p_dim_idx = 1 to gdi_p_pv_ptr -> print_vector.number_of_dimensions
         while (gdi_p_pv_ptr -> print_vector.dimension (gdi_p_dim_idx).identifier ^= gdi_p_identifier);
      end;
      if gdi_p_dim_idx > gdi_p_pv_ptr -> print_vector.number_of_dimensions
      then gdi_p_dim_idx = UNDEFINED_DIMENSION;
   end GET_DIM_IDX;
%page;
GET_VALUE:
   proc (gv_p_print_vector_ptr, gv_p_dim_identifier, gv_p_dim_value);
      dcl	    gv_p_print_vector_ptr  ptr parameter;
      dcl	    gv_p_dim_identifier    fixed bin parameter;
      dcl	    gv_p_dim_value	       char (*) varying;

      dcl	    gv_dim_idx	       fixed bin init (0);

      call GET_DIM_IDX (gv_p_print_vector_ptr, gv_p_dim_identifier, gv_dim_idx);

      if gv_dim_idx = UNDEFINED_DIMENSION
      then call
	    sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0,
	    "^/All of the vectors in the result print_vector_array must contain the
dimension with identifier ^d.  The current print_vector does not.", gv_p_dim_identifier);
      gv_p_dim_value = gv_p_print_vector_ptr -> print_vector.dimension (gv_dim_idx).value;
   end GET_VALUE;
%page;
FINISH:
   proc;
      if p_definition_ptr = null & definition_ptr ^= null
      then
         do;
	  do pv_idx = 1 to definition_ptr -> print_vector_array.number_of_vectors;
	     print_vector_ptr = definition_ptr -> print_vector_array.vector_slot (pv_idx);
	     if print_vector_ptr ^= null
	     then free print_vector;
	  end;
	  free definition_ptr -> print_vector_array;
         end;
   end FINISH;


ERROR_RETURN:
   proc ();
      call FINISH ();
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
GET_ARG_VALUES:
   proc (gav_p_is_arg_dimension, gav_p_print_vector_ptr, gav_p_value_str);
      dcl	    gav_p_is_arg_dimension (*) bit (1) aligned parameter;
      dcl	    gav_p_print_vector_ptr ptr parameter;
      dcl	    gav_p_value_str	       char (*) varying parameter;

      dcl	    gav_current_value_ptr  ptr init (null);
      dcl	    gav_current_value      based (gav_current_value_ptr) char (sys_info$max_seg_size * 4) varying;

      dcl	    gav_dim_idx	       fixed bin init (0);
      dcl     RESERVED_CHARS	       char(64) var init(SPACE_CHAR || TAB_CHAR || NEWLINE_CHAR || """;[]()|");

      gav_p_value_str = "";
      do gav_dim_idx = 1 to gav_p_print_vector_ptr -> print_vector.number_of_dimensions;

         if gav_p_is_arg_dimension (gav_p_print_vector_ptr -> print_vector.dimension (gav_dim_idx).identifier)
         then
	  do;
	     gav_current_value_ptr = addr (gav_p_print_vector_ptr -> print_vector.dimension (gav_dim_idx).value);
/*	     if index (ltrim (gav_current_value, SPACE_CHAR || TAB_CHAR), "-") = 1
	     then gav_p_value_str = gav_p_value_str || " " || "-quote"; */
	     if search(gav_current_value, RESERVED_CHARS) > 0
	     then gav_p_value_str = gav_p_value_str || " " || requote_string_((gav_current_value));
	     else gav_p_value_str = gav_p_value_str || " " || gav_current_value;
	  end;

      end;
   end GET_ARG_VALUES;
%page;
GET_REFNAME_AND_VALUES:
   proc (grav_p_is_arg_dimension, grav_p_print_vector_ptr, grav_p_option_name, grav_p_linear_form);
      dcl	    grav_p_is_arg_dimension
			       (*) bit (1) aligned parameter;
      dcl	    grav_p_print_vector_ptr
			       ptr parameter;
      dcl	    grav_p_option_name     char (*) varying parameter;
      dcl	    grav_p_linear_form     char (*) varying parameter;

      dcl	    (grav_positive_refname, grav_negative_refname)
			       char (256) varying init ("");

      grav_p_linear_form = "";

      call
         process_arguments_$get_reference_name (definition_ptr, grav_p_option_name, grav_positive_refname,
         grav_negative_refname);
      call GET_ARG_VALUES (grav_p_is_arg_dimension, grav_p_print_vector_ptr, grav_p_linear_form);

      if grav_negative_refname = ""
      then grav_p_linear_form = grav_positive_refname || " " || grav_p_linear_form;
      else if index (grav_p_linear_form, "false") > 0
      then grav_p_linear_form = grav_negative_refname;
      else grav_p_linear_form = grav_positive_refname;
   end GET_REFNAME_AND_VALUES;
%page;
FIND_ARG_DIMENSIONS:
   proc (fad_p_result_ptr, fad_p_is_arg_dimension);
      dcl	    fad_p_result_ptr       ptr parameter;
      dcl	    fad_p_is_arg_dimension (*) bit (1) aligned parameter;

      dcl	    fad_dim_identifier     fixed bin init (0);
      dcl	    fad_dim_name	       char (128) varying init ("");

      fad_p_is_arg_dimension (*) = "1"b;

      do fad_dim_name = COMMAND_NAME_DIM_NAME, OPTION_NAME_DIM_NAME, ORDER_DIM_NAME, INSTANCE_DIM_NAME;
         call SET_ID_REQUIRED (fad_p_result_ptr, fad_dim_name, fad_dim_identifier);
         fad_p_is_arg_dimension (fad_dim_identifier) = "0"b;
      end;
   end FIND_ARG_DIMENSIONS;
%page;
%include sub_err_flags;
%page;
%include vu_print_vector_array;
%page;
%include pa_dim_name_constants;
   end pa_cv_result_to_lf;




		    pa_get_option_value.pl1         10/24/88  1652.3r w 10/24/88  1359.0      189540



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
pa_get_option_value:
   proc (p_result_print_vector_array_ptr, p_area_ptr, p_found_option);

/* DESCRIPTION:

         This entry extracts the values of arguments of options as present in
     a result print_vector_array produced by process_arguments_.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 06/11/83.
Modified:
06/15/83 by Lindsey L. Spratt:  Added a new argument, p_found_option, to
            record which of the requested options were found in the result
            pva.
06/30/83 by Lindsey L. Spratt:  Changed to use pa_dim_name_constants.incl.pl1.
           Changed to look for the option name dimension in the print_vector
            rather than assume it is the next to last dimension.
07/07/83 by Lindsey L. Spratt:  Fixed to correctly handle varying character
            return data.
08/04/83 by S. Krupp to correctly handle varying character input data
            (the option_name argument specifically).
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_result_print_vector_array_ptr
			       ptr;		/*is a pointer to a result
                                                print_vector_array produced by
                                                process_arguments_.*/
      dcl	    p_area_ptr	       ptr;		/*is a pointer to the area in
                                                which this entry is to
                                                allocate its output
                                                information (when
                                                appropriate).*/
      dcl	    p_found_option	       bit (*) parameter;

/* Automatic */

      dcl	    output_area_ptr	       ptr init (null);	/* Pointer on which output_area is based. */
      dcl	    system_area_ptr	       ptr init (null);
      dcl	    nargs		       fixed bin init (0);	/* Number of arguments with which this subroutine was called. */
      dcl	    arg_list_ptr	       ptr init (null);	/* Pointer to the argument list for this subroutine. */
      dcl	    arg_list_arg_count     fixed bin init (0);	/* Variable used by the arg_list structure. */
      dcl	    number_of_option_values_requested
			       fixed bin init (0);
      dcl	    option_name_identifier fixed bin init (0);	/* This is the index into the dimension_table */
						/* of the definition of the option_name dimension. */
      dcl	    vhbu_number_of_vectors fixed bin init (0);	/* The extent of the vector_has_been_used bit array. */
      dcl	    vector_has_been_used_ptr
			       ptr init (null);	/* Points at the vector_has_been_used array. */

      dcl	    option_idx	       fixed bin init (0);	/* The loop counter for the OPTION_LOOP. */
      dcl	    option_name_arg_idx    fixed bin init (0);	/* The index into the argument list of the current */
						/* (in the OPTION_LOOP) option's name. */
      dcl	    option_variable_arg_idx
			       fixed bin init (0);	/* The index into the argument list of the */
						/* current option's return value variable. */

      dcl	    type		       fixed bin init (0);	/* Set by calling decode_descriptor_. */
      dcl	    packed	       bit (1) aligned init ("0"b);
						/* Set by calling decode_descriptor_. */
      dcl	    ndims		       fixed bin init (0);	/* Set by calling decode_descriptor_. */
      dcl	    size		       fixed bin init (0);	/* Set by calling decode_descriptor_. */
      dcl	    scale		       fixed bin init (0);	/* Set by calling decode_descriptor_. */

      dcl	    option_name_ptr	       ptr init (null);	/* Pointer on which option_name is based. Set from */
						/* the argument_list. */
      dcl	    option_name_length     fixed bin init (0);	/* Length of the option_name from the argument_list. */

      dcl	    current_option_vector_idx
			       fixed bin init (0);	/* Index into the print_vector_array of */
						/* the print_vector from which the current */
						/* option_value was extracted. */
      dcl	    option_value_ptr       ptr init (null);	/* Pointer on which the option_value is based. */

      dcl	    data_ptr	       ptr init (null);	/* Pointer to return variable in which the option_value is to */
						/* be placed. */

      dcl	    char_data_length       fixed bin init (0);
      dcl	    vchar_data_length      fixed bin init (0);

      dcl	    option_value_link_ptr  ptr init (null);
      dcl	    root_option_value_link_ptr
			       ptr init (null);
      dcl	    previous_option_value_link_ptr
			       ptr init (null);
      dcl	    next_option_value_link_ptr
			       ptr init (null);

      dcl	    value_idx	       fixed bin init (0);

/* Based */

      dcl	    output_area	       area based (output_area_ptr);
						/* Area in which option_value_list structures */
						/* area allocated for the caller. */
      dcl	    system_area	       area based (system_area_ptr);
						/* Area for scratch storage. */
      dcl	    vector_has_been_used   (vhbu_number_of_vectors) bit (1) aligned based (vector_has_been_used_ptr);
						/* This array is used by FIND_OPTION_VALUE to avoid looking at */
						/* any vector in the caller-provided print_vector_array */
						/* more than once. */
      dcl	    option_name	       char (option_name_length) based (option_name_ptr);
      dcl	    option_value	       char (sys_info$max_seg_size * 4) varying based (option_value_ptr);
      dcl	    var_option_name_size   fixed bin(21) based(addwordno(option_name_ptr, -1));

      dcl	    aligned_char_data      based (data_ptr) aligned char (char_data_length);
      dcl	    unaligned_char_data    based (data_ptr) unaligned char (char_data_length);

      dcl	    aligned_vchar_data     based (data_ptr) aligned char (vchar_data_length) varying;
      dcl	    unaligned_vchar_data   based (data_ptr) unaligned char (vchar_data_length) varying;

      dcl	    aligned_flag_data      based (data_ptr) aligned bit (1);
      dcl	    unaligned_flag_data    based (data_ptr) unaligned bit (1);

      dcl	    aligned_integer_data   based (data_ptr) aligned fixed bin (35);
      dcl	    unaligned_integer_data based (data_ptr) unaligned fixed bin (35);

      dcl	    aligned_list_ptr_data  based (data_ptr) aligned ptr;
      dcl	    unaligned_list_ptr_data
			       based (data_ptr) unaligned ptr;

      dcl	    1 option_value_link    based (option_value_link_ptr),
	      2 next_ptr	       ptr init (null),
	      2 value_ptr	       ptr init (null),
	      2 vector_idx	       fixed bin init (0);

/* Builtin */

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

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    MINIMUM_POSSIBLE_NUMBER_OF_ARGS
			       init (5),
	    NUMBER_OF_NONVALUE_ARGS
			       init (3),
	    NUMBER_OF_INITIAL_NONVALUE_ARGS
			       init (3),
	    NO_CURRENT_OPTION_VECTOR_IDX
			       init (0)
	    )		       fixed bin internal static options (constant);

      dcl	    MYNAME	       init ("pa_get_option_value") char (32) varying internal static options (constant);

/* Entry */

      dcl	    requote_string_	       entry (char (*)) returns (char (*));
      dcl	    get_system_free_area_  entry () returns (ptr);

      dcl	    cu_$arg_count	       entry (fixed bin, fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);

      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);

      dcl	    sub_err_	       entry () options (variable);

/* External */

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

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

/* END OF DECLARATIONS */

      print_vector_array_ptr = p_result_print_vector_array_ptr;
      output_area_ptr = p_area_ptr;
      system_area_ptr = get_system_free_area_ ();

      call CHECK_VERSION (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array");

      on cleanup call FINISH;

      call cu_$arg_count (nargs, (0));
      arg_list_arg_count = nargs;
      call cu_$arg_list_ptr (arg_list_ptr);


      if nargs < MINIMUM_POSSIBLE_NUMBER_OF_ARGS
      then call sub_err_ (error_table_$too_few_args, MYNAME, ACTION_CANT_RESTART, null, 0);
      else if mod (nargs - NUMBER_OF_NONVALUE_ARGS, 2) ^= 0
      then call
	    sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
	    "^/The option names/value variable arguments must be paired.  
This was not the case.");

      number_of_option_values_requested = divide (nargs - NUMBER_OF_NONVALUE_ARGS, 2, 17, 0);

      call GET_DIMENSION_IDENTIFIER (print_vector_array_ptr, (OPTION_NAME_DIM_NAME), option_name_identifier);

      vhbu_number_of_vectors = print_vector_array.number_of_vectors;
      alloc vector_has_been_used in (system_area);
      unspec (vector_has_been_used) = "0"b;

      if length (p_found_option) < number_of_option_values_requested
      then call
	    sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
	    "^/The caller-provided ""found_option"" string must have as many bits in it
as the number of options for which values are requested.  However, there are
only ^d bits in the ""found_option"" string and ^d options were requested.", length (p_found_option),
	    number_of_option_values_requested);

      p_found_option = "0"b;

OPTION_LOOP:
      do option_idx = 1 to number_of_option_values_requested;
         option_name_arg_idx = 2 * (option_idx - 1) + 1 + NUMBER_OF_INITIAL_NONVALUE_ARGS;
         option_variable_arg_idx = option_name_arg_idx + 1;

         call decode_descriptor_ (arg_list_ptr, option_name_arg_idx, type, packed, ndims, size, scale);
         if type ^= char_dtype & type ^= varying_char_dtype
         then call
	       sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
	       "^/Option name parameter number ^d (argument number ^d) does not have 
a character string data type.", option_idx, option_name_arg_idx);

         option_name_ptr = arg_list_ptr -> arg_list.arg_ptrs (option_name_arg_idx);
         if type = varying_char_dtype
         then option_name_length = var_option_name_size;
         else option_name_length = size;

         current_option_vector_idx = NO_CURRENT_OPTION_VECTOR_IDX;

         call
	  FIND_OPTION_VALUE (print_vector_array_ptr, option_name_identifier, (option_name), vector_has_been_used,
	  current_option_vector_idx, option_value_ptr);

         if option_value_ptr ^= null
         then
PROCESS_OPTION_VALUE:
	  do;
	     substr (p_found_option, option_idx, 1) = "1"b;
	     call decode_descriptor_ (arg_list_ptr, option_variable_arg_idx, type, packed, ndims, size, scale);

	     data_ptr = arg_list_ptr -> arg_list.arg_ptrs (option_variable_arg_idx);

	     if type = char_dtype
	     then
CHAR_DATA:
	        do;
		 char_data_length = size;
		 if packed
		 then
		    do;
(stringsize):
		       unaligned_char_data = option_value;
		    end;
		 else
		    do;
(stringsize):
		       aligned_char_data = option_value;
		    end;
	        end CHAR_DATA;
	     else if type = varying_char_dtype
	     then
VCHAR_DATA:
	        do;
		 data_ptr = addwordno (data_ptr, -1);	/* To adjust for peculiar handling of the varying data type in arg_list preparation. */
		 vchar_data_length = size;
		 if packed
		 then
		    do;
(stringsize):
		       unaligned_vchar_data = option_value;
		    end;
		 else
		    do;
(stringsize):
		       aligned_vchar_data = option_value;
		    end;
	        end VCHAR_DATA;
	     else if type = bit_dtype & size = 1
	     then
FLAG_DATA:
	        do;
		 if packed
		 then unaligned_flag_data = CONVERT_TO_FLAG (option_value);
		 else aligned_flag_data = CONVERT_TO_FLAG (option_value);
	        end FLAG_DATA;
	     else if type = real_fix_bin_1_dtype
	     then
INTEGER_DATA:
	        do;
		 if packed
		 then unaligned_integer_data = CONVERT_TO_INTEGER (option_value);
		 else aligned_integer_data = CONVERT_TO_INTEGER (option_value);
	        end INTEGER_DATA;
	     else if type = pointer_dtype
	     then
DATA_LIST:
	        do;
		 alloc option_value_link in (system_area);
		 root_option_value_link_ptr = option_value_link_ptr;
		 option_value_link.value_ptr = option_value_ptr;
		 option_value_link.vector_idx = current_option_vector_idx;

		 call
		    FIND_OPTION_VALUE (print_vector_array_ptr, option_name_identifier, (option_name),
		    vector_has_been_used, current_option_vector_idx, option_value_ptr);
DATA_LIST_LOOP:
		 do ovl_number_of_values = 1 by 1 while (option_value_ptr ^= null);
		    previous_option_value_link_ptr = option_value_link_ptr;
		    alloc option_value_link in (system_area);
		    previous_option_value_link_ptr -> option_value_link.next_ptr = option_value_link_ptr;
		    option_value_link.next_ptr = null;
		    option_value_link.value_ptr = option_value_ptr;
		    option_value_link.vector_idx = current_option_vector_idx;
		    call
		       FIND_OPTION_VALUE (print_vector_array_ptr, option_name_identifier, (option_name),
		       vector_has_been_used, current_option_vector_idx, option_value_ptr);

		 end DATA_LIST_LOOP;

/* The refer extent variable, ovl_number_of_values, is set in the 
DATA_LIST_LOOP. 
*/

		 alloc option_value_list in (output_area);
		 option_value_list.version = OPTION_VALUE_LIST_VERSION_1;
		 option_value_link_ptr = root_option_value_link_ptr;
		 do value_idx = 1 to option_value_list.number_of_values;
		    next_option_value_link_ptr = option_value_link.next_ptr;
		    option_value_list.value (value_idx).ptr = option_value_link.value_ptr;
		    option_value_list.value (value_idx).vector_idx = option_value_link.vector_idx;

		    option_value_link_ptr = next_option_value_link_ptr;

		 end;

		 if packed
		 then unaligned_list_ptr_data = option_value_list_ptr;
		 else aligned_list_ptr_data = option_value_list_ptr;

	        end DATA_LIST;
	     else call
		   sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
		   "^/Option variable parameter number ^d (argument number ^d) does not have 
a valid data type.  It must be one of the following data types:
character (varying or non-varying), bit (1), fixed bin (<36), or pointer.", option_idx, option_variable_arg_idx);
	  end PROCESS_OPTION_VALUE;
      end OPTION_LOOP;

      call FINISH;
      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, MYNAME, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
GET_DIMENSION_IDENTIFIER:
   proc (gdi_p_pva_ptr, gdi_p_dimension_name, gdi_p_dimension_identifier);
      dcl	    gdi_p_pva_ptr	       ptr parameter;
      dcl	    gdi_p_dimension_name   char (*) parameter;
      dcl	    gdi_p_dimension_identifier
			       fixed bin parameter;

      dcl	    gdi_dim_idx	       fixed bin;

      do gdi_dim_idx = 1 to gdi_p_pva_ptr -> print_vector_array.number_of_dimensions
         while (gdi_p_pva_ptr -> print_vector_array.dimension_table (gdi_dim_idx).name ^= gdi_p_dimension_name);
      end;
      if gdi_dim_idx > gdi_p_pva_ptr -> print_vector_array.number_of_dimensions
      then call
	    sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
	    "^/The input result print_vector_array does not have a dimension named ^a.",
	    requote_string_ (gdi_p_dimension_name));
      gdi_p_dimension_identifier = gdi_dim_idx;
   end GET_DIMENSION_IDENTIFIER;
%page;
FIND_OPTION_VALUE:
   proc (fov_p_print_vector_array_ptr, fov_p_option_name_identifier, fov_p_option_name, fov_p_vector_has_been_used,
      fov_p_current_option_vector_idx, fov_p_option_value_ptr);
      dcl	    fov_p_print_vector_array_ptr
			       ptr parameter;
      dcl	    fov_p_option_name_identifier
			       fixed bin parameter;
      dcl	    fov_p_option_name      char (*) parameter;
      dcl	    fov_p_vector_has_been_used
			       (*) bit (1) aligned parameter;
      dcl	    fov_p_current_option_vector_idx
			       fixed bin parameter;
      dcl	    fov_p_option_value_ptr ptr parameter;

      dcl	    fov_print_vector_ptr   ptr;
      dcl	    fov_print_vector_idx   fixed bin (35);
      dcl	    (fov_name_dim_idx, fov_value_dim_idx)
			       fixed bin init (0);


FOV_PRINT_VECTOR_LOOP:
      do fov_print_vector_idx = fov_p_current_option_vector_idx + 1
         to fov_p_print_vector_array_ptr -> print_vector_array.number_of_vectors;
         if ^fov_p_vector_has_been_used (fov_print_vector_idx)
         then
	  do;
	     fov_print_vector_ptr =
	        fov_p_print_vector_array_ptr -> print_vector_array.vector_slot (fov_print_vector_idx);

	     do fov_name_dim_idx = 1 to fov_print_vector_ptr -> print_vector.number_of_dimensions
	        while (fov_print_vector_ptr -> print_vector.dimension (fov_name_dim_idx).identifier
	        ^= fov_p_option_name_identifier);
	     end;
	     if fov_name_dim_idx > fov_print_vector_ptr -> print_vector.number_of_dimensions
	     then call
		   sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
		   "^/The option name dimension must be present in all of the
result print_vectors.  This is not the case for print_vector ^d.", fov_print_vector_idx);

	     if fov_p_option_name = fov_print_vector_ptr -> print_vector.dimension (fov_name_dim_idx).value
	     then
	        do;
		 fov_p_current_option_vector_idx = fov_print_vector_idx;
		 fov_value_dim_idx = fov_print_vector_ptr -> print_vector.number_of_dimensions;
		 fov_p_option_value_ptr =
		    addr (fov_print_vector_ptr -> print_vector.dimension (fov_value_dim_idx).value);
		 fov_p_vector_has_been_used (fov_print_vector_idx) = "1"b;
		 return;
	        end;
	  end;
      end FOV_PRINT_VECTOR_LOOP;

      fov_p_current_option_vector_idx = 0;
      fov_p_option_value_ptr = null;


   end FIND_OPTION_VALUE;
%page;
CONVERT_TO_FLAG:
   proc (ctf_p_option_value) returns (bit (1) aligned);
      dcl	    ctf_p_option_value     char (*) varying parameter;

      if ctf_p_option_value = "true" | ctf_p_option_value = "t" | ctf_p_option_value = "on" | ctf_p_option_value = "yes"
         | ctf_p_option_value = "y" | ctf_p_option_value = "1"
      then return ("1"b);
      else if ctf_p_option_value = "false" | ctf_p_option_value = "f" | ctf_p_option_value = "off"
	    | ctf_p_option_value = "no" | ctf_p_option_value = "n" | ctf_p_option_value = "0"
      then return ("0"b);
      else call
	    sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
	    "^/The option  ^a has a value which is not convertable to a flag.
Its value is ^a.", requote_string_ ((option_name)), requote_string_ ((ctf_p_option_value)));
   end CONVERT_TO_FLAG;
%page;
CONVERT_TO_INTEGER:
   proc (cti_p_option_value) returns (fixed bin (35));
      dcl	    cti_p_option_value     char (*) varying parameter;

      dcl	    cti_integer	       fixed bin (35);
      dcl	    cti_code	       fixed bin (35);
      dcl	    cv_dec_check_	       entry (char (*), fixed bin (35)) returns (fixed bin (35));
      dcl	    requote_string_	       entry (char (*)) returns (char (*));

      cti_integer = cv_dec_check_ ((cti_p_option_value), cti_code);
      if cti_code ^= 0
      then call
	    sub_err_ (error_table_$bad_arg, MYNAME, ACTION_CANT_RESTART, null, 0,
	    "^/The value for option ^a, ^a, couldn't be converted to an integer.
The conversion failed on character ^d, ^a.", requote_string_ ((option_name)), requote_string_ ((cti_p_option_value)),
	    cti_code, requote_string_ (substr (cti_p_option_value, cti_code, 1)));
      return (cti_integer);
   end CONVERT_TO_INTEGER;
%page;
FINISH:
   proc ();
      if root_option_value_link_ptr ^= null
      then
         do;
	  root_option_value_link_ptr = null;
	  option_value_link_ptr = root_option_value_link_ptr;
	  do while (option_value_link_ptr ^= null);
	     next_option_value_link_ptr = option_value_link_ptr;
	     free option_value_link in (system_area);
	     option_value_link_ptr = next_option_value_link_ptr;
	  end;
         end;
      if vector_has_been_used_ptr ^= null
      then free vector_has_been_used in (system_area);
   end FINISH;
%page;
%include sub_err_flags;
%page;
%include vu_print_vector_array;
%page;
%include std_descriptor_types;
%page;
%include pa_option_value_list;
%page;
%include pa_dim_name_constants;
%page;
%include arg_list;
   end pa_get_option_value;




		    pa_get_refname.pl1              02/16/84  1306.5r w 02/16/84  1249.8       68796



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
pa_get_refname:
   proc (p_definition_pva_ptr, p_option_name, p_positive_reference_name, p_negative_reference_name);

/* DESCRIPTION:

         This  entry  returns  the primary name by which the specified option
     can be referenced in a linear form.  If the option is one  which  sets  a
     flag  based  on  whether  it  is referenced by its "positive" name or its
     "negative" name, then this entry returns the primary "positive"  and  the
     primary "negative" reference names.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 06/30/83.
Modified:
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_definition_pva_ptr   ptr;		/*is a pointer to a standard
                                                argument processing
                                                definition.*/
      dcl	    p_option_name	       char (*) varying;	/*is the name of an option for
                                                which the reference name is
                                                desired.*/
      dcl	    p_positive_reference_name
			       char (*) varying;	/*is the primary reference
                                                name for the specified option.
                                                If the option has positive and
                                                negative reference names, then
                                                this is the primary positive
                                                reference name.*/
      dcl	    p_negative_reference_name
			       char (*) varying;	/*is the primary negative
                                                reference name.  If the option
                                                does not have a negative
                                                reference name, this parameter
                                                gets a null value.*/

/* Automatic */

      dcl	    (option_name_identifier, synonym_identifier, negative_form_identifier)
			       fixed bin init (0);
      dcl	    (pv_dim_idx, syn_pv_dim_idx, neg_pv_dim_idx)
			       fixed bin init (0);
      dcl	    print_vector_idx       fixed bin init (0);
      dcl	    (finished, have_found_a_vector_for_the_option)
			       bit (1) aligned init ("0"b);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    UNDEFINED_DIMENSION    init (-1) fixed bin internal static options (constant);
      dcl	    myname	       init ("pa_get_refname") char (32) varying internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

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

/* END OF DECLARATIONS */

      print_vector_array_ptr = p_definition_pva_ptr;
      call CHECK_VERSION (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array");

      call SET_ID_REQUIRED (print_vector_array_ptr, OPTION_NAME_DIM_NAME, option_name_identifier);
      call SET_ID_REQUIRED (print_vector_array_ptr, SYNONYM_DIM_NAME, synonym_identifier);
      call SET_ID (print_vector_array_ptr, NEGATIVE_FORM_DIM_NAME, negative_form_identifier);
      if negative_form_identifier = UNDEFINED_DIMENSION
      then neg_pv_dim_idx = UNDEFINED_DIMENSION;
      else neg_pv_dim_idx = 0;

      p_negative_reference_name, p_positive_reference_name = "";

DEFINITION_LOOP:
      do print_vector_idx = 1 to print_vector_array.number_of_vectors while (^finished);
         print_vector_ptr = print_vector_array.vector_slot (print_vector_idx);
         call GET_DIM_IDX (print_vector_ptr, option_name_identifier, pv_dim_idx);
         if pv_dim_idx ^= UNDEFINED_DIMENSION
         then if print_vector.dimension (pv_dim_idx).value = p_option_name
	    then
FOUND_VECTOR_FOR_OPTION:
	       do;
		have_found_a_vector_for_the_option = "1"b;
		call GET_DIM_IDX (print_vector_ptr, synonym_identifier, syn_pv_dim_idx);
		if syn_pv_dim_idx ^= UNDEFINED_DIMENSION
		then
PROCESS_REFNAME:
		   do;
		      if negative_form_identifier ^= UNDEFINED_DIMENSION
		      then call GET_DIM_IDX (print_vector_ptr, negative_form_identifier, neg_pv_dim_idx);
		      if neg_pv_dim_idx = UNDEFINED_DIMENSION
		      then
		         do;
			  if p_positive_reference_name = ""
			  then p_positive_reference_name = print_vector.dimension (syn_pv_dim_idx).value;
			  finished =
			     (p_negative_reference_name ^= "" | negative_form_identifier = UNDEFINED_DIMENSION);

		         end;
		      else
		         do;
			  if p_negative_reference_name = ""
			  then p_negative_reference_name = print_vector.dimension (syn_pv_dim_idx).value;
			  finished = (p_positive_reference_name ^= "");
		         end;
		   end PROCESS_REFNAME;
	       end FOUND_VECTOR_FOR_OPTION;
	    else finished = have_found_a_vector_for_the_option;
      end DEFINITION_LOOP;
      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
SET_ID:
   proc (si_p_pva_ptr, si_p_dim_name, si_p_dim_id);
      dcl	    si_p_pva_ptr	       ptr parameter;
      dcl	    si_p_dim_name	       char (*) varying parameter;
      dcl	    si_p_dim_id	       fixed bin parameter;

      dcl	    si_dim_is_required     bit (1) aligned init ("0"b);

      dcl	    requote_string_	       entry (char (*)) returns (char (*));
      goto SI_JOIN;

SET_ID_REQUIRED:
   entry (si_p_pva_ptr, si_p_dim_name, si_p_dim_id);
      si_dim_is_required = "1"b;

SI_JOIN:
      do si_p_dim_id = 1 to si_p_pva_ptr -> print_vector_array.number_of_dimensions
         while (si_p_pva_ptr -> print_vector_array.dimension_table (si_p_dim_id).name ^= si_p_dim_name);
      end;
      if si_p_dim_id > si_p_pva_ptr -> print_vector_array.number_of_dimensions
      then if si_dim_is_required
	 then call
	         sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0,
	         "^/The argument processing definition structure must have a ^a dimension in it,
but the one provided does not.", requote_string_ ((si_p_dim_name)));
	 else si_p_dim_id = UNDEFINED_DIMENSION;

   end SET_ID;
%page;
GET_DIM_IDX:
   proc (gdi_p_pv_ptr, gdi_p_identifier, gdi_p_dim_idx);
      dcl	    gdi_p_pv_ptr	       ptr;
      dcl	    gdi_p_identifier       fixed bin;
      dcl	    gdi_p_dim_idx	       fixed bin;

      do gdi_p_dim_idx = 1 to gdi_p_pv_ptr -> print_vector.number_of_dimensions
         while (gdi_p_pv_ptr -> print_vector.dimension (gdi_p_dim_idx).identifier ^= gdi_p_identifier);
      end;
      if gdi_p_dim_idx > gdi_p_pv_ptr -> print_vector.number_of_dimensions
      then gdi_p_dim_idx = UNDEFINED_DIMENSION;
   end GET_DIM_IDX;
%page;
%include sub_err_flags;
%page;
%include vu_print_vector_array;
%page;
%include pa_dim_name_constants;
   end pa_get_refname;




		    pa_process_arguments.pl1        10/24/88  1652.3r w 10/24/88  1359.1      793485



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



/****^  HISTORY COMMENTS:
  1) change(82-03-18,Spratt), approve(), audit(), install():
     Written.
  2) change(83-05-01,York), approve(), audit(), install():
     William M.  York and Suzanne Krupp: to prepare for exposure release as
     part of the new tape software.
  3) change(83-06-20,Spratt), approve(), audit(), install():
     Converted from process_arguments_.pl1.  Renamed the main entry
     $argument_list, added the $argument_array and $argument_string entries,
     and the code which supports them.
  4) change(83-06-27,Spratt), approve(), audit(), install():
     Moved the search list code into a separate module, pa_search_list.
  5) change(83-06-29,York), approve(), audit(), install():
     Get all the excluded options out of the definition, fix checking
     for required arguments, and add validation of arguments.
  6) change(83-07-01,York), approve(), audit(), install():
     Interpret a required argument as meaning that only one instance of the
     argument is required even if more are allowed.  Also improved error
     messages and set proper maximum value lengths for the dimensions of the
     result pva.
  7) change(83-07-01,Spratt), approve(), audit(), install():
     Fixed to use the new calling sequence of $get_default_linear_form.  The
     process_arguments_$argument_string entry is now used to parse the
     default_linear_form into an initial result_print_vector_array.  This
     interaction should be improved so that the invocation of
     pa_process_arguments which gets the default_linear_form and the
     invocation of pa_process_arguments can share the processed form of the
     definition.  Fixed to call CONVERT_STRING_TO_ARG_LIST for the
     default_linear_form.
  8) change(83-07-07,Spratt), approve(), audit(), install():
     Fixed to use a first_arg_idx of 1 when processing the default linear
     form.  Also fixed to report a missing explanation instead of taking a
     null pointer fault.  Changed to evaluate active strings in default linear
     forms.
  9) change(83-07-08,Spratt), approve(), audit(), install():
     Changed to use "-quote -foo" instead of "--foo" to force the
     interpretation of "-foo" as an option value and not an option reference
     name.  Moved the invocation of PRINT_EXPLANATION into the main
     option-value-processing do-group of the ARG_LOOP to ensure that the
     control_argument_ptr is set.
 10) change(83-07-20,Spratt), approve(), audit(), install():
     Changed the CONVERT_ARRAY_TO_LIST to return a null arg_list_ptr when the
     input argument_array has one element which equals "".  Changed
     CONVERT_STRING_TO_LIST to return a null arg_list_ptr when the input
     arg_string equals "".
 11) change(83-07-25,SKrupp), approve(), audit(), install():
     Fixed handling of implied options that have arguments prefixed by a
     "-quote".  Fixed MISPLACED_CONTROL_ARGUMENT to test for
     control_argument_is_in_effect as well as what it already tests for.
 12) change(83-08-03,SKrupp), approve(), audit(), install():
     Added result validation and fixed assorted bugs.
 13) change(83-08-28,SKrupp), approve(), audit(), install():
     Added argument validation explanations and the ability to force arguments
     to be taken literally in to the -quote facility.
 14) change(85-10-03,GWMay), approve(85-10-03,MCR7282), audit(85-12-16,GDixon),
     install(85-12-17,MR12.0-1001):
     Reformatted history comments.  Modified PROCESS_ARGUMENT_LIST to
     initialize the control_argument_is_in_effect,
     using_implicit_control_argument and option_accepts_explicit_argument
     switches to false.
                                                   END HISTORY COMMENTS */

/* format: style2,ind3 */
pa_process_arguments:
   proc ();


/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_command_name	       char (*);
      dcl	    p_arg_processing_mode  fixed bin;
      dcl	    p_arg_list_ptr	       ptr;
      dcl	    p_first_arg_idx	       fixed bin;
      dcl	    p_arg_array	       (*) char (*) varying;
      dcl	    p_arg_string	       char (*) varying;
      dcl	    p_definition_print_vector_array_ptr
			       ptr;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_result_print_vector_array_ptr
			       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    using_implicit_control_argument
			       bit (1) aligned init ("0"b);
      dcl	    last_arg_idx_processed fixed bin init (0);
      dcl	    first_arg_idx	       fixed bin init (0);
      dcl	    (arg_list_ptr, default_arg_list_ptr)
			       ptr init (null);
      dcl	    dim_idx	       fixed bin;
      dcl	    max_value_arg_len      fixed bin;
      dcl	    (implied_control_argument_name_identifier, control_argument_name_identifier,
	    next_implied_control_argument_name_identifier, result_control_argument_name_identifier,
	    argument_name_identifier, initial_argument_name_identifier, next_argument_name_identifier,
	    option_presence_identifier, argument_presence_identifier, explanation_identifier, synonym_identifier,
	    validation_string_identifier, antonym_identifier, result_instance_identifier,
	    result_command_name_identifier, result_order_identifier, default_argument_value_identifier,
	    negative_default_argument_value_identifier, excluded_option_identifier)
			       fixed bin;
      dcl	    implied_control_argument_ptr
			       ptr;
      dcl	    vector_idx	       fixed bin;
      dcl	    temp_idx	       fixed bin;
      dcl	    real_vector_count      fixed bin;
      dcl	    control_argument_name_dim_id
			       fixed bin;
      dcl	    old_control_argument_name_dim_id
			       fixed bin;
      dcl	    old_print_vector_ptr   ptr;
      dcl	    old_control_argument_ptr
			       ptr;
      dcl	    root_control_argument_ptr
			       ptr;
      dcl	    arg_exists	       bit (1) aligned;
      dcl	    option_accepts_explicit_argument
			       bit (1) aligned;
      dcl	    control_argument_is_in_effect
			       bit (1) aligned init ("0"b);
      dcl	    exists_implied_control_argument
			       bit (1) aligned init ("0"b);
      dcl	    implied_control_argument_name_ptr
			       ptr;
      dcl	    implied_control_argument_name_length
			       fixed bin;
      dcl	    first_argument_name_ptr
			       pointer;
      dcl	    first_argument_name_len
			       fixed bin;
      dcl	    global_instance_count  fixed bin init (0);
      dcl	    value_idx	       fixed bin init (0);
      dcl	    arg_idx	       fixed bin;
      dcl	    nargs		       fixed bin;
      dcl	    arg_ptr	       ptr;
      dcl	    arg_len	       fixed bin;
      dcl	    force_interpretation_as_non_control_argument
			       bit (1) aligned init ("0"b);
      dcl	    control_argument_ptr   ptr;
      dcl	    arg_info_ptr	       ptr;
      dcl	    name_array_idx	       fixed bin;
      dcl	    active_string	       char (4096) varying;
      dcl     active_explanation     char(4096) varying;
      dcl	    result	       char (5) varying;


      dcl	    name_array_count       fixed bin init (0);

      dcl	    1 name_array	       (200),
	      2 name_ptr	       ptr,
	      2 def_ptr	       ptr,
	      2 antonym	       bit (1) aligned;

      dcl	    1 value	       (100),
	      2 arg_name_ptr       ptr,
	      2 arg_name_len       fixed bin,
	      2 arg_ptr	       ptr,
	      2 arg_len	       fixed bin;

      dcl	    default_linear_form_string
			       char (4096) varying init ("");
      dcl     command_name_str       char(86) var init("");
      dcl     validate_result_identifier fixed bin;
      dcl     validate_result_explanation_identifier fixed bin;
      dcl     validate_result_list_ptr ptr;
      dcl     validate_result_explanation_list_ptr ptr;
      dcl     list_ptr ptr;
      dcl     node_ptr ptr;
      dcl     force_literal_identifier fixed bin;
      dcl     validate_explanation_identifier fixed bin;

/* Based */

      dcl	    based_real_fix_bin_1u  fixed bin (35) based unaligned;

      dcl	    name_array_name	       char (256) varying based (name_array (name_array_idx).name_ptr);

      dcl	    active_string_length   fixed bin (21) based (addr (active_string));
      dcl     active_explanation_length
                                     fixed bin(21) based(addr(active_explanation));
      dcl	    active_string_nonvarying
			       char (4096) based (addwordno (addr (active_string), 1));
      dcl     active_explanation_nonvarying
                                     char(4096) based(addwordno(addr(active_explanation), 1));

      dcl	    implied_control_argument_name
			       char (implied_control_argument_name_length) varying
			       based (implied_control_argument_name_ptr);
      dcl	    first_argument_name    char (first_argument_name_len) based (first_argument_name_ptr);
      dcl	    arg		       char (arg_len) based (arg_ptr);
      dcl	    arg_char_array	       (arg_len) char (1) based (arg_ptr);

      dcl	    1 control_argument     based (control_argument_ptr),
	      2 next	       ptr,
	      2 previous	       ptr,
	      2 excluded_option_chain
			       pointer,
	      2 control_argument_name_ptr
			       ptr,
	      2 control_argument_name_length
			       fixed bin,
	      2 first_arg_vector_idx
			       fixed bin,
	      2 last_arg_vector_idx
			       fixed bin,
	      2 initial_arg_vector_idx
			       fixed bin,
	      2 vector_idx	       fixed bin,
	      2 instance_count     fixed bin,		/* how many so far this command line? */
	      2 instances_required fixed bin,		/* how many must we have? */
	      2 flags	       unaligned,
	        3 accepts_explicit_argument
			       bit (1),
	        3 antonym	       bit (1),
	        3 pad	       bit (34);

      dcl	    control_argument_name  char (control_argument.control_argument_name_length)
			       based (control_argument.control_argument_name_ptr);

      dcl	    1 arg_info	       based (arg_info_ptr),
	      2 arg_name_ptr       ptr,
	      2 arg_name_len       fixed bin,
	      2 explanation_ptr    ptr,
	      2 validation_string_ptr
			       ptr,
	      2 validation_string_length
			       fixed bin,
                2 validate_explanation_ptr
                                     ptr,
	      2 arg_def_vector_idx fixed bin,
	      2 number_of_required_occurences
			       fixed bin,
	      2 default_argument_value_ptr
			       pointer,
	      2 default_argument_value_len
			       fixed bin,
                2 flags            unaligned,
                  3 got_explicit_value
                                   bit(1),
                  3 force_literal  bit(1),
                  3 pad            bit(34);


      dcl	    arg_name	       char (arg_info.arg_name_len) based (arg_info.arg_name_ptr);
      dcl	    arg_explanation	       char (sys_info$max_seg_size) varying based (arg_info.explanation_ptr);
      dcl	    validation_string      char (arg_info.validation_string_length) based (arg_info.validation_string_ptr);
      dcl     validate_explanation   char(sys_info$max_seg_size) var based(arg_info.validate_explanation_ptr);

      dcl	    1 excluded_option      aligned based,
	      2 next_excluded_option
			       pointer,
	      2 option_name_length fixed bin,
	      2 option_name	       char (excluded_option_name_length refer (excluded_option.option_name_length));
      dcl	    excluded_option_name_length
			       fixed bin;

      dcl	    work_area	       area (sys_info$max_seg_size) based (p_work_area_ptr);

      dcl     1 validate_result_list like list based(validate_result_list_ptr);

      dcl     1 validate_result_explanation_list like list based(validate_result_explanation_list_ptr);

      dcl     1 list based(list_ptr),
                2 head_ptr ptr,
                2 tail_ptr ptr;

      dcl     1 node based(node_ptr),
                2 str_len fixed bin(21),
                2 str_ptr ptr,
                2 next_ptr ptr;


/* Builtin */

      dcl	    (addr, addcharno, addwordno, after, index, length, null, reverse, rtrim, substr, unspec)   builtin;

/* Condition */

      dcl	    active_function_error  condition;
      dcl     cleanup                condition;
      dcl     stringrange            condition;

/* Constant */

      dcl	    MY_NAME	       init ("pa_process_arguments") char (20) static options (constant);
      dcl	    (
	    NO_MODE	       init (1),
	    PROMPT_MODE	       init (2),
	    MENU_MODE	       init (3),
	    NUMBER_OF_NON_ARGUMENT_DIMENSIONS
			       init (4),
	    SLOT_INCREASE_FACTOR   init (25),
	    RETRY_LIMIT	       init (10)
	    )		       fixed bin internal static options (constant);
      dcl	    PROCESS_ARGUMENTS_SEARCH_LIST_NAME
			       init ("process_arguments") char (17) internal static options (constant);

      dcl	    (
	    COMMAND_NAME_DIM_NAME  init ("command name"),
	    DEFAULT_LINEAR_FORM_DIM_NAME
			       init ("default linear form"),
	    CONTROL_ARGUMENT_NAME_DIM_NAME
			       init ("option"),
	    SYNONYM_DIM_NAME       init ("synonym"),
	    ANTONYM_DIM_NAME       init ("negative form"),
	    EXCLUDED_OPTION_DIM_NAME
			       init ("excluded option"),
	    IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME
			       init ("initial implied option"),
	    NEXT_IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME
			       init ("next implied option"),
	    ARGUMENT_NAME_DIM_NAME init ("argument"),
	    INITIAL_ARGUMENT_NAME_DIM_NAME
			       init ("initial argument"),
	    NEXT_ARGUMENT_NAME_DIM_NAME
			       init ("next argument"),
	    DEFAULT_ARGUMENT_VALUE_DIM_NAME
			       init ("default value"),
	    NEGATIVE_VALUE_DIM_NAME
			       init ("negative value"),
	    ARGUMENT_VALIDATION_STRING_DIM_NAME
			       init ("validation string"),
	    EXPLANATION_DIM_NAME   init ("explanation"),
	    ARGUMENT_PRESENCE_DIM_NAME
			       init ("presence required"),
	    INSTANCE_DIM_NAME      init ("instance"),
	    RESULT_ORDER_DIM_NAME  init ("order"),
	    VALIDATE_RESULT_DIM_NAME
                                     init("validate result"),
              VALIDATE_RESULT_EXPLANATION_DIM_NAME
                                     init("validate result explanation"),
              VALIDATE_EXPLANATION_DIM_NAME
                                     init("validate explanation"),
              FORCE_LITERAL_DIM_NAME
                                     init("force literal")
	    )		       char (64) varying internal static options (constant);
      dcl	    NO_ARGUMENT	       init ("NONE") char (32) varying internal static options (constant);

      dcl	    LEFT_BOUND_STR	       init("&(") char(2) int static options(constant);
      dcl     RIGHT_BOUND_STR	       init(")") char(1) int static options(constant);
      dcl	    ARG_PROC_MSG	       init("(argument processing)") char(21) int static options(constant);

      dcl     (
              CONTROL_ARGUMENT_NAME_DIM_IDX init(1),
              INSTANCE_DIM_IDX init(2),
              COMMAND_NAME_DIM_IDX init(3),
              RESULT_ORDER_DIM_IDX init(4)
              ) fixed bin int static options(constant);

/* Entry */

      dcl	    process_arguments_$argument_string
			       entry (char (*), fixed bin, char (*) var, ptr, ptr, ptr, fixed bin (35));

      dcl	    ioa_$rsnnl	       entry () options (variable);

      dcl	    cv_dec_check_	       entry (char (*), fixed bin (35)) returns (fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    com_err_	       entry () options (variable);
      dcl	    ioa_		       entry () options (variable);
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    search_paths_$get      entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    requote_string_	       entry (char (*)) returns (char (*));
      dcl	    process_arguments_$get_definition
			       entry (char (*) var, ptr, ptr, fixed bin (35));
      dcl	    process_arguments_$get_default_linear_form
			       entry (char (*) var, char (*) var, fixed bin (35));
      dcl     process_arguments_$get_option_value
                                     entry options(variable);
      dcl	    cu_$evaluate_active_string
			       entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35));
      dcl     find_condition_frame_  entry (ptr) returns(ptr);
      dcl     find_condition_info_   entry (ptr, ptr, fixed bin(35));
      dcl     define_area_          entry (ptr, fixed bin(35));
      dcl     release_area_         entry (ptr);

/* External */

      dcl	    error_table_$asynch_change
			       fixed bin (35) ext static;
      dcl	    error_table_$noarg     fixed bin (35) ext static;
      dcl	    vd_error_$dimension_already_defined
			       fixed bin (35) ext;
      dcl	    vd_error_$no_vector    fixed bin (35) ext;
      dcl	    error_table_$fatal_error
			       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;
      dcl	    error_table_$badopt    fixed bin (35) ext;
      dcl	    error_table_$bad_arg   fixed bin (35) ext;
      dcl	    error_table_$smallarg  fixed bin(35) ext static;
          dcl     error_table_$unimplemented_version fixed bin(35) ext static;

/* END OF DECLARATIONS */

argument_array:
   entry (p_command_name, p_arg_processing_mode, p_arg_array, p_definition_print_vector_array_ptr, p_work_area_ptr,
      p_result_print_vector_array_ptr, p_code);
      call CONVERT_ARGUMENT_ARRAY_TO_LIST (p_arg_array, p_work_area_ptr, arg_list_ptr);
      first_arg_idx = 1;
      goto JOIN;

argument_string:
   entry (p_command_name, p_arg_processing_mode, p_arg_string, p_definition_print_vector_array_ptr, p_work_area_ptr,
      p_result_print_vector_array_ptr, p_code);
      call CONVERT_ARGUMENT_STRING_TO_LIST (p_arg_string, p_work_area_ptr, arg_list_ptr);
      first_arg_idx = 1;
      goto JOIN;


argument_list:
   entry (p_command_name, p_arg_processing_mode, p_arg_list_ptr, p_first_arg_idx, p_definition_print_vector_array_ptr,
      p_work_area_ptr, p_result_print_vector_array_ptr, p_code);
      arg_list_ptr = p_arg_list_ptr;
      first_arg_idx = p_first_arg_idx;
%page;
JOIN:

      command_name_str = rtrim(p_command_name) || " " || ARG_PROC_MSG;

      p_result_print_vector_array_ptr = null;
      if p_definition_print_vector_array_ptr = null
      then
         do;
	  call
	     process_arguments_$get_definition ((p_command_name), p_work_area_ptr, p_definition_print_vector_array_ptr,
	     p_code);
	  if p_code ^= 0
	  then
	     do;
	        call REPORT_MISSING_DEFINITION(p_code);
	        return;
	     end;
         end;

      call process_arguments_$get_default_linear_form ((p_command_name), default_linear_form_string, p_code);
      if p_code ^= 0 | default_linear_form_string = ""
      then do;
           if (p_code = vd_error_$no_vector | default_linear_form_string = "") &
              arg_list_ptr = null
	 then do;
                p_code = vd_error_$no_vector;          /* Make sure nonzero p_code is returned. */
	      call com_err_((0), (command_name_str), "There is no default linear form.");
	      return;
	 end;
	 else if p_code = vd_error_$no_vector
	 then p_code = 0;
	 else if p_code ^= 0
           then do;
	      call com_err_(p_code, (command_name_str), "Unable to get the default linear form for ""^a"".", p_command_name);
	      return;
	 end;
      end;

      call SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST;
      alloc arg_info in (work_area);
      print_vector_array_ptr = null;

      if p_result_print_vector_array_ptr = null
      then
         do;
	  result_control_argument_name_identifier = 1;
	  result_command_name_identifier = 2;
	  result_instance_identifier = 3;
	  result_order_identifier = 4;
	  call
	     vector_util_$init_print_vector_array (p_work_area_ptr, SLOT_INCREASE_FACTOR,
	     CONTROL_ARGUMENT_NAME_DIM_NAME, COMMAND_NAME_DIM_NAME, INSTANCE_DIM_NAME, RESULT_ORDER_DIM_NAME,
	     p_result_print_vector_array_ptr, p_code);
	  if p_code ^= 0
	  then return;
         end;
      else call SET_RESULT_IDS;

      p_result_print_vector_array_ptr
         -> print_vector_array.dimension_table (result_command_name_identifier).maximum_value_length =
         length (p_command_name);

      if default_linear_form_string ^= ""
      then
         do;
	  call
	     cu_$evaluate_active_string (null (), "do " || requote_string_ ((default_linear_form_string)),
	     NORMAL_ACTIVE_STRING, default_linear_form_string, p_code);
	  if p_code ^= 0
	  then return;


	  call CONVERT_ARGUMENT_STRING_TO_LIST (default_linear_form_string, p_work_area_ptr, default_arg_list_ptr);
	  call PROCESS_ARGUMENT_LIST (default_arg_list_ptr, 1, p_code);
	  if p_code ^= 0
	  then return;
         end;

      if arg_list_ptr ^= null
      then call PROCESS_ARGUMENT_LIST (arg_list_ptr, first_arg_idx, p_code);

      if p_code ^= 0
      then return;

/* Now compress the print vector array, removing entries that we
         nulled out earlier. */

      do vector_idx = 1 to p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors;
         if p_result_print_vector_array_ptr -> print_vector_array.vector_slot (vector_idx) = null ()
         then
	  do;					/* copy the remaining vectors down one slot */
	     p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors =
	        p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors - 1;
	     do temp_idx = vector_idx to p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors;
	        p_result_print_vector_array_ptr -> print_vector_array.vector_slot (temp_idx) =
		 p_result_print_vector_array_ptr -> print_vector_array.vector_slot (temp_idx + 1);
	     end;					/* make sure to check the same slot again */
	     vector_idx = vector_idx - 1;
	  end;
      end;

      call VALIDATE_RESULTS(p_code);

      return;					/* Effective end of process_arguments. */
%page;
SET_IDS:
   proc;
      call SET_ID (SYNONYM_DIM_NAME, synonym_identifier);
      call SET_ID (ANTONYM_DIM_NAME, antonym_identifier);
      call SET_ID (EXCLUDED_OPTION_DIM_NAME, excluded_option_identifier);
      call SET_ID (IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME, implied_control_argument_name_identifier);
      call SET_ID (EXPLANATION_DIM_NAME, explanation_identifier);
      call SET_ID (CONTROL_ARGUMENT_NAME_DIM_NAME, control_argument_name_identifier);
      call SET_ID (ARGUMENT_NAME_DIM_NAME, argument_name_identifier);
      call SET_ID (INITIAL_ARGUMENT_NAME_DIM_NAME, initial_argument_name_identifier);
      call SET_ID (NEXT_ARGUMENT_NAME_DIM_NAME, next_argument_name_identifier);
      call SET_ID (DEFAULT_ARGUMENT_VALUE_DIM_NAME, default_argument_value_identifier);
      call SET_ID (NEGATIVE_VALUE_DIM_NAME, negative_default_argument_value_identifier);
      call SET_ID (NEXT_IMPLIED_CONTROL_ARGUMENT_NAME_DIM_NAME, next_implied_control_argument_name_identifier);
      call SET_ID (ARGUMENT_PRESENCE_DIM_NAME, argument_presence_identifier);
      call SET_ID (ARGUMENT_VALIDATION_STRING_DIM_NAME, validation_string_identifier);
      call SET_ID (VALIDATE_RESULT_DIM_NAME, validate_result_identifier);
      call SET_ID (VALIDATE_RESULT_EXPLANATION_DIM_NAME, validate_result_explanation_identifier);
      call SET_ID (FORCE_LITERAL_DIM_NAME, force_literal_identifier);
      call SET_ID (VALIDATE_EXPLANATION_DIM_NAME, validate_explanation_identifier);

   end SET_IDS;
%skip;
SET_ID:
   proc (p_dim_name, p_identifier);
      dcl	    p_dim_name	       char (*) varying;
      dcl	    p_identifier	       fixed bin;
      do p_identifier = 1 to p_definition_print_vector_array_ptr -> print_vector_array.number_of_dimensions
         while (p_definition_print_vector_array_ptr -> print_vector_array.dimension_table (p_identifier).name
         ^= p_dim_name);
      end;
      if p_identifier > p_definition_print_vector_array_ptr -> print_vector_array.number_of_dimensions
      then p_identifier = -1;
   end SET_ID;
%page;
SET_RESULT_IDS:
   proc;
      call SET_RESULT_ID (COMMAND_NAME_DIM_NAME, result_command_name_identifier);
      call SET_RESULT_ID (RESULT_ORDER_DIM_NAME, result_order_identifier);
      call SET_RESULT_ID (INSTANCE_DIM_NAME, result_instance_identifier);
      call SET_RESULT_ID (CONTROL_ARGUMENT_NAME_DIM_NAME, result_control_argument_name_identifier);
   end SET_RESULT_IDS;
%skip;
SET_RESULT_ID:
   proc (p_dimension_name, p_identifier);

      dcl	    p_dimension_name       char (*) varying;
      dcl	    p_identifier	       fixed bin;

      do p_identifier = 1 to p_result_print_vector_array_ptr -> print_vector_array.number_of_dimensions
         while (p_result_print_vector_array_ptr -> print_vector_array.dimension_table (p_identifier).name
         ^= p_dimension_name);
      end;
      if p_identifier > p_result_print_vector_array_ptr -> print_vector_array.number_of_dimensions
      then p_identifier = -1;

   end SET_RESULT_ID;
%page;
SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST:
   proc;

      dcl	    dim_idx	       fixed bin;
      dcl	    temp_ptr	       pointer;

      call SET_IDS;
      print_vector_ptr = null;
      control_argument_ptr = null;
      control_argument_name_dim_id = -1;
      implied_control_argument_name_ptr = null;
      implied_control_argument_ptr = null;
      exists_implied_control_argument = "0"b;
      validate_result_list_ptr = null;
      validate_result_explanation_list_ptr = null;

      do vector_idx = 1 to p_definition_print_vector_array_ptr -> print_vector_array.number_of_vectors;
         old_control_argument_name_dim_id = control_argument_name_dim_id;
         old_print_vector_ptr = print_vector_ptr;
         call SETUP_VECTOR_AND_CONTROL_ARGUMENT_NAME_DIM_ID (vector_idx, print_vector_ptr, control_argument_name_dim_id);
         if control_argument_name_dim_id = -1
         then call SETUP_IMPLIED_CONTROL_ARGUMENT;
         else
	  do;
	     if control_argument_ptr = null
	     then call SETUP_NEW_CONTROL_ARGUMENT;


/* check to see if we have finished the definition of the
	        option we were just working on */
	     else if print_vector.dimension (control_argument_name_dim_id).value
		   ^= old_print_vector_ptr -> print_vector.dimension (old_control_argument_name_dim_id).value
	     then
	        do;
		 call CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION;
		 call SETUP_NEW_CONTROL_ARGUMENT;
	        end;

/* see if this is the initial implied option */
	     if vector_idx = control_argument.vector_idx
	     then if implied_control_argument_name_ptr ^= null
		then if control_argument_name = implied_control_argument_name
		     then
		        do;
			 implied_control_argument_ptr = control_argument_ptr;
			 exists_implied_control_argument = "1"b;
		        end;

/* Now check for other dimensions in the vector that define
	        other attributes of the option */

	     call GET_DIM_IDX (print_vector_ptr, argument_name_identifier, dim_idx);
	     if dim_idx > 0
	     then
	        do;
		 if print_vector_ptr -> print_vector.dimension (dim_idx).value = first_argument_name
		 then control_argument.initial_arg_vector_idx = vector_idx;
		 if control_argument.first_arg_vector_idx = 0
		 then
		    do;
		       control_argument.first_arg_vector_idx = vector_idx;
		       control_argument.last_arg_vector_idx = vector_idx;
		    end;
	        end;

/* See if there is an excluded option dimension */
	     call GET_DIM_IDX (print_vector_ptr, excluded_option_identifier, dim_idx);
	     if dim_idx > 0
	     then
	        do;
		 excluded_option_name_length = length (print_vector_ptr -> print_vector.dimension (dim_idx).value);
		 allocate excluded_option in(work_area) set (temp_ptr);
		 temp_ptr -> excluded_option.option_name = print_vector_ptr -> print_vector.dimension (dim_idx).value;
		 temp_ptr -> excluded_option.next_excluded_option = control_argument.excluded_option_chain;
		 control_argument.excluded_option_chain = temp_ptr;
	        end;

/* see if the vector defines a synonym for the option */
	     call ADD_SYNONYM;

	  end;

            call SETUP_RESULT_VALIDATION_INFO(print_vector_ptr, validate_result_list_ptr, validate_result_explanation_list_ptr);

      end;

/* We have run out of vectors, close out the last option definition */
      call CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION;

   end SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST;
%page;
ADD_SYNONYM:
   proc;
      dcl	    dim_idx	       fixed bin;

      call GET_DIM_IDX (print_vector_ptr, synonym_identifier, dim_idx);
      if dim_idx = -1
      then return;

      name_array_count = name_array_count + 1;
      name_array (name_array_count).name_ptr = addr (print_vector.dimension (dim_idx).value);
      name_array (name_array_count).def_ptr = control_argument_ptr;

/* See if this synonym is really an antonym. Will be used for filling
         in the default value later. */
      call GET_DIM_IDX (print_vector_ptr, antonym_identifier, dim_idx);
      name_array (name_array_count).antonym = (dim_idx ^= -1);

   end ADD_SYNONYM;
%page;
SETUP_NEW_CONTROL_ARGUMENT:
   proc ();

      old_control_argument_ptr = control_argument_ptr;

      alloc control_argument in (work_area);
      control_argument.next = null;
      control_argument.previous = old_control_argument_ptr;
      if old_control_argument_ptr = null
      then root_control_argument_ptr = control_argument_ptr;
      else old_control_argument_ptr -> control_argument.next = control_argument_ptr;

/* relies on vector_idx being set by caller, presumably while looping
         through all the vectors */
      control_argument.vector_idx = vector_idx;

      control_argument.control_argument_name_ptr =
         addrel (addr (print_vector.dimension (control_argument_name_dim_id).value), 1);
      control_argument.control_argument_name_length =
         length (print_vector.dimension (control_argument_name_dim_id).value);

      control_argument.excluded_option_chain = null ();
      control_argument.initial_arg_vector_idx = 0;
      control_argument.first_arg_vector_idx = 0;
      control_argument.last_arg_vector_idx = 0;
      control_argument.accepts_explicit_argument = "0"b;

/* Get the name of the initial arg for this option. If there is no
         such dimension, the option doesn't accept command line arguments.
         However, it may still have one argument whose value will be filled
         in from the default. This is how -long/-brief style flags work. */

      call GET_DIM_IDX (print_vector_ptr, initial_argument_name_identifier, dim_idx);
      if dim_idx ^= -1
      then
         do;
	  first_argument_name_ptr = addrel (addr (print_vector_ptr -> print_vector.dimension (dim_idx).value), 1);
	  first_argument_name_len = length (print_vector_ptr -> print_vector.dimension (dim_idx).value);
	  control_argument.accepts_explicit_argument = "1"b;
         end;
      else
         do;
	  first_argument_name_ptr = addr (NO_ARGUMENT);
	  first_argument_name_len = length (NO_ARGUMENT);
	  control_argument.accepts_explicit_argument = "0"b;
         end;

/* at this point we should find the option_presence dimension a gets its
         value, but it isn7t in the DB yet. */
      control_argument.instance_count = 0;		/* this field isn't examined yet */
      control_argument.instances_required = 1;

   end SETUP_NEW_CONTROL_ARGUMENT;

CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION:
   procedure;

      if control_argument_ptr = null ()
      then return;

      control_argument.last_arg_vector_idx = vector_idx - 1;

      if ^control_argument.accepts_explicit_argument	/* the option doesn't accept explicit args, but we still have
	         to set the initial arg idx so defaults work later */
      then control_argument.initial_arg_vector_idx = control_argument.first_arg_vector_idx;

/* if no argument matched the name of the first argument for this
	    option (as specified in the definition for this command), then
	    signal an error. */

      else if (control_argument.initial_arg_vector_idx = 0)
      then call
	    sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null (), 0,
	    "First argument of ""^a"" specified for option ""^a"" of command ""^a"" is not defined.",
	    first_argument_name, control_argument_name);

   end CLOSE_OUT_CONTROL_ARGUMENT_DEFINITION;
%page;
SETUP_VECTOR_AND_CONTROL_ARGUMENT_NAME_DIM_ID:
   proc (p_vector_idx, p_print_vector_ptr, p_control_argument_name_dim_id);
      dcl	    p_vector_idx	       fixed bin;
      dcl	    p_print_vector_ptr     ptr;
      dcl	    p_control_argument_name_dim_id
			       fixed bin;
      p_print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (p_vector_idx);
      call GET_DIM_IDX (p_print_vector_ptr, control_argument_name_identifier, p_control_argument_name_dim_id);
   end SETUP_VECTOR_AND_CONTROL_ARGUMENT_NAME_DIM_ID;
%page;
SETUP_IMPLIED_CONTROL_ARGUMENT:
   proc;
      dcl	    dim_idx	       fixed bin;
      call GET_DIM_IDX (print_vector_ptr, implied_control_argument_name_identifier, dim_idx);

      if dim_idx = -1
      then return;
      implied_control_argument_name_ptr = addr (print_vector.dimension (dim_idx).value);
      implied_control_argument_name_length = length (print_vector.dimension (dim_idx).value);
   end SETUP_IMPLIED_CONTROL_ARGUMENT;
%page;
PROCESS_ARGUMENT_LIST:
   proc (pal_p_arg_list_ptr, pal_p_first_arg_idx, pal_p_code);
      dcl	    pal_p_arg_list_ptr     ptr parameter;
      dcl	    pal_p_first_arg_idx    fixed bin parameter;
      dcl	    pal_p_code	       fixed bin (35) parameter;

      nargs = pal_p_arg_list_ptr -> arg_list.header.arg_count - pal_p_first_arg_idx + 1;
      last_arg_idx_processed = pal_p_first_arg_idx - 1;
      force_interpretation_as_non_control_argument = "0"b;
      value_idx = 0;
      max_value_arg_len = 0;
      unspec(arg_info) = "0"b;
      control_argument_is_in_effect = "0"b;
      using_implicit_control_argument = "0"b;
      option_accepts_explicit_argument = "0"b;

      control_argument_ptr = null;


ARG_LOOP:
      do arg_idx = pal_p_first_arg_idx to pal_p_arg_list_ptr -> arg_list.header.arg_count;
         arg_ptr = pal_p_arg_list_ptr -> arg_list.arg_ptrs (arg_idx);
         call decode_descriptor_ (pal_p_arg_list_ptr -> arg_list.desc_ptrs (arg_idx), 0, 0, "0"b, 0, arg_len, 0);

         force_interpretation_as_non_control_argument = (force_interpretation_as_non_control_argument |
					       (arg_info.force_literal & control_argument_is_in_effect));

/*         if arg = "-quote" & ^force_interpretation_as_non_control_argument
         then
	  do;
	     last_arg_idx_processed = arg_idx;
	     force_interpretation_as_non_control_argument = "1"b;
	  end;					/* Now for the non-option cases.
         else */

         if index (arg, "-") ^= 1 | force_interpretation_as_non_control_argument
         then
	  do;					/* if there is no explicit option in effect,
		  try the current implied option */
	     force_interpretation_as_non_control_argument = "0"b;
	     if ^control_argument_is_in_effect
	     then if exists_implied_control_argument
		then
		   do;				/* If we already processed the previous token,
			  don't do it again. */
		      if last_arg_idx_processed < (arg_idx - 1)
		      then call CLOSE_OUT_OPTION;

		      control_argument_ptr = implied_control_argument_ptr;
		      call
		         SETUP_FIRST_ARG_INFO (control_argument_ptr, option_accepts_explicit_argument, arg_info_ptr);
						/* if this option doesn't accept an argument,
			  the current token is bogus */
		      if ^option_accepts_explicit_argument
		      then call
			    sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null (), 0,
			    "Error in definition. Implied option ^a doesn't accept arguments.",
			    control_argument_name);

		      control_argument_is_in_effect, using_implicit_control_argument = "1"b;
		   end;
	     if arg = "?"
	     then
	        do;
		 last_arg_idx_processed = arg_idx;
		 call PRINT_EXPLANATION;
	        end;

/* OK, the token is an argument to an option. */
	     else
	        do;

		 call PROCESS_ARGUMENT (pal_p_code);
                     if pal_p_code = error_table_$bad_arg
                     then do;
                          call PRINT_VALIDATION_EXPLANATION();
                          return;
                     end;
                     else if pal_p_code ^= 0
                     then return;
	        end;
	  end;

         else if MISPLACED_CONTROL_ARGUMENT ()
         then
	  do;
	     pal_p_code = error_table_$noarg;
	     call
	        com_err_ (pal_p_code, (command_name_str),
	        "^/Encountered option ^a instead of the ^a argument to option ^a.", requote_string_ (arg),
	        requote_string_ (arg_name), requote_string_ (control_argument_name));
	     return;
	  end;

/* The token is an option */
         else
CONTROL_ARGUMENT:
	  do;					/* If we already processed the previous token,
	       don't do it again. */
	     if last_arg_idx_processed < (arg_idx - 1)
	     then call CLOSE_OUT_OPTION;

	     using_implicit_control_argument = "0"b;

/* See if the token matches any known option name */
	     do name_array_idx = 1 to name_array_count while (arg ^= name_array_name);
	     end;
	     if name_array_idx > name_array_count
	     then
	        do;
		 call REPORT_UNRECOGNIZED_CONTROL_ARGUMENT ();
		 return;
	        end;

	     control_argument_ptr = name_array (name_array_idx).def_ptr;

/* depending on which name (e.g. -foo vs. -no_foo) was used
	        to find this option, set the antonym flag */
	     control_argument.antonym = name_array (name_array_idx).antonym;

/* fill in arg_info structure for the option's first arg */
	     call SETUP_FIRST_ARG_INFO (control_argument_ptr, option_accepts_explicit_argument, arg_info_ptr);

/* if the option has args, future tokens should be interpreted
	        as "belonging" to this option, so we say the option is still
	        in effect.  If the option has no args, future tokens are
	        unrelated to the option. */

	     control_argument_is_in_effect = option_accepts_explicit_argument;
	     if ^control_argument_is_in_effect
	     then call CLOSE_OUT_OPTION;
	  end CONTROL_ARGUMENT;
      end ARG_LOOP;

/* The loop above increments the arg_idx to one 
         past the last argument. Set it back for comparison purposes. */
      arg_idx = arg_idx - 1;

/* No more command line arguments.  Check to see if any more were
         required. */

      if using_implicit_control_argument
      then
         do;					/* if the pending option is implicit we don't care if there
	         is no associated argument as long as we have seen at least
	         one instance of the option before, e.g. "copy foo bar"
	         is OK even though there is a pending implicit
	         -source_pathname option with a required argument */

	  if control_argument.instance_count = 0
	  then
	     do;
	        call SETUP_FIRST_ARG_INFO (control_argument_ptr, option_accepts_explicit_argument, arg_info_ptr);
	        if ^option_accepts_explicit_argument
	        then call
		      sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null (), 0,
		      "Error in definition. Implied option ^a doesn't accept arguments.", control_argument_name);
	        if (arg_info.number_of_required_occurences > 0)
	        then
		 do;
		    pal_p_code = error_table_$noarg;
		    call REPORT_MISSING_ARGUMENT ();
		    return;
		 end;
	     end;
         end;

/* if the option was explicit, then honor the required flag */
      else if control_argument_is_in_effect
      then if (arg_info.number_of_required_occurences > 0)
	 then
	    do;
	       pal_p_code = error_table_$noarg;
	       call REPORT_MISSING_ARGUMENT ();
	       return;
	    end;

/* Close out the last token if it hasn't been processed yet */
      if last_arg_idx_processed < arg_idx
      then call CLOSE_OUT_OPTION;

   end PROCESS_ARGUMENT_LIST;
%page;
PROCESS_ARGUMENT:
   proc (p_code);

      dcl	    p_code	       fixed bin (35) parameter;
      dcl	    temp_value_idx	       fixed bin;


      if ^control_argument_is_in_effect
      then
         do;
	  p_code = error_table_$bad_arg;
	  call com_err_ (p_code, (command_name_str), "^/Argument ^a can not be matched with any option.", arg);
	  return;
         end;

/* Validate the argument value if possible */
      if arg_info.validation_string_ptr ^= null ()
      then
         do;					/* Get a temp for the requoted string */
	  call
	     ioa_$rsnnl ("do ^a ^a", active_string_nonvarying, active_string_length,
	     requote_string_ ("[" || validation_string || "]"), requote_string_ (arg));

	  on active_function_error
	     begin;
	        goto validation_error_return;
	     end;

	  call cu_$evaluate_active_string (null (), (active_string), NORMAL_ACTIVE_STRING, result, p_code);
	  if p_code ^= 0
	  then return;

	  revert active_function_error;

	  if result ^= "true"
	  then
	     do;
validation_error_return:
	        p_code = error_table_$bad_arg;
	        call
		 com_err_ (p_code, (command_name_str), "^/Invalid argument ^a for option ^a", requote_string_ (arg),
		 requote_string_ (control_argument_name));
	        return;
	     end;
         end;

      value_idx = value_idx + 1;
      value (value_idx).arg_name_ptr = arg_info.arg_name_ptr;
      value (value_idx).arg_name_len = arg_info.arg_name_len;
      value (value_idx).arg_ptr = arg_ptr;
      value (value_idx).arg_len = arg_len;
      max_value_arg_len = max (max_value_arg_len, arg_len);

      call SETUP_NEXT_ARG_INFO (control_argument_ptr, arg_exists, arg_info_ptr);
      control_argument_is_in_effect = arg_exists;

      if ^control_argument_is_in_effect
      then call CLOSE_OUT_OPTION;
      else
         do;
	  do temp_value_idx = 1 to value_idx while (arg_info.arg_name_ptr ^= value (temp_value_idx).arg_name_ptr);
	  end;
	  if temp_value_idx <= value_idx
	  then /* Only one occurence of each named argument can be present per "result" vector. */
	       call ADD_VALUE_TO_RESULT;
         end;
   end PROCESS_ARGUMENT;
%page;
GET_NEXT_IMPLIED_CONTROL_ARGUMENT:
   proc;
      print_vector_ptr =
         p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (control_argument.vector_idx);

      call GET_DIM_IDX (print_vector_ptr, next_implied_control_argument_name_identifier, dim_idx);
      if dim_idx = -1
      then return;
      else
         do;
	  implied_control_argument_name_ptr = addr (print_vector.dimension (dim_idx).value);
	  implied_control_argument_name_length = length (print_vector.dimension (dim_idx).value);
	  do control_argument_ptr = root_control_argument_ptr repeat (control_argument.next)
	     while (control_argument.next ^= null & control_argument_name ^= implied_control_argument_name);
	  end;
	  if control_argument_name = implied_control_argument_name
	  then
	     do;
	        exists_implied_control_argument = "1"b;
	        implied_control_argument_ptr = control_argument_ptr;
	     end;
	  else
	     do;
	        exists_implied_control_argument = "0"b;
	        implied_control_argument_ptr = null;
	     end;
         end;
   end GET_NEXT_IMPLIED_CONTROL_ARGUMENT;
%page;
/* Internal routine to close out the current option.  This is called
   when we run out of arguments for a particular option (either by getting
   all the arguments we expect or encountering the next option), or when
   there are no more tokens on the command line. */

CLOSE_OUT_OPTION:
   procedure;

      if control_argument_ptr = null ()
      then return;

/* If no explicit value was specified for the argument to this option
	   then see if there was a default argument value in the definition. */

      if ^arg_info.got_explicit_value
      then if arg_info.default_argument_value_ptr ^= null ()
	 then
	    do;
	       value_idx = value_idx + 1;
	       value (value_idx).arg_name_ptr = arg_info.arg_name_ptr;
	       value (value_idx).arg_name_len = arg_info.arg_name_len;
	       value (value_idx).arg_ptr = arg_info.default_argument_value_ptr;
	       value (value_idx).arg_len = arg_info.default_argument_value_len;

	       max_value_arg_len = max (max_value_arg_len, value (value_idx).arg_len);
	    end;

      call ADD_VALUE_TO_RESULT;

/* If the option that we just processed is the same as the current
	   implied option, move on to the next implied option */
      if exists_implied_control_argument
      then if control_argument_name = implied_control_argument_name
	 then call GET_NEXT_IMPLIED_CONTROL_ARGUMENT;

      return;
   end CLOSE_OUT_OPTION;
%page;
/* Routine to add the vector for this option (including all argument values)
   to the result pva. */

ADD_VALUE_TO_RESULT:
   proc;

      dcl	    temp_value_idx	       fixed bin;
      dcl	    dim_idx	       fixed bin;
      dcl	    value_arg_name	       char (value (temp_value_idx).arg_name_len)
			       based (value (temp_value_idx).arg_name_ptr);
      dcl	    instance_count_pic     pic "999v";
      dcl	    order_pic	       pic "999v";

      dcl	    value_arg	       char (value (temp_value_idx).arg_len) based (value (temp_value_idx).arg_ptr);

      last_arg_idx_processed = arg_idx;

      call
         vector_util_$append_general_print_vector (p_work_area_ptr, SLOT_INCREASE_FACTOR, "1"b, (-1), value_idx + 4,
         max (length (control_argument_name), length (p_command_name), max_value_arg_len),
         p_result_print_vector_array_ptr, p_code);
      if p_code ^= 0
      then
         do;
	  call
	     sub_err_ (p_code, p_command_name, "h", null, 0,
	     "^/Unable to add the result vector for the ""^a"" control argument (and 
associated arguments) ending with argument number ^d.", control_argument_name, arg_idx);
	  return;
         end;

      print_vector_ptr =
         p_result_print_vector_array_ptr
         -> print_vector_array.vector_slot (p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors);

/* Fill in all the non-argument-value dimensions */
      print_vector.dimension (INSTANCE_DIM_IDX).identifier = result_instance_identifier;
      instance_count_pic = global_instance_count;
      print_vector.dimension (INSTANCE_DIM_IDX).value = instance_count_pic;
      global_instance_count = global_instance_count + 1;

      print_vector.dimension (CONTROL_ARGUMENT_NAME_DIM_IDX).identifier = result_control_argument_name_identifier;
      print_vector.dimension (CONTROL_ARGUMENT_NAME_DIM_IDX).value = control_argument_name;

/* now set the maximum option name length. */
      p_result_print_vector_array_ptr
         -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length =
         max (p_result_print_vector_array_ptr
         -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length,
         length (control_argument_name));

      p_result_print_vector_array_ptr
         -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length =
         max (p_result_print_vector_array_ptr
         -> print_vector_array.dimension_table (result_control_argument_name_identifier).maximum_value_length,
         length (control_argument_name));

      print_vector.dimension (COMMAND_NAME_DIM_IDX).identifier = result_command_name_identifier;
      print_vector.dimension (COMMAND_NAME_DIM_IDX).value = p_command_name;
      print_vector.dimension (RESULT_ORDER_DIM_IDX).identifier = result_order_identifier;
      order_pic = p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors;
      print_vector.dimension (RESULT_ORDER_DIM_IDX).value = order_pic;

/* Now fill in all the arguments */
      do temp_value_idx = 1 to value_idx;

/* skip over those dims that we already filled in */
         dim_idx = temp_value_idx + NUMBER_OF_NON_ARGUMENT_DIMENSIONS;

         call
	  vector_util_$append_dimension_print (p_work_area_ptr, "0"b, value_arg_name, null,
	  p_result_print_vector_array_ptr, print_vector.dimension (dim_idx).identifier, p_code);
         if p_code ^= 0
         then if p_code = vd_error_$dimension_already_defined
	    then p_code = 0;
	    else return;
         print_vector.dimension (dim_idx).value = value_arg;

/* keep track of longest dimension id */
         p_result_print_vector_array_ptr
	  -> print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length =
	  max (p_result_print_vector_array_ptr
	  -> print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length,
	  length (value_arg));

      end;


      max_value_arg_len = 0;
      value_idx = 0;

   end ADD_VALUE_TO_RESULT;
%page;
/* Routine to set up state information for a an option that has just been
   encountered on the command line. */

SETUP_FIRST_ARG_INFO:
   proc (p_control_argument_ptr, p_option_accepts_explicit_argument, p_arg_info_ptr);
      dcl	    p_control_argument_ptr ptr;
      dcl	    p_option_accepts_explicit_argument
			       bit (1) aligned;
      dcl	    p_arg_info_ptr	       ptr;
      dcl	    1 p_arg_info	       like arg_info based (p_arg_info_ptr);

      dcl	    idx		       fixed bin;
      dcl	    (temp_print_vector_ptr, temp_excluded_option_ptr)
			       pointer;

/* First remove any vectors belonging to options that are excluded
         by the current option */

      do idx = 1 to p_result_print_vector_array_ptr -> print_vector_array.number_of_vectors;
         temp_print_vector_ptr = p_result_print_vector_array_ptr -> print_vector_array.vector_slot (idx);

/* loop through the chain of excluded options, checking the option
	    names against the option that owns the current vector */
         do temp_excluded_option_ptr = (p_control_argument_ptr -> control_argument.excluded_option_chain)
	  repeat (temp_excluded_option_ptr -> excluded_option.next_excluded_option)
	  while ((temp_excluded_option_ptr ^= null ())
	  & (p_result_print_vector_array_ptr -> print_vector_array.vector_slot (idx) ^= null ()));

/* If this vector belongs to an excluded option, free it */
	  if temp_print_vector_ptr -> print_vector.dimension (1).value
	     = temp_excluded_option_ptr -> excluded_option.option_name
	  then
	     do;
	        free temp_print_vector_ptr -> print_vector;
	        p_result_print_vector_array_ptr -> print_vector_array.vector_slot (idx) = null ();
	     end;
         end;
      end;

      p_arg_info.arg_def_vector_idx = 0;

/* Keep track of how many times we see each control argument */
      p_control_argument_ptr -> control_argument.instance_count =
         p_control_argument_ptr -> control_argument.instance_count + 1;

      p_arg_info.force_literal = "0"b;

      call SETUP_NEXT_ARG_INFO (p_control_argument_ptr, p_option_accepts_explicit_argument, p_arg_info_ptr);

      p_option_accepts_explicit_argument = p_control_argument_ptr -> control_argument.accepts_explicit_argument;

   end SETUP_FIRST_ARG_INFO;


SETUP_NEXT_ARG_INFO:
   proc (p_control_argument_ptr, p_arg_exists, p_arg_info_ptr);
      dcl	    p_control_argument_ptr ptr;
      dcl	    p_arg_exists	       bit (1) aligned;
      dcl	    p_arg_info_ptr	       ptr;
      dcl	    1 p_arg_info	       like arg_info based (p_arg_info_ptr);
      dcl	    p_arg_name	       char (p_arg_info.arg_name_len) based (p_arg_info.arg_name_ptr);
      dcl	    local_print_vector_ptr ptr;
      dcl	    temp_dimension_identifier
			       fixed bin;
      dcl	    dim_idx	       fixed bin;
      dcl	    p_control_argument_name
			       char (p_control_argument_ptr -> control_argument.control_argument_name_length)
			       based (p_control_argument_ptr -> control_argument.control_argument_name_ptr);

      if p_arg_info.arg_def_vector_idx ^= 0
      then call FIND_NEXT_ARG (p_arg_info.arg_def_vector_idx, local_print_vector_ptr, dim_idx);
      else if p_control_argument_ptr -> control_argument.initial_arg_vector_idx = 0
      then
         do;
	  arg_exists = "0"b;
	  return;
         end;
      else
         do;
	  p_arg_info.arg_def_vector_idx = p_control_argument_ptr -> control_argument.initial_arg_vector_idx;
	  call SETUP_VECTOR_AND_ARG_NAME_DIM_IDX (p_arg_info.arg_def_vector_idx, local_print_vector_ptr, dim_idx);
         end;
      if dim_idx = -1
      then
         do;
	  p_arg_exists = "0"b;
	  return;
         end;
      p_arg_exists = "1"b;
      if local_print_vector_ptr = null
      then
         do;
	  if p_arg_info.number_of_required_occurences > 0
	  then p_arg_info.number_of_required_occurences = p_arg_info.number_of_required_occurences - 1;
	  return;
         end;

/* Fill in arg_info structure with data for this argument. */

      p_arg_info.arg_name_ptr = addrel (addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value), 1);
      p_arg_info.arg_name_len = length (local_print_vector_ptr -> print_vector.dimension (dim_idx).value);

      call GET_DIM_IDX (local_print_vector_ptr, validation_string_identifier, dim_idx);
      if dim_idx > 0
      then
         do;
	  p_arg_info.validation_string_ptr =
	     addrel (addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value), 1);
	  p_arg_info.validation_string_length =
	     length (local_print_vector_ptr -> print_vector.dimension (dim_idx).value);
         end;
      else p_arg_info.validation_string_ptr = null ();

      call GET_DIM_IDX(local_print_vector_ptr, validate_explanation_identifier, dim_idx);
      if dim_idx > 0
      then p_arg_info.validate_explanation_ptr = addr(local_print_vector_ptr->print_vector.dimension(dim_idx).value);
      else p_arg_info.validate_explanation_ptr = null;

      call GET_DIM_IDX (local_print_vector_ptr, explanation_identifier, dim_idx);
      if dim_idx > 0
      then p_arg_info.explanation_ptr = addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value);
      else p_arg_info.explanation_ptr = null;

      call GET_DIM_IDX (local_print_vector_ptr, argument_presence_identifier, dim_idx);

/* If there is such a dim, the arg is required.  Later we may want a count of
   the number of required occurences, but for now it is yes or no. */
      if dim_idx = -1
      then p_arg_info.number_of_required_occurences = 0;
      else p_arg_info.number_of_required_occurences = 1;

/* If the option was -no_foo, get the negative default value for the
         argument, otherwise get the regular default */
      if control_argument.antonym
      then temp_dimension_identifier = negative_default_argument_value_identifier;
      else temp_dimension_identifier = default_argument_value_identifier;

/* Now try to find the default value for this argument. */
      call GET_DIM_IDX (local_print_vector_ptr, temp_dimension_identifier, dim_idx);
      if dim_idx = -1
      then p_arg_info.default_argument_value_ptr = null ();
      else
         do;
	  p_arg_info.default_argument_value_ptr =
	     addrel (addr (local_print_vector_ptr -> print_vector.dimension (dim_idx).value), 1);
	  p_arg_info.default_argument_value_len =
	     length (local_print_vector_ptr -> print_vector.dimension (dim_idx).value);
         end;

      call GET_DIM_IDX(local_print_vector_ptr, force_literal_identifier, dim_idx);
      p_arg_info.force_literal = (dim_idx ^= -1);

/* This flag is used later to determine if we have seen an explicit value
         for this argument on the command line. If not, use the default value*/
      p_arg_info.got_explicit_value = "0"b;

      return;


SETUP_VECTOR_AND_ARG_NAME_DIM_IDX:
   proc (p_vector_idx, p_print_vector_ptr, p_dim_idx);
      dcl	    p_vector_idx	       fixed bin;
      dcl	    p_print_vector_ptr     ptr;
      dcl	    p_dim_idx	       fixed bin;

      p_print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (p_vector_idx);
      call GET_DIM_IDX (p_print_vector_ptr, argument_name_identifier, p_dim_idx);
   end SETUP_VECTOR_AND_ARG_NAME_DIM_IDX;


FIND_NEXT_ARG:
   proc (p_vector_idx, p_print_vector_ptr, p_dim_idx);
      dcl	    p_vector_idx	       fixed bin;
      dcl	    p_print_vector_ptr     ptr;
      dcl	    p_dim_idx	       fixed bin;
      dcl	    next_arg_dim_idx       fixed bin;
      dcl	    temp_print_vector_ptr  ptr;

      p_dim_idx = 0;
      p_print_vector_ptr = p_definition_print_vector_array_ptr -> print_vector_array.vector_slot (p_vector_idx);

/* No next_argument dimension means use the same argument again.
         Returning a null pointer is a convention for this case. */
      call GET_DIM_IDX (p_print_vector_ptr, next_argument_name_identifier, next_arg_dim_idx);
      if next_arg_dim_idx = -1
      then
         do;
	  p_print_vector_ptr = null;
	  return;
         end;

/* If the next arg is the same as this arg, use the same values */
      else if p_print_vector_ptr -> print_vector.dimension (next_arg_dim_idx).value = p_arg_name
      then
         do;
	  p_print_vector_ptr = null ();
	  return;
         end;

/* If there is no next argument at all, indicate that fact. */
      else if p_print_vector_ptr -> print_vector.dimension (next_arg_dim_idx).value = NO_ARGUMENT
      then
         do;
	  p_dim_idx = -1;
	  p_print_vector_ptr = null;
	  return;
         end;

      do p_vector_idx = p_control_argument_ptr -> control_argument.first_arg_vector_idx
         to p_control_argument_ptr -> control_argument.last_arg_vector_idx;
         call SETUP_VECTOR_AND_ARG_NAME_DIM_IDX (p_vector_idx, temp_print_vector_ptr, p_dim_idx);
         if p_dim_idx = -1
         then call
	       sub_err_ (error_table_$fatal_error, p_command_name, "h", null, 0,
	       "^/Vector ^d of the definition is in the argument definition range of vectors
for control argument ""^a"", but does not specify an argument name (as it must).", p_vector_idx, p_control_argument_name)
	       ;
         else if temp_print_vector_ptr -> print_vector.dimension (p_dim_idx).value
	       = p_print_vector_ptr -> print_vector.dimension (next_arg_dim_idx).value
         then
	  do;
	     p_print_vector_ptr = temp_print_vector_ptr;
	     return;
	  end;
      end;
      p_code = error_table_$fatal_error;
   end FIND_NEXT_ARG;
   end SETUP_NEXT_ARG_INFO;
%page;
GET_DIM_IDX:
   proc (p_print_vector_ptr, p_identifier, p_dim_idx);
      dcl	    p_print_vector_ptr     ptr;
      dcl	    p_identifier	       fixed bin;
      dcl	    p_dim_idx	       fixed bin;

      do p_dim_idx = 1 to p_print_vector_ptr -> print_vector.number_of_dimensions
         while (p_print_vector_ptr -> print_vector.dimension (p_dim_idx).identifier ^= p_identifier);
      end;
      if p_dim_idx > p_print_vector_ptr -> print_vector.number_of_dimensions
      then p_dim_idx = -1;

   end GET_DIM_IDX;



MISPLACED_CONTROL_ARGUMENT:
   proc () returns (bit (1) aligned);
      if arg_info_ptr = null
      then return ("0"b);
      else return ((arg_info.number_of_required_occurences > 0) & ^using_implicit_control_argument
	    & control_argument_is_in_effect);
   end MISPLACED_CONTROL_ARGUMENT;
REPORT_UNRECOGNIZED_CONTROL_ARGUMENT:
   proc;
      p_code = error_table_$badopt;
      call com_err_ (p_code, (command_name_str), """^a""", arg);
   end REPORT_UNRECOGNIZED_CONTROL_ARGUMENT;
%page;
REPORT_MISSING_ARGUMENT:
   proc;
      call
         com_err_ (error_table_$noarg, (command_name_str), "^/Expected the ""^a"" argument of the ""^a"" control argument.",
         arg_name, control_argument_name);

   end REPORT_MISSING_ARGUMENT;
%page;
REPORT_MISSING_DEFINITION:
   proc(code);

      dcl code fixed bin(35);

      call
         com_err_ (code, (command_name_str),
         "Unable to locate the argument-processing^/syntax definition for this command.");

   end REPORT_MISSING_DEFINITION;
%page;
PRINT_EXPLANATION:
   proc;
      if arg_info.explanation_ptr ^= null
      then call ioa_ ("Explanation for the ""^a"" argument of the ^[(implicit)^] ""^a"" option:
^a", arg_name, using_implicit_control_argument, control_argument_name, arg_explanation);
      else call
	    ioa_ ("There is no explanation provided for the ""^a"" argument of the ^[(implicit)^] ""^a"" option.",
	    arg_name, using_implicit_control_argument, control_argument_name);
   end PRINT_EXPLANATION;

%page;

PRINT_VALIDATION_EXPLANATION: proc();

  /* Automatic */

          dcl code fixed bin(35);

          if arg_info.validate_explanation_ptr ^= null
          then do;
               call MAKE_V_SUBSTITUTIONS((validate_explanation), arg_name, arg, active_explanation_nonvarying, active_explanation_length, code);
               if code ^= 0
               then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0,
                  "^/Unable to make substitutions in the validation explanation:^/""^a"".",
                  validate_explanation);
               else call ioa_((active_explanation));
          end;

     end PRINT_VALIDATION_EXPLANATION;
%page;
CONVERT_ARGUMENT_ARRAY_TO_LIST:
   proc (caatl_p_arg_array, caatl_p_work_area_ptr, caatl_p_arg_list_ptr);
      dcl	    caatl_p_arg_array      (*) char (*) varying;
      dcl	    caatl_p_work_area_ptr  ptr;
      dcl	    caatl_p_arg_list_ptr   ptr;

      dcl	    caatl_al_arg_count     fixed bin init (0);
      dcl	    caatl_arg_idx	       fixed bin init (0);
      dcl	    1 caatl_arg_descriptor_template
			       like arg_descriptor;
      dcl	    caatl_arg_descriptor_ptr
			       ptr init (null);

      dcl	    caatl_work_area	       area based (caatl_p_work_area_ptr);
      dcl	    1 caatl_arg_list       based (caatl_p_arg_list_ptr),
	      2 header	       like arg_list.header,
	      2 arg_ptrs	       (caatl_al_arg_count refer (caatl_arg_list.header.arg_count)) ptr,
	      2 desc_ptrs	       (caatl_al_arg_count refer (caatl_arg_list.header.arg_count)) ptr;
      dcl	    1 caatl_arg_descriptor based (caatl_arg_descriptor_ptr) like arg_descriptor;

      caatl_p_arg_list_ptr = null;

      caatl_al_arg_count = hbound (caatl_p_arg_array, 1);
      if caatl_al_arg_count = 1 & caatl_p_arg_array (1) = ""
      then return;

      alloc caatl_arg_list in (caatl_work_area);
      caatl_arg_list.header.pad1 = "0"b;
      caatl_arg_list.header.call_type = Interseg_call_type;
      caatl_arg_list.header.desc_count = caatl_al_arg_count;
      caatl_arg_list.header.pad2 = "0"b;
      caatl_arg_descriptor_template.flag = "1"b;
      caatl_arg_descriptor_template.type = char_dtype;
      caatl_arg_descriptor_template.packed = "0"b;
      caatl_arg_descriptor_template.number_dims = 0;
      caatl_arg_descriptor_template.size = 0;

      do caatl_arg_idx = 1 to caatl_al_arg_count;
         caatl_arg_list.arg_ptrs (caatl_arg_idx) = addwordno (addr (caatl_p_arg_array (caatl_arg_idx)), 1);
         alloc caatl_arg_descriptor in (caatl_work_area);
         caatl_arg_descriptor = caatl_arg_descriptor_template;
         caatl_arg_descriptor.size = length (caatl_p_arg_array (caatl_arg_idx));
         caatl_arg_list.desc_ptrs (caatl_arg_idx) = caatl_arg_descriptor_ptr;
      end;

   end CONVERT_ARGUMENT_ARRAY_TO_LIST;
%page;
CONVERT_ARGUMENT_STRING_TO_LIST:
   proc (castl_p_arg_string, castl_p_work_area_ptr, castl_p_arg_list_ptr);
      dcl	    castl_p_arg_string     char (*) varying;
      dcl	    castl_p_work_area_ptr  ptr;
      dcl	    castl_p_arg_list_ptr   ptr;

      dcl	    castl_al_arg_count     fixed bin init (0);
      dcl	    1 castl_arg_descriptor_template
			       like arg_descriptor;
      dcl	    castl_arg_descriptor_ptr
			       ptr init (null);
      dcl	    castl_arg_link_ptr     ptr init (null);

      dcl	    (castl_arg_idx, castl_arg_index, castl_new_arg_index, castl_arg_length, castl_quote_index,
	    castl_old_quote_index) fixed bin init (0);
      dcl	    (castl_root_arg_link_ptr, castl_old_arg_link_ptr)
			       ptr init (null);

      dcl	    castl_work_area	       area based (castl_p_work_area_ptr);
      dcl	    1 castl_arg_list       based (castl_p_arg_list_ptr),
	      2 header	       like arg_list.header,
	      2 arg_ptrs	       (castl_al_arg_count refer (castl_arg_list.header.arg_count)) ptr,
	      2 desc_ptrs	       (castl_al_arg_count refer (castl_arg_list.header.arg_count)) ptr;
      dcl	    1 castl_arg_descriptor based (castl_arg_descriptor_ptr) like arg_descriptor;
      dcl	    1 castl_arg_link       based (castl_arg_link_ptr),
	      2 next_ptr	       ptr,
	      2 arg_ptr	       ptr,
	      2 arg_length	       fixed bin,
	      2 desc_ptr	       ptr;

      dcl	    (
	    CASTL_SPACE_CHAR       init (" "),
	    CASTL_TAB_CHAR	       init ("	"),
	    CASTL_QUOTE_CHAR       init ("""")
	    )		       char (1) internal static options (constant);

      castl_p_arg_list_ptr = null;

      if castl_p_arg_string = ""
      then return;

      castl_al_arg_count = 0;

      castl_arg_descriptor_template.flag = "1"b;
      castl_arg_descriptor_template.type = char_dtype;
      castl_arg_descriptor_template.packed = "0"b;
      castl_arg_descriptor_template.number_dims = 0;
      castl_arg_descriptor_template.size = 0;

      castl_new_arg_index = 1;
      castl_arg_index = 1;
      castl_arg_length = 0;

CASTL_PARSE_LOOP:
      do while (castl_new_arg_index > 0);
         castl_new_arg_index =
	  verify (substr (castl_p_arg_string, castl_arg_index + castl_arg_length), CASTL_SPACE_CHAR || CASTL_TAB_CHAR);
         if castl_new_arg_index > 0
         then
CASTL_HAVE_ARG:
	  do;
	     castl_arg_index = castl_arg_length + castl_arg_index + castl_new_arg_index - 1;
	     castl_arg_length =
	        search (substr (castl_p_arg_string, castl_arg_index), CASTL_SPACE_CHAR || CASTL_TAB_CHAR);
	     if castl_arg_length = 0
	     then castl_arg_length = length (castl_p_arg_string) - castl_arg_index + 1;
	     else castl_arg_length = castl_arg_length - 1;

	     castl_quote_index =
	        index (substr (castl_p_arg_string, castl_arg_index, castl_arg_length), CASTL_QUOTE_CHAR);
	     castl_old_quote_index = castl_arg_index;

CASTL_QUOTE_LOOP:
	     do while (castl_quote_index > 0);
	        castl_quote_index = castl_old_quote_index + castl_quote_index;
CASTL_DOUBLE_QUOTE_LOOP:
	        do while (substr (castl_p_arg_string, castl_quote_index, 1) = CASTL_QUOTE_CHAR);
		 castl_old_quote_index = castl_quote_index;
		 castl_quote_index = index (substr (castl_p_arg_string, castl_old_quote_index + 1), CASTL_QUOTE_CHAR);
		 if castl_quote_index = 0
		 then call
		         sub_err_ (error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null, 0,
		         "^/Unable to process the ^a command.
There is a missing quote character after character ^d, in its argument string:
^a.", requote_string_ ((p_command_name)), castl_old_quote_index, requote_string_ ((castl_p_arg_string)));

		 castl_quote_index = castl_old_quote_index + castl_quote_index;
	        end CASTL_DOUBLE_QUOTE_LOOP;

	        castl_old_quote_index = castl_quote_index;
	        castl_quote_index = index (substr (castl_p_arg_string, castl_old_quote_index), CASTL_QUOTE_CHAR);
	        castl_arg_length =
		 search (substr (castl_p_arg_string, castl_quote_index + castl_old_quote_index),
		 CASTL_SPACE_CHAR || CASTL_TAB_CHAR) + castl_quote_index + castl_old_quote_index - 1;
	        castl_quote_index =
		 index (substr (castl_p_arg_string, castl_old_quote_index + castl_quote_index, castl_arg_length),
		 CASTL_QUOTE_CHAR);
	     end CASTL_QUOTE_LOOP;

	     castl_old_arg_link_ptr = castl_arg_link_ptr;
	     alloc castl_arg_link in (castl_work_area);

	     if castl_old_arg_link_ptr = null
	     then castl_root_arg_link_ptr = castl_arg_link_ptr;
	     else castl_old_arg_link_ptr -> castl_arg_link.next_ptr = castl_arg_link_ptr;

	     castl_arg_link.arg_ptr = addcharno (addwordno (addr (castl_p_arg_string), 1), castl_arg_index - 1);

	     alloc castl_arg_descriptor in (castl_work_area);
	     castl_arg_descriptor = castl_arg_descriptor_template;
	     castl_arg_descriptor.size = castl_arg_length;

	     castl_arg_link.desc_ptr = castl_arg_descriptor_ptr;

	     castl_al_arg_count = castl_al_arg_count + 1;
	  end CASTL_HAVE_ARG;
      end CASTL_PARSE_LOOP;

      alloc castl_arg_list in (castl_work_area);
      castl_arg_list.header.pad1 = "0"b;
      castl_arg_list.header.call_type = Interseg_call_type;
      castl_arg_list.header.desc_count = castl_al_arg_count;
      castl_arg_list.header.pad2 = "0"b;

      castl_arg_link_ptr = castl_root_arg_link_ptr;

      do castl_arg_idx = 1 to castl_al_arg_count;

         castl_arg_list.arg_ptrs (castl_arg_idx) = castl_arg_link.arg_ptr;
         castl_arg_list.desc_ptrs (castl_arg_idx) = castl_arg_link.desc_ptr;

         castl_old_arg_link_ptr = castl_arg_link_ptr;
         castl_arg_link_ptr = castl_arg_link.next_ptr;
         free castl_old_arg_link_ptr -> castl_arg_link in (castl_work_area);

      end;

   end CONVERT_ARGUMENT_STRING_TO_LIST;
%page;

/* This procedure takes two lists as input, the validate_result_list
   and the validate_result_explanation_list.  Each member (node) of
   the validate_result_list contains an active function that is
   applied to the results of the previous argument processing
   (i.e., the information in the result_print_vector_array).
   Each member of the validate_result_explanation_list contains
   an explanation (error message) that is printed if the result of
   evaluating the corresponding validate_result_list_node is "false".
   If there is no explanation supplied, a "standard" error message
   This procedure returns on the first error encountered after
   printing an error message.

   The input lists, validate_result_list and validate_result_explanation_list,
   are initialized in "SETUP_DIM_IDS_AND_CONTROL_ARGUMENT_LIST".
*/

VALIDATE_RESULTS: proc(code);

  /* Parameter */

          dcl code fixed bin(35);

  /* Automatic */

	dcl i fixed bin(35);
	dcl result char(5) var;
          dcl vr_ptr ptr;
          dcl vre_ptr ptr;
	dcl vr_ovl_ptr ptr;
	dcl vre_ovl_ptr ptr;

  /* Based */

          dcl validate_result_explanation char(vre_node.str_len) var based(vre_node.str_ptr);
          dcl validate_result_str char(vr_node.str_len) var based(vr_node.str_ptr);

          dcl 1 vr_node based(vr_ptr) like node;
          dcl 1 vre_node based(vre_ptr) like node;


          code = 0;

          if validate_result_list_ptr = null
	then return;

          if validate_result_explanation_list_ptr ^= null
          then vre_ptr = validate_result_explanation_list.head_ptr;
          else vre_ptr = null;

          do vr_ptr = validate_result_list.head_ptr repeat(vr_node.next_ptr) while(vr_ptr ^= null);

	     call MAKE_VR_SUBSTITUTIONS((validate_result_str), active_string_nonvarying, active_string_length, code);
	     if code ^= 0
	     then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0,
	        "^/Unable to make substitutions in the result validation string:^/""^a"".",
	        validate_result_str);

	     on active_function_error call PRINT_AF_ERROR_MSG("result validation", (active_string));

	     call cu_$evaluate_active_string(null, (active_string), NORMAL_ACTIVE_STRING, result, code);
	     if code ^= 0
	     then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0,
	        "^/Unable to evaluate the active string:^/""^a"".",
	        active_string);

	     revert active_function_error;

	     if result ^= "true"
               then do;
	          if vre_ptr ^= null
		then do;
                         call MAKE_VR_SUBSTITUTIONS((validate_result_explanation), active_explanation_nonvarying,
		        active_explanation_length, code);
                         if code ^= 0
                         then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null, 0,
		        "^/Unable to make substitutions in the result validation explanation:^/""^a"".",
		        validate_result_explanation);
                         call com_err_(0, (command_name_str), active_explanation);
		end;
		else call com_err_(0, (command_name_str), "Evaluation of the following" ||
		   "^/result validation active string yields ""false"":^/""^a""." ||
		   "^/No explanation has been provided.",
		   active_string);
                    code = error_table_$bad_arg;
		return;
	     end;

               if validate_result_explanation_list_ptr ^= null
               then do;
                    if vre_ptr = null
                    then ;                                            /* End of explanation list. */
                    else vre_ptr = vre_node.next_ptr;
               end;

	end;

	call FREE_LIST (validate_result_list_ptr);
	call FREE_LIST (validate_result_explanation_list_ptr);

     end VALIDATE_RESULTS;

%page;

/* This procedure makes substitutions in an input string and returns
   the resulting character string.  It searches the input string for
   occurences of option names framed on the left by "&(" and on the
   right by ")".  For each such occurence it substitutes the option
   value found in the result_print_vector_array.  If the
   result_print_vector_array contains no such option, the null string
   is substituted.
*/

MAKE_VR_SUBSTITUTIONS: proc(initial_vr_str, buffer, n_chars_ret, code);

  /* Parameter */

          dcl buffer char(*);
	dcl code fixed bin(35);
	dcl initial_vr_str char(*);
	dcl n_chars_ret fixed bin(21);

  /* Automatic */

          dcl begin_looking_pos fixed bin(21);
	dcl found_option bit(1);
          dcl option_name char(length(initial_vr_str)) var;
	dcl search_str_len fixed bin(21);
	dcl search_str_pos fixed bin(21);
	dcl sub_str char(length(buffer)) var;
	dcl temp_buffer char(length(buffer)) var;

  /* Based */

          dcl search_str char(search_str_len) based(addcharno(addr(temp_buffer), (search_str_pos - 1) + 4));          /* 4 for str len at beginning of var str. */
          dcl sub_str_len fixed bin(21) based(addr(sub_str));
	dcl sub_str_nonvar char(length(buffer)) based(addwordno(addr(sub_str), 1));

          code = 0;
	buffer = "";
	n_chars_ret = 0;
	temp_buffer = initial_vr_str;
	begin_looking_pos = 1;

	call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len);

	do while(search_str_pos ^= 0);

               option_name = LR_TRIM((search_str), LEFT_BOUND_STR, RIGHT_BOUND_STR);

	     call process_arguments_$get_option_value(p_result_print_vector_array_ptr, p_work_area_ptr, found_option,
	        option_name, option_value_list_ptr);

	     if ^found_option
	     then sub_str = "";
               else do;
	          call CV_OPTION_VALUES_TO_STRING(option_value_list_ptr, sub_str_nonvar, sub_str_len, code);
	          if code ^= 0
	          then return;
               end;

               call SUBSTITUTE((temp_buffer),(search_str), (sub_str), search_str_pos, addr(temp_buffer), code);
               if code ^= 0
               then return;

               begin_looking_pos = search_str_pos + sub_str_len;

	     call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len);

	end;

	buffer = temp_buffer;
	n_chars_ret = length(temp_buffer);

     end MAKE_VR_SUBSTITUTIONS;

%page;
/* This routine substitutes argument values into a specified character string
   and returns the resulting character string.  It searches the input string
   for occurences of the current argument name framed on the left by "&(
   and on the right by ")".  For each such occurence it substitutes the
   current argument value into the string.
*/

MAKE_V_SUBSTITUTIONS: proc(initial_vr_str, input_arg_name, input_arg_value, buffer, n_chars_ret, code);

  /* Parameter */

          dcl buffer char(*);
          dcl code fixed bin(35);
          dcl initial_vr_str char(*);
          dcl input_arg_name char(*);
          dcl input_arg_value char(*);
          dcl n_chars_ret fixed bin(21);

  /* Automatic */

          dcl arg_name char(length(buffer)) var;
          dcl begin_looking_pos fixed bin(21);
          dcl search_str_len fixed bin(21);
          dcl search_str_pos fixed bin(21);
          dcl temp_buffer char(length(buffer)) var;

  /* Based */

          dcl search_str char(search_str_len) based(addcharno(addr(temp_buffer), (search_str_pos - 1) + 4));          /* 4 for str length at beginning of var str. */

          code = 0;
          buffer = "";
          n_chars_ret = 0;
          temp_buffer = initial_vr_str;
          begin_looking_pos = 1;

          call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len);

          do while(search_str_pos ^= 0);

               arg_name = LR_TRIM(search_str, LEFT_BOUND_STR, RIGHT_BOUND_STR);

               if arg_name = input_arg_name
               then do;
                    call SUBSTITUTE((temp_buffer), (search_str), (input_arg_value), search_str_pos, addr(temp_buffer), code);
                    if code ^= 0
                    then return;
                    begin_looking_pos = search_str_pos + length(input_arg_value);
               end;
               else begin_looking_pos = search_str_pos + search_str_len;

               call STAR_STR_SEARCH((temp_buffer), LEFT_BOUND_STR, RIGHT_BOUND_STR, begin_looking_pos, search_str_pos, search_str_len);

          end;

          buffer = temp_buffer;
          n_chars_ret = length(temp_buffer);

     end MAKE_V_SUBSTITUTIONS;
%page;

/* This procedure searches an input string for occurences of a search string.
   The search string has definite sets of characters on the left and right
   and a non-deterministic set of characters in the middle.  The search
   begins at a designated position in the input string, not always at
   the beginning.  The position of the search string (relative to
   the beginning of the input string) and its length are returned.
   If the search string is not found, a position and length of 0 are
   returned.
*/

STAR_STR_SEARCH: proc(str_to_search, start_str, end_str, initial_begin_looking_pos, search_str_pos, search_str_len);

  /* Parameter */

          dcl end_str char(*);
	dcl initial_begin_looking_pos fixed bin(21);
	dcl search_str_len fixed bin(21);
	dcl search_str_pos fixed bin(21);
          dcl start_str char(*);
          dcl str_to_search char(*);

  /* Automatic */

          dcl begin_looking_pos fixed bin(21);
	dcl end_str_idx fixed bin(21);
	dcl end_str_pos fixed bin(21);
	dcl start_str_idx fixed bin(21);
	dcl start_str_pos fixed bin(21);
	dcl substr_to_search char(length(str_to_search)) var;


          search_str_pos = 0;
	search_str_len = 0;

	begin_looking_pos = initial_begin_looking_pos;
	substr_to_search = substr(str_to_search, begin_looking_pos);

	start_str_idx = index(substr_to_search, start_str);
	if start_str_idx = 0
	then return;

	start_str_pos = begin_looking_pos + start_str_idx - 1;

	begin_looking_pos = start_str_pos + length(start_str);
	substr_to_search = substr(str_to_search, begin_looking_pos);

	end_str_idx = index(substr_to_search, end_str);
	if end_str_idx = 0
	then return;

	end_str_pos = begin_looking_pos + (end_str_idx - 1) + length(end_str) - 1;

	search_str_pos = start_str_pos;
	search_str_len = end_str_pos - start_str_pos + 1;

     end STAR_STR_SEARCH;

%page;

/* This procedure takes a pointer to an option_value_list and returns
   all of the values concatenated together separated by spaces in
   the buffer provided.
*/

CV_OPTION_VALUES_TO_STRING: proc(ovl_ptr, buffer, n_chars_ret, code);

  /* Parameter */

          dcl buffer char(*);
	dcl code fixed bin(35);
	dcl n_chars_ret fixed bin(21);
          dcl ovl_ptr ptr;

  /* Automatic */

          dcl i fixed bin;
          dcl max_buffer_len fixed bin(21);
	dcl option_value_ptr ptr;
	dcl temp_buffer char(length(buffer)) var;
	dcl work_str char(length(buffer)) var;

  /* Based */

          dcl option_value char(sys_info$max_seg_size) var based(option_value_ptr);


          code = 0;
	buffer = "";
	n_chars_ret = 0;
	max_buffer_len = length(buffer);
	temp_buffer = "";

	do i = 1 to ovl_ptr->option_value_list.number_of_values;
	     work_str = temp_buffer;
	     option_value_ptr = ovl_ptr->option_value_list.value(i).ptr;
	     if length(requote_string_((option_value))) + length(work_str) + 1 > max_buffer_len
	     then do;
	          code = error_table_$smallarg;
		return;
	     end;
	     if i = 1
	     then temp_buffer = requote_string_((option_value));
	     else temp_buffer = work_str || " " || requote_string_((option_value));
	end;

	buffer = temp_buffer;
	n_chars_ret = length(temp_buffer);

     end CV_OPTION_VALUES_TO_STRING;

%page;

/* This function takes an input string, and trims one occurence of given
   character strings off the immediate left and immediate right of the input
   string.  It returns the result.
*/

LR_TRIM: proc(str, lchars, rchars) returns(char(*));

  /* Parameter */

          dcl lchars char(*);
	dcl rchars char(*);
	dcl str char(*);

  /* Automatic */

          dcl new_str char(length(str)) var;


          new_str = str;

	if index(new_str, lchars) = 1
	then new_str = after(new_str, lchars);

	if index(reverse(new_str), reverse(rchars)) = 1
	then new_str = reverse(after(reverse(new_str), reverse(rchars)));

	return((new_str));

     end LR_TRIM;

%page;
/* This procedure takes a string that contains an occurence of an "old"
   sequence of characters at a specified position in the string, and
   replaces the old sequence with a new sequence handing the result
   back in a varying character buffer.
*/

(stringrange):
SUBSTITUTE: proc(str, old, new, old_pos, buffer_ptr, code);

  /* Parameter */

          dcl buffer_ptr ptr;
          dcl code fixed bin(35);
          dcl new char(*);
          dcl old char(*);
          dcl old_pos fixed bin(21);
          dcl str char(*);

  /* Automatic */

          dcl left_str char(length(buffer)) var;
          dcl old_len fixed bin(21);
          dcl right_str char(length(buffer)) var;

  /* Based */

          dcl buffer char(sys_info$max_seg_size) var based(buffer_ptr);

          code = 0;

          on stringrange begin;
               code = error_table_$smallarg;
               goto SUBSTITUTE_RETURN;
          end;

          old_len = length(old);

          left_str = substr(str, 1, old_pos - 1);
          right_str = substr(str, old_pos + old_len);

          buffer = left_str || new || right_str;

SUBSTITUTE_RETURN:

          return;

     end SUBSTITUTE;

%page;
/* This procedure is called when evaluating an active function and
   the active_function_error condition is signalled.  It finds the
   condition_info set up for active function errors, extracts
   and prints the error message.
*/

PRINT_AF_ERROR_MSG: proc(af_user_name, af);

  /* Parameter */

          dcl af char(*);
          dcl af_user_name char(*);

  /* Automatic */

          dcl code fixed bin(35);
          dcl stack_ptr ptr;

          dcl 1 auto_condition_info aligned like condition_info;

  /* Based */

          dcl af_error_msg char(com_af_error_info.errmess_lth) based(com_af_error_info.errmess_ptr);
	dcl af_name char(com_af_error_info.name_lth) based(com_af_error_info.name_ptr);

          unspec(auto_condition_info) = "0"b;
          auto_condition_info.version = condition_info_version_1;

          stack_ptr = find_condition_frame_(null);

	call find_condition_info_(stack_ptr, addr(auto_condition_info), code);
	if code ^= 0
	then call sub_err_(code, MY_NAME, ACTION_CANT_RESTART, null,  0,
	   "^/Unable to obtain an error message for an error that occured while" ||
	   "^/processing the ^a active string:^/""^a"".",
	   af_user_name, af);

          com_af_error_info_ptr = auto_condition_info.info_ptr;

          if com_af_error_info.version ^= com_af_error_info_version_3
          then call sub_err_(error_table_$unimplemented_version, MY_NAME, ACTION_CANT_RESTART, null, 0,
	   "^/Unable to obtain the correct version of error information for an error" ||
	   "^/that occured while processing the ^a active string:^/""^a"".",
             af_user_name, af);

          call sub_err_(error_table_$fatal_error, MY_NAME, ACTION_CANT_RESTART, null, 0,
	   "^a^/An error occured while processing the ^a active string:^/""^a"".",
	   af_error_msg, af_user_name, af);

     end PRINT_AF_ERROR_MSG;

%page;

/* This procedure is called to build and maintain the validate_result_list
   and the validate_result_explanation_list.  It looks in a given
   print_vector for a validate_result_string and validate_result_explanation,
   and adds them to the appropriate list if they are found.
*/

SETUP_RESULT_VALIDATION_INFO: proc(pv_ptr, vr_list_ptr, vre_list_ptr);

  /* Parameter */

          dcl pv_ptr ptr;
          dcl vre_list_ptr ptr;
          dcl vr_list_ptr ptr;

          call ADD_TO_LIST(pv_ptr, vr_list_ptr, validate_result_identifier);

          call ADD_TO_LIST(pv_ptr, vre_list_ptr, validate_result_explanation_identifier);

     end SETUP_RESULT_VALIDATION_INFO;


%page;

/* This is a list maintenance procedure.  It adds a node to a list if
   there is a specific dimension value in a given print_vector.
*/

ADD_TO_LIST: proc(pv_ptr, list_ptr, dim_identifier);

  /* Parameter */

          dcl dim_identifier fixed bin;
          dcl list_ptr ptr;
          dcl pv_ptr ptr;

  /* Automatic */

          dcl dim_idx fixed bin;
          dcl new_node_ptr ptr;

          call GET_DIM_IDX(pv_ptr, dim_identifier, dim_idx);

          if dim_idx = -1
          then return;

          call GET_LIST_NODE(list_ptr, new_node_ptr);

          new_node_ptr->node.str_len = length(pv_ptr->print_vector.dimension(dim_idx).value);
          new_node_ptr->node.str_ptr = addr(pv_ptr->print_vector.dimension(dim_idx).value);

     end ADD_TO_LIST;
%page;
/* This is a list maintenance procedure.  It allocates storage for a node
   in a given list, initializes the values in the node, and tacks that node
   on to the end of the list.  It also initializes the list header if
   necessary.
*/

GET_LIST_NODE: proc(list_ptr, new_node_ptr);

  /* Parameter */

          dcl list_ptr ptr;
          dcl new_node_ptr ptr;

          allocate node in(work_area) set(new_node_ptr);
          new_node_ptr->node.next_ptr = null;

          if list_ptr = null
          then do;
               allocate list in(work_area) set(list_ptr);
               list_ptr->list.head_ptr = new_node_ptr;
               list_ptr->list.tail_ptr = new_node_ptr;
          end;
          else do;
               list_ptr->list.tail_ptr->node.next_ptr = new_node_ptr;
               list_ptr->list.tail_ptr = new_node_ptr;
          end;

     end GET_LIST_NODE;
%page;
/* This is a list maintenance procedure.  I frees up all of the storage
   that has been allocated for a list.
*/

FREE_LIST: proc(list_ptr);

  /* Parameter */

          dcl list_ptr ptr;

  /* Automatic */

          dcl next_node_ptr ptr;


          if list_ptr = null
	then return;

          node_ptr = list_ptr->list.head_ptr;

	do while(node_ptr ^= null);
	     next_node_ptr = node.next_ptr;
	     free node;
	     node_ptr = next_node_ptr;
	end;

     end FREE_LIST;

%page;
/* This entry really belongs in vector_util.  It is just temporary.
*/

free_print_vector_array: entry(p_print_vector_array_ptr);

  /* Parameter */

          dcl p_print_vector_array_ptr ptr;

  /* Automatic */

          dcl i fixed bin;

          if p_print_vector_array_ptr = null
	then return;

          print_vector_array_ptr = p_print_vector_array_ptr;

	do i = 1 to print_vector_array.number_of_vectors;
	     print_vector_ptr = print_vector_array.vector_slot(i);
	     free print_vector;
	end;

          free print_vector_array;

	return;

%page;
%include vu_print_vector_array;
%page;
%include arg_list;
%page;
%include vu_entry_dcls;
%page;
%include sub_err_flags;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
%page;
%include cp_active_string_types;
%page;
%include pa_option_value_list;
%page;
%include condition_info_header;
%page;
%include com_af_error_info;
%page;
%include condition_info;

   end pa_process_arguments;




		    pa_search_list.pl1              02/27/89  1058.7rew 02/27/89  1051.8      125001



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1989                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(89-01-17,TLNguyen), approve(89-01-27,MCR8052),
     audit(89-02-06,Parisek), install(89-02-27,MR12.3-1015):
     a. Replace error_table_$programming_error with error_table_$fatal_error
        when calling sub_err_ to report a null area pointer error.
     b. Assign initial values for automatic variables in the internal
        procedure, INITIALIZATION.  Remove the reference to
        get_temp_segment_.
                                                   END HISTORY COMMENTS */


/* format: style2,ind3 */
pa_search_list:
   proc (p_command_name, p_caller_area_ptr, p_array_ptr, p_code);

/* DESCRIPTION:

          This subroutine searches the databases in the process_arguments
     search list for either an argument processing definition or a default
     linear form.
*/

/* HISTORY:

Written by Lindsey Spratt, 06/27/83.
Modified:
06/28/83 by Lindsey L. Spratt:  Fixed to not report errors encountered while
            searching the list until the list just searched passes the change
            count test.  Also fixed to check the change count before using the
            stored sl_info.
07/01/83 by Lindsey L. Spratt:  Fixed to look for default linear form strings,
            rather than result pva's.  Also, taught to look in value segments
            (when that's specified in the search list).
07/07/83 by Lindsey L. Spratt:  Fixed to set the sl_info_p pointer to the
            current value of search_list_info_ptr.
07/08/83 by Lindsey L. Spratt:  Fixed to not report errors of
            vd_error_$no_vector or error_table_$noentry when searching for a
            default linear form.
07/24/83 by Lindsey L. Spratt:  Converted to retrieve a pva_string definition
            from a value seg, rather than a print_vector_array definition from
            a vector_db.
08/03/83 by S.Krupp to distinguish between internal work area and caller
            provided area to fix bad search_list_info_ptr bug.
	  The sl_info structure is now allocated in the internal work area.
	  Also, to change the name of the search list to mtape_arguments
	  and fix assorted bugs.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_command_name	       char (*) varying;
      dcl	    p_caller_area_ptr      ptr;
      dcl	    p_array_ptr	       ptr;
      dcl	    p_default_linear_form  char (*) varying;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    (retry_count, path_idx)
			       fixed bin;
      dcl	    definition_value_name  char (256) varying;
      dcl	    dir_name	       char (256);
      dcl	    entry_name	       char (128);
      dcl	    default_linear_form_value_name
			       char (128) varying;
      dcl	    get_definition	       bit (1) aligned;
      dcl	    work_area_ptr	       ptr;
      dcl	    caller_area_ptr	       ptr;

/* Based */

      dcl	    based_real_fix_bin_2u  fixed bin (71) unaligned based;

/* Builtin */

      dcl	    (addr, null, string)   builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("pa_get_definition") char (64) varying internal static options (constant);

      dcl	    PROCESS_ARGUMENTS_SEARCH_LIST_NAME
			       init ("mtape_arguments") char (64) varying internal static options (constant);
      dcl	    VALUE_SUFFIX	       init ("value") char (5) internal static options (constant);
      dcl	    PERMANENT_VALUE	       init ("01"b) bit (2) aligned internal static options (constant);
      dcl	    (
	    RETRY_LIMIT	       init (5),
	    BYTES_PER_WORD	       init (4)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    get_system_free_area_  entry () returns (ptr);
      dcl	    value_$get_data	       entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35));
      dcl	    sub_err_	       entry options (variable);
      dcl	    expand_pathname_$add_suffix
			       entry (char (*), char (*), char (*), char (*), fixed bin (35));
      dcl	    search_paths_$get      entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));
      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	    ioa_$rsnnl	       entry() options(variable);

/* External */
      dcl	    (
	    error_table_$asynch_change,
	    error_table_$noentry,
	    error_table_$fatal_error,
	    error_table_$oldnamerr
	    )		       fixed bin (35) ext;

/* Internal */

      dcl	    (search_list_info_ptr)
			       ptr init (null) internal static;


/* END OF DECLARATIONS */

get_definition:
   entry (p_command_name, p_caller_area_ptr, p_array_ptr, p_code);

      call INITIALIZATION ();

      caller_area_ptr = p_caller_area_ptr;
      get_definition = "1"b;
      goto JOIN;

get_default_linear_form:
   entry (p_command_name, p_default_linear_form, p_code);

      call INITIALIZATION ();

      get_definition = "0"b;
JOIN:
      work_area_ptr = get_system_free_area_ ();

      if (caller_area_ptr = null) & (get_definition)
      then call sub_err_ (error_table_$fatal_error, myname, "s", null, 0, "The area_ptr given to this module must be non-null.");

      p_code = 0;
      p_array_ptr = null;

      default_linear_form_value_name = DEFAULT_LINEAR_FORM_PREFIX || "." || p_command_name;
      definition_value_name = DEFINITION_PREFIX || "." || p_command_name;

      if search_list_info_ptr = null
      then
         do;
	  call SETUP_SEARCH_LIST (search_list_info_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN ();
         end;

      sl_info_p = search_list_info_ptr;
      if sl_info.change_index ^= sl_info.change_index_p -> based_real_fix_bin_2u
      then
         do;
	  call SETUP_SEARCH_LIST (search_list_info_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN ();
	  sl_info_p = search_list_info_ptr;
         end;
      call SEARCH_LIST;

RETRY_SEARCH:
      do while (retry_count <= RETRY_LIMIT & sl_info.change_index ^= sl_info.change_index_p -> based_real_fix_bin_2u);

         call SETUP_SEARCH_LIST (search_list_info_ptr, p_code);
         if p_code ^= 0
         then call ERROR_RETURN ();
         sl_info_p = search_list_info_ptr;

         retry_count = retry_count + 1;

         call SEARCH_LIST;

      end RETRY_SEARCH;

      if p_code ^= 0
      then call ERROR_RETURN ();
      else if retry_count > RETRY_LIMIT
      then p_code = error_table_$asynch_change;

      call FINISH;

MAIN_RETURN:
      return;

%page;
INITIALIZATION:  proc();

      retry_count = 0;
      path_idx = 0;
      definition_value_name = "";
      dir_name = "";
      entry_name = "";
      get_definition = "0"b;
      work_area_ptr = null;
      caller_area_ptr = null;

      return;
      end INITIALIZATION;

%page;
FINISH:
   proc ();


   end FINISH;

ERROR_RETURN:
   proc ();
      call FINISH;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
SEARCH_LIST:
   proc ();
      dcl	    sl_pv_idx	       fixed bin;

      if get_definition
      then
         do;
	  if p_array_ptr ^= null
	  then
	     do;
	        do sl_pv_idx = 1 to p_array_ptr -> print_vector_array.number_of_vectors;
		 free p_array_ptr -> print_vector_array.vector_slot (sl_pv_idx) -> print_vector;
	        end;
	        free p_array_ptr -> print_vector_array;
	        p_array_ptr = null;
	     end;
         end;
      else p_default_linear_form = "";

      do path_idx = 1 to sl_info.num_paths;
         call expand_pathname_$add_suffix (sl_info.paths (path_idx).pathname, VALUE_SUFFIX, dir_name, entry_name, p_code);
         if p_code ^= 0
         then return;
         if get_definition
         then
	  do;
	     call RETRIEVE_DEFINITION (dir_name, entry_name, p_array_ptr, p_code);
	     if p_array_ptr ^= null
	     then return;				/* A definition was found. */
	     else if p_code ^= error_table_$oldnamerr & p_code ^= error_table_$noentry
	     then return;				/* An error fatal to the search was hit. */
	  end;
         else
	  do;
	     call RETRIEVE_DEFAULT_LINEAR_FORM (dir_name, entry_name, p_default_linear_form, p_code);
	     if p_code ^= 0
	     then if p_code ^= error_table_$oldnamerr & p_code ^= error_table_$noentry
		then return;			/* An error fatal to the search was hit. */
		else p_code = 0;
	  end;
      end;
      if get_definition
      then if p_array_ptr = null
	 then p_code = error_table_$oldnamerr;
   end SEARCH_LIST;
%page;
RETRIEVE_DEFAULT_LINEAR_FORM:
   proc (rdlf_p_db_dir, rdlf_p_db_entry, rdlf_p_default_linear_form, rdlf_p_code);
      dcl	    rdlf_p_db_dir	       char (*) parameter;
      dcl	    rdlf_p_db_entry	       char (*) parameter;
      dcl	    rdlf_p_default_linear_form
			       char (*) varying parameter;
      dcl	    rdlf_p_code	       fixed bin (35) parameter;

      dcl	    rdlf_value_seg_ptr     ptr init (null);
      dcl	    rdlf_default_linear_form_value
			       char (rdlf_dlfv_length_in_bytes) varying based(rdlf_dlfv_ptr);
      dcl     rdlf_dlfv_length_in_bytes
                                     fixed bin(21) init(0);
      dcl     rdlf_dlfv_length_in_words
                                     fixed bin(18) init(0);
      dcl     rdlf_dlfv_ptr	       ptr init(null);

      call initiate_file_ (rdlf_p_db_dir, rdlf_p_db_entry, R_ACCESS, rdlf_value_seg_ptr, (0), p_code);
      if rdlf_value_seg_ptr = null
      then return;

      call
         value_$get_data (rdlf_value_seg_ptr, (PERMANENT_VALUE), (default_linear_form_value_name),
         work_area_ptr, rdlf_dlfv_ptr, rdlf_dlfv_length_in_words, p_code);
      if p_code ^= 0
      then
         do;
	  call RDLF_FINISH;
	  return;
         end;

      rdlf_dlfv_length_in_bytes = rdlf_dlfv_length_in_words * BYTES_PER_WORD;

      call terminate_file_ (rdlf_value_seg_ptr, (0), TERM_FILE_TERM, p_code);
      if p_code ^= 0
      then
         do;
	  call RDLF_FINISH;
	  return;
         end;

      call ioa_$rsnnl("^a^[^; ^]^a", rdlf_p_default_linear_form, 0, (rdlf_default_linear_form_value),
         (rdlf_default_linear_form_value = "" | rdlf_p_default_linear_form = ""), (rdlf_p_default_linear_form));

/*      rdlf_p_default_linear_form = rdlf_default_linear_form_value || " " || rdlf_p_default_linear_form*/


      call RDLF_FINISH;
      return;
RDLF_FINISH:
   proc;

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

   end RDLF_FINISH;
   end RETRIEVE_DEFAULT_LINEAR_FORM;
%page;
RETRIEVE_DEFINITION:
   proc (rd_p_db_dir, rd_p_db_entry, rd_p_array_ptr, rd_p_code);
      dcl	    rd_p_db_dir	       char (*) parameter;
      dcl	    rd_p_db_entry	       char (*) parameter;
      dcl	    rd_p_array_ptr	       ptr parameter;
      dcl	    rd_p_code	       fixed bin (35) parameter;
      dcl	    rd_value_seg_ptr       ptr init (null);
      dcl	    rd_definition_pva_string
			       char (rd_definition_pva_string_length_in_bytes) varying
			       based (rd_definition_pva_string_ptr);
      dcl	    rd_definition_pva_string_ptr
			       ptr init (null);
      dcl	    rd_definition_pva_string_length_in_words
			       fixed bin (18) init (0);
      dcl	    rd_definition_pva_string_length_in_bytes
			       fixed bin (21) init (0);

      call initiate_file_ (rd_p_db_dir, rd_p_db_entry, R_ACCESS, rd_value_seg_ptr, (0), p_code);
      if rd_value_seg_ptr = null
      then return;

      call
         value_$get_data (rd_value_seg_ptr, (PERMANENT_VALUE), (definition_value_name), caller_area_ptr,
         rd_definition_pva_string_ptr, rd_definition_pva_string_length_in_words, p_code);
      if p_code ^= 0
      then
         do;
	  call RD_FINISH;
	  return;
         end;

      rd_definition_pva_string_length_in_bytes = rd_definition_pva_string_length_in_words * BYTES_PER_WORD;

      call terminate_file_ (rd_value_seg_ptr, (0), TERM_FILE_TERM, p_code);
      if p_code ^= 0
      then
         do;
	  call RD_FINISH;
	  return;
         end;

      call
         vector_util_$cv_string_to_pva ((rd_definition_pva_string_ptr), (rd_definition_pva_string_length_in_bytes),
         caller_area_ptr, rd_p_array_ptr, rd_p_code);


      call RD_FINISH;
      return;
%page;
RD_FINISH:
   proc;

      if rd_definition_pva_string_ptr ^= null
      then free rd_definition_pva_string;

   end RD_FINISH;
   end RETRIEVE_DEFINITION;
%page;
SETUP_SEARCH_LIST:
   proc (ssl_p_sl_info_p, ssl_p_code);
      dcl	    ssl_p_code	       fixed bin (35) parameter;
      dcl	    ssl_p_sl_info_p	       ptr parameter;

      ssl_p_code = 0;
      ssl_p_sl_info_p = null;

      sl_control_s.af_pathname = "1"b;
      sl_control_s.pad1 = "0"b;
      sl_control_s.key_ref_dir = "0"b;
      sl_control_s.key_work_dir = "1"b;
      sl_control_s.key_home_dir = "1"b;
      sl_control_s.key_proc_dir = "1"b;
      sl_control_s.pad2 = "0"b;

      call
         search_paths_$get ((PROCESS_ARGUMENTS_SEARCH_LIST_NAME), string (sl_control_s), "", null, work_area_ptr,
         sl_info_version_1, ssl_p_sl_info_p, ssl_p_code);

   end SETUP_SEARCH_LIST;
%page;
%include pa_value_names;
%page;
%include vu_entry_dcls;
%page;
%include vu_print_vector_array;
%page;
%include sl_info;
%page;
%include sl_control_s;
%page;
%include sub_err_flags;
%page;
%include pa_dim_name_constants;
%page;
%include access_mode_values;
%page;
%include terminate_file;
   end pa_search_list;




		    process_arguments_.alm          02/16/84  1306.5r w 02/16/84  1249.9       15480



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
" HISTORY:
"
" Written By Lindsey Spratt, 06/20/83.
" Modified:
" 06/27/83 by Lindsey Spratt:  Fixed the $get_definition and 
"	    $get_default_linear_form entries to transfer into pa_search_list.
" 06/30/83 by Lindsey Spratt:  Added the $get_refname entry.
" 07/05/83 by Lindsey Spratt:  Changed cv_result_to_linear_form to reference
"	    pa_cv_result_to_lf$pa_cv_result_to_lf, $get_option_refname to 
"	    reference pa_get_refname$pa_get_refname.
" 	    Changed $get_refname to $get_reference_name.
" 09/06/83 by S. Krupp:  Added free_print_vector_array.
"
	name	process_arguments_
"
" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer argument_array,pa_process_arguments$argument_array
	ext_transfer argument_list,pa_process_arguments$argument_list
	ext_transfer argument_string,pa_process_arguments$argument_string
	ext_transfer get_option_value,pa_get_option_value$pa_get_option_value
	ext_transfer cv_result_to_linear_form,pa_cv_result_to_lf$pa_cv_result_to_lf
	ext_transfer get_option_refname,pa_get_refname$pa_get_refname
	ext_transfer get_default_linear_form,pa_search_list$get_default_linear_form
	ext_transfer get_definition,pa_search_list$get_definition
	ext_transfer get_reference_name,pa_get_refname$pa_get_refname
	ext_transfer free_print_vector_array,pa_process_arguments$free_print_vector_array
	end




		    vd_error_.alm                   11/05/86  1243.0r w 11/04/86  1038.2       21051



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	include 	et_macros
	et 	vd_error_
"
" Written by Lindsey Spratt.
" Modified:
" 07/08/82 by Lindsey Spratt: Added the short_buffer error code.
" 08/29/82 by Ed Wallman: Added nonexistent_variable_reference error code.
" 09/25/82 by Ed Wallman: Added empty_report error code.
" 10/14/82 by Lindsey Spratt: Added the mismatched_descriptors and wrong_type
"	    error codes.
" 06/09/83 by S. Krupp: added bad_print_vector_index and dim_not_in_vector
"             error codes.
"
ec no_vector,novec,
	(No vector was found.)

ec bad_parent_pos,badprnt,
	(The parent position in the node does not match the position of the parent node in the current path.)

ec bad_node,bn,
	(A node is inconsistent.)

ec vector_is_already_in_db,vecdup,
	(The vector is already present.)

ec line_too_short_for_vector,shrtline,
	(Data does not fit given line length.)

ec  inconsistent_display_definition,bad_def,
          (Display definition is inconsistent.)

ec invalid_field_name,badfield,
	(Invalid field name specified.)

ec dim_already_in_vector,dimdup,
	(The dimension is already present in the vector.)

ec bad_range_syntax,badrange,
	(The syntax of the range specification is invalid.)

ec dimension_already_defined,dimdef,
	(The dimension was already present in the dimension_table.)

ec short_buffer,shortbuf,
	(The buffer is to small for the requested data.)

ec nonexistent_variable_reference,novarref,
	(A reference to a nonexistent variable has been found.)

ec empty_report,empty,
	(The report as specified is empty.)

ec wrong_type,badtype,
	(The wrong type of vector structure was provided.)

ec mismatched_descriptors,baddesc,
	(The descriptors aren't the same.)

ec invalid_alignment,invalign,
	(The data is incorrectly aligned.)

ec unimplemented_data_type,baddt,
	(The data type is no implemented.)

ec bad_print_vector_index,badpvi,
          (The index does given not specify a print_vector in the print_vector_array.)

ec dim_not_in_vector,nodim,
          (The specified dimension is not present in the print_vector.)

	end




		    vector_util_.alm                02/16/84  1306.5r w 02/16/84  1249.9       16029



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	vector_util_

" Modified:
" 06/28/82 by Lindsey Spratt: added the cv_typed_to_print entry_point.
" 09/19/82 by Ed Wallman: Added build_display_info entrypoint.
" 09/23/82 by Lindsey Spratt:  Added the free_typed_vector and
"	    free_typed_vector_array entries.
" 02/08/83 by Lindsey Spratt:  added copy_typed_vector,
"	    copy_typed_vector_array.
" 03/08/83 by Matthew Pierret: added copy_typed_vector_array for real.
" 06/09/83 by S. Krupp: added replace_print_value entry.
" 07/24/83 by Lindsey Spratt: added cv_pva_to_string and cv_string_to_pva.
" 08/31/83 by J. A. Bush: remove entries not needed by process_arguments_ for 
"	 inclusion in bound_mtape_ for the MR10.2 release.
" Macro to generate a call to an external entrypoint in the utilities

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer init_print_vector_array,vu_init_print_vector_array$vu_init_print_vector_array
	ext_transfer append_simple_print_vector,vu_append_simple_print$vu_append_simple_print
	ext_transfer append_general_print_vector,vu_append_general_print$vu_append_general_print
	ext_transfer append_dimension_print,vu_append_dimension_print$vu_append_dimension_print
	ext_transfer err_no_operation,vu_err_no_operation$vu_err_no_operation
	ext_transfer replace_print_value,vu_replace_print_value$replace_print_value
	ext_transfer cv_pva_to_string,vu_cv_pva_to_string$vu_cv_pva_to_string
	ext_transfer cv_string_to_pva,vu_cv_string_to_pva$vu_cv_string_to_pva
	end




		    vu_append_dimension_print.pl1   02/16/84  1306.5r w 02/16/84  1249.9       52200



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_append_dimension_print:
append_dimension_print:
   proc (p_work_area_ptr, p_free_old_print_vector_array, p_dimension_name, p_descriptor_ptr, p_print_vector_array_ptr,
      p_dimension_identifier, p_code);

/* DESCRIPTION:
          This module adds a new dimension to an existing print_vector_array.
*/

/* HISTORY:
Written by Lindsey Spratt, 06/01/82.
Modified:
06/30/83 by Lindsey L. Spratt:  Due to an apparent bug in the PL/1 compiler,
            an assignment of structure element of an array to a new copy of
            the array was not working (off by a word, or so).  This assignment
            was replaced with a set of explicit assignments, one for each
            element of the structure.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_free_old_print_vector_array
			       bit (1) aligned;
      dcl	    p_dimension_name       char (*);
      dcl	    p_descriptor_ptr       ptr;
      dcl	    p_print_vector_array_ptr
			       ptr;
      dcl	    p_dimension_identifier fixed bin;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    dim_idx	       fixed bin;
      dcl	    old_pva_ptr	       ptr;
      dcl	    vector_idx	       fixed bin;


/* Based */

      dcl	    descriptor_string      bit (36) aligned based;
      dcl	    work_area	       area based (p_work_area_ptr);

/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    MYNAME	       init ("vu_append_dimension_print") char (40) varying internal static
			       options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    vd_error_$dimension_already_defined
			       fixed bin (35) ext;
      dcl	    error_table_$bad_arg   fixed bin (35) ext;
      dcl	    vd_error_$mismatched_descriptors
			       fixed bin (35) ext;
      dcl	    error_table_$fatal_error
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      print_vector_array_ptr = p_print_vector_array_ptr;

      do p_dimension_identifier = 1 to print_vector_array.number_of_dimensions
         while (print_vector_array.dimension_table (p_dimension_identifier).name ^= p_dimension_name);
      end;
      if p_dimension_identifier <= print_vector_array.number_of_dimensions
      then
         do;
	  p_code = vd_error_$dimension_already_defined;
	  if p_descriptor_ptr = print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr
	  then return;
	  else if p_descriptor_ptr = null
		| print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr = null
	  then return;
	  else if p_descriptor_ptr -> descriptor_string
		= print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr -> descriptor_string
	  then return;
	  else
	     do;
	        p_code = vd_error_$mismatched_descriptors;
	        return;
	     end;
         end;
      pva_number_of_vector_slots = print_vector_array.number_of_vector_slots;
      pva_number_of_dimensions = p_dimension_identifier;

      pva_maximum_dimension_name_length =
         max (print_vector_array.maximum_dimension_name_length, length (p_dimension_name));

      old_pva_ptr = print_vector_array_ptr;
      alloc print_vector_array in (work_area);
      print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2;
      print_vector_array.number_of_vectors = old_pva_ptr -> print_vector_array.number_of_vectors;

      print_vector_array.vector_slot = old_pva_ptr -> print_vector_array.vector_slot;

      do p_dimension_identifier = 1 to print_vector_array.number_of_dimensions - 1;
         print_vector_array.dimension_table (p_dimension_identifier).name =
	  old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).name;
         print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr =
	  old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr;
         print_vector_array.dimension_table (p_dimension_identifier).cv_to_print =
	  old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).cv_to_print;
         print_vector_array.dimension_table (p_dimension_identifier).cv_to_typed =
	  old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).cv_to_typed;
         print_vector_array.dimension_table (p_dimension_identifier).maximum_value_length =
	  old_pva_ptr -> print_vector_array.dimension_table (p_dimension_identifier).maximum_value_length;
      end;

      print_vector_array.dimension_table (p_dimension_identifier).name = p_dimension_name;
      print_vector_array.dimension_table (p_dimension_identifier).descriptor_ptr = p_descriptor_ptr;

      print_vector_array.dimension_table (p_dimension_identifier).maximum_value_length = 0;
      print_vector_array.dimension_table (p_dimension_identifier).cv_to_print = vector_util_$err_no_operation;
      print_vector_array.dimension_table (p_dimension_identifier).cv_to_typed = vector_util_$err_no_operation;
      p_print_vector_array_ptr = print_vector_array_ptr;
      p_dimension_identifier = pva_number_of_dimensions;
      p_code = 0;
      if p_free_old_print_vector_array
      then free old_pva_ptr -> print_vector_array in (work_area);
      return;

%include vu_print_vector_array;
%page;
%include desc_types;
%page;
%include descriptor;
%page;
%include arg_list;
%page;
%include vu_entry_dcls;
   end vu_append_dimension_print;




		    vu_append_general_print.pl1     02/16/84  1306.5r w 02/16/84  1249.9      114795



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_append_general_print:
append_general_print_vector:
   proc ();

/* DESCRIPTION:

          This entry appends a print vector to a print vector array.
*/

/* HISTORY:
Written by Lindsey Spratt, sometime in 1980?
Modified:
03/10/83 by Lindsey Spratt:  Added a new parameter (now the 4th one) which is
	  used to specify that an existing print_vector is to be added onto.
03/15/83 by Lindsey Spratt:  Added a nosubrg prefix to avoid a compiler bug in
	  assigning from one array to another when the arrays have different
	  extents.
08/30/83 by Lindsey L. Spratt:  Fixed to use vd_error_$dim_already_in_vector.
*/

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

      dcl	    dimension_name_ptr     ptr;
      dcl	    dimension_name_length  fixed bin;


      dcl	    CODE_ARG_IDX	       fixed bin;
      dcl	    PVA_PTR_ARG_IDX	       fixed bin;
      dcl	    (dim_idx, temp_dim_idx)
			       fixed bin;
      dcl	    values_given	       bit (1) aligned init ("0"b);
      dcl	    is_dimension_value     bit (1) aligned;
      dcl	    old_pva_ptr	       ptr;
      dcl	    vector_idx	       fixed bin;
      dcl	    (vector_slot_idx_ptr, old_print_vector_ptr)
			       ptr init (null);
      dcl	    free_old_print_vector_array_ptr
			       ptr;
      dcl	    arg_list_arg_count     fixed bin;
      dcl	    arg_list_ptr	       ptr;
      dcl	    type		       fixed bin;
      dcl	    packed	       bit (1) aligned;
      dcl	    size		       fixed bin;
      dcl	    ndims		       fixed bin;
      dcl	    scale		       fixed bin;
      dcl	    p_code_ptr	       ptr;
      dcl	    nargs		       fixed bin;
      dcl	    arg_idx	       fixed bin;
      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    vector_slot_idx	       fixed bin (35) based (vector_slot_idx_ptr) aligned;
      dcl	    free_old_print_vector_array
			       bit (1) aligned based (free_old_print_vector_array_ptr);
      dcl	    work_area	       area based (work_area_ptr);
      dcl	    s_fixed_real_template  based fixed bin;
      dcl	    ptr_template	       based ptr;
      dcl	    dimension_name	       based (dimension_name_ptr) char (dimension_name_length);
      dcl	    v_char_template	       based char (size) varying;
      dcl	    char_template	       based char (size);

      dcl	    p_code	       based (p_code_ptr) fixed bin (35);


/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    MYNAME	       init ("vu_append_general_print") char (40) varying internal static
			       options (constant);

      dcl	    (
	    AREA_PTR_ARG_IDX       init (1),
	    SLOT_INCREASE_ARG_IDX  init (2),
	    FREE_OLD_PVA_ARG_IDX   init (3),
	    VECTOR_SLOT_IDX_ARG_IDX
			       init (4),
	    NUMBER_OF_DIMENSIONS_ARG_IDX
			       init (5),
	    MAXIMUM_VALUE_LENGTH_ARG_IDX
			       init (6),
	    NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING
			       init (4),
	    PVA_PTR_ARG_OFFSET_FROM_END
			       init (1),
	    NUMBER_OF_NONVALUE_ARGS_AT_END
			       init (2)
	    )		       fixed bin internal static options (constant);


/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    cu_$arg_count	       entry (fixed bin);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$bad_arg   fixed bin (35) ext;
      dcl	    error_table_$fatal_error
			       fixed bin (35) ext;
      dcl	    vd_error_$dim_already_in_vector
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      call cu_$arg_count (nargs);
      arg_list_arg_count = nargs;
      call cu_$arg_list_ptr (arg_list_ptr);

      CODE_ARG_IDX = nargs;
      PVA_PTR_ARG_IDX = nargs - PVA_PTR_ARG_OFFSET_FROM_END;

      call decode_descriptor_ (arg_list_ptr, CODE_ARG_IDX, type, packed, ndims, size, scale);
      if type ^= s_fixed_real_desc
      then call
	    sub_err_ (error_table_$fatal_error, MYNAME, "s", null, 0,
	    "^/^a was called incorrectly.^/The final argument must be fixed bin(35).", MYNAME);

      p_code_ptr = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARG_IDX);

      call decode_descriptor_ (arg_list_ptr, AREA_PTR_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= pointer_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      work_area_ptr = arg_list_ptr -> arg_list.arg_ptrs (AREA_PTR_ARG_IDX) -> ptr_template;

      call decode_descriptor_ (arg_list_ptr, PVA_PTR_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= pointer_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template;

      call decode_descriptor_ (arg_list_ptr, SLOT_INCREASE_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= s_fixed_real_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;


      pva_number_of_vector_slots =
         print_vector_array.number_of_vector_slots
         + arg_list_ptr -> arg_list.arg_ptrs (SLOT_INCREASE_ARG_IDX) -> s_fixed_real_template;
      call decode_descriptor_ (arg_list_ptr, FREE_OLD_PVA_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= bit_desc | packed | size ^= 1
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      free_old_print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (FREE_OLD_PVA_ARG_IDX);

      call decode_descriptor_ (arg_list_ptr, VECTOR_SLOT_IDX_ARG_IDX, type, packed, ndims, size, scale);
      if type ^= s_fixed_real_desc | packed
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;
      vector_slot_idx_ptr = arg_list_ptr -> arg_list.arg_ptrs (VECTOR_SLOT_IDX_ARG_IDX);
      if vector_slot_idx = 0 | vector_slot_idx < -1 | vector_slot_idx > print_vector_array.number_of_vectors
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;
      else if vector_slot_idx = -1
      then old_print_vector_ptr = null;
      else old_print_vector_ptr = print_vector_array.vector_slot (vector_slot_idx);


      call decode_descriptor_ (arg_list_ptr, NUMBER_OF_DIMENSIONS_ARG_IDX, type, packed, ndims, size, scale);
      if type = s_fixed_real_desc
      then if ^packed
	 then
	    do;
	       values_given = "0"b;
	       pv_number_of_dimensions =
		arg_list_ptr -> arg_list.arg_ptrs (NUMBER_OF_DIMENSIONS_ARG_IDX) -> s_fixed_real_template;
	       call decode_descriptor_ (arg_list_ptr, MAXIMUM_VALUE_LENGTH_ARG_IDX, type, packed, ndims, size, scale);
	       if type = s_fixed_real_desc
	       then if ^packed
		  then pv_maximum_value_length =
			arg_list_ptr -> arg_list.arg_ptrs (MAXIMUM_VALUE_LENGTH_ARG_IDX) -> s_fixed_real_template;
		  else
		     do;
		        p_code = error_table_$bad_arg;
		        return;
		     end;

	    end;
	 else
	    do;
	       p_code = error_table_$bad_arg;
	       return;
	    end;
      else
         do;
	  values_given = "1"b;
	  pv_number_of_dimensions =
	     (nargs - (NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + NUMBER_OF_NONVALUE_ARGS_AT_END)) / 2;
	  pv_maximum_value_length = 0;

	  do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 2 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END by 2;

	     call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);

	     if type = v_char_desc | type = char_desc
	     then
	        do;

		 pv_maximum_value_length =
		    max (pv_maximum_value_length,
		    length (rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template)));
	        end;
	     else
	        do;
		 p_code = error_table_$bad_arg;
		 return;
	        end;
	  end;
         end;

      if old_print_vector_ptr = null
      then
         do;
	  alloc print_vector in (work_area);
	  print_vector_array.number_of_vectors = print_vector_array.number_of_vectors + 1;
	  if print_vector_array.number_of_vectors > print_vector_array.number_of_vector_slots
	  then
	     do;
	        pva_maximum_dimension_name_length = print_vector_array.maximum_dimension_name_length;
	        pva_number_of_dimensions = print_vector_array.number_of_dimensions;
	        old_pva_ptr = print_vector_array_ptr;
	        alloc print_vector_array in (work_area);
	        arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template = print_vector_array_ptr;
	        print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2;
	        print_vector_array.dimension_table = old_pva_ptr -> print_vector_array.dimension_table;
	        print_vector_array.number_of_vectors = old_pva_ptr -> print_vector_array.number_of_vectors;
						/* This number includes the newly created print_vector. */
	        do vector_idx = 1 to print_vector_array.number_of_vectors - 1;
(nosubrg):
		 print_vector_array.vector_slot (vector_idx) =
		    old_pva_ptr -> print_vector_array.vector_slot (vector_idx);
	        end;
	        if free_old_print_vector_array
	        then free old_pva_ptr -> print_vector_array in (work_area);
	     end;
	  print_vector_array.vector_slot (print_vector_array.number_of_vectors) = print_vector_ptr;

	  dim_idx = 0;
         end;
      else
         do;
	  pv_number_of_dimensions = pv_number_of_dimensions + old_print_vector_ptr -> print_vector.number_of_dimensions;
	  pv_maximum_value_length =
	     max (pv_maximum_value_length, old_print_vector_ptr -> print_vector.maximum_value_length);
	  alloc print_vector in (work_area);
	  do dim_idx = 1 to old_print_vector_ptr -> print_vector.number_of_dimensions;
(nosubrg):
	     print_vector.dimension (dim_idx) = old_print_vector_ptr -> print_vector.dimension (dim_idx);
	  end;
	  dim_idx = old_print_vector_ptr -> print_vector.number_of_dimensions;
         end;

      is_dimension_value = "1"b;
      if values_given
      then
         do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END;
	  is_dimension_value = (mod (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING, 2) = 0);
	  call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);
	  if type ^= v_char_desc & type ^= char_desc
	  then
	     do;
	        p_code = error_table_$bad_arg;
	        return;
	     end;
	  else if is_dimension_value
	  then
	     do;
	        print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length =
		 max (print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier)
		 .maximum_value_length, size);
	        print_vector.dimension (dim_idx).value =
		 rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template);
	     end;
	  else
	     do;
	        dim_idx = dim_idx + 1;
	        dimension_name_ptr = arg_list_ptr -> arg_list.arg_ptrs (arg_idx);
	        dimension_name_length = size;
	        do print_vector.dimension (dim_idx).identifier = 1 to print_vector_array.number_of_dimensions
		 while (print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).name
		 ^= dimension_name);
	        end;
	        if print_vector.dimension (dim_idx).identifier > print_vector_array.number_of_dimensions
	        then call
		      vector_util_$append_dimension_print (work_area_ptr, free_old_print_vector_array, dimension_name,
		      print_vector_array_ptr, null, print_vector.dimension (dim_idx).identifier, p_code);

	        do temp_dim_idx = 1 to dim_idx - 1
		 while (print_vector.dimension (temp_dim_idx).identifier
		 ^= print_vector.dimension (dim_idx).identifier);
	        end;
	        if temp_dim_idx < dim_idx
	        then
		 do;
		    p_code = vd_error_$dim_already_in_vector;
		    return;
		 end;

	     end;
         end;
      else
         do;
	  do dim_idx = dim_idx + 1 to print_vector.number_of_dimensions;
	     print_vector.dimension (dim_idx).value = "";
	     print_vector.dimension (dim_idx).identifier = 0;
	  end;
         end;
      if old_print_vector_ptr ^= null
      then
         do;
	  print_vector_array.vector_slot (vector_slot_idx) = print_vector_ptr;
	  free old_print_vector_ptr -> print_vector in (work_area);
	  old_print_vector_ptr = null;
         end;
      return;

%include vu_print_vector_array;
%page;
%include desc_types;
%page;
%include descriptor;
%page;
%include arg_list;
%page;
%include vu_entry_dcls;
   end vu_append_general_print;




		    vu_append_simple_print.pl1      02/16/84  1306.5r w 02/16/84  1249.9       76131



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_append_simple_print:
append_simple_print_vector:
   proc ();

/* DESCRIPTION:

          This entry appends a print vector to a print vector array.
*/

/* History:

Written by Lindsey Spratt, 02/01/82.
Modified:
08/23/82 by Lindsey Spratt:  Fixed to set the vector_slot when the
	  number_of_vectors  is less than or equal to the number of vector
	  slots.
*/

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

      dcl	    CODE_ARG_IDX	       fixed bin;
      dcl	    PVA_PTR_ARG_IDX	       fixed bin;
      dcl	    dim_idx	       fixed bin;
      dcl	    values_given	       bit (1) aligned init ("0"b);
      dcl	    old_pva_ptr	       ptr;
      dcl	    vector_idx	       fixed bin;
      dcl	    free_old_print_vector_array_ptr
			       ptr;
      dcl	    arg_list_arg_count     fixed bin;
      dcl	    arg_list_ptr	       ptr;
      dcl	    type		       fixed bin;
      dcl	    packed	       bit (1) aligned;
      dcl	    size		       fixed bin;
      dcl	    ndims		       fixed bin;
      dcl	    scale		       fixed bin;
      dcl	    p_code_ptr	       ptr;
      dcl	    nargs		       fixed bin;
      dcl	    arg_idx	       fixed bin;
      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    free_old_print_vector_array
			       bit (1) aligned based (free_old_print_vector_array_ptr);
      dcl	    work_area	       area based (work_area_ptr);
      dcl	    s_fixed_real_template  based fixed bin;
      dcl	    ptr_template	       based ptr;
      dcl	    v_char_template	       based char (size) varying;
      dcl	    char_template	       based char (size);

      dcl	    p_code	       based (p_code_ptr) fixed bin (35);


/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    MYNAME	       init ("vector_util_$init_print_vector_array") char (40) varying internal
			       static options (constant);

      dcl	    (
	    AREA_PTR_ARG_IDX       init (1),
	    SLOT_INCREASE_ARG_IDX  init (2),
	    FREE_OLD_PVA_ARG_IDX   init (3),
	    MAXIMUM_VALUE_LENGTH_ARG_IDX
			       init (4),
	    NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING
			       init (3),
	    PVA_PTR_ARG_OFFSET_FROM_END
			       init (1),
	    NUMBER_OF_NONVALUE_ARGS_AT_END
			       init (2)
	    )		       fixed bin internal static options (constant);


/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    cu_$arg_count	       entry (fixed bin);
      dcl	    sub_err_	       entry () options (variable);

/* External */

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

/* END OF DECLARATIONS */

      call cu_$arg_count (nargs);
      arg_list_arg_count = nargs;
      call cu_$arg_list_ptr (arg_list_ptr);

      CODE_ARG_IDX = nargs;
      PVA_PTR_ARG_IDX = nargs - PVA_PTR_ARG_OFFSET_FROM_END;

      call decode_descriptor_ (arg_list_ptr, CODE_ARG_IDX, type, packed, ndims, size, scale);
      if type ^= s_fixed_real_desc
      then call
	    sub_err_ (error_table_$fatal_error, MYNAME, "s", null, 0,
	    "^/^a was called incorrectly.^/The final argument must be fixed bin(35).", MYNAME);

      p_code_ptr = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARG_IDX);

      call decode_descriptor_ (arg_list_ptr, AREA_PTR_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= pointer_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      work_area_ptr = arg_list_ptr -> arg_list.arg_ptrs (AREA_PTR_ARG_IDX) -> ptr_template;

      call decode_descriptor_ (arg_list_ptr, PVA_PTR_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= pointer_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template;

      call decode_descriptor_ (arg_list_ptr, SLOT_INCREASE_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= s_fixed_real_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;


      pva_number_of_vector_slots =
         print_vector_array.number_of_vector_slots
         + arg_list_ptr -> arg_list.arg_ptrs (SLOT_INCREASE_ARG_IDX) -> s_fixed_real_template;
      call decode_descriptor_ (arg_list_ptr, FREE_OLD_PVA_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= bit_desc | packed | size ^= 1
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      free_old_print_vector_array_ptr = arg_list_ptr -> arg_list.arg_ptrs (FREE_OLD_PVA_ARG_IDX);

      pv_number_of_dimensions = print_vector_array.number_of_dimensions;
      call decode_descriptor_ (arg_list_ptr, MAXIMUM_VALUE_LENGTH_ARG_IDX, type, packed, ndims, size, scale);
      if type = s_fixed_real_desc
      then if ^packed
	 then
	    do;
	       pv_maximum_value_length =
		arg_list_ptr -> arg_list.arg_ptrs (MAXIMUM_VALUE_LENGTH_ARG_IDX) -> s_fixed_real_template;
	       values_given = "0"b;
	    end;
	 else
	    do;
	       p_code = error_table_$bad_arg;
	       return;
	    end;
      else
         do;
	  values_given = "1"b;
	  pv_maximum_value_length = 0;
	  do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END;
	     call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);

	     if type = v_char_desc | type = char_desc
	     then
	        do;
		 pv_maximum_value_length =
		    max (pv_maximum_value_length,
		    length (rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template)));
	        end;
	     else
	        do;
		 p_code = error_table_$bad_arg;
		 return;
	        end;
	  end;
         end;

      alloc print_vector in (work_area);
      print_vector_array.number_of_vectors = print_vector_array.number_of_vectors + 1;
      if print_vector_array.number_of_vectors > print_vector_array.number_of_vector_slots
      then
         do;
	  pva_maximum_dimension_name_length = print_vector_array.maximum_dimension_name_length;
	  pva_number_of_dimensions = print_vector_array.number_of_dimensions;
	  old_pva_ptr = print_vector_array_ptr;
	  alloc print_vector_array in (work_area);
	  print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2;
	  print_vector_array.dimension_table = old_pva_ptr -> print_vector_array.dimension_table;
	  print_vector_array.number_of_vectors = old_pva_ptr -> print_vector_array.number_of_vectors;
						/* This number includes the newly created print_vector. */
	  do vector_idx = 1 to print_vector_array.number_of_vectors - 1;
	     print_vector_array.vector_slot (vector_idx) = old_pva_ptr -> print_vector_array.vector_slot (vector_idx);
	  end;
	  print_vector_array.vector_slot (vector_idx) = print_vector_ptr;
	  if free_old_print_vector_array
	  then free old_pva_ptr -> print_vector_array in (work_area);
         end;
      else print_vector_array.vector_slot (print_vector_array.number_of_vectors) = print_vector_ptr;

      if values_given
      then
         do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONVALUE_ARGS_AT_END;
	  call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);
	  if type = v_char_desc | type = char_desc
	  then print_vector.dimension (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING).value =
		rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template);
	  else
	     do;
	        p_code = error_table_$bad_arg;
	        return;
	     end;
	  print_vector.dimension (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING).identifier =
	     arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING;
         end;
      else
         do dim_idx = 1 to print_vector.number_of_dimensions;
	  print_vector.dimension (dim_idx).value = "";
	  print_vector.dimension (dim_idx).identifier = dim_idx;
         end;

      return;

%include vu_print_vector_array;
%page;
%include desc_types;
%page;
%include descriptor;
%page;
%include arg_list;
   end vu_append_simple_print;




		    vu_cv_pva_to_string.pl1         02/16/84  1306.5r w 02/16/84  1249.9       46341



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_cv_pva_to_string:
   proc (p_print_vector_array_ptr, p_pva_string_ptr, p_pva_string_length, p_code);

/* DESCRIPTION:

         This  entry  takes  a print_vector_array as input and produces a bit
     string as output which is suitable for permanent storage, formatted as  a
     pva_string followed by any number of pv_strings.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 07/24/83.
Modified:
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_print_vector_array_ptr
			       ptr;		/*is a pointer to a
                                             print_vector_array.*/
      dcl	    p_pva_string_ptr       ptr;		/*is a pointer to a buffer in
                                             which the pva_string is to be
                                             placed.*/
      dcl	    p_pva_string_length    fixed bin (35);	/*on input, this is the length in
                                             bytes of the pva_string buffer;
                                             on output, this is the length in
                                             bytes of the pva_string
                                             produced.*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system error
                                             code.*/

/* Automatic */

      dcl	    (pva_string_length_in_words, pva_string_buffer_length_in_words)
			       fixed bin (35) init (0);
      dcl	    (dim_idx, vector_idx)  init (0) fixed bin;

/* Based */
/* Builtin */

      dcl	    (addwordno, currentsize, divide, null)
			       builtin;

/* Constant */

      dcl	    BYTES_PER_WORD	       init (4) fixed bin (35) internal static options (constant);

      dcl	    myname	       init ("vu_cv_pva_to_string") char (32) varying internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

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

/* END OF DECLARATIONS */

      p_code = 0;

      print_vector_array_ptr = p_print_vector_array_ptr;
      call CHECK_VERSION (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array");

      pva_string_ptr = p_pva_string_ptr;
      pva_string.number_of_dimensions = print_vector_array.number_of_dimensions;
      pva_string.maximum_name_length = print_vector_array.maximum_dimension_name_length;

      pva_string_buffer_length_in_words = divide (p_pva_string_length, BYTES_PER_WORD, 35, 0);
      pva_string_length_in_words = currentsize (pva_string);

      if pva_string_length_in_words > pva_string_buffer_length_in_words
      then call
	    sub_err_ (error_table_$fatal_error, myname, ACTION_CANT_RESTART, null, 0,
	    "^/The buffer provided by the caller to hold the pva_string was only ^d words
long, when ^d words are required to hold just the pva_string structure.", pva_string_buffer_length_in_words,
	    pva_string_length_in_words);

      pva_string.version = PVA_STRING_VERSION_1;
      pva_string.number_of_vectors = print_vector_array.number_of_vectors;

      do dim_idx = 1 to print_vector_array.number_of_dimensions;
         pva_string.dimension_table (dim_idx).name = print_vector_array.dimension_table (dim_idx).name;
      end;

      do vector_idx = 1 to print_vector_array.number_of_vectors;

         pv_string_ptr = addwordno (pva_string_ptr, pva_string_length_in_words);
         print_vector_ptr = print_vector_array.vector_slot (vector_idx);

         pv_string.number_of_dimensions = print_vector.number_of_dimensions;
         pv_string.maximum_value_length = print_vector.maximum_value_length;

         do dim_idx = 1 to print_vector.number_of_dimensions;

	  pv_string.dimension (dim_idx).identifier = print_vector.dimension (dim_idx).identifier;
	  pv_string.dimension (dim_idx).value = print_vector.dimension (dim_idx).value;

         end;

         pva_string_length_in_words = pva_string_length_in_words + currentsize (pv_string);

      end;

      p_pva_string_length = BYTES_PER_WORD * pva_string_length_in_words;

      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include vu_pva_string;
%page;
%include vu_print_vector_array;
   end vu_cv_pva_to_string;




		    vu_cv_string_to_pva.pl1         02/16/84  1306.5r w 02/16/84  1249.9       54360



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_cv_string_to_pva:
   proc (p_pva_string_ptr, p_pva_string_length, p_area_ptr, p_print_vector_array_ptr, p_code);

/* DESCRIPTION:

         This    entry    converts   a   pva_string   representation   of   a
     print_vector_array back into a print_vector_array.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 07/24/83.
Modified:
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_pva_string_ptr       ptr;		/*is a pointer to a pva_string.*/
      dcl	    p_pva_string_length    fixed bin (35);	/*is the length of the pva_string
                                             in bytes.*/
      dcl	    p_area_ptr	       ptr;		/*is a pointer to a PL1 area in
                                             which the converted
                                             print_vector_array is to be
                                             placed.*/
      dcl	    p_print_vector_array_ptr
			       ptr;		/*is a pointer to a
                                             print_vector_array which is the
                                             converted version of the
                                             pva_string.*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system error
                                             code.*/

/* Automatic */

      dcl	    (dim_idx, vector_idx)  fixed bin (17) init (0);
      dcl	    current_pva_string_word_offset
			       fixed bin (35) init (0);

/* Based */
/* Builtin */

      dcl	    (addwordno, currentsize, length, max, null)
			       builtin;

/* Constant */

      dcl	    (
	    DEFAULT_SLOT_INCREASE_FACTOR
			       init (0) fixed bin (35),
	    DEFAULT_VECTOR_SLOT_IDX
			       init (-1) fixed bin (35),
	    DONT_FREE_OLD_PVA      init ("0"b) bit (1) aligned,
	    myname	       init ("vu_cv_string_to_pva") char (32) varying
	    )		       internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      pva_string_ptr = p_pva_string_ptr;
      call CHECK_VERSION (pva_string.version, PVA_STRING_VERSION_1, "pva_string");

      call
         vector_util_$init_print_vector_array (p_area_ptr, bin (pva_string.number_of_vectors, 35, 0),
         bin (pva_string.number_of_dimensions, 35, 0), bin (pva_string.maximum_name_length, 35, 0),
         print_vector_array_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION_FB (print_vector_array.version, PRINT_VECTOR_ARRAY_VERSION_2, "print_vector_array");

      print_vector_array.number_of_vectors = 0;		/* This value is incremented by $append_general_print_vector */

      do dim_idx = 1 to pva_string.number_of_dimensions;
         print_vector_array.dimension_table (dim_idx).name = pva_string.dimension_table (dim_idx).name;
         print_vector_array.dimension_table (dim_idx).maximum_value_length = 0;
      end;

      current_pva_string_word_offset = currentsize (pva_string);

      do vector_idx = 1 to pva_string.number_of_vectors;

         pv_string_ptr = addwordno (pva_string_ptr, current_pva_string_word_offset);

         call
	  vector_util_$append_general_print_vector (p_area_ptr, DEFAULT_SLOT_INCREASE_FACTOR, DONT_FREE_OLD_PVA,
	  DEFAULT_VECTOR_SLOT_IDX, bin (pv_string.number_of_dimensions, 35, 0),
	  bin (pv_string.maximum_value_length, 35, 0), print_vector_array_ptr, p_code);
         if p_code ^= 0
         then call ERROR_RETURN ();

         print_vector_ptr = print_vector_array.vector_slot (print_vector_array.number_of_vectors);

         do dim_idx = 1 to pv_string.number_of_dimensions;
	  print_vector.dimension (dim_idx).identifier = pv_string.dimension (dim_idx).identifier;
	  print_vector.dimension (dim_idx).value = pv_string.dimension (dim_idx).value;
	  print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length =
	     max (print_vector_array.dimension_table (print_vector.dimension (dim_idx).identifier).maximum_value_length,
	     length (print_vector.dimension (dim_idx).value));
         end;

         current_pva_string_word_offset = current_pva_string_word_offset + currentsize (pv_string);

      end;

      p_print_vector_array_ptr = print_vector_array_ptr;

MAIN_RETURN:
      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (*);
      dcl	    p_expected_version     char (*);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_FB:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION_FB;
%page;
ERROR_RETURN:
   proc;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
%include sub_err_flags;
%page;
%include vu_print_vector_array;
%page;
%include vu_pva_string;
%page;
%include vu_entry_dcls;
   end vu_cv_string_to_pva;





		    vu_err_no_operation.pl1         02/16/84  1306.5r w 02/16/84  1249.9        7362



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_err_no_operation:
err_no_operation:
   proc (p1_ptr, p2_fb17, p3_fb17, p4_ptr, p5_ptr, p_code);
      dcl	    p1_ptr	       ptr;
      dcl	    p2_fb17	       fixed bin (17);
      dcl	    p3_fb17	       fixed bin (17);
      dcl	    p4_ptr	       ptr;
      dcl	    p5_ptr	       ptr;
      dcl	    p_code	       fixed bin (35);

      dcl	    error_table_$no_operation
			       ext fixed bin (35);

      p_code = error_table_$no_operation;
   end vu_err_no_operation;




		    vu_init_print_vector_array.pl1  02/16/84  1306.5r w 02/16/84  1249.9       65268



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_init_print_vector_array:
init_print_vector_array:
   proc ();

/* Written by Lindsey Spratt.
Modified:
03/09/82 by Lindsey Spratt:  Changed to use named constants for the position
	  of the arguments.  Added another calling sequence.
*/
/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

      dcl	    names_given	       bit (1) aligned init ("0"b);
      dcl	    arg_list_arg_count     fixed bin;
      dcl	    arg_list_ptr	       ptr;
      dcl	    type		       fixed bin;
      dcl	    packed	       bit (1) aligned;
      dcl	    size		       fixed bin;
      dcl	    ndims		       fixed bin;
      dcl	    scale		       fixed bin;
      dcl	    CODE_ARG_IDX	       fixed bin;
      dcl	    PVA_PTR_ARG_IDX	       fixed bin;
      dcl	    p_code_ptr	       ptr;
      dcl	    nargs		       fixed bin;
      dcl	    arg_idx	       fixed bin;
      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    work_area	       area based (work_area_ptr);
      dcl	    s_fixed_real_template  based fixed bin;
      dcl	    ptr_template	       based ptr;
      dcl	    v_char_template	       based char (size) varying;
      dcl	    char_template	       based char (size);

      dcl	    p_code	       based (p_code_ptr) fixed bin (35);


/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    MYNAME	       init ("vector_util_$init_print_vector_array") char (40) varying internal
			       static options (constant);
      dcl	    (
	    AREA_PTR_ARG_IDX       init (1),
	    NUMBER_OF_SLOTS_ARG_IDX
			       init (2),
	    NUMBER_OF_NONNAME_ARGS_AT_BEGINNING
			       init (2),
	    PVA_PTR_ARG_OFFSET_FROM_END
			       init (1),
	    NUMBER_OF_NONNAME_ARGS_AT_END
			       init (2),
	    NUMBER_OF_DIMENSIONS_ARG_IDX
			       init (3),
	    MAX_DIM_NAME_LEN_ARG_IDX
			       init (4)
	    )		       fixed bin (17) internal static options (constant);

/* Entry */

      dcl	    vector_util_$err_no_operation
			       entry (ptr, fixed bin (17), fixed bin (17), ptr, ptr, fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    cu_$arg_count	       entry (fixed bin);
      dcl	    sub_err_	       entry () options (variable);

/* External */

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

/* END OF DECLARATIONS */

      call cu_$arg_count (nargs);
      arg_list_arg_count = nargs;
      call cu_$arg_list_ptr (arg_list_ptr);
      CODE_ARG_IDX = nargs;
      PVA_PTR_ARG_IDX = nargs - PVA_PTR_ARG_OFFSET_FROM_END;

      call decode_descriptor_ (arg_list_ptr, CODE_ARG_IDX, type, packed, ndims, size, scale);
      if type ^= s_fixed_real_desc
      then call
	    sub_err_ (error_table_$fatal_error, MYNAME, "s", null, 0,
	    "^/^a was called incorrectly.^/The final argument must be fixed bin(35).", MYNAME);

      p_code_ptr = arg_list_ptr -> arg_list.arg_ptrs (CODE_ARG_IDX);
      p_code = 0;

      call decode_descriptor_ (arg_list_ptr, AREA_PTR_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= pointer_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      work_area_ptr = arg_list_ptr -> arg_list.arg_ptrs (AREA_PTR_ARG_IDX) -> ptr_template;

      call decode_descriptor_ (arg_list_ptr, NUMBER_OF_SLOTS_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= s_fixed_real_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;
      pva_number_of_vector_slots = arg_list_ptr -> arg_list.arg_ptrs (NUMBER_OF_SLOTS_ARG_IDX) -> s_fixed_real_template;

      call decode_descriptor_ (arg_list_ptr, PVA_PTR_ARG_IDX, type, packed, ndims, size, scale);

      if type ^= pointer_desc
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

/* All of the arguments except for the vd_info_ptr, 
the max_splitter_len, the return pointer to the input_vector that is defined,
and the final "code" argument, are dimension names.*/

      call decode_descriptor_ (arg_list_ptr, NUMBER_OF_DIMENSIONS_ARG_IDX, type, packed, ndims, size, scale);
      if type = s_fixed_real_desc
      then
         do;
	  pva_number_of_dimensions =
	     arg_list_ptr -> arg_list.arg_ptrs (NUMBER_OF_DIMENSIONS_ARG_IDX) -> s_fixed_real_template;
	  names_given = "0"b;
	  call decode_descriptor_ (arg_list_ptr, MAX_DIM_NAME_LEN_ARG_IDX, type, packed, ndims, size, scale);
	  if type ^= s_fixed_real_desc
	  then
	     do;
	        p_code = error_table_$bad_arg;
	        return;
	     end;
	  pva_maximum_dimension_name_length =
	     arg_list_ptr -> arg_list.arg_ptrs (MAX_DIM_NAME_LEN_ARG_IDX) -> s_fixed_real_template;
         end;
      else
         do;
	  names_given = "1"b;
	  pva_number_of_dimensions = nargs - (NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + NUMBER_OF_NONNAME_ARGS_AT_END);

	  pva_maximum_dimension_name_length = 0;
	  do arg_idx = NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONNAME_ARGS_AT_END;
	     call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);

	     if type = v_char_desc | type = char_desc
	     then
	        do;
		 pva_maximum_dimension_name_length =
		    max (pva_maximum_dimension_name_length,
		    length (rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template)));
	        end;
	     else
	        do;
		 p_code = error_table_$bad_arg;
		 return;
	        end;
	  end;
         end;

      alloc print_vector_array in (work_area);
      print_vector_array.version = PRINT_VECTOR_ARRAY_VERSION_2;
      print_vector_array.number_of_vectors = 0;
      print_vector_array.dimension_table.descriptor_ptr = null;
      print_vector_array.dimension_table.cv_to_print = vector_util_$err_no_operation;
      print_vector_array.dimension_table.cv_to_typed = vector_util_$err_no_operation;
      print_vector_array.dimension_table.maximum_value_length = 0;
      if names_given
      then
         do arg_idx = NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONNAME_ARGS_AT_END;
	  call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);
	  if type = v_char_desc | type = char_desc
	  then print_vector_array.dimension_table (arg_idx - NUMBER_OF_NONNAME_ARGS_AT_BEGINNING).name =
		rtrim (arg_list_ptr -> arg_list.arg_ptrs (arg_idx) -> char_template);
	  else
	     do;
	        p_code = error_table_$bad_arg;
	        return;
	     end;
         end;
      else print_vector_array.dimension_table.name = "";

      arg_list_ptr -> arg_list.arg_ptrs (PVA_PTR_ARG_IDX) -> ptr_template = print_vector_array_ptr;
      return;

%include vu_print_vector_array;
%page;
%include desc_types;
%page;
%include descriptor;
%page;
%include arg_list;
   end vu_init_print_vector_array;




		    vu_replace_print_value.pl1      02/16/84  1306.5r w 02/16/84  1249.9       45513



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vu_replace_print_value:
replace_print_value:
   proc (p_print_vector_array_ptr, p_print_vector_index, p_area_ptr, p_dimension_name, p_dimension_value, p_code);

/* DESCRIPTION:

         This  subroutine  replaces  the  value of a specified dimension in a
     print vector.
*/

/* HISTORY:

Written by S. Krupp, 06/07/83.
Modified:
*/

/* START OF DECLARATIONS */

/* Automatic */

      dcl	    i		       fixed bin;
      dcl	    old_pv_ptr	       ptr;
      dcl	    value_length	       fixed bin;

/* Based */

      dcl	    based_area	       area based (p_area_ptr);

      dcl	    1 old_pv	       based (old_pv_ptr),	/* like print_vector */
	      2 number_of_dimensions
			       fixed bin (17),
	      2 maximum_value_length
			       fixed bin (35),
	      2 dimension	       (0 refer (old_pv.number_of_dimensions)),
	        3 identifier       fixed bin (17),
	        3 value	       char (0 refer (old_pv.maximum_value_length)) varying;

/* Builtin */

      dcl	    (hbound, lbound, length, null)
			       builtin;

/* Constant */

      dcl	    myname	       init ("vu_replace_print_value") char (32) varying internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    (
	    vd_error_$bad_print_vector_index,
	    vd_error_$dim_not_in_vector
	    )		       fixed bin (35) ext;

/* Parameter */

      dcl	    p_print_vector_array_ptr
			       ptr;		/*is a pointer to a
                                             print_vector_array.*/
      dcl	    p_print_vector_index   fixed bin;		/*is the index of the
                                             print_vector in the
                                             print_vector_array that holds the
                                             dimension whose value is to be
                                             replaced.*/
      dcl	    p_area_ptr	       ptr;		/*is a pointer to an area where
                                             the print_vector may be
                                             reallocated if necessary.*/
      dcl	    p_dimension_name       char (*);		/*is the name of the dimension
                                             whose value is to be replaced.*/
      dcl	    p_dimension_value      char (*);		/*is the new value of the
                                             specified dimension.*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system status
                                             code.*/

/* END OF DECLARATIONS */


      p_code = 0;

      print_vector_array_ptr = p_print_vector_array_ptr;

      call CHECK_VERSION ((print_vector_array.version), (PRINT_VECTOR_ARRAY_VERSION_2), "print_vector_array");

      if p_print_vector_index < lbound (print_vector_array.vector_slot, 1)
         | p_print_vector_index > hbound (print_vector_array.vector_slot, 1)
      then
         do;
	  p_code = vd_error_$bad_print_vector_index;
	  return;
         end;

      print_vector_ptr = print_vector_array.vector_slot (p_print_vector_index);

      do i = 1 to print_vector.number_of_dimensions
         while (print_vector_array.dimension_table (print_vector.dimension (i).identifier).name ^= p_dimension_name);
      end;

      if i > print_vector.number_of_dimensions
      then
         do;
	  p_code = vd_error_$dim_not_in_vector;
	  return;
         end;

      value_length = length (p_dimension_value);

      if value_length > print_vector.maximum_value_length
      then
         do;
	  pv_maximum_value_length = value_length;
	  pv_number_of_dimensions = print_vector.number_of_dimensions;
	  old_pv_ptr = print_vector_ptr;
	  allocate print_vector in (based_area) set (print_vector_ptr);
	  print_vector.dimension = old_pv.dimension;
	  print_vector_array.vector_slot (p_print_vector_index) = print_vector_ptr;
	  free old_pv_ptr -> print_vector;
         end;

      print_vector.dimension (i).value = p_dimension_value;

      return;

%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include vu_print_vector_array;

   end vu_replace_print_value;






		    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
