



		    canonicalize.pl1                04/25/90  1435.4rew 04/12/90  1653.5      800667



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


/****^  HISTORY COMMENTS:
  1) change(71-01-01,VanVleck), approve(), audit(), install():
      Written by THVV, date unknown (above date is made up).
  2) change(71-01-01,Vinograd), approve(), audit(), install():
      Modified by D. Vinograd to add subroutine entry (date unknown).
  3) change(78-11-01,Spector), approve(), audit(), install():
      Modified by David Spector:
      1. Bug which could cause a fatal process error fixed.
      2. Subroutine entry made to call clean_up when done.
      3. Bug in which final lines not terminated by NL, VT, or FF were deleted
         fixed.
      4. Bug in which final lines consisting only of NL, VT, or FF ("null
         lines") were deleted fixed.
      5. Command made to check for error when setting bit count of the output
         segment.
      6. Truncation of output segment now done in right place and with right
         count.
      7. Precision of several char length calculations corrected to 21 bits.
      8. Command made to check for write access to output segment.
      9. Bug in which allocated "bead" not freed upon certain errors fixed.
      10. Command made to use expand_pathname_ instead of expand_path_.
  4) change(80-03-26,Herbst), approve(), audit(), install():
      Modified by S. Herbst to leave zero-length seg alone.
  5) change(81-04-01,Wallman), approve(), audit(), install():
      Modified by E. Wallman to enforce range of printing chars.
  6) change(84-01-01,Lippard), approve(85-12-30,MCR7322),
     audit(86-01-15,KFleming), install(86-01-20,MR12.0-1006):
      Modified by Jim Lippard to:
      1. allow input tab length specification
      2. refuse to canonicalize object segments and archives
      3. not delete nonprinting characters
      4. terminate zero-length segments
      5. query if input segment is to be overwritten
      6. add the name "-ev" to "-every"
      7. optimize processing of non-overstruck data (speedup from
         Calgary's modified canonicalize by Tom Oke)
  7) change(86-02-11,Lippard), approve(86-02-11,PBF7322),
     audit(86-02-11,Dickson), install(86-02-17,MR12.0-1018):
      Modified to determine if a character is a nonprinting character
      correctly.
  8) change(86-03-06,Lippard), approve(86-03-14,MCR7371),
     audit(86-04-22,Dickson), install(86-04-22,MR12.0-1042):
      Modified to calculate the increment of col correctly.
  9) change(86-08-21,Lippard), approve(86-09-08,MCR7537),
     audit(86-09-30,Dickson), install(86-10-07,MR12.0-1178):
      Modified to properly strip white space off the ends of lines which
      contain no other characters.
 10) change(88-05-26,TLNguyen), approve(88-05-26,MCR7879),
     audit(88-10-04,RBarstad), install(90-04-12,MR12.4-1004):
     SCP6348: allow MSF in canon.
 11) change(90-03-02,LZimmerman), approve(90-03-02,MCR8158),
     audit(90-03-07,Kallstrom), install(90-04-12,MR12.4-1004):
     Correct unwarranted termination of input segment. (canonicalize_,
     canonicalize_tabs_)
                                                   END HISTORY COMMENTS */

/* format: style4 */

canonicalize:
canon:
     proc;

/* CANONICALIZE - fix file up to be canonical form. take out tabs too. (option to put in again) */

/* Syntax as a command: canon path1 {path2} {-control_args}             */


/* automatic variables */
dcl  Access_ptr ptr;				/* access pointer */
						/* the structure defined below is needed for both special cases: */
						/* SSF canonicalize MSF (expanded); MSF canonicalize SSF (shrunk) */
						/* Warning: the access structure defined below must be the same as */
						/* the access structure defined in the access_.pl1 program */
						/* access.set can be:  0 = NO, 1 = ACL_ADDED, or 2 = ACL_REPLACED */
						/* access.type can be SEGMENT, DIRECTORY, or MSF */
						/* access.old_mode to be reset when ACL_REPLACED */
						/* directory path whose access was changed */
						/* entryname whose access was changed */
dcl  1 Access aligned based (Access_ptr),
       2 version char (8),
       2 set fixed bin,
       2 type fixed bin (2),
       2 old_mode bit (36),
       2 dir char (168) unaligned,
       2 ent char char (32) unaligned;

dcl  Arg_len fixed bin;				/* length of an input argument */
dcl  Arg_numb fixed bin;				/* counter */
dcl  Arg_ptr ptr;					/* pointer to an input argument. */
dcl  Arg_count fixed bin;				/* counter */

dcl  Area_ptr ptr;
dcl  Bead_ptr ptr;
dcl  Bead_storage (1024) fixed bin;
dcl  Bead_storage_size fixed bin;
dcl  Beg_line fixed bin (21);				/* location of the beginning of the next line */
dcl  Bitc fixed bin (24);				/* bit count of an input segment */
dcl  Cantab_flag bit (1) aligned;
dcl  Chars_in_line fixed bin (21);			/* counter */
dcl  Chars_to_remove fixed bin (21);			/* counter */
dcl  Charx fixed bin;				/* counter */
dcl  Col fixed bin;					/* column position in input scan */
dcl  Create_temp_msf_flag bit (1) aligned;
dcl  Desired_access bit (36);
dcl  Dn char (168);					/* directory name of an input segment. */
dcl  Do_not_create_temp_msf_flag bit (1) aligned;
dcl  Ec fixed bin (35);				/* error code */
dcl  En char (32);					/* entryname of an input segment */
dcl  Eof_flag bit (1) aligned;			/* set when end of file of an input segment reaches. */
dcl  Eqln char (32);				/* equal entryname of an output segment.  Got from calling expand_pathname_, given an output segment pathname. */
dcl  Everytab fixed bin;
dcl  Fs_util_type char (32);				/* determine the type of a specified entry */
dcl  Have_infile_flag bit (1) aligned;			/* set if an input segment is specified */
dcl  Have_outfile_flag bit (1) aligned;			/* set if an output segment is specified */
dcl  Ii fixed bin (21);				/* counter */
dcl  In_everytab fixed bin;
dcl  In_nstops fixed bin;
dcl  In_msf_comp_bitc fixed bin (24);			/* bit count of a component of an input MSF */
						/* the number of components in an input MSF */
dcl  In_msf_total_original_comps fixed bin (24);
dcl  Input_msf_comp_index fixed bin;			/* the number of components in an input MSF */
dcl  Input_msf_comp_ptr ptr;				/* pointer to a component of an input msf */
dcl  Input_msf_fcb_ptr ptr;				/* pointer to the FCB for an input MSF */
dcl  In_stops (40) fixed bin;
dcl  In_stopx fixed bin;
dcl  Jj fixed bin (21);				/* counter */
dcl  Kk fixed bin (21);				/* counter */
dcl  Lth fixed bin (21);				/* line length */
dcl  Mm fixed bin;					/* counter */
dcl  Nch fixed bin (21);				/* population of Beads */
dcl  Next_pos fixed bin;				/* number of positions output */
dcl  Nonexistent_outfile_flag bit (1) aligned;
dcl  Nstops fixed bin;
dcl  Obuf_ptr ptr;					/* ptr to output buffer temp */
dcl  Out_seg_ptr ptr;				/* ptr to an Outc segment. */
dcl  Outc_ptr ptr;					/* ptr to Outc which holds a line of canonical characters */
dcl  Out_dname char (168);				/* a directory name contains a specified Outc file (path2) */
dcl  Out_ename char (32);				/*  an entryname of a specified Outc file (path2) */
dcl  Outc_len fixed bin (21);				/* the length of Outc which holds a line of canonical chars */
dcl  Output_segment_length_in_words fixed bin (19);
dcl  Overwrite_exist_path_flag bit (1);
dcl  Ox fixed bin (21);				/* output line index */
dcl  Spaces_to_go fixed bin;				/* counter */
dcl  Second_temp_seg_ptr ptr;
dcl  Specified_infile_type fixed bin (2);
dcl  Specified_temp_file_flag bit (1) aligned;		/* set when -temp_file PATH is specified */
dcl  Seg_ptr ptr;					/* ptr to an input segment. */
dcl  Stops (40) fixed bin;
dcl  Stopx fixed bin;				/* counter */
dcl  Subroutine_call_flag bit (1) aligned;
dcl  Tab_flag bit (1) aligned;			/* set if insert tabs. */
dcl  Target_tabstop fixed bin;
dcl  Temp_msf_comp_bitc fixed bin (24);			/* bit count of an component of an output MSF */
dcl  Temp_msf_fcb_ptr ptr;				/* pointer to the FCB for an output MSF */
dcl  Temp_ptr ptr;
dcl  Temp_dn char (168);				/* directory name contains a temp file */
dcl  Temp_en char (32);				/* temp file */
dcl  Temp_seg_len fixed bin (21);			/* the length of a temp seg */
dcl  Temp_seg_len_in_chars fixed bin (21);		/* the length of a temp seg in characters */
dcl  Temp_seg_ptr ptr;				/* points to a temp seg */
dcl  Temp_msf_total_components fixed bin (24);		/* the number of components in a temp MSF */
dcl  Temp_msf_comp_index fixed bin;
dcl  Temp_msf_comp_ptr ptr;				/* pointer to an component of an output MSF. */
dcl  This_tabstop fixed bin;

/* based */

dcl  Arg char (Arg_len) based (Arg_ptr);		/* temp storage for for each input argument on the command line. */

dcl  Bcs char (Lth) based (Seg_ptr) aligned;		/* holds the contents of the input file in NONcanonical form */

/* Temp storage for a char string in line. It has a char position and char value fields */
dcl  1 Bead (Bead_storage_size) based (Bead_ptr) aligned,
       2 loc fixed bin (26) unal,
       2 char char (1) unal;

dcl  Obuf char (512) based (Obuf_ptr);			/* holds up to 512 chars of path1 in NONcanonical form */
						/* temporary segment holds the contents of path1 in CANONICAL form */

dcl  Outc char (Outc_len) based (Outc_ptr);		/* holds the contents of one line of characters in CANONICAL form */

dcl  Second_temp_seg char (Temp_seg_len_in_chars) based (Second_temp_seg_ptr);

dcl  Temp_seg char (Temp_seg_len_in_chars) based (Temp_seg_ptr);

dcl  System_area area based (Area_ptr);

dcl  Word_array (Output_segment_length_in_words) bit (36) based;
						/* an array of an output segment in words. */

/* builtin */
dcl  (
     addr,
     copy,
     divide,
     hbound,
     index,
     max,
     min,
     null,
     rank,
     reverse,
     rtrim,
     search,
     substr,
     unspec,
     verify
     ) builtin;

/* condition */
dcl  (cleanup, record_quota_overflow) condition;

/* external entries */
dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  access_$reset entry (ptr, fixed bin (35));
dcl  access_$set_temporarily entry (char (*), char (*), fixed bin (2), bit (*), ptr, fixed bin (35));
dcl  active_fnc_err_ entry options (variable);
dcl  archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  com_err_$suppress_name entry options (variable);
dcl  command_query_$yes_no entry () options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  dm_error_$file_in_use fixed bin (35) external;
dcl  (
     error_table_$active_function,
     error_table_$archive_pathname,
     error_table_$bad_arg,
     error_table_$badopt,
     error_table_$dirseg,
     error_table_$empty_file,
     error_table_$rqover,
     error_table_$noarg,
     error_table_$noentry,
     error_table_$no_m_permission,
     error_table_$no_r_permission,
     error_table_$no_w_permission,
     error_table_$not_seg_type,
     error_table_$zero_length_seg
     ) fixed bin (35) external;

dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_group_id_ entry returns (char (32) aligned);
dcl  get_pdir_ entry returns (char (168));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
dcl  msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35));
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

/* like attribute */
dcl  1 oi aligned like object_info;

/* static constants */
dcl  ACL_REPLACED fixed bin (2) int static options (constant) init (2);

dcl  HT char (1) int static options (constant) init ("	");
dcl  NLVTFF char (3) int static options (constant) init ("
");
dcl  SP char (1) int static options (constant) init (" ");
dcl  BS char (1) int static options (constant) init ("");
dcl  CR char (1) int static options (constant) init ("");
dcl  SPBSCRHT char (4) int static options (constant) init (" 	");
dcl  HTSP char (2) int static options (constant) init ("	 ");
dcl  BSCR char (2) int static options (constant) init ("");

dcl  COMPONENT_ZERO fixed bin int static options (constant) init (0);

dcl  DIRECTORY fixed bin (2) int static options (constant) init (2);
dcl  MSF fixed bin (2) int static options (constant) init (3);
dcl  SEGMENT fixed bin (2) int static options (constant) init (1);

dcl  FALSE bit (1) int static options (constant) init ("0"b);
dcl  TRUE bit (1) int static options (constant) init ("1"b);

dcl  PRECISION_FIXED_BIN_17 fixed bin int static options (constant) init (17);
dcl  PRECISION_FIXED_BIN_19 fixed bin int static options (constant) init (19);
dcl  PRECISION_FIXED_BIN_21 fixed bin int static options (constant) init (21);

dcl  SWITCHES bit (6) int static options (constant) init ("100111"b);
dcl  THREE_BIT_SWITCH bit (3) int static options (constant) init ("111"b);

dcl  ME char (12) int static options (constant) init ("canonicalize");

/* -------------------------------------------------------------------------- */
%page;
/* begin canonicalize main program */

	call initialization;

	call parsing_input_arguments;
	if Ec ^= 0 then return;

	if ^Have_infile_flag then do;			/* forget path1 */
	     call com_err_$suppress_name ((0), ME, "Usage: ^a path1 {path2} {-control_args}", ME);
	     return;
	end;
						/* prepare access values for later reference */
	if ^Have_outfile_flag then
	     Desired_access = RW_ACCESS;		/* when wanted to overwrite the original input file (segment or MSF) */
	else Desired_access = R_ACCESS;		/* otherwise, only "read" access is needed */

	on cleanup begin;
	     call clean_up;
	     call term_segs;
	end;
	

/* mainly proceeds canonicalization of an input file whose type is either a Segment or a Multisegment_file */
	call get_temp_segment_ (ME, Outc_ptr, Ec);	/* points to a temp storage Outc which holds one line of canincal chars */
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "Cannot get temp segment.");
	     return;
	end;

	if ^Specified_temp_file_flag then do;		/* by default, create a temp seg in the process directory */
						/* points to a temp storage Temp_seg which holds a segment size of canonical chars */
	     call get_temp_segment_ (ME, Temp_seg_ptr, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME, "Cannot get temp segment.");
		return;
	     end;
	end;
	else do;					/* -temp_file PATH was specified */
	     call hcs_$make_seg (Temp_dn, Temp_en, "", RW_ACCESS_BIN, Temp_seg_ptr, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME, "^a", pathname_ (Temp_dn, Temp_en));
		return;
	     end;
	end;

/* determine the entry type of an input file path1 and its length in bits */
	call hcs_$status_minf (Dn, En, 1, Specified_infile_type, Bitc, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
	     call release_temp_segment_ (ME, Outc_ptr, (0));
	     call release_temp_segment_ (ME, Temp_seg_ptr, (0));
	     return;
	end;

	if Specified_infile_type = SEGMENT then
	     call canon_segment;

	else if Specified_infile_type = DIRECTORY then
	     call canon_msf;

	else do;
	     call com_err_ (error_table_$not_seg_type, ME, "^a", pathname_ (Dn, En));
	     call release_temp_segment_ (ME, Outc_ptr, (0));
	     call release_temp_segment_ (ME, Temp_seg_ptr, (0));
	     return;
	end;

	call clean_up;
	call term_segs;


	return;					/* complete canonicalize main program */

/* --------------------------------------------------------------------------- */
%page;
parsing_input_arguments: proc;

/* evaluate each input argument specified on the command level.              */

/* begin parsing_input_arguments procedure */

	Ec = 0;

	call cu_$arg_count (Arg_count, Ec);
	if Ec ^= 0 then do;
	     if Ec = error_table_$active_function then call active_fnc_err_ (Ec, ME);
	     else call com_err_ (Ec, ME);
	     return;
	end;

	do Arg_numb = 1 to Arg_count;
	     call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME);
		return;
	     end;

	     if index (Arg, "-") = 1 then do;
		if Arg = "-output_tabs" | Arg = "-otabs" then do;
		     Tab_flag = TRUE;

		     Arg_numb = Arg_numb + 1;
		     if Arg_numb > Arg_count then do;
			Ec = error_table_$noarg;
			call com_err_ (Ec, ME);
			return;
		     end;

		     call continue_parsing_arguments;
		     if Ec ^= 0 then return;
		end;
		else if Arg = "-no_output_tabs" | Arg = "-notabs" then Tab_flag = FALSE;
		else if Arg = "-input_tabs" | Arg = "-itabs" then do;
		     Arg_numb = Arg_numb + 1;
		     if Arg_numb > Arg_count then do;
			Ec = error_table_$noarg;
			call com_err_ (Ec, ME);
			return;
		     end;

		     call continue_parsing_arguments;
		     if Ec ^= 0 then return;
		end;
		else if Arg = "-force" | Arg = "-fc" then Overwrite_exist_path_flag = TRUE;
		else if Arg = "-no_force" | Arg = "-nfc" then Overwrite_exist_path_flag = FALSE;
		else if Arg = "-temp_file" | Arg = "-tf" then do;
		     Specified_temp_file_flag = TRUE;

		     if Arg_numb = Arg_count then do;	/* -temp_file */
			Ec = -1;
			call com_err_ (0, ME, "Missing PATH argument for ^a.", Arg);
			return;
		     end;
		     else do;			/* -temp_file PATH */
			Arg_numb = Arg_numb + 1;
			call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
			if Ec ^= 0 then do;
			     call com_err_ (Ec, ME, "Cannot get PATH argument for -temp_file.");
			     return;
			end;

			if index (Arg, "-") = 1 then do;
						/* -temp_file -bad_input_argument */
			     Ec = error_table_$badopt;
			     call com_err_ (Ec, ME, "^a.  Missing PATH argument for -temp_file.", Arg);
			     return;
			end;

			call expand_pathname_ (Arg, Temp_dn, Temp_en, Ec);
			if Ec ^= 0 then do;
			     call com_err_ (Ec, ME, "Cannot expand the given PATH argument ^a for -temp_file.", Arg);
			     return;
			end;
						/* since  the equal convention is allowed to specify a temp file similar to the input file */
			call get_equal_name_ (En, Temp_en, Temp_en, Ec);

			if Ec ^= 0 then do;
			     call com_err_ (Ec, ME, "Cannot get an equal name similar to the original input file name ^a", pathname_ (Dn, En));
			     return;
			end;
		     end;
		end;
		else do;
		     Ec = error_table_$badopt;
		     call com_err_ (Ec, ME, "^a", Arg);
		     return;
		end;
	     end;
	     else if ^Have_infile_flag then do;
		call expand_pathname_ (Arg, Dn, En, Ec);
		if Ec ^= 0 then do;
		     call com_err_ (Ec, ME, "Cannot expand the given input path1 ^a", Arg);
		     return;
		end;
		Have_infile_flag = TRUE;
	     end;
	     else if ^Have_outfile_flag then do;
		Have_outfile_flag = TRUE;
		call expand_pathname_ (Arg, Out_dname, Eqln, Ec);
		if Ec ^= 0 then do;			/* name for output seg */
		     call com_err_ (Ec, ME, "Cannot expand the specified output path2 ^a", Arg);
		     return;
		end;

		call get_equal_name_ (En, Eqln, Out_ename, Ec);
		if Ec ^= 0 then do;
		     call com_err_ (Ec, ME, "Cannot get an equal name similar to the original file name ^a", pathname_ (Dn, En));
		     return;
		end;
	     end;
	     else do;
		Ec = error_table_$bad_arg;
		call com_err_$suppress_name (Ec, ME, "Usage: ^a path1 {path2} {-control_args}", ME);
		return;
	     end;
	end;

	return;					/* return from parsing_input_arguments procedure to canonicalize main program */

/* --------------------------------------------------------------------------- */
%page;
continue_parsing_arguments: proc;

	     call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME, "^a", Arg);
		return;
	     end;

	     if Arg = "-every" | Arg = "-ev" then do;
		Arg_numb = Arg_numb + 1;
		if Arg_numb > Arg_count then do;
		     Ec = error_table_$noarg;
		     call com_err_ (Ec, ME, "Missing value for ^a", Arg);
		     return;
		end;

		call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec);
		if Ec ^= 0 then do;
		     call com_err_ (Ec, ME);
		     return;
		end;

		if Tab_flag then Everytab = cv_dec_check_ (Arg, Ec);
		else In_everytab = cv_dec_check_ (Arg, Ec);

		if Ec ^= 0 then do;
		     Ec = error_table_$bad_arg;
		     call com_err_ (Ec, ME, "^a", Arg);
		     return;
		end;
	     end;
	     else do;
		if Tab_flag then call grab_tabs (Stops, Nstops);
		else call grab_tabs (In_stops, In_nstops);

		if Ec ^= 0 then return;
	     end;

	     return;				/* return to parsing_input_arguments procedure */

	end continue_parsing_arguments;

/* --------------------------------------------------------------------------- */
%page;
grab_tabs: proc (p_stops, p_nstop);


dcl  p_nstop fixed bin,				/* number of stops set */
     p_stops (*) fixed bin;				/* array of set tab stops */

/* begin grab_tabs procedure */

	     Ec = 0;
	     Kk = 1;
	     do while (Kk < Arg_len);
		Jj = index (substr (Arg, Kk), ",");
		if Jj = 0 then Jj = Arg_len - Kk + 2;

		Mm = cv_dec_check_ (substr (Arg, Kk, Jj - 1), Ec);
		if Ec ^= 0 then do;
		     Ec = error_table_$bad_arg;
		     call com_err_ (Ec, ME, "^a", substr (Arg, Kk, Jj - 1));
		     return;
		end;

		p_nstop = p_nstop + 1;
		if p_nstop > hbound (p_stops, 1) - 1 then do;
		     Ec = -1;			/* indicates error */
		     call com_err_ (0, ME, "Too many ^[output^;input^] tabstops: ^d - max is ^d", Tab_flag, Mm, hbound (p_stops, 1) - 1);
		     return;			/* we blew it */
		end;

		p_stops (p_nstop) = Mm;
		Kk = Kk + Jj;
	     end;

	     return;				/* return to parsing_input_arguments. */

	end grab_tabs;

/* --------------------------------------------------------------------------- */
%page;
     end parsing_input_arguments;

/* --------------------------------------------------------------------------- */
%page;
canonicalize_tabs_:
     entry (p_input_ptr, p_input_len, p_output_ptr, p_output_len, p_tab_flag, p_code);

dcl  p_tab_flag bit (1);				/* input parameter */

/* begin canonicalize_tabs_ external entry */

	call initialization;

	Tab_flag = p_tab_flag;
	if Tab_flag then Everytab = 10;

	goto NON_MSF_COMMON;

/* ----------------------------------------------------------------------- */

canonicalize_:
     entry (p_input_ptr, p_input_len, p_output_ptr, p_output_len, p_code);

dcl  p_code fixed bin (35);
dcl  p_input_ptr ptr;
dcl  p_input_len fixed bin (21);
dcl  p_output_ptr ptr;
dcl  p_output_len fixed bin (21);

/* begin canonicalize_ entry */

	call initialization;

NON_MSF_COMMON:
	p_code = 0;
						/* prepare canonicalization of the given input file whose type is segment */
	Seg_ptr = p_input_ptr;
	Lth = p_input_len;

	if Lth = 0 then do;				/* the given input file is empty */
	     p_code = error_table_$zero_length_seg;
	     return;
	end;

	on cleanup call clean_up;

	call get_temp_segment_ (ME, Outc_ptr, p_code);	/* each line of the input file is canonicalized and then a line of */
						/* canonical characters are stored in a temp segment pointed by Outc_ptr pointer */
	if p_code ^= 0 then return;

/* the entire input file is canonicalized and then the entire canonical */
/* characters are stored in a temp segment pointed by Temp_seg_ptr pointer */
	call get_temp_segment_ (ME, Temp_seg_ptr, p_code);
	if p_code ^= 0 then return;
						/* do not create a temp MSF when canonicalization of an input file */
						/* causes a temp segment reach its max seg size while canonicalization is in progress */
	Do_not_create_temp_msf_flag = TRUE;

	call do_canon;				/* convert the contents of the input SSF into a canonical form */

	if Ec ^= 0 then p_code = Ec;
	else do;
	     p_output_ptr -> Temp_seg = Temp_seg;	/* copy Temp_seg into a specified output file whose type is segment */
	     p_output_len = Temp_seg_len_in_chars;	/* update the length of the output file */
	end;

Seg_ptr = null;

	call clean_up;

	return;					/* complete either canonicalize_tabs_ or canonicalize_ */

/* --------------------------------------------------------------------------- */
%page;
validate_access: proc (p_dir, p_ename, p_type, p_desired_access, p_overwritten_flag);

/* validate the access modes of the directory input parameter.  If that      */
/* directory doesn't have a "modify" mode then canon reports an error.       */
/* Otherwise, an appropriate queried message will be printed when an user    */
/* wanted to overwrite an input path1 or a specified existent output path2,  */
/* but he either did not have a "write" access mode to it or has a           */
/* sufficient access (rew or rw) to it.                                      */
/* For the case of unsufficient access, if he answers yes to the question,   */
/* a "write" mode is TEMPORARILY set on it.  Otherwise, canon returns to the */
/* command level.                                                            */

/* in/out parameters */
dcl  p_desired_access bit (*);			/* input */
dcl  (p_dir, p_ename) char (*);			/* input */
dcl  p_type char (*);				/* input */
dcl  p_overwritten_flag bit (1);			/* input/output */

/* local */
dcl  full_pathname char (168);
dcl  grand_dn char (168);
dcl  mode fixed bin (5);
dcl  msf_directory_pathname char (168);
dcl  parents_dn char (32);
dcl  ring fixed bin;
dcl  user_id char (32);

/* begin validate_access procedure */

	Ec = 0;
	full_pathname = " ";
	grand_dn = " ";
	mode = 0;
	msf_directory_pathname = " ";
	parents_dn = " ";
	ring = -1;				/* indicates that a default value of the validation level of the calling process is used */
	user_id = " ";

	on cleanup call clean_up;

	call absolute_pathname_ (p_dir, full_pathname, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "Cannot get the absolute pathname of the directory ^a", p_dir);
	     return;
	end;
	call expand_pathname_ (full_pathname, grand_dn, parents_dn, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "Cannot expand the directory ^a", full_pathname);
	     return;
	end;

	user_id = get_group_id_ ();
	call hcs_$get_user_effmode (grand_dn, parents_dn, user_id, ring, mode, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "Cannot get the user effective mode of directory ^a", pathname_ (grand_dn, parents_dn));
	     return;
	end;

	if (mode ^= M_ACCESS_BIN) & (mode ^= SM_ACCESS_BIN) & (mode ^= SMA_ACCESS_BIN) then do;
	     Ec = error_table_$no_m_permission;
	     call com_err_ (Ec, ME, "^a", pathname_ (grand_dn, parents_dn));
	     return;
	end;

	if p_type = FS_OBJECT_TYPE_SEGMENT then do;
	     call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to update the protected file ^a?", pathname_ (p_dir, p_ename));
	     if ^p_overwritten_flag then return;

	     call access_$set_temporarily (p_dir, p_ename, SEGMENT, p_desired_access, Access_ptr, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME, "Cannot set ""write"" access mode on ^a", pathname_ (p_dir, p_ename));
		return;
	     end;
	end;

	if p_type = FS_OBJECT_TYPE_MSF then do;
	     msf_directory_pathname = pathname_ (p_dir, p_ename);
	     call hcs_$get_user_effmode (msf_directory_pathname, "0", user_id, ring, mode, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME, "Cannot get effective access mode of component 0 for MSF ^a", pathname_ (p_dir, p_ename));
		return;
	     end;

	     if (mode = N_ACCESS_BIN) | (mode = E_ACCESS_BIN) | (mode = W_ACCESS_BIN) then do;
		Ec = error_table_$no_r_permission;
		call com_err_ (Ec, ME, "^a", pathname_ (p_dir, p_ename));
		return;
	     end;

	     else if (mode = R_ACCESS_BIN) | (mode = RE_ACCESS_BIN) then do;
		call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to update the protected file ^a?",
		     pathname_ (p_dir, p_ename));
		if ^p_overwritten_flag then return;
						/* add a "write" access mode temporarily on a "read" only MSF */
		call access_$set_temporarily (p_dir, p_ename, MSF, p_desired_access, Access_ptr, Ec);
		if Ec ^= 0 then do;
		     call com_err_ (Ec, ME, "Cannot set ""write"" access  mode on ^a", pathname_ (p_dir, p_ename));
		     return;
		end;
	     end;
						/* ask for overwritten a specified existent MSF after finding that */
						/* it has a sufficient ACL (either RW_ACCESS_BIN or REW_ACCESS_BIN */
	     else call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (p_dir, p_ename));
	end;

	return;

     end validate_access;

/* --------------------------------------------------------------------------- */
%page;
canon_msf: proc;

/* given an input file whose type is MSF, an user's request was wanted to   */
/* convert its NONCANONICAL characters into a CANONICAL form.               */
/* The canonical data can be put either back into that input file if wanted */
/* to overwrite it (e.g. canon infile_MSF) or into a specified  output      */
/* file (e.g. canon infile_MSF existent_or_nonexistent_outfile).  Note      */
/* that a specified output file can be ALREADY existed in an user's working */
/* working directory or NOT existed yet.                                    */
/*                                                                          */
/* If an output path2 is specified and is not existed yet in the current    */
/* working directory, it will be created in one of the following methods:   */
/*    (a) by calling initiate_file_$create when canonicalization of the     */
/*        input MSF gives canonical characters which are stored in the      */
/*        Temp_seg and Temp_seg length has NEVER reached its max segment    */
/*        length.                                                           */
/*    (b) by creating a temporary MSF when canonicalization of the input    */
/*        MSF gives canonical characters which are stored in the Temp_seg   */
/*        and Temp_seg length has reached its maximum segment length        */
/*        AT LEAST ONCE while canonicalization is in progress.  This causes */
/*        a temp MSF to be created to copy Temp_seg's contents into an      */
/*        appropriate component of the temp MSF in order to continue        */
/*        canonicalization of the remaining components of the input MSF.    */
/*                                                                          */
/* There are two cases for processing canonicalization of the original      */
/* inut file whose entry type is Multissegment file (MSF):                  */
/*    Case 1: MSF canonicalize MSF (unchanged: type is unchanged)           */
/*           Canonicalization of an input file, whose type is MSF, gives    */
/*           canonical characters to be stored in an output file.           */
/*           The length of the canonical output file is GREATER than the    */
/*           max length of a segment.  So its type is MSF which is the same */
/*           type as the type of the noncanonical input file path1.         */
/*                                                                          */
/*    Case 2: MSF canonicalize SSF (shrink: type changed from MSF to SSF)   */
/*            Canonicalization of an input file path1, whose type is MSF,   */
/*            gives canonical characters to be stored in an output file.    */
/*            The length of the canonical output file is LESS or EQUAL than */
/*            the max length of a segment.  So the type of the canonical    */
/*            output file is SSF which is different type with the           */
/*            noncanonical input file path1 whose type is MSF.              */
/*                                                                          */


/* begin canon_msf procedure */

	In_msf_total_original_comps = Bitc;		/* save the total components of the input path1 MSF for later reference */

	on cleanup call clean_up;

	if Bitc = 0 then do;			/* the input path1 is a directory type which is not allowed for canon. */
	     call com_err_ (error_table_$dirseg, ME, "Cannot canonicalize a directory.  ^a", pathname_ (Dn, En));
	     return;
	end;
						/* make sure that acceptable path1 type is either segment or Multisegment-file. */
	call get_specified_file_type (Dn, En, Fs_util_type);
	if Ec ^= 0 then return;

	if ^Have_outfile_flag then do;		/* only an input path1 is specified */
	     call validate_access (Dn, En, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag);
	     if Ec ^= 0 then return;

	     if ^Overwrite_exist_path_flag then return;	/* did not want to overwrite the input path2 MSF */
	end;
	else do;					/* an output file path2 is specified */
	     call initiate_specified_output_file;
	     if Ec ^= 0 then return;
						/* the specified output file path2 exists and do not want to overwrite it */
	     if ^Nonexistent_outfile_flag & ^Overwrite_exist_path_flag then return;
	end;

/* open the specified input path1 whose type is MSF */
	call msf_manager_$open (Dn, En, Input_msf_fcb_ptr, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "Cannot open MSF input file.   ^a", pathname_ (Dn, En));
	     return;
	end;
						/* for each component of input path1 MSF, call do_canon to convert */
						/* its noncanonical data into a canonical data which stored in Temp_seg */
	do Input_msf_comp_index = COMPONENT_ZERO to (In_msf_total_original_comps - 1);
						/* get a specified component of the input file path1 whose type is MSF */
	     call msf_manager_$msf_get_ptr (Input_msf_fcb_ptr, Input_msf_comp_index, FALSE, Input_msf_comp_ptr, In_msf_comp_bitc, Ec);
	     if Ec ^= 0 then do;			/* the input MSF and the temp MSF will be closed in the clean_up internal proc */
		if Seg_ptr ^= null then		/* sp points to a specified component of the input file (MSF) path1 */
		     Seg_ptr = null;		/* do not call terminate_file_ to terminate the current component of the input MSF */
		call com_err_ (Ec, ME, "Cannot get component ^d of input MSF ^a.", Input_msf_comp_index, pathname_ (Dn, En));
		return;
	     end;

	     Seg_ptr = Input_msf_comp_ptr;		/* prepare for converting a particular component's contents into a canonical form */
						/* calculate the length of that component in characters */
	     Lth = divide (In_msf_comp_bitc + (BITS_PER_CHAR - 1), BITS_PER_CHAR, PRECISION_FIXED_BIN_21, 0);

	     if Lth = 0 then do;
		Seg_ptr = null;			/* do not call terminate_file_ to terminate the current component of an input MSF */
		Ec = error_table_$empty_file;
		call com_err_ (Ec, ME, "The component ^d of the input MSF ^a is empty.", Input_msf_comp_index, rtrim (pathname_ (Dn, En)));
		return;
	     end;

	     call do_canon;				/* perform canonicalization of a specified component of the input MSF */

	     if Ec ^= 0 then do;			/* the input MSF path1 and temp MSF will be closed in the clean_up int.proc */
		Seg_ptr = null;			/* do not call terminate_file_ to terminate the current component of an input MSF */
		return;
	     end;

	     Eof_flag = FALSE;			/* prepare to convert the next component's contents of the input MSF into a canonical form */
	end;					/* complete read in components of the input path1 MSF */

	if ^Create_temp_msf_flag then do;		/* case: MSF canonicalize SSF SHRUNK */
	     if ^Have_outfile_flag then do;		/* wanted to overwrite the input path1 MSF */
		call copy_temp_seg_into_msf (Dn, En, Input_msf_fcb_ptr, COMPONENT_ZERO, Input_msf_comp_ptr, In_msf_comp_bitc,
		     Temp_msf_total_components);
		if Ec ^= 0 then return;

		call msf_manager_$adjust (Input_msf_fcb_ptr, COMPONENT_ZERO, In_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
		if Ec ^= 0 then do;			/* the input MSF path1 will be closed in the clean_up internal proc. */
		     Seg_ptr = null;		/* do not call terminate_file_ to terminate the current component of an input MSF */
		     call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF  ^a", COMPONENT_ZERO, rtrim (pathname_ (Dn, En)));
		     return;
		end;
	     end;					/* only the input path1 was specified */
	     else do;				/* output path2 was specified */
		if Out_seg_ptr ^= null then		/* the specified output path2 exists and its type is SSF */
						/* put the contents of Temp_seg into a specified existent output path2 SSF */
		     call copy_temp_seg_into_segment;

		else if Nonexistent_outfile_flag then do;
						/* output path2 was specified and did not exist yet since Out_seg_ptr value is null */
						/* so, creates and initiates the specified nonexistent output path2 */
		     call initiate_file_$create (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Nonexistent_outfile_flag, Bitc, Ec);
		     if Ec ^= 0 then do;		/* will close the input MSF path1 in the clean_up internal proc. */
			Seg_ptr = null;		/* do not call terminate_file_ to terminate the current component of an input MSF */
			call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
			return;
		     end;
						/* copy the contents of Temp_seg into a newly created segment */
		     call copy_temp_seg_into_segment;
		end;				/* output path2 was specified and did not exist yet */

		else if Fs_util_type = FS_OBJECT_TYPE_MSF then do;
						/* copy Temp_seg into the specified output path2 whose type is MSF */
		     call copy_temp_seg_into_spec_pth2_MSF;
		     if Ec ^= 0 then do;		/* will close the input MSF path1 in the clean_up internal proc. */
			Seg_ptr = null;		/* do not call terminate_file_ to terminate the current component of an input MSF */
			return;
		     end;
		end;				/* copy Temp_seg into a specified existent path2 whose type is MSF */
	     end;					/* copy Temp_seg into a specified path2 whose type is either SSF or MSF */
	end;					/* case: MSF canonicalize SSF SHRUNK */
	else do;					/* case: MSF canonicalize MSF UNCHANGED */
	     if Temp_seg_len_in_chars > 0 then do;
		call temp_seg_to_temp_msf;		/* copy Temp_seg into a the next created component of a temp MSF */
		if Ec ^= 0 then return;		/* will close the input MSF path1 in the clean_up; temp MSF is already closed */
	     end;

	     if ^Have_outfile_flag then do;		/* only the input MSF path1 was specified */
		call temp_msf_to_infile_or_outfile (Dn, En);
		if Ec ^= 0 then return;
	     end;
	     else do;
						/* open the specified output file path2 */
		call msf_manager_$open (Out_dname, Out_ename, Input_msf_fcb_ptr, Ec);
		if Ec ^= 0 then do;
		     if Ec ^= error_table_$noentry then do;
			call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
			return;
		     end;
		     else Ec = 0;			/* no problem.  It will be created soon by the call to msf_manager_$msf_get_ptr */
		end;
						/* copy temp MSF into the specified output file */
		call temp_msf_to_infile_or_outfile (Out_dname, Out_ename);
		if Ec ^= 0 then return;

		if Out_seg_ptr ^= null then Out_seg_ptr = null; /* points to a specified output SSF path2.  Do not call terminate_file_ */
	     end;					/* output file path2 was specified */
	end;					/* case: MSF canonicalize MSF UNCHANGED */

	return;

     end canon_msf;

/* ------------------------------------------------------------------------ */
%page;
canon_segment: proc;

/* given an input file whose type is Segment, an user's request was to      */
/* convert its NONCANICAL characters into a CANONICAL form.                 */
/* Canonical chars can be put either back into that input file if wanted    */
/* to overwrite it (e.g. canon infile_MSF) or into a specified  output      */
/* file (e.g. canon infile_MSF existent_or_nonexistent_outfile).  Note      */
/* that a specified output file can be ALREADY existed in an user's working */
/* working directory or NOT existed yet.                                    */
/*                                                                          */
/* If an output path2 is specified and is not existed yet in the current    */
/* working directory, it will be created in one of the following methods:   */
/*    (a) by calling initiate_file_$create when canonicalization of the     */
/*        input SSF gives canonical characters which are stored in the      */
/*        Temp_seg and Temp_seg length has NEVER reached its max segment    */
/*        length.                                                           */
/*    (b) by creating a temporary MSF when canonicalization of the input    */
/*        SSF gives canonical characters which are stored in the Temp_seg   */
/*        and Temp_seg length has reached its maximum segment length        */
/*        AT LEAST ONCE while canonicalization is in progress.  This causes */
/*        a temp MSF to be created to copy Temp_seg's contents into an      */
/*        appropriate component of the temp MSF in order to continue        */
/*        canonicalization of the remaining components of the input SSF.    */
/*                                                                          */
/* There are two cases for processing canonicalization of a specified input */
/* file whose type is segment (SSF).                                        */
/*                                                                          */
/* Case 1: SSF canonicalize SSF (type is unchanged)                         */
/*         Canonicalization of input file path1, whose type is SSF, gives   */
/*         canonical characters to be stored in an output file.             */
/*         Because the length of the canonical output file is LESS or EQUAL */
/*         the maximum length of a segment, so the type of the output file  */
/*         is SSF which is the same type as the noncanical input file path1 */
/*                                                                          */
/* Case 2: SSF canonicalize MSF (expanded: type is changed from SSF to MSF) */
/*         Canonicalization of input file path1, whose type is SSF, gives   */
/*         canonical characters to be stored in an output file.             */
/*         Because the max length of canonical output file is GREATER than  */
/*         the max length of a segment, so the type of the canonical output */
/*         file is MSF which is different type with the noncanonical input  */
/*         file path1 whose type is SSF.                                    */
/*                                                                          */

/* begin canon_segment procedure */

	on cleanup call clean_up;

	if Bitc = 0 then do;			/* the input path1 whose type is SSF is empty */
	     call com_err_ (error_table_$zero_length_seg, ME, "^a", pathname_ (Dn, En));
	     return;
	end;
						/* initiate the input path1 SSF */
	call initiate_file_ (Dn, En, Desired_access, Seg_ptr, Bitc, Ec);
	if Ec ^= 0 then do;
	     if Ec = error_table_$no_w_permission then do;/* do not treat as an error until digging in details */
		Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
		call validate_access (Dn, En, Fs_util_type, Desired_access, Overwrite_exist_path_flag);
		if Ec ^= 0 then return;
		if ^Overwrite_exist_path_flag then return;
						/* must reinitiate again to get Seg_ptr pointer pointing to an input SSF path1 */
		call initiate_file_ (Dn, En, Desired_access, Seg_ptr, Bitc, (0));
	     end;
	     else do;
		call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
		return;
	     end;
	end;					/* an error occured while initiating the input path1 */
						/* assume had no problem with initiation.  Ask for overwritting the input path1 */
	if ^Have_outfile_flag & ^Overwrite_exist_path_flag then do;
	     call command_query_$yes_no (Overwrite_exist_path_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (Dn, En));
	     if ^Overwrite_exist_path_flag then return;
						/* at this point, users want to overwrite the input path1 SSF */
	     Fs_util_type = FS_OBJECT_TYPE_SEGMENT;	/* mark for later reference for the case: SSF canonicalize MSF (expanded) */
	end;

	call archive_$next_component (Seg_ptr, Bitc, (null ()), (0), (""), Ec);
	if Ec = 0 then do;
	     Ec = error_table_$archive_pathname;
	     call com_err_ (Ec, ME, "The specified path is an archive. ^a", pathname_ (Dn, En));
	     return;
	end;

	oi.version_number = object_info_version_2;
	call object_info_$brief (Seg_ptr, Bitc, addr (oi), Ec);
	if Ec = 0 then do;
	     Ec = error_table_$bad_arg;
	     call com_err_ (Ec, ME, "The specified path is an object segment. ^a", pathname_ (Dn, En));
	     return;
	end;
						/* calculate the length of input path1 SSF in characters */
	Lth = divide (Bitc + (BITS_PER_CHAR - 1), BITS_PER_CHAR, PRECISION_FIXED_BIN_21, 0);

	if Have_outfile_flag then do;			/* output path2 is specified */
	     call initiate_specified_output_file;
	     if Ec ^= 0 then return;
						/* the specified output file path2 exists and do not want to overwrite it */
	     if ^Nonexistent_outfile_flag & ^Overwrite_exist_path_flag then return;
	end;
	else Out_seg_ptr = Seg_ptr;			/* Out_seg_ptr points to an input file path1 SSF because wanted to overwrite it */


	call do_canon;				/* convert the contents of the input SSF into a canonical form */
	if Ec ^= 0 then return;

	if ^Create_temp_msf_flag then do;		/* case: SSF canonicalize SSF (canonical chars are stored in a temp seg) */
	     if Out_seg_ptr ^= null then
						/* copy Temp_seg into either the input file (SSF) path1, or */
						/* the specified existent output file (SSF) path2 */
		call copy_temp_seg_into_segment;

	     else if Nonexistent_outfile_flag then do;	/* the specified output file path2 did not exist */
		call initiate_file_$create (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Nonexistent_outfile_flag, Bitc, Ec);
		if Ec ^= 0 then do;
		     call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
		     return;
		end;

		call copy_temp_seg_into_segment;	/* copy Temp_seg contents into the newly created output file (SSF) path2 */
	     end;

	     else do;				/* the specified existent output path2 is a Multisegment-file (MSF) */
		call copy_temp_seg_into_spec_pth2_MSF;
		if Ec ^= 0 then return;
	     end;					/* the specified existent output path2 is a Multisegment-file (MSF) */
						/* terminate the input path1 SSF pointed by Seg_ptr pointer by call terminate_file_ */
	     call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0));
	end;					/* case: SSF canonicialize SSF */
	else do;					/* case: SSF canonicalize MSF */
	     if Temp_seg_len_in_chars > 0 then do;	/* Temp_seg contains canonical characters */
		call temp_seg_to_temp_msf;		/* copy the contents of Temp_seg into a proper component of a temp MSF */
		if Ec ^= 0 then return;
	     end;

	     if ^Have_outfile_flag then do;		/* for overwritten an input path1 SSF */
		call msf_manager_$open (Dn, En, Input_msf_fcb_ptr, Ec);
		if Ec ^= 0 then do;			/* will close temp MSF in the clean_up internal proc. */
		     call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
		     return;
		end;
						/* copy the contents of temp msf into the input path1 SSF which converted to MSF */
		call temp_msf_to_infile_or_outfile (Dn, En);
		if Ec ^= 0 then return;

		Seg_ptr = null;			/* don't call terminate_file_ because the input SSF path1 has converted to MSF */
	     end;
	     else do;				/* a output path2 was specified */
						/* open either a specified existent output path2 whose type either SSF or MSF */
						/* or a specified nonexistent output file path2 */
		call msf_manager_$open (Out_dname, Out_ename, Input_msf_fcb_ptr, Ec);
		if Ec ^= 0 then do;
		     if Ec ^= error_table_$noentry then do; /* will close the temp MSF in the clean_up internal procedure */
			call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
			return;
		     end;
		     else Ec = 0;			/* OK for specifying a nonexistent output file path2 */
						/* it will be created when msf_manager_$msf_get_ptr is called */
		end;
						/* copy the contents of temp MSF into a specified output file path2 */
		call temp_msf_to_infile_or_outfile (Out_dname, Out_ename);
		if Ec ^= 0 then do;
		     if Nonexistent_outfile_flag then
			call delete_$path (Out_dname, Out_ename, SWITCHES, ME, (0));
		     return;
		end;
						/* call terminate_file_ to terminate the input SSF path1 after */
						/* copying the contents of temp MSF into a specified output file path2 */
		call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0));
	     end;
	end;					/*  case: SSF CANONICALIZE MSF EXPANDED */

	return;

     end canon_segment;

/* --------------------------------------------------------------------------- */
%page;
clean_up: proc;

/* begin clean_up procedure */

	if Access_ptr ^= null then do;		/* a write access mode has been temporarily added to a read only file */
	     if Create_temp_msf_flag then do;		/* a temp MSF has been created earlier */

		if Fs_util_type = FS_OBJECT_TYPE_SEGMENT then do;
						/* must take care the ACL of the converted MSF whose original type is SSF */
		     Access.type = MSF;		/* reinitialize to 3 to indicate that the new entry type is MSF */
		     Access.set = ACL_REPLACED;	/* prepare to replace the current ACL with its original ACL */
		     Access.old_mode = R_ACCESS;	/* restore its origial access mode */
		     call access_$reset (Access_ptr, (0)); /* replace the current ACL with the original ACL */
		end;				/* the original type of the converted path2 MSF was SSF */

		if Fs_util_type = FS_OBJECT_TYPE_MSF then /* the original entry type was MSF */
		     call access_$reset (Access_ptr, (0)); /* remove the "write" access mode that temporarily added earlier */
	     end;					/* a temp MSF was created */
	     else if Fs_util_type ^= " " then do;	/* a temp MSF has NEVER been created and the entry type is SSF or MSF */
		if Fs_util_type = FS_OBJECT_TYPE_MSF then
						/* the original type of the converted path2 SSF was MSF */
		     Access.type = SEGMENT;		/* update the entry type which is SSF */

		call access_$reset (Access_ptr, (0));	/* remove the "write" access mode that temporarily added earlier */
	     end;
	end;					/* a "write" access mode has been temporarily added to a "read" only in/out file */

	if Input_msf_fcb_ptr ^= null then do;
	     call msf_manager_$close (Input_msf_fcb_ptr);
	     if Seg_ptr ^= null then Seg_ptr = null;	/* double check since sp pointed to a specified component of an input MSF path1 */
						/* or to the convert input MSF path1 whose original type was SSF */
	end;

	if Temp_msf_fcb_ptr ^= null then do;
	     call msf_manager_$close (Temp_msf_fcb_ptr);
	     if Out_seg_ptr ^= null then Out_seg_ptr = null; /* double check since Out_seg_ptr pointed to the converted output MSF path2 whose original type is SSF */
	end;

	if Temp_ptr ^= null then free Temp_ptr -> Bead;

	if Outc_ptr ^= null then
	     call release_temp_segment_ (ME, Outc_ptr, (0));

	if Temp_seg_ptr ^= null then do;
	     if ^Specified_temp_file_flag then
		call release_temp_segment_ (ME, Temp_seg_ptr, (0));
	     else do;
		Temp_seg_ptr = null;
		call delete_$path (Temp_dn, Temp_en, SWITCHES, ME, (0));
	     end;
	end;

	if Second_temp_seg_ptr ^= null then
	     call release_temp_segment_ (ME, Second_temp_seg_ptr, (0));

	return;

     end clean_up;

/***************************************************************************/
/*  This is part of the clean_up procedure that is not required if the
    call has come thru canonicalize_ or canonicalize_tabs_.                */

term_segs:
     proc;
     
	if Out_seg_ptr = Seg_ptr then Out_seg_ptr = null; /* Out_seg_ptr also pointed to source since wanted to overwrite the input file path1 */

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

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

end term_segs;
/****************************************************************************/

/* -------------------------------------------------------------------------- */
%page;
copy_temp_seg_into_msf: proc (p_dn, p_en, p_fcb_ptr, p_comp_index, p_comp_ptr, p_comp_bitc, p_temp_msf_total_components);

/* put the contents of Temp_seg which contains canonical characters into     */
/* either an appropriate component of the temp MSF or component 0 of a       */
/* specified output path2 whose type is MSF.                                 */

/* parameters */
dcl  (p_dn, p_en) char (*);
dcl  (p_comp_ptr, p_fcb_ptr) ptr;
dcl  p_comp_index fixed bin;
dcl  (p_comp_bitc, p_temp_msf_total_components) fixed bin (24);

/* begin copy_temp_seg_into_msf procedure */

	Ec = 0;

	on cleanup call clean_up;

	on record_quota_overflow begin;
	     Ec = error_table_$rqover;
	     call msf_manager_$close (p_fcb_ptr);
	     revert record_quota_overflow;
	     goto temp_seg_to_msf_ERROR_RETURN;
	end;
						/* want to create a specified component if it doesn't exist yet */
	call msf_manager_$msf_get_ptr (p_fcb_ptr, p_comp_index, TRUE, p_comp_ptr, p_comp_bitc, Ec);
	if Ec ^= 0 then do;
	     call msf_manager_$close (p_fcb_ptr);

	     if Fs_util_type = FS_OBJECT_TYPE_MSF then
		call com_err_ (Ec, ME, "Cannot get component ^d of specified output MSF ^a", p_comp_index, pathname_ (p_dn, p_en));
	     else call com_err_ (Ec, ME, "Cannot get component ^d of temp MSF ^a", p_comp_index, pathname_ (p_dn, p_en));

	     return;
	end;

	p_comp_ptr -> Temp_seg = Temp_seg;		/* copy the contents of Temp_seg into into a specified component */

	if (p_comp_index = 0) & (p_temp_msf_total_components = 0) then
						/* case of a specified path2 is nonexistent and a temp MSF has been created */
	     p_temp_msf_total_components = 1;		/* update the total number of components in a temp MSF */

/* calculate the bitc count of that component */
	p_comp_bitc = Temp_seg_len_in_chars * BITS_PER_CHAR;

temp_seg_to_msf_ERROR_RETURN:

	return;

     end copy_temp_seg_into_msf;

/* --------------------------------------------------------------------------- */
%page;
copy_temp_seg_into_spec_pth2_MSF: proc;

/* copy the contents of Temp_seg into the component 0 of a specified output  */
/* path2 whose type is MSF.                                                  */

/* begin copy_temp_seg_into_spec_pth2_MSF procedure */
/* get File control Block pointer */
	call msf_manager_$open (Out_dname, Out_ename, Temp_msf_fcb_ptr, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
	     return;
	end;
						/* copy Temp_seg into the component 0 of the specified output path2 MSF */
	call copy_temp_seg_into_msf (Out_dname, Out_ename, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr,
	     Temp_msf_comp_bitc, Temp_msf_total_components);
	if Ec ^= 0 then return;
						/* sets the bit count, truncates, and terminates its component 0 */
	call msf_manager_$adjust (Temp_msf_fcb_ptr, (Temp_msf_comp_index), Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
	if Ec ^= 0 then do;
	     call msf_manager_$close (Temp_msf_fcb_ptr);
	     call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", Temp_msf_comp_index, pathname_ (Out_dname, Out_ename));
	     return;
	end;

	return;

     end copy_temp_seg_into_spec_pth2_MSF;

/* --------------------------------------------------------------------------- */
%page;
copy_temp_seg_into_segment: proc;

/* when canonicalization of an input SSF is finished and Temp_seg length has */
/* not reached the system defined max length yet, CHARS_PER_SEGMENT,         */
/* copy_temp_seg_into_segment copies the contents of Temp_seg into one       */
/* of the following files:                                                   */
/*    (a) the specified output path2.  Note that if it did not exist, it     */
/*        was created by calling initiate_file_$create earlier.              */
/*    (b) the original input path1.                                          */


dcl  output_segment_length_in_bits fixed bin (24);

/* begin copy_temp_seg_into_segment procedure */

	output_segment_length_in_bits = 0;

	on cleanup call clean_up;

	on record_quota_overflow begin;
	     Ec = error_table_$rqover;
	     revert record_quota_overflow;
	     goto temp_seg_to_segment_ERROR_RETURN;
	end;

	Output_segment_length_in_words = divide (Temp_seg_len_in_chars + (CHARS_PER_WORD - 1), CHARS_PER_WORD, PRECISION_FIXED_BIN_19, 0);
	call terminate_file_ (Out_seg_ptr, (Output_segment_length_in_words), TERM_FILE_TRUNC, Ec);
	if Ec ^= 0 then do;
	     if Out_seg_ptr = Seg_ptr then
		call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
	     else call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
	     return;
	end;
						/* Clear last word used */
	Out_seg_ptr -> Word_array (Output_segment_length_in_words) = FALSE;

	Out_seg_ptr -> Temp_seg = Temp_seg;		/* copy canonical data into either input path1 or a specified output path2 */

	output_segment_length_in_bits = Temp_seg_len_in_chars * BITS_PER_CHAR;
	call terminate_file_ (Out_seg_ptr, (output_segment_length_in_bits), TERM_FILE_BC, Ec);
	if Ec ^= 0 then do;
	     if Out_seg_ptr = Seg_ptr then
		call com_err_ (Ec, ME, "^a", pathname_ (Dn, En));
	     else call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
	     return;
	end;

temp_seg_to_segment_ERROR_RETURN:
	call terminate_file_ (Out_seg_ptr, (0), TERM_FILE_TERM, Ec);

	return;

     end copy_temp_seg_into_segment;

/* -------------------------------------------------------------------------- */
%page;
do_canon: procedure;

/* Each line of either the input segment or the specified component of the  */
/* input MSF is read in.  Scan each character in that line to find out      */
/* whether it is a normal character or a specified character.  For standard */
/* characters, no convertion to canonical form is made, just copied them    */
/* into Outc.  However, for special characters such as Backspace (BS), SP,  */
/* Carriage return (CR), Horizontal tab (HT), ect., special processing is   */
/* required to convertion them into standard (canonical) form before storing */
/* in Outc.  So, continue to proceed the input line until a slew character  */
/* is found.  Then copy the Outc which contains a line of characters in     */
/* standard (canonical) form into the Temp_seg.  At this point, canon       */
/* checks the length of Temp_seg in order to decide what actions will be    */
/* taken next if tem_seg length reaches the maximum segment length.         */
/* (a) Assume that the max segment length has not been reached.  Read in the */
/*     next input line.  Repeat canonicalization of that line.  do_canon    */
/*     terminates the convertion after the last line of the input segment   */
/*     or of a specified component of the input MSF has been converted into */
/*     a canonical form.                                                    */
/* (b) Assume that the max segment length has been reached while            */
/*     canonicalization is in progress.  A temporarly MSF is created in     */
/*     either the process directory with a unique name (by default) or      */
/*     in a specified directory (-temp_file was specified).  Copy Temp_seg  */
/*     which is now full into a specified component of the newly created    */
/*     temp MSF.  Then clear out the Temp_seg before continuing to put the  */
/*     remaining contents of Outc (which is left over) into Temp_seg.       */
/*     do_canon terminates the canonicalization of the input file after     */
/*     the last line of the input file has been converted.                  */
/*                                                                          */
/* A "slew" character is a line-terminator (NL, VT, or FF).                 */

dcl  available_pos_for_insertion fixed bin (21);
dcl  next_char_pos fixed bin (21);
dcl  remaining_pos_for_insertion fixed bin (21);
dcl  slew_index fixed binary (21);
dcl  slew_present_flag bit (1);

%page;
/* begin do_canon procedure */

	Ec = 0;
	available_pos_for_insertion = 0;
	remaining_pos_for_insertion = 0;
	Obuf_ptr = null;
	Beg_line = 1;				/* beginning line position */

	on cleanup call clean_up;

	Bead_storage_size = hbound (Bead_storage, 1);

	Bead_ptr = addr (Bead_storage);
	Area_ptr = get_system_free_area_ ();

	do while (^Eof_flag);			/* scan each existing line of the input (segment or MSF component). */
	     Outc_len, Ox = 0;			/* clear out Outc which contains a line of caninical chars before continuing */
						/* to convert the next input line into canonical form and store them in Outc */
	     Nch = 0;				/* no chars seen */
	     Obuf_ptr = addr (substr (Bcs, Beg_line, 1)); /* locate begin of line */

	     Chars_in_line = search (substr (Bcs, Beg_line), NLVTFF);
						/* find end of line */
	     if Chars_in_line = 0 then do;		/* no more NL or other slew chars remain in input */
		slew_present_flag = FALSE;
		Chars_in_line = Lth - Beg_line + 2;
						/* include a mythical slew char in count */
	     end;
	     else slew_present_flag = TRUE;		/* NL or other slew char found in input */

	     Beg_line = Beg_line + Chars_in_line;	/* up to begin of next line */
	     if Beg_line > Lth then Eof_flag = TRUE;

	     slew_index = Chars_in_line;

/* Remove trailing SPBSCRHTs. */
	     Chars_to_remove = verify (reverse (substr (Obuf_ptr -> Bcs, 1, Chars_in_line - 1)), SPBSCRHT);
	     if Chars_to_remove = 0 then Chars_to_remove = Chars_in_line;

	     Chars_in_line = Chars_in_line - Chars_to_remove + 1;

	     Col, Jj, In_stopx, Stopx, Next_pos = 1;
	     if search (substr (Obuf_ptr -> Bcs, 1, Chars_in_line - 1), BSCR) ^= 0 then do; /* special processing necessary */
		do while (Jj <= Chars_in_line - 1);	/* .. simulating a typewriter */
		     if substr (Obuf, Jj, 1) = BS then do;
			Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), BS) - 1;
			Jj = Jj + Ii;
			Col = max (Col - Ii, 1);	/* don't backspace off end */
		     end;
		     else if substr (Obuf, Jj, 1) = CR then do;
			Col = 1;
			Jj = Jj + 1;
		     end;
		     else if substr (Obuf, Jj, 1) = HT then do;
			Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), HT) - 1;
			if In_nstops > 0 then do;
			     if Col >= In_stops (In_nstops) then Col = Col + Ii;
			     else do;
				do In_stopx = In_stopx to In_nstops + 1
				     while (Col >= In_stops (In_stopx));
				end;
				if In_stopx + Ii > In_nstops then
				     Col = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops;
				else Col = In_stops (In_stopx + Ii - 1);
			     end;
			end;
			else Col = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1;

			Jj = Jj + Ii;
		     end;
		     else if substr (Obuf, Jj, 1) = SP then do;
			Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), SP) - 1;
			Jj = Jj + Ii;
			Col = Col + Ii;
		     end;
		     else do;			/* printing char */
			Nch = Nch + 1;		/* allocate */
			if Nch > Bead_storage_size then do; /* make sure don't blow array */
			     Mm = Bead_storage_size;
			     Bead_storage_size = 2 * Bead_storage_size;

			     allocate Bead set (Temp_ptr) in (System_area);

			     Bead_storage_size = Mm;
			     Temp_ptr -> Bead = Bead;
			     if Bead_ptr ^= addr (Bead_storage) then free Bead;

			     Bead_ptr = Temp_ptr;
			     Bead_storage_size = 2 * Bead_storage_size;
			end;
			Bead (Nch).char = substr (Obuf, Jj, 1);
			Bead (Nch).loc = Col;	/* note (aparent) position */

			if (rank (substr (Obuf, Jj, 1)) >= rank (" ") & rank (substr (Obuf, Jj, 1)) <= rank ("~")) then Col = Col + 1;

			Jj = Jj + 1;
		     end;
		end;				/* looping termination */

		call sort;			/* all chars done. sort array */

		Next_pos = 1;			/* next output pos */
		do Charx = 1 to Nch;		/* now put out the chars in right order */
		     if Charx > 1 then do;
			if unspec (Bead (Charx)) = unspec (Bead (Charx - 1))
			then goto do_canon_SKIP;
		     end;
						/* Canonical form says no duplicate in same pos */
		     Spaces_to_go = Bead (Charx).loc - Next_pos;
						/* number of spaces to put */
		     if Spaces_to_go > 0 then do;	/* if space needed */
			if Tab_flag & Spaces_to_go > 1 then do; /* inserting tabs? */
			     if Nstops > 0 then do;
				do Stopx = 1 to Nstops while (Next_pos >= Stops (Stopx));
				end;

				Cantab_flag = (Stopx <= Nstops);
				do while (Cantab_flag & (Bead (Charx).loc >= Stops (Stopx)));
				     call output (HT);
				     Next_pos = Stops (Stopx);
				     Spaces_to_go = Bead (Charx).loc - Next_pos;
						/* Recalculate spaces needed. */
				     if Stopx >= Nstops then Cantab_flag = FALSE;
				     else if Stops (Stopx + 1) > Bead (Charx).loc then Cantab_flag = FALSE;
				     else Stopx = Stopx + 1;
				end;
			     end;
			     else do;		/* -every case */
				Target_tabstop = Everytab * divide (Bead (Charx).loc - 1, Everytab, PRECISION_FIXED_BIN_17, 0) + 1;

				do while (Next_pos < Target_tabstop);
				     call output (HT);

				     This_tabstop = Everytab * divide (Next_pos - 1 + Everytab, Everytab, PRECISION_FIXED_BIN_17, 0) + 1;
				     Next_pos = This_tabstop;
				     Spaces_to_go = Bead (Charx).loc - Next_pos;
						/* Recalculate spaces needed */
				end;
			     end;
			end;

			do Ii = 1 to Spaces_to_go;	/* put out blanks */
			     call output (SP);
			end;
		     end;

/* We consider nonprinting characters to not take up space for the purposes of
   calculating tabs and so forth, but we don't actually want to separate them
   by backspaces. */
		     if Spaces_to_go < 0 & (rank (Bead (Charx).char) >= rank (" ") & rank (Bead (Charx).char) <= rank ("~"))
		     then call output ((BS));		/* never more than one */

		     call output (Bead (Charx).char);	/* type char out */

		     Next_pos = Bead (Charx).loc + 1;	/* next column */
do_canon_SKIP:
		end;
	     end;					/* typewriter simulation */
	     else do;				/* just take the whole line */
		Nch = 1;				/* non_zero to start copy */

		if ^Tab_flag then do;		/* process case with space fill */
		     do while (Nch ^= 0);
			Nch = index (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT); /* find HT */
			if Nch = 0 then
			     Ii = Chars_in_line - Jj;
			else Ii = Nch - 1;		/* omit the tab in copy */
			if Ii > 0 then do;
			     Outc_len = Outc_len + Ii;
			     substr (Outc, Ox + 1, Ii) = substr (Obuf_ptr -> Bcs, Jj, Ii);

			     do Kk = Jj to (Jj + Ii - 1);
				if (rank (substr (Obuf_ptr -> Bcs, Kk, 1)) >= rank (" ") & rank (substr (Obuf_ptr -> Bcs, Kk, 1)) <= rank ("~"))
				then Col = Col + 1;
			     end;

			     Ox = Ox + Ii;
			     Jj = Jj + Ii;
			end;

			if Nch ^= 0 then do;	/* fill spaces */
			     Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT) - 1; /* take out multiples */

			     Next_pos = Col;
			     if In_nstops > 0 then do;
				if Col >= In_stops (In_nstops) then Spaces_to_go = Ii;
				else do;
				     do In_stopx = In_stopx to In_nstops + 1
					while (Col >= In_stops (In_stopx));
				     end;

				     if In_stopx + Ii > In_nstops
				     then Spaces_to_go = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops - Col;
				     else Spaces_to_go = In_stops (In_stopx + Ii - 1) - Next_pos;
				end;
			     end;
			     else Spaces_to_go = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1 - Next_pos; /* number of spaces to fill in */

			     Outc_len = Outc_len + Spaces_to_go;
			     substr (Outc, Ox + 1, Spaces_to_go) = copy (SP, Spaces_to_go);
			     Ox = Ox + Spaces_to_go;
			     Col = Col + Spaces_to_go;
			     Jj = Jj + Ii;		/* add source space for the tab */
			end;
		     end;
		end;

%page;
/* Process Case with Tab Fill */
		else do;
		     do while (Jj <= Chars_in_line - 1);

/* Clip spacing before section */
			do while (search (substr (Obuf_ptr -> Bcs, Jj, 1), HTSP) ^= 0);
			     if substr (Obuf_ptr -> Bcs, Jj, 1) = SP then do;
				Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), SP) - 1;
				Col = Col + Ii;
				Jj = Jj + Ii;
			     end;
			     else do;
				Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT) - 1;

				if In_nstops > 0 then do;
				     if Col >= In_stops (In_nstops) then
					Col = Col + Ii;
				     else do;
					do In_stopx = In_stopx to In_nstops + 1
					     while (Col >= In_stops (In_stopx));
					end;
					if In_stopx + Ii > In_nstops then
					     Col = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops;
					else Col = In_stops (In_stopx + Ii - 1);
				     end;
				end;
				else Col = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1;

				Jj = Jj + Ii;
			     end;
			end;

/* At this point initial white space has been clipped, Col = column after the
   white space, and Next_pos = last column printed + 1.  Now section through
   the tabulation. */
			Spaces_to_go = Col - Next_pos;/* number of spaces to put */
			if Spaces_to_go > 0 then do;	/* if space needed */
			     if (Tab_flag) & (Spaces_to_go > 1) then do; /* inserting tabs? */
				if Nstops > 0 then do;
				     if Next_pos > Stops (Nstops)
				     then goto omit_simple_spaces; /* beyond reach */
						/* Start from last tabstop for scan */
				     do Stopx = Stopx to Nstops + 1
					while (Next_pos >= Stops (Stopx));
				     end;

				     do Ii = Stopx to Nstops + 1
					while (Col >= Stops (Ii));
				     end;		/* find terminator */

				     Ii = Ii - Stopx; /* number of tabs involved */
				     if Ii < 1 then goto omit_simple_spaces; /* no tabs involved */

				     Spaces_to_go = Col - Stops (Ii + Stopx - 1); /* spaces after last tab */
				end;
				else do;		/* -every */
						/* tabstop number */
				     Target_tabstop = divide (Col - 1, Everytab, PRECISION_FIXED_BIN_17, 0);
						/* number of tabs to do */
				     Ii = Target_tabstop - divide (Next_pos - 1, Everytab, PRECISION_FIXED_BIN_17, 0);
				     if Ii < 1 then goto omit_simple_spaces; /* no tabbing involved */
				     Spaces_to_go = Col - (Target_tabstop * Everytab + 1); /* spaces left after */
				end;

				if Ii > 0 then do;
				     Outc_len = Outc_len + Ii;
				     substr (Outc, Ox + 1, Ii) = copy (HT, Ii);
				     Ox = Ox + Ii;	/* Output Horizontal tabs */
				end;
			     end;

omit_simple_spaces:
			     if Spaces_to_go > 0 then do;
				Outc_len = Outc_len + Spaces_to_go;
				substr (Outc, Ox + 1, Spaces_to_go) = copy (SP, Spaces_to_go);
				Ox = Ox + Spaces_to_go;
			     end;
			end;

/* Take out a string of text, to next gap. */
			Ii = search (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HTSP) - 1;
			if Ii < 1 then
			     Ii = Chars_in_line - Jj;

			Outc_len = Outc_len + Ii;
			substr (Outc, Ox + 1, Ii) = substr (Obuf_ptr -> Bcs, Jj, Ii); /* output string */
			Ox = Ox + Ii;
			do Kk = Jj to (Jj + Ii - 1);
			     if (rank (substr (Obuf_ptr -> Bcs, Kk, 1)) >= rank (" ") & rank (substr (Obuf_ptr -> Bcs, Kk, 1)) <= rank ("~")) then
				Col = Col + 1;
			end;

			Jj = Jj + Ii;
			Next_pos = Col;
		     end;				/* end of parse loop */
		end;
	     end;

	     if slew_present_flag then
						/* finally, append the slew char to the Outc which contains a line of CANONINCAL chars */
		call output (substr (Obuf, slew_index, 1));

/* check the boundary of temp seg after adding an entire line of canonincal chars to it */
	     if (Temp_seg_len_in_chars + Outc_len) < CHARS_PER_SEGMENT then do;
						/* copy the entire line of canonical chars (stored in Outc) into the Temp_seg */
		next_char_pos = Temp_seg_len_in_chars + 1;
		Temp_seg_len_in_chars = Temp_seg_len_in_chars + Outc_len;
		substr (Temp_seg, next_char_pos, Outc_len) = Outc;
	     end;
	     else do;				/* case of reaching the maximum length of Temp_seg */
						/* calculate the number of spaces left in temp seg, then filled up temp seg */
		available_pos_for_insertion = CHARS_PER_SEGMENT - Temp_seg_len_in_chars;
		next_char_pos = Temp_seg_len_in_chars + 1;
		Temp_seg_len_in_chars = Temp_seg_len_in_chars + available_pos_for_insertion;
		substr (Temp_seg, next_char_pos, available_pos_for_insertion) = substr (Outc, 1, available_pos_for_insertion);

		if Do_not_create_temp_msf_flag then do;
						/* the canonicalize_tab_ and canonincal_ entries don't want to expand path1 SSF into MSF */
		     Ec = error_table_$rqover;
		     return;
		end;
						/* temp seg containing canonical characters is full */
		if ^Create_temp_msf_flag then do;
		     Create_temp_msf_flag = TRUE;

		     if ^Specified_temp_file_flag then do; /* by default: prepare to create a temp MSF in the process directory with an unique name */
			Temp_dn = get_pdir_ ();
			Temp_en = unique_chars_ (FALSE);
		     end;
		     else do;			/* a temp segment ws created ealier by hcs_$make_seg when -tf was given */
						/* this specified temp segment will be converted to a temp MSF very soon. */
						/* So, canon must get another temp seg for continuing canonicalization. */
			call get_temp_segment_ (ME, Second_temp_seg_ptr, Ec);
			if Ec ^= 0 then do;
			     call com_err_ (Ec, ME, "Cannot get temp segment.");
			     return;
			end;
						/* copy the specified temp segment's contents into another temp segment */
			Second_temp_seg_ptr -> Second_temp_seg = Temp_seg_ptr -> Temp_seg;
						/* assign Temp_seg_ptr points to another temp segment */
						/* such that the remaining canonical chars will be stored in the second temp seg */
						/* and the specified temp segment in a specified directory will be */
						/* converted into a temp MSF by calling msf_manager_$msf_get_ptr soon */
						/* in the call to copy_temp_seg_into_msf internal procedure */
			Temp_seg_ptr = Second_temp_seg_ptr;

			Second_temp_seg_ptr = null;	/* no need */
		     end;
						/* open temp MSF.  Wants a pointer that points to the FCB of the temp MSF */
		     call msf_manager_$open (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Ec);
		     if Ec ^= 0 then do;
			if Ec ^= error_table_$noentry then do;
			     call com_err_ (Ec, ME, "^a", pathname_ (Temp_dn, Temp_en));
			     return;
			end;
			else Ec = 0;		/* OK for temp MSF not found.  It will be created in copy_temp_seg_into_msf */
		     end;
		end;
						/* prepare to request a component greater than 0 */
		if Temp_msf_total_components > 0 then do;
		     Temp_msf_comp_index = Temp_msf_total_components;
		     Temp_msf_total_components = Temp_msf_total_components + 1;
		end;

/* copy tem_seg into an appropriate component of a newly created temp MSF */
		call copy_temp_seg_into_msf (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Temp_msf_comp_index,
		     Temp_msf_comp_ptr, Temp_msf_comp_bitc, Temp_msf_total_components);
		if Ec ^= 0 then return;

		Temp_seg_len_in_chars = 0;		/* clear out Temp_seg  to indicate it is now empty. */
						/* Is any char left in the Outc after filled up tem_seg? */
		remaining_pos_for_insertion = Outc_len - available_pos_for_insertion;
		if remaining_pos_for_insertion > 0 then do;
						/* copy left over canonical characters from the Outc into Temp_seg */
		     Temp_seg_len_in_chars = remaining_pos_for_insertion;
		     substr (Temp_seg, 1, remaining_pos_for_insertion) = substr (Outc, available_pos_for_insertion + 1, remaining_pos_for_insertion);
		end;
	     end;					/* case of reaching the boundary of Temp_seg */
	end;					/* end of do while (^Eof_flag) */

	return;					/* return from do_canon procedure */

/* --------------------------------------------------------------------------- */
%page;
output:	proc (p_slew_char);

/* append a slew character (NL, VT, or FF) to Outc which contains a line    */
/* of canonical (standard) characters.                                      */

dcl  p_slew_char char (1);				/* input parameter */

/* begin output procedure which is called by do_canon procedure */

	     Outc_len, Ox = Ox + 1;			/* update canonical line length.  Also update output line index */
	     substr (Outc, Ox, 1) = p_slew_char;	/* append a slew character to a line of canonical character */

	     return;				/* return to do_canon procedure */

	end output;

/* -------------------------------------------------------------------------- */
%page;
sort:	proc;

/* Sort characters in Bead array of record.  Bead contains characters */
/* and corresponding character positions in the current line.  Nch is */
/* the actual upper bound of the array.                               */

dcl  d fixed bin;
dcl  i fixed bin;
dcl  swaps fixed bin;
dcl  temp bit (36) aligned;

/* begin sort procedure */

	     d = Nch;				/* get the actual max array index */

sort_pass:
	     swaps = 0;				/* prepare to sort characters in alphabetic order */

	     d = divide (d + 1, 2, 17, 0);		/* split the entire portion into two equal array portions */

	     do i = 1 to Nch - d;			/* loop through the upper portion */
						/* compare each character in the upper portion with each character in the lower portion, respectively */
		if unspec (Bead (i)) > unspec (Bead (i + d)) then do;
		     swaps = swaps + 1;
		     temp = unspec (Bead (i));
		     unspec (Bead (i)) = unspec (Bead (i + d));
		     unspec (Bead (i + d)) = temp;
		end;
	     end;

	     if d > 1 then goto sort_pass;		/* continue to split the upper array portion based on upper array portion's update max index */

	     if swaps > 0 then goto sort_pass;

	     return;				/* return to do_canon procedure */

	end sort;

/* --------------------------------------------------------------------------- */
%page;
     end do_canon;

/* --------------------------------------------------------------------------- */
%page;
get_specified_file_type: proc (p_dn, p_en, p_fs_util_type);

/* get the entry type of a specified file by calling fs_util_$get_type.      */
/* Only accept canonicalization of either a single Segment file (SSF) or     */
/* a Multisegment_file (MSF).                                                */

/* parameters */
dcl  (p_dn, p_en) char (*);				/* input */
dcl  p_fs_util_type char (32);			/* in/out */

/* begin get_specified_file_type procedure */

	Ec = 0;

	call fs_util_$get_type (p_dn, p_en, p_fs_util_type, Ec);
	if Ec ^= 0 then do;
	     call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en));
	     return;
	end;

	if p_fs_util_type = FS_OBJECT_TYPE_DIRECTORY then do;
	     Ec = error_table_$dirseg;
	     call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en));
	end;

	if p_fs_util_type = FS_OBJECT_TYPE_DM_FILE then do;
	     Ec = dm_error_$file_in_use;
	     call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en));
	end;

	return;

     end get_specified_file_type;

/* ------------------------------------------------------------------------ */
%page;
initialization: proc;

/* initializes all automatic variables.  They are grouped together        */
/* depending on their data types.  For each group, their appearance       */
/* is based on alphabetic order.  This purpose is used to speed up canon. */

/* begin initialization procedure */

	Access_ptr,
	     Input_msf_comp_ptr,
	     Input_msf_fcb_ptr,
	     Outc_ptr,
	     Out_seg_ptr,
	     Second_temp_seg_ptr,
	     Seg_ptr,
	     Temp_msf_comp_ptr,
	     Temp_msf_fcb_ptr,
	     Temp_ptr,
	     Temp_seg_ptr = null;

	Bitc,
	     Ec,
	     Everytab,
	     Input_msf_comp_index,
	     In_msf_comp_bitc,
	     In_msf_total_original_comps,
	     In_nstops,
	     In_stops (*),
	     Mm,
	     Nstops,
	     Specified_infile_type,
	     Stops (*),
	     Temp_msf_comp_bitc,
	     Temp_msf_comp_index,
	     Temp_msf_total_components,
	     Temp_seg_len,
	     Temp_seg_len_in_chars = 0;

	Dn,
	     En,
	     Fs_util_type,
	     Out_dname,
	     Out_ename,
	     Temp_dn,
	     Temp_en = " ";

	Create_temp_msf_flag,
	     Do_not_create_temp_msf_flag,
	     Eof_flag,
	     Have_infile_flag,
	     Have_outfile_flag,
	     Overwrite_exist_path_flag,
	     Nonexistent_outfile_flag,
	     Specified_temp_file_flag,
	     Subroutine_call_flag,
	     Tab_flag = FALSE;

	Desired_access = (36)"0"b;

	In_everytab = 10;				/* by default */

	return;

     end initialization;

/* --------------------------------------------------------------------------- */
%page;
initiate_specified_output_file: proc;

/* initiate the specified output file path2.  If suceeds initiatation, ask   */
/* for overwritten the specified existent output path2.                      */

/* begin initiate_specified_output_file procedure */

	Ec = 0;

	call initiate_file_ (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Bitc, Ec);
	if Ec ^= 0 then do;
	     if Ec = error_table_$noentry then do;	/* it's OK for a specified NONEXISTENT output path2.  Will make it exist later on */
						/* depending on either case MSF canonicalize MSF or MSF canonicalize SSF */
		Ec = 0;
		Nonexistent_outfile_flag = TRUE;	/* mark that the specified output path2 does not exist. */
	     end;

	     else if Ec = error_table_$no_w_permission then do;
						/* do not treat as an error until digging in details */
		Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
		call validate_access (Out_dname, Out_ename, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag);
		if Ec ^= 0 then return;
		if ^Overwrite_exist_path_flag then return;
						/* must reinitiate again to get its pointer value, Out_seg_ptr */
		call initiate_file_ (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Bitc, Ec);
		if Ec ^= 0 then do;
		     call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
		     return;
		end;
	     end;

	     else if Ec = error_table_$dirseg then do;	/* the specified output path2 EXISTS and its type is either directory or MSF */
						/* do not treat as an error until digging in details */
		call get_specified_file_type (Out_dname, Out_ename, Fs_util_type);
		if Ec ^= 0 then return;

		call validate_access (Out_dname, Out_ename, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag);
		if Ec ^= 0 then return;
		if ^Overwrite_exist_path_flag then return;
	     end;					/* the specified path2 exists and its type is either directory or MSF */
	     else do;
		call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename));
		return;
	     end;
	end;					/* an error occured while initiating the specified output path2 */

	if ^Overwrite_exist_path_flag & ^Nonexistent_outfile_flag then do;
						/* assume had no problem when initiated the specified EXISTENT output path2 */
	     call command_query_$yes_no (Overwrite_exist_path_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (Out_dname, Out_ename));
	     if ^Overwrite_exist_path_flag then return;

	     Fs_util_type = FS_OBJECT_TYPE_SEGMENT;
	end;

	return;

     end initiate_specified_output_file;

/* --------------------------------------------------------------------------- */
%page;
temp_seg_to_temp_msf: proc;

/* copies the contents of Temp_seg into the next component of the temp MSF.  */
/* This is done by calling the internal procedure named                      */
/* copy_temp_seg_into_msf.  Then calls msf_manager_$adjust to set          */
/* the bit count, truncate, and terminate that component.                    */

/* begin temp_seg_to_temp_msf procedure */

	if Temp_msf_total_components > 0 then do;	/* prepare to create another component in the temp MSF */
	     Temp_msf_comp_index = Temp_msf_total_components;
	     Temp_msf_total_components = Temp_msf_total_components + 1;
	end;
						/* copy the contents of Temp_seg into a specified component of a temp. MSF */
	call copy_temp_seg_into_msf (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr,
	     Temp_msf_comp_bitc, Temp_msf_total_components);
	if Ec ^= 0 then do;				/* close temp MSF */
	     call msf_manager_$close (Temp_msf_fcb_ptr);
	     return;
	end;
						/* sets the bit count, truncates and terminates the components of the temp. MSF */
	call msf_manager_$adjust (Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
	if Ec ^= 0 then do;				/* close temp MSF */
	     call msf_manager_$close (Temp_msf_fcb_ptr);
	     call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", Temp_msf_comp_index, pathname_ (Temp_dn, Temp_en));
	     return;
	end;

	return;

     end temp_seg_to_temp_msf;

/* --------------------------------------------------------------------------- */
%page;
temp_msf_to_infile_or_outfile: proc (p_dirname, p_enname);

/* copy each component of a temp MSF into the corresponding component of     */
/* either the input file path1 or a specified output file path2.             */
/* If path2 was specified and does not exist, the call to                    */
/* msf_manager_$msf_get_ptr will create it as a MSF.                         */

/* input parameters */
dcl  p_dirname char (*);
dcl  p_enname char (*);

/* begin temp_msf_to_infile_or_outfile procedure */

	Ec = 0;

	on record_quota_overflow begin;
	     Ec = error_table_$rqover;
	     call msf_manager_$close (Input_msf_fcb_ptr);
	     call msf_manager_$close (Temp_msf_fcb_ptr);
	     revert record_quota_overflow;
	     goto temp_msf_ERROR_RETURN;
	end;

	Temp_seg_len = Temp_seg_len_in_chars;		/* save the current length of Temp_seg */

	Temp_seg_len_in_chars = CHARS_PER_SEGMENT;	/* prepare to copy full components (whose length has reached the max */
						/* component length) of a temp MSF */

	do Temp_msf_comp_index = COMPONENT_ZERO to (Temp_msf_total_components - 1);
						/* prepare to create a specified component */
	     Input_msf_comp_index = Temp_msf_comp_index;
						/* create a specified component if it does not exist yet */
	     call msf_manager_$msf_get_ptr (Input_msf_fcb_ptr, Input_msf_comp_index, TRUE, Input_msf_comp_ptr, In_msf_comp_bitc, Ec);

	     if Ec ^= 0 then do;
		call msf_manager_$close (Input_msf_fcb_ptr);
		call msf_manager_$close (Temp_msf_fcb_ptr);
		call com_err_ (Ec, ME, "Cannot get component ^d of MSF ^a", Input_msf_comp_index, pathname_ (p_dirname, p_enname));
		return;
	     end;
						/* get a specified component of the temp MSF */
	     call msf_manager_$msf_get_ptr (Temp_msf_fcb_ptr, Temp_msf_comp_index, FALSE, Temp_msf_comp_ptr, Temp_msf_comp_bitc, Ec);
	     if Ec ^= 0 then do;
		call com_err_ (Ec, ME, "Cannot get component ^d of MSF ^a.", Input_msf_comp_index, pathname_ (Temp_dn, Temp_en));
		call msf_manager_$close (Input_msf_fcb_ptr);
		call msf_manager_$close (Temp_msf_fcb_ptr);
		return;
	     end;
						/* have the last component of the temp MSF been reached */
	     if Temp_msf_comp_index = (Temp_msf_total_components - 1) then
						/* prepare to copy the last component of the temp MSF */
		Temp_seg_len_in_chars = Temp_seg_len;

/* copy the contents of each component of temp MSF into the corresponding */
/* component of either input file path1 or a specified output file path2 */
	     Input_msf_comp_ptr -> Temp_seg = Temp_msf_comp_ptr -> Temp_seg;
	end;					/* complete copied one by one component */
						/* sets bit count, truncates, and terminates the components of that file */
	call msf_manager_$adjust (Input_msf_fcb_ptr, Input_msf_comp_index, Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec);
	if Ec ^= 0 then do;
	     call msf_manager_$close (Input_msf_fcb_ptr);
	     call msf_manager_$close (Temp_msf_fcb_ptr);
	     call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a.", Input_msf_comp_index, pathname_ (p_dirname, p_enname));
	     return;
	end;

temp_msf_ERROR_RETURN:
	return;

     end temp_msf_to_infile_or_outfile;

/* --------------------------------------------------------------------------- */
%page;
%include access_mode_values;
%page;
%include object_info;
%page;
%include system_constants;
%page;
%include terminate_file;
%page;
%include copy_flags;
%page;
%include suffix_info;

     end canonicalize;




		    compare.pl1                     04/09/85  1514.1r w 04/08/85  1128.7      157014



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


compare: proc;

/* The compare command and active function compares two segments.

Usage:  compare pathA{|offsetA} pathB{|offsetB} {-control_args}


Written 08/07/79 S. Herbst */

/* Added -inhibit_error, -no_inhibit_error, -short, -total 09/25/84 S. Herbst */
/* Changed to work on archive components 11/14/84 Steve Herbst */
/* Fixed compilation warning about star_entry_ptr 12/03/84 Steve Herbst */
/* Fixed equal convention broken by last installation 12/05/84 Steve Herbst */
/* Backed out change to use max length if bit count = 0 12/11/84 Steve Herbst */


/* Constants */

dcl ME char (32) int static options (constant) init ("compare");
dcl FORMAT (2) char (32) int static options (constant) init
	("^4x^6o^2x^w", "^26x^6o^2x^w");
dcl STRING_FORMAT (2) char (32) int static options (constant) init
	("^4x^a", "^26x^a");
dcl DOUBLE_FORMAT char (32) int static options (constant) init ("^4x^6o^2x^w^2x^6o^2x^w");
dcl SKIP (2) char (32) int static options (constant) init
	("^9x|^4x--------", "^31x|^4x--------");
dcl DOUBLE_SKIP char (32) int static options (constant) init ("^9x|^4x--------^9x|^4x--------");

/* Based */

dcl word (0:max_len) bit (36) based;
dcl area area based (area_ptr);

/* Automatic */

dcl 1 info (1:2),
   2 path char (194),
   2 msf_component_name char (32),
   2 (done_sw, msf_sw, noentry_sw) bit (1),
   2 (ptr, entries_ptr, names_ptr) ptr,
   2 (k, len, msf_count, msf_index, offset) fixed bin;

dcl arg char (arg_len) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr);
dcl dn char (168);
dcl (cn, cn1, en, en1, xcn, xen) char (32);
dcl (bad_arg, bad_base) character (10) varying;

dcl mask bit (36);
dcl (af_sw, brief_sw, inhibit_error_sw, printed_header_sw, printed_component_header_sw, short_sw, totals_sw) bit (1);

dcl (area_ptr, arg_ptr, return_ptr) ptr;

dcl (arg_count, arg_len, block_len, col, common_len, dis_count) fixed bin;
dcl (given_len, i, j, max_len, path_count, return_len, word_count) fixed bin;
dcl max_length fixed bin (19);
dcl bit_count fixed bin (24);
dcl (code, octal_mask) fixed bin (35);

/* External */

dcl error_table_$bad_conversion fixed binary (35) external static;
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$dirseg fixed bin (35) ext;
dcl error_table_$item_too_big fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;
dcl error_table_$not_act_fnc fixed bin (35) ext;
dcl error_table_$not_archive fixed bin (35) ext;

/* Entries */

dcl complain entry variable options (variable);
dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl get_equal_name_$component entry (char (*), char (*), char (*), char (*), char (*), char (*), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35));
dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl ioa_ entry options (variable);
dcl pathname_ entry (char(*), char(*)) returns(char(168));
dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (168));
dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));

dcl (addrel, divide, index, max, min, null, substr, sum, unspec) builtin;

dcl cleanup condition;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	end;

	if arg_count < 2 then do;
USAGE:	     if af_sw then call active_fnc_err_$suppress_name (0, ME,
		"Usage:  [compare pathA{|offsetA} pathB{|offsetB} {-control_args}]");
	     else call com_err_$suppress_name (0, ME,
		"Usage:  compare pathA{|offsetA} pathB{|offsetB} {-control_args}");
	     return;
	end;

	given_len, path_count = 0;
	mask = (36) "1"b;
	brief_sw, inhibit_error_sw, short_sw, totals_sw = "0"b;
	unspec (info) = "0"b;
	do i = 1 to 2;
	     ptr (i), entries_ptr (i), names_ptr (i) = null;
	end;
	area_ptr = null;

	on condition (cleanup) call clean_up;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if substr (arg, 1, 1) = "-" then
		if arg = "-brief" | arg = "-bf" then
		     if af_sw then go to BADOPT;
		     else brief_sw = "1"b;
		else if arg = "-inhibit_error" | arg = "-ihe" then
		     if ^af_sw then go to BADOPT;
		     else inhibit_error_sw = "1"b;
		else if arg = "-long" | arg = "-lg" then
		     if af_sw then go to BADOPT;
		     else brief_sw = "0"b;
		else if arg = "-length" | arg = "-ln" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			call complain (0, ME, "No value specified for -length");
			return;
		     end;
		     given_len = cv_oct_check_ (arg, code);
		     bad_arg = "-length";
		     if code ^= 0 then do;
BAD_OCTAL_NUM:
			bad_base = "an octal";
BAD_NUM:			call complain (error_table_$bad_conversion, ME,
			     "^a requires ^a number, not ^a.", bad_arg, bad_base, arg);
			return;
		     end;
		     if given_len <= 0
		     then do;
			     bad_base = "a positive";
			     go to BAD_NUM;
			end;
		end;
		else if arg = "-mask" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if code ^= 0 then do;
			call complain (0, ME, "No value specified for -mask");
			return;
		     end;
		     octal_mask = cv_oct_check_ (arg, code);
		     if code ^= 0
		     then do;
			     bad_arg = "-mask";
			     go to BAD_OCTAL_NUM;
			end;
		     mask = unspec (octal_mask);
		end;
		else if arg = "-no_inhibit_error" | arg = "-nihe" then
		     if ^af_sw then go to BADOPT;
		     else inhibit_error_sw = "0"b;
		else if arg = "-short" | arg = "-sh" then
		     if af_sw then go to BADOPT;
		     else short_sw = "1"b;
		else if arg = "-totals" | arg = "-total" | arg = "-tt" then
		     if af_sw then go to BADOPT;
		     else totals_sw = "1"b;
		else do;
BADOPT:		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;
	     else do;
		path_count = path_count + 1;
		if path_count > 2 then go to USAGE;
		call get_path (path_count);
	     end;
	end;

	if path_count ^= 2 then go to USAGE;

	if noentry_sw (1) | noentry_sw (2) then do;
	     if inhibit_error_sw then do;
		if noentry_sw (1) & noentry_sw (2) then do;
		     call complain (error_table_$noentry, ME, "^/^5x^a^/^5x^a", path (1), path (2));
		     go to RETURN;
		end;
		else do;
		     return_arg = "false";  /* note that -inhibit_error is only allowed with active function */
		     go to RETURN;
		end;
	     end;
	     else do;
		if noentry_sw (1) then i = 1;
		else i = 2;
		call complain (error_table_$noentry, ME, "^a", path (i));
		go to RETURN;
	     end;
	end;

	if ptr (1) = ptr (2) & ^msf_sw (1) & offset (1) = offset (2) then do;
	     call complain (0, ME, "Attempt to compare data with itself.");
	     call clean_up;
	     return;
	end;

	if min (len (1), len (2)) = 0 & af_sw then do;	/* one or both zero length */
	     if len (1) = len (2) then return_arg = "true";
	     else return_arg = "false";
	     call clean_up;
	     return;
	end;

	dis_count, word_count = 0;
	printed_header_sw = "0"b;

	if ^msf_sw (1) & ^msf_sw (2) then call print_discrepancies ();  /* both are segments */
	else do;
	     if af_sw & msf_sw (1) ^= msf_sw (2) then do;
		return_arg = "false";
		go to RETURN;
	     end;

	     do while (^done_sw (1) & ^done_sw (2));
		call get_next_msf_component (1);
		call get_next_msf_component (2);
		printed_component_header_sw = "0"b;
		call print_discrepancies ();
	     end;
	     do i = 1 to 2;
		if ^done_sw (i) then do;
		     dis_count = dis_count + 1;
		     if ^af_sw then call ioa_ ("Remaining components of MSF ^a", path (i));
		     do while (^done_sw (i));
			call get_next_msf_component (i);
			word_count = word_count + len (i);
			if ^af_sw then call ioa_ (STRING_FORMAT (i), get_msf_component_name (i));
		     end;
		end;
	     end;
	end;

/* Print totals */

	if af_sw then do;
	     return_arg = "true";
	     go to RETURN;
	end;

	if dis_count = 0 then call ioa_ ("No discrepancies.");
	else call ioa_ ("^/Total ^d discrepanc^[ies^;y^], ^d word^[s^]",
	     dis_count, dis_count > 1, word_count, word_count > 1);

RETURN:	call clean_up;
	return;
%page;
clean_up: proc;

dcl i fixed bin;

	do i = 1 to 2;
	     if ptr (i) ^= null then call terminate_file_ (ptr (i), 0, TERM_FILE_TERM, code);
	     if entries_ptr (i) ^= null then free entries_ptr (i) -> star_entries in (area);
	     if names_ptr (i) ^= null then free names_ptr (i) -> star_names in (area);
	end;

end clean_up;
%page;
get_msf_component_name: proc (P_i) returns (char (64));

/* Returns either "Segment" or "Component <name>" */

dcl P_i fixed bin;

	if ^msf_sw (P_i) then return ("Segment");
	else return ("Component " || msf_component_name (P_i));

end get_msf_component_name;
%page;
get_next_msf_component: proc (P_i);

/* Positions to next component of an MSF, turns on done_sw (P_i) if the last one. */
/* For a segment, just turns on done_sw (P_i). */

dcl P_i fixed bin;

	if ^msf_sw (P_i) then done_sw (P_i) = "1"b;
	else do;
	     msf_index (P_i) = min (msf_index (P_i) + 1, msf_count (P_i));
	     if msf_index (P_i) = msf_count (P_i) then done_sw (P_i) = "1"b;
	     msf_component_name (P_i) =
		names_ptr (P_i) -> star_names (entries_ptr (P_i) -> star_entries (msf_index (P_i)).nindex);

	     call initiate_file_ (path (P_i), msf_component_name (P_i), R_ACCESS, ptr (P_i), bit_count, code);
	     if code ^= 0 then do;
		call complain (code, ME, "MSF component ^a", pathname_ (path (P_i), msf_component_name (P_i)));
		go to RETURN;
	     end;
	     len (P_i) = divide (bit_count + 35, 36, 17, 0);
	end;

end get_next_msf_component;
%page;
get_path: proc (P_i);

dcl P_i fixed bin;

	j = index (arg, "|");
	if j = arg_len then do;			/* no offset after "|" */
BAD_OFFSET:    call complain (code, ME, "Invalid offset in ^a", arg);
	     goto RETURN;
	end;

	if j ^= 0 then do;
	     offset (P_i) = cv_oct_check_ (substr (arg, j + 1), code);
	     if code ^= 0 then do;
		code = error_table_$bad_conversion;
		goto BAD_OFFSET;
	     end;
	     arg_len = j - 1;
	end;

	call expand_pathname_$component (arg, dn, en, cn, code);
	if code ^= 0 & code ^= error_table_$not_archive then do;
	     call complain (code, ME, "^a", arg);
	     go to RETURN;
	end;

	if P_i = 2 then do;
	     call get_equal_name_$component (en1, cn1, en, cn, xen, xcn, code);
	     if code ^= 0 then do;
		call complain (code, ME, "^a^[::^a^] applied to ^a^[::^a^]",
		     en, cn ^= "", cn, en1, cn1 ^= "", cn1);
		go to RETURN;
	     end;
	     en = xen;
	     cn = xcn;
	end;
	else do;
	     en1 = en;				/* save for 2nd time through */
	     cn1 = cn;
	end;

	path (P_i) = pathname_$component (dn, en, cn);	/* for an error message if needed */

	if cn ^= "" then call initiate_file_$component (dn, en, cn, R_ACCESS, ptr (P_i), bit_count, code);
	else call initiate_file_ (dn, en, R_ACCESS, ptr (P_i), bit_count, code);
	if ptr (P_i) = null then do;
	     if code = error_table_$dirseg then do;
		bit_count = 0;
		call hcs_$status_minf (dn, en, 1, 0, bit_count, 0);
		if bit_count ^= 0 then do;		/* MSF */
		     if offset (P_i) ^= 0 then do;
			call complain (0, ME, "Nonzero offset not allowed for MSF ^a",
			     pathname_ (dn, en));
			go to RETURN;
		     end;

		     msf_sw (P_i) = "1"b;

		     if area_ptr = null then area_ptr = get_system_free_area_ ();
		     call hcs_$star_ (pathname_ (dn, en), "**", star_BRANCHES_ONLY, area_ptr,
			star_entry_count, star_entry_ptr, star_names_ptr, code);
		     if code ^= 0 then do;
			if code = error_table_$nomatch then call complain (0, ME, "Invalid MSF ^a",
			     pathname_ (dn, en));
			else call complain (code, ME, "^a", pathname_ (dn, en));
			go to RETURN;
		     end;
		     entries_ptr (P_i) = star_entry_ptr;
		     names_ptr (P_i) = star_names_ptr;
		     msf_count (P_i) = star_entry_count;
		     msf_index (P_i) = 0;
		     len (P_i) = 1;		/* ie., not zero length */
		     return;
		end;
	     end;
	     else if code = error_table_$noentry then do;
		noentry_sw (P_i) = "1"b;
		return;				/* catch this later */
	     end;
	     else call complain (code, ME, "^a", path (P_i));
	     go to RETURN;
	end;

	len (P_i) = divide (bit_count + 35, 36, 17, 0);

	if offset (P_i) > len (P_i) then do;
	     call complain (error_table_$item_too_big, ME,"
Base-zero offset ^d greater than length ^d", offset (P_i), len (P_i));
	     go to RETURN;
	end;

end get_path;
%page;
print_discrepancies: proc;

	max_len = max (len (1), len (2));
	common_len = min (len (1) - offset (1), len (2) - offset (2));
	if given_len ^= 0 then do;
	     max_len = min (max_len, offset (1) + given_len, offset (2) + given_len);
	     common_len = min (common_len, given_len);
	end;

	k (1) = offset (1);
	k (2) = offset (2);

	block_len = 0;

	do i = 1 to common_len;

	     do i = i to common_len while
		((mask & ptr (1) -> word (k (1) + block_len)) ^= (mask & ptr (2) -> word (k (2) + block_len)));
		     block_len = block_len + 1;
	     end;

	     if block_len > 0 then do;		/* block of discrepancies */

		if af_sw then do;
		     return_arg = "false";
		     go to RETURN;
		end;

		if ^printed_header_sw then call print_header;

		if ^printed_component_header_sw then do;
		     printed_component_header_sw = "1"b;
		     if (msf_sw (1) | msf_sw (2)) & ^totals_sw then
			call ioa_ ("^a / ^a:", get_msf_component_name (1), get_msf_component_name (2));
		end;

		dis_count = dis_count + 1;
		word_count = word_count + block_len;

		if short_sw | totals_sw then do;
		     if ^totals_sw then call ioa_ ("^5d word^[s^; ^] at: ^6o", block_len, block_len > 1, k (1));
		     k (1) = k (1) + block_len;
		     k (2) = k (2) + block_len;
		end;
		else if block_len > 3 & brief_sw then do;
		     call ioa_ (DOUBLE_FORMAT,
			k (1), ptr (1) -> word (k (1)),
			k (2), ptr (2) -> word (k (2)));
		     call ioa_ (DOUBLE_SKIP);
		     k (1) = k (1) + block_len;	/* skip block */
		     k (2) = k (2) + block_len;
		     call ioa_ (DOUBLE_FORMAT,
			k (1) - 1, ptr (1) -> word (k (1) - 1),
			k (2) - 1, ptr (2) -> word (k (2) - 1));
		end;
		else do;
		     do j = 1 to block_len;
			call ioa_ (DOUBLE_FORMAT,
			     k (1), ptr (1) -> word (k (1)),
			     k (2), ptr (2) -> word (k (2)));
			k (1) = k (1) + 1;		/* skip block */
			k (2) = k (2) + 1;
		     end;
		end;

		if i <= common_len then do;		/* skip matching word ending the block */
		     k (1) = k (1) + 1;
		     k (2) = k (2) + 1;
		end;

		block_len = 0;
	     end;

	     else do;				/* no discrepancy, skip 1 matching word */
		k (1) = k (1) + 1;
		k (2) = k (2) + 1;
	     end;
	end;

	if max_len > max (k (1), k (2)) then do;	/* print remaining words of longer seg */

	     if af_sw then do;
		return_arg = "false";
		go to RETURN;
	     end;

	     if ^printed_header_sw then call print_header;
	     if min (len (1), len (2)) = 0 then dis_count = dis_count + 1;
	     else if (mask & ptr (1) -> word (k (1) - 1)) = (mask & ptr (2) -> word (k (2) - 1)) then
		dis_count = dis_count + 1;		/* not continuation of previous discrepancy */
	     if len (1) > len (2) then col = 1;
	     else col = 2;
	     block_len = max_len - k (col);
	     word_count = word_count + block_len;

	     if totals_sw then;
	     else if short_sw then call ioa_ ("^5d word^[s^; ^] at: ^6o (file ^d)",
		block_len, block_len > 1, k (col), col);
	     else if block_len > 3 & brief_sw then do;
		call ioa_ (FORMAT (col), k (col), ptr (col) -> word (k (col)));
		call ioa_ (SKIP (col));
		call ioa_ (FORMAT (col), max_len - 1, ptr (col) -> word (max_len - 1));
	     end;
	     else do j = k (col) to max_len - 1;
		call ioa_ (FORMAT (col), j, ptr (col) -> word (j));
	     end;
	end;

end print_discrepancies;
%page;
print_header: proc;

	printed_header_sw = "1"b;
	if short_sw | totals_sw then return;
	call ioa_ ("Discrepancies:");
	call ioa_ ("^4xoffset^4xcontents^4xoffset^4xcontents");

end print_header;
%page;
%include access_mode_values;
%page;
%include star_structures;
%page;
%include terminate_file;


end compare;




		    convert_characters.pl1          11/04/82  1951.6rew 11/04/82  1627.6      114309



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


convert_characters: cvc: proc;

/* procedure to convert a predefined set of characters in a segment to a different set */

/* Originally coded by E. Franklin
   Recode for SSS by R. Mullen */

dcl  unique_chars_ entry (bit (*)) returns (char (15));	/* to make tempname */
dcl  establish_cleanup_proc_ entry (entry);		/* remember to cleanup */
dcl  ioa_ ext entry options (variable);			/* input output ascii */
dcl  com_err_ ext entry options (variable);
dcl  cu_$arg_count ext entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$terminate_noname ext entry (ptr, fixed bin (35));
dcl  hcs_$initiate_count ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
     fixed bin (12), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, ptr, fixed bin (35));
dcl  hcs_$fs_move_seg entry (ptr, ptr, fixed bin (1), fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));

dcl (inptr, tempptr, outptr) ptr init (null);		/* point to segs to be dealt with */
dcl  fs_flag bit (1) aligned init ("0"b);		/* 1 => setting from_string */
dcl  string char (charnum) based;
dcl (bcd_flag, dart_flag, uc_flag, lc_flag, mult_flag, sp_flag) bit (1) unaligned init ("0"b);
dcl  ts_flag bit (1) aligned init ("0"b);		/* 1 => setting to_string */
dcl  procname char (18) aligned init ("convert_characters");
dcl  tempname char (24) aligned;			/* name of seg in process dir */
dcl  max_nargs fixed bin init (3);			/* will be set to two for some entrys */

dcl (from_string, to_string) char (128) varying aligned init (""); /* define the conversion */
dcl (static_from_string, static_to_string) char (128) varying aligned /* define the default conversion */
     internal static init ("");

dcl (code, bcode) fixed bin (35);			/* status codes */
dcl (error_table_$action_not_performed,			/* to make sure user knows */
     error_table_$noarg,
     error_table_$too_many_args)
     fixed bin (35) external static;

dcl  argptr pointer;				/* will point to last arg picked up */
dcl (arglen, nargs) fixed bin (17);

dcl  aa char (4) aligned;				/* aligned arg */
dcl  argbuf char (arglen) based (argptr);		/* the last arg picked up */

dcl  dir char (168) aligned;				/* dirname for last patharg picked up */
dcl  entry char (32) aligned;				/* ename for same */
dcl  btcnt fixed bin (24);				/* bit count */

dcl (i, j) fixed bin (24);
dcl  charnum fixed bin (24);				/* num of chars in seg being converted */


dcl (addr, addrel, divide, length, min, null, ptr, substr, translate) builtin; /* pawns */


/* This entry converts from one user specified string to another */

	call cu_$arg_count (nargs);
	call cu_$arg_ptr (1, argptr, arglen, code);
	if code ^= 0 then go to error;
	aa = argbuf;
	if aa = "sp" then go to special;
	else if aa = "bcd" then go to convert_bcd;
	else if aa = "dart" then go to convert_dartmouth;
	else if aa = "mp" then go to convert_multics_pl1;
	else if aa = "uc" then go to convert_upper_case;
	else if aa = "lc" then go to convert_lower_case;
	else if aa = "to" then go to convert_to;
	else if aa = "from" then go to convert_from;
	else do;
	     call com_err_ (0, procname, "Unrecognized  key - ^a", argptr -> argbuf);
	     return;
	end;
special:
	sp_flag = "1"b;
	from_string = static_from_string;		/* it uses internal static strings */
	to_string = static_to_string;			/* to define the conversion */
	if nargs = 1 then go to print_strings;		/* no problem even if int static strings were not set */
	if static_from_string = "" then if static_to_string = "" then do; /* complain */
		code = error_table_$action_not_performed;
		call com_err_ (code, procname, "^/First use convert_from and convert_to to specify conversion.");
		return;
	     end;
	go to got_nargs;				/* if one string is "" then the strings will be unequal below */

/* This entry converts bcd special characters to corresponding ascii/ebcdic ones */

convert_bcd:
	bcd_flag = "1"b;
	from_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ%<#&";
	to_string = "abcdefghijklmnopqrstuvwxyz()=+";
	go to start;


convert_dartmouth:
	dart_flag = "1"b;
	from_string = "^_>+='{""?";
	to_string = "'=""<>:+?!";
	go to start;

/* This entry converts all lower case letters to upper case */

convert_upper_case:
	uc_flag = "1"b;
	from_string = "abcdefghijklmnopqrstuvwxyz";
	to_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
	go to start;

/* This entry converts all upper case letters to lower case. */

convert_lower_case:
	lc_flag = "1"b;
	from_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
	to_string = "abcdefghijklmnopqrstuvwxyz";
	go to start;

/* This entry converts from multics pl1 format to 360 pl1 format */

convert_multics_pl1:
	mult_flag = "1"b;
	from_string = "abcdefghijklmnopqrstuvwxyz	""";
	to_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ '";
	go to start;


/* The above entries all have max_nargs set to 3.
   If no nore args are given the appropriate from_string and to_string will be printed.
   If one or two more args are given the first is the pathname of the segment to be converted.
   If one more arg is given the converted copy will replace the original.
   If two more args are given then the converted copy will be placed in arg2.

   The entries below set max_nargs to 2.
   Only one more arg may be given, either the from_string or the to_string.
   */

/* This entry causes from string to be reset */

convert_from:
	fs_flag = "1"b;
	max_nargs = 2;go to start;

/* This entry causes to string to be reset */

convert_to:
	ts_flag = "1"b;
	max_nargs = 2;go to start;

/* The body of the command starts here. */
start:						/* all keys come here except "sp" */
	if nargs = 1 then do;
	     if max_nargs = 3 then go to print_strings;	/* automatic copies have been set */
	     else do;				/* should have gotten a string to set */
		code = error_table_$noarg;		/* set up status code */
error:		call com_err_ (code, procname);	/* come here if nothing to say besides code */
		go to RETURN;			/* go through cleanup */
	     end;
	end;

got_nargs: if nargs > max_nargs then do;		/* here if nargs ^= 0 */
	     code = error_table_$too_many_args;		/* set status code */
	     go to error;				/* and print a simple message */
	end;

	call cu_$arg_ptr (2, argptr, arglen, code);	/* get ptr to arg we know is there */
	if code ^= 0 then go to error;		/* suprise */

	if max_nargs = 2 then do;			/* setting a string */
	     if arglen > 128 then do;			/* cmust not be too long */
		call com_err_ (0, procname, "The string length (^d) exceeds 128 characters.", arglen);
		return;				/* nothing to clean up */
	     end;
	     if fs_flag then static_from_string = argbuf; /* copy arg to proper */
	     else if ts_flag then static_to_string = argbuf; /* internal static string */
	     return;				/* and just return */
	end;

	if sp_flag & length (from_string) ^= length (to_string) then do; /* be sensible */
	     code = error_table_$action_not_performed;	/* let user know nothing happened */
	     call com_err_ (code, procname, "^/Length of from_string (^d) is not equal to length of to_string (^d).",
		length (from_string), length (to_string)); /* give useful information */
	     return;				/* and give up */
	end;
	call expand_path_ (argptr, arglen, addr (dir), addr (entry), code); /* get absolute pathname */
	if code ^= 0 then do;			/* can't */
error_tell_arg: call com_err_ (code, procname, argptr -> argbuf); /* here to tell user which arg loses */
	     go to RETURN;				/* go through cleanup */
	end;

	call establish_cleanup_proc_ (cleanup);		/* dont leave a mess in any case */

	call hcs_$initiate_count (dir, entry, "", btcnt, 1, inptr, code); /* get ptr to seg to be converted */
	if inptr = null then do;			/* could not initiate if */
error_tell_dirent: call com_err_ (code, procname, "^a>^a", dir, entry); /* here to tell losing pathname */
	     go to RETURN;				/* go though cleanup */
	end;
	charnum = divide (btcnt+8, 9, 24, 0);		/* compute number of characters */

	tempname = "cvc_temp." || unique_chars_ ("0"b);	/* name for temp seg is reasonable & unique */
	call hcs_$make_seg ("", tempname, "", 1011b, tempptr, code); /* create a temporary seg */
	if tempptr = null then do;			/* could not create it */
	     call com_err_ (code, procname,		/* tell user what happened */
		"Unable to create ^a in process directory.", tempname); /* and why */
	     go to RETURN;				/* go through cleanup */
	end;

	if nargs = 3 then do;			/* don't write back into original seg */
	     call cu_$arg_ptr (3, argptr, arglen, code);	/* get name of output seg */
	     if code ^= 0 then go to error;		/* give simple message and return */
	     call expand_path_ (argptr, arglen, addr (dir), addr (entry), code); /* convert arg to abs path */
	     if code ^= 0 then go to error_tell_arg;	/* print errmessage, which arg lost, and return */
	     call hcs_$make_seg (dir, entry, "", 1011b, outptr, code); /* create output seg if does not exist */
	     if outptr = null then go to error_tell_dirent; /* tell dir and entry since we know which */
	end;
	else outptr = inptr;			/* modify original seg */

/* Here we do conversion.  to take advantage of EIS we convert large
blocks at a time.  To take advantage of the MVT instruction we must
use constants in the translate builtin. */
	do j = 1 to charnum by 16384;
	     i = min (16384, charnum-j+1);

	     if bcd_flag then
		substr (tempptr -> string, 1, i) = translate
		(substr (inptr -> string, 1, i), "abcdefghijklmnopqrstuvwxyz()=+", "ABCDEFGHIJKLMNOPQRSTUVWXYZ%<#&");
	     else if dart_flag then
		substr (tempptr -> string, 1, i) = translate
		(substr (inptr -> string, 1, i), "^_>+='{""?", "'=""<>:+?!");
	     else if lc_flag then
		substr (tempptr -> string, 1, i) = translate
		(substr (inptr -> string, 1, i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	     else if uc_flag then
		substr (tempptr -> string, 1, i) = translate
		(substr (inptr -> string, 1, i), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");
	     else if mult_flag then
		substr (tempptr -> string, 1, i) = translate
		(substr (inptr -> string, 1, i), "abcdefghijklmnopqrstuvwxyz	""", "ABCDEFGHIJKLMNOPQRSTUVWXYZ '");
	     else if sp_flag then
		substr (tempptr -> string, 1, i) = translate
		(substr (inptr -> string, 1, i), to_string, from_string);
	     tempptr = addrel (tempptr, 4096);
	     inptr = addrel (inptr, 4096);
	end;
	call hcs_$set_bc_seg (tempptr, 9*charnum, bcode); /* in case of trouble later */

	tempptr = ptr (tempptr, 0);
	call hcs_$fs_move_seg (tempptr, outptr, 1, code); /* truncate out seg, copy temp, trunc temp */
	if code ^= 0 then do;			/* somehow failed */
	     tempptr = null;			/* so we won't delete temp */
	     call com_err_ (code, procname, "^/Converted copy ^a is in process directory.", tempname); /* tell user all is not lost */
	     if bcode ^= 0 then call com_err_ (bcode, procname, tempname); /* warn if bcnt not set on temp */
	     go to RETURN;				/* cleanup and leave */
	end;

	if outptr ^= inptr then do;			/* if same following steps not needed */
	     call hcs_$set_bc_seg (outptr, 9*charnum, code); /* set btcnt on output seg */
	     if code ^= 0 then go to error_tell_dirent;	/* could not set btcnt, tell user the segments name */
	end;

RETURN:						/* come here to exit if anything to cleanup */
	call cleanup;				/* use handy internal proc */

	return;					/* now we can return */
print_strings:					/* here to print strings */
	call ioa_ ("From string = ""^a""", from_string); /* first one */
	call ioa_ ("  To string = ""^a""^/", to_string);	/* then other */
	return;					/* and all is done */

/* --------------------------------------------------------------------------- */

cleanup:	proc;
	     if tempptr ^= null then call hcs_$delentry_seg (tempptr, code); /* delete temp seg */
	     if outptr ^= null then if inptr ^= outptr then call hcs_$terminate_noname (outptr, code);
	     if inptr ^= null then call hcs_$terminate_noname (inptr, code); /* & terminate others */
	end cleanup;
     end convert_characters;




		    dump_segment.pl1                01/12/88  1305.7rew 01/12/88  1245.0      696249



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

dump_segment:
ds:
     proc;


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This command dumps the contents of a segment in octal, hex8, or hex9 with */
/* optional ascii, bcd, ebcdic9, ebcdic8, or 4-bit translation. The segment  */
/* to be dumped may be specified by octal segment number, SLT name,	       */
/* (relative) pathname.					       */
/*							       */
/* Usage:							       */
/*							       */
/*    dump_segment seg start count -control_args			       */
/* or:							       */
/*    dump_segment virtual_pointer count -control_args		       */
/*							       */
/* where:							       */
/*							       */
/* seg		is the segment to dump			       */
/* start		is the first word to dump			       */
/* count		is the number of words to dump		       */
/* virtual_pointer	is a pointer understood by cv_ptr_		       */
/*							       */
/* and control args can be:					       */
/*							       */
/* -long (-lg)						       */
/* -short (-sh)						       */
/* -character (-ch, -ascii)					       */
/* -bcd							       */
/* -ebcdic9						       */
/* -ebcdic8						       */
/* -4bit							       */
/* -name (-nm) path						       */
/* -hex8							       */
/* -hex9							       */
/* -block (-bk) N						       */
/* -address (-addr)						       */
/* -no_address (-nad, -naddr)					       */
/* -offset (-ofs) N						       */
/* -no_offset (-nofs)					       */
/* -header (-he)						       */
/* -no_header (-nhe)					       */
/* -entry_point (-ep) name					       */
/* -interpreted_data (-id)					       */
/* -no_interpreted_data (-nid)				       */
/* -raw_data (-rd)						       */
/* -no_raw_data (-nrd)					       */
/* -suppress_duplicates (-sd)					       */
/* -no_suppress_duplicates (nsd)				       */
/* -rest							       */
/* -as structure_name					       */
/* -in pathname						       */
/*							       */
/* Defaults for use as a command:				       */
/*   -no_offset, -raw_data, -no_interpreted_data, -suppress_duplicates       */
/* Defaults for use as an active function:			       */
/*   -no_header, -no_address, -no_offset, -raw_data, -no_interpreted_data    */
/*   -no_suppress_duplicates					       */
/*							       */
/* Last modified (date and reason):				       */
/* 5/15/75	by S.Webber Initial coding (discarding earlier code)     */
/* 11/15/75	by S.Webber to add -address, -offset, -header, and       */
/*			         -block control args		       */
/* 04/27/76	by T. Casey to fix "-block N -offset" to reset offset    */
/*			  for each block, to make -name N work right,  */
/* 			  to accept control argument abbreviations     */
/*			  -addr and -bk, and clean up code and fix     */
/*			  minor obscure bugs.		       */
/* 10/18/76 	by R.Kissel to add -ebcdic9, -ebcdic8, -4bit, -hex8,     */
/*			  hex9 to clean up code, and to change	       */
/*  			  the output format.		       */
/* 02/16/77	by R.Kissel to add the dump_segment_ subroutine entry    */
/*			  point.				       */
/* 01/16/79	by R.J.C. Kissel to fix error message bug.	       */
/* 06/22/79	by S. Herbst to fix error message for MSF's.	       */
/* 04/04/81	by W. Olin Sibert, to use			       */
/*			         ring_zero_peek_$get_max_length_ptr    */
/*			         instead of depending on SDW format.   */
/* 11/03/81	by J. Bongiovanni for -entry_point		       */
/* 09/26/83	by C. Spitzer				       */
/*		phx07028 return more than 1 word if invoked as AF.       */
/*		phx07253 add -raw_data -interpreted_data and complements */
/*		phx08128 use current length instead of max length.       */
/*		phx10338,phx12336 bugfix to print et_$dirseg for	       */
/*			        directories.		       */
/* 		phx08905 make -lg -hex9 -ch work together.	       */
/*		phx14729 correct display for -hex8 and hex9 format.      */
/*		suggestion: add -suppress_duplicates and complement      */
/*			        format.			       */
/*		bug: diagnose illegal CAs when used as active function.  */
/*		bug: correct display for -ch and incompletely filled line*/
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/****^  HISTORY COMMENTS:
  1) change(85-12-17,Spitzer), approve(85-12-17,MCR7119),
     audit(86-01-20,Lippard), install(86-01-29,MR12.0-1009):
     Make -ep work same as octal offsets. Allow rzd dump stack_0.  Add -rest
     CA.
  2) change(85-12-17,Spitzer), approve(85-12-17,MCR7268),
     audit(86-01-20,Lippard), install(86-01-29,MR12.0-1009):
     Allow virtual pointers as input.
  3) change(86-07-30,Kissel), approve(86-07-30,MCR7476), audit(86-08-01,Ex),
     install(86-08-19,MR12.0-1132):
     Changed to call translate_bytes_to_hex9_, which is the new name for
     translate_to_hex9.
  4) change(87-01-02,TLNguyen), approve(87-01-02,MCR7596),
     audit(87-01-16,GWMay), install(87-03-19,MR12.1-1004):
     Fixed the "dump_segment" active function to strip trailing spaces.
  5) change(87-11-26,GDixon), approve(88-01-05,MCR7817),
     audit(88-01-06,Farley), install(88-01-12,MR12.2-1012):
      A) Add -as and -in to display data as a structure.
                                                   END HISTORY COMMENTS */

%page;

/* Automatic */

	dcl     active_func		 bit (1) aligned;
	dcl     arg_for_header_given
				 bit (1);
	dcl     argc		 fixed bin;
	dcl     bit_count		 fixed bin (24);
	dcl     block		 fixed bin (18);
	dcl     buffer		 (64) fixed bin;
	dcl     code		 fixed bin (35);
	dcl     count		 fixed bin (18);
	dcl     cur_length		 fixed bin (18);
	dcl     defn_ptr		 ptr;
	dcl     dir_len		 fixed bin;
	dcl     dirname		 char (168);
	dcl     ename		 char (32);
	dcl     entry_point_name	 char (32);
	dcl     entry_point_offset	 fixed bin (18);
	dcl     entry_type		 fixed bin;
	dcl     entry_var		 entry variable options (variable);
	dcl     first		 fixed bin (18);
	dcl     have_count		 bit (1);
	dcl     have_entry_point	 bit (1);
	dcl     have_first		 bit (1);
	dcl     have_name		 bit (1);
	dcl     have_structure	 bit (1);
	dcl     have_structure_path	 bit (1);
	dcl     hcsp		 (1) ptr;
	dcl     hc_seg		 bit (1);
	dcl     highseg		 fixed bin;
	dcl     i			 fixed bin;
	dcl     initsw		 bit (1);
	dcl     iocbp		 ptr;
	dcl     line_format		 char (28) var;
	dcl     max_length		 fixed bin (19);
	dcl     1 obj_info		 aligned like object_info;
	dcl     p			 ptr;		/* pointer to the segment we are dumping */
	dcl     rel_offset		 fixed bin (18);
	dcl     rest		 bit (1) aligned;
	dcl     ret_tc		 fixed bin (21);
	dcl     ret_tp		 ptr;
	dcl     output_line_len	 fixed bin (21);
	dcl     output_line		 char (256);
	dcl     rz_call		 bit (1);
	dcl     rb2		 bit (6);		/* third ring bracket number */
	dcl     segno		 fixed bin (18);
	dcl     seg_num		 bit (1);
	dcl     structure_name	 char(256) varying; /* name of structure to dump. */
	dcl     structure_path	 char(168);	/* pathname of object pgm compiled with -table */
	dcl     tc		 fixed bin;	/* count of chars in command_arg */
	dcl     tca		 fixed bin;	/* count of chars in seg_name */
	dcl     tp		 ptr;		/* pointer to command_arg */
	dcl     tpa		 ptr;		/* pointer to seg_name */

/* Format control flags */

%include dump_segment_format;
	dcl     address_fmt		 bit (1) defined (dump_segment_format) pos (1);
	dcl     offset_fmt		 bit (1) defined (dump_segment_format) pos (2);
	dcl     short_fmt		 bit (1) defined (dump_segment_format) pos (3);
	dcl     bcd_fmt		 bit (1) defined (dump_segment_format) pos (4);
	dcl     char_fmt		 bit (1) defined (dump_segment_format) pos (5);
	dcl     long_fmt		 bit (1) defined (dump_segment_format) pos (6);
	dcl     ebcdic9_fmt		 bit (1) defined (dump_segment_format) pos (7);
	dcl     ebcdic8_fmt		 bit (1) defined (dump_segment_format) pos (8);
	dcl     bit4_fmt		 bit (1) defined (dump_segment_format) pos (9);
	dcl     hex8_fmt		 bit (1) defined (dump_segment_format) pos (10);
	dcl     hex9_fmt		 bit (1) defined (dump_segment_format) pos (11);
	dcl     octal_fmt		 bit (1) defined (dump_segment_format) pos (12);
	dcl     header		 bit (1) defined (dump_segment_format) pos (13);
	dcl     raw_data_fmt	 bit (1) defined (dump_segment_format) pos (14);
	dcl     interpreted_data_fmt	 bit (1) defined (dump_segment_format) pos (15);
	dcl     suppress_dup_fmt	 bit (1) defined (dump_segment_format) pos (16);
	dcl     command_output_fmt	 bit (1) defined (dump_segment_format) pos (17);

/* Based */

	dcl     command_arg		 char (tc) based (tp);
	dcl     seg_name		 char (tca) based (tpa);
	dcl     return_arg		 char (ret_tc) based (ret_tp) var;

/* Conditions */

	dcl     linkage_error	 condition;
	dcl     cleanup		 condition;
	dcl     not_in_read_bracket
				 condition;

/* Static */

	dcl     dots		 char (33) aligned internal static options (constant) init ((33)".");
	dcl     first_time		 bit (1) static init ("1"b);
	dcl     nonprinting_chars	 char (33) aligned internal static;
	dcl     com_err_fmt		 (25) char (80) var options (constant) static
				 init ("", "^a", "^s^a>^a", "Nonoctal number: ^a", "name/no of segment",
				 "Hardcore segment won't be dumped.", "block size for dumping", "Zero is illegal for count",
				 "First word is ^4s^o, max_length is only ^o", "No control arguments specified to dump any data.",
				 "Control arguments were specified to dump both raw and interpreted data.", "-hex8 and -hex9.",
				 "entry_point name", "^2s^a$^a", "^1s^a>^a$^a",
				 "word count and -entry_point", "Nonpositive octal number: ^a",
				 "Attempt to dump before the beginning of the referenced segment.",
				 "Count argument and -rest.", 
				 "-as must be followed by a structure name.",
				 "-in must be followed by path of object segment.",
				 "-as not allowed with active function.",
				 "Parsing structure ^6s^a.",
				 "Searching for structure ^6s^a in ^[^a^;library^].",
				 "Displaying structure ^6s^a.");
	dcl     active_all_rings_data_$stack_base_segno fixed bin (35) ext static;
	dcl     hcscnt		 fixed bin static;
	dcl     NL		 char (1) int static options (constant) init ("
");
	dcl     me		 (0:1) char (14) internal static options (constant)
				 init ("dump_segment", "ring_zero_dump");

/* External */

	dcl     error_table_$badopt	 fixed bin (35) ext;
	dcl     error_table_$dirseg	 fixed bin (35) ext;
	dcl     error_table_$inconsistent fixed bin(35) ext static;
	dcl     error_table_$lower_ring fixed bin (35) ext;
	dcl     error_table_$msf	 fixed bin (35) ext;
	dcl     error_table_$no_s_permission fixed bin (35) ext;
	dcl     error_table_$noarg	 fixed bin (35) ext;
	dcl     error_table_$too_many_args fixed bin (35) ext;

	dcl     iox_$user_output	 ptr ext;

/* Builtin */

	dcl     (addr, addrel, baseno, baseptr, binary, clock, collate,
	         divide, fixed, index, length, min, mod, null, rel, ptr,
	         reverse, rtrim, search, substr, string, translate, wordno,
	         unspec, verify) builtin;

/* Entries */

	dcl     get_temp_segments_	 entry (char (*), (*) ptr, fixed bin (35));
	dcl     release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     initiate_file_	 entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl     phcs_$initiate	 entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
	dcl     requote_string_	 entry (char(*)) returns(char(*));
	dcl     (ioa_$ioa_switch, com_err_, active_fnc_err_)
				 entry options (variable);
	dcl     hcs_$fs_get_path_name  entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$high_low_seg_count
				 entry (fixed bin, fixed bin);
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2),
				 fixed bin (24), fixed bin (35));
	dcl     ring0_get_$segptr	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     ring0_get_$definition entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35));
	dcl     ring0_get_$name	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     ring_zero_peek_	 entry (ptr, ptr, fixed bin (18), fixed bin (35));
	dcl     ring_zero_peek_$get_max_length_ptr
				 entry (ptr, fixed bin (19), fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));
	dcl     cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
	dcl     (ioa_$rs, ioa_$rsnnl)	 entry options (variable);
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     cv_oct_check_	 entry (char (*), fixed bin (35)) returns (fixed bin);
	dcl     translate_bytes_to_hex9_	 entry (bit (*), char (*));
	dcl     get_ring_		 entry returns (fixed bin (3));
	dcl     get_definition_	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35));
	dcl     display_data_$for_azm  entry (ptr, bit(*) aligned, (*) char(*) var,
				 fixed bin, ptr, ptr, fixed bin(18), ptr, ptr, (2,*) fixed bin(24),
				 fixed bin, fixed bin(35));
	dcl     structure_find_$pathname
		        		 entry (char(*), char(*), ptr, fixed bin(35));
	dcl     structure_find_$search entry (char(*), ptr, fixed bin(35));
	dcl     structure_ref_$parse   entry (char(*), char(*), char(*), (2,*) fixed bin(24),
				 fixed bin, (*) char(*) var, fixed bin, fixed bin(35));
%page;
	rz_call = "0"b;

	goto COMMON_CODE;				/* dump_segment entry */

ring_zero_dump:
rzd:
     entry;

	rz_call = "1"b;				/* indicate it is legal to dump ring 0 segs */

COMMON_CODE:
	if first_time
	then do;					/* only once get segment number of last hardcore segment */
		call hcs_$high_low_seg_count (highseg, hcscnt);
						/* so we can know if the given seg is hardcore or not */
		nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1);
		first_time = "0"b;
	     end;


/* Initialize */

	string (dump_segment_format) = ""b;		/* initialize all the format flags to 0 */
	iocbp = iox_$user_output;
	have_name, seg_num, have_first, have_count, have_entry_point,
	     have_structure, have_structure_path, initsw,
	     arg_for_header_given, hc_seg = "0"b;
	rest = "0"b;
	rel_offset = 0;
	entry_point_offset = 0;
	block = 0;
	max_length = 0;
	hcsp (1) = null;
	tp = null;
	tc = 0;

	call cu_$af_return_arg (argc, ret_tp, ret_tc, code);
						/* see if active function, also get return string info */
	if code = 0
	then do;
		active_func = "1"b;			/* active function call */
		raw_data_fmt = "1"b;
		return_arg = "";
	     end;
	else do;
		active_func = "0"b;			/* command call */
		address_fmt, raw_data_fmt, suppress_dup_fmt = "1"b;
	     end;

	if argc = 0
	then call PRINT_ERROR (error_table_$noarg, 5);	/* need at least a segment name */

	on cleanup
	     call cleaner_upper;

/* Loop through all arguments setting flags and variables */

	do i = 1 to argc;
	     call get_arg_ptr (i);			/* get pointer and length of i'th arg */
	     if index (command_arg, "-") = 1
	     then do;				/* process control arguments */
		     if (command_arg = "-long" | command_arg = "-lg") & ^active_func
		     then do;
			     long_fmt = "1"b;
			     short_fmt = "0"b;
			end;
		     else if (command_arg = "-suppress_duplicates" | command_arg = "-sd") & ^active_func
		     then suppress_dup_fmt = "1"b;
		     else if command_arg = "-no_suppress_duplicates" | command_arg = "-nsd"
		     then suppress_dup_fmt = "0"b;
		     else if command_arg = "-raw"
		     then raw_data_fmt = "1"b;
		     else if command_arg = "-no_raw" | command_arg = "-nraw"
		     then raw_data_fmt = "0"b;
		     else if command_arg = "-rest"
		     then rest = "1"b;
		     else if command_arg = "-interpreted" | command_arg = "-it"
		     then interpreted_data_fmt = "1"b;
		     else if command_arg = "-no_interpret" | command_arg = "-nit"
		     then interpreted_data_fmt = "0"b;
		     else if command_arg = "-character" | command_arg = "-ch" | command_arg = "-ascii"
		     then do;
			     char_fmt, interpreted_data_fmt = "1"b;
			     bit4_fmt, ebcdic8_fmt, ebcdic9_fmt, bcd_fmt = "0"b;
			     if active_func
			     then raw_data_fmt = "0"b;
			end;
		     else if command_arg = "-bcd"
		     then do;
			     bcd_fmt, interpreted_data_fmt = "1"b;
			     char_fmt, bit4_fmt, ebcdic8_fmt, ebcdic9_fmt = "0"b;
			     if active_func
			     then raw_data_fmt = "0"b;
			end;
		     else if command_arg = "-ebcdic9"
		     then do;
			     ebcdic9_fmt, interpreted_data_fmt = "1"b;
			     char_fmt, bit4_fmt, ebcdic8_fmt = "0"b;
			     if active_func
			     then raw_data_fmt = "0"b;
			end;
		     else if command_arg = "-ebcdic8"
		     then do;
			     ebcdic8_fmt, interpreted_data_fmt = "1"b;
			     char_fmt, bit4_fmt, ebcdic9_fmt = "0"b;
			     if active_func
			     then raw_data_fmt = "0"b;
			end;
		     else if command_arg = "-4bit"
		     then do;
			     bit4_fmt, interpreted_data_fmt = "1"b;
			     char_fmt, ebcdic8_fmt, ebcdic9_fmt = "0"b;
			     if active_func
			     then raw_data_fmt = "0"b;
			end;
		     else if command_arg = "-hex8"
		     then do;
			     hex8_fmt, raw_data_fmt = "1"b;
			     hex9_fmt, octal_fmt = "0"b;
			     if active_func
			     then interpreted_data_fmt = "0"b;
			end;
		     else if command_arg = "-hex9"
		     then do;
			     hex9_fmt, raw_data_fmt = "1"b;
			     hex8_fmt, octal_fmt = "0"b;
			     if active_func
			     then interpreted_data_fmt = "0"b;
			end;
		     else if command_arg = "-octal" | command_arg = "-oc"
		     then do;
			     octal_fmt, raw_data_fmt = "1"b;
			     hex8_fmt, hex9_fmt = "0"b;
			     if active_func
			     then interpreted_data_fmt = "0"b;
			end;
		     else if (command_arg = "-short" | command_arg = "-sh") & ^active_func
		     then do;
			     short_fmt = "1"b;
			     long_fmt = "0"b;
			end;
		     else if (command_arg = "-address" | command_arg = "-ad" | command_arg = "-addr") & ^active_func
		     then address_fmt = "1"b;
		     else if (command_arg = "-no_address" | command_arg = "-naddr" | command_arg = "-nad") & ^active_func
		     then address_fmt = "0"b;
		     else if (command_arg = "-offset" | command_arg = "-ofs") & ^active_func
		     then do;
			     offset_fmt = "1"b;
			     if i < argc
			     then do;
				     call get_arg_ptr (i + 1);
						/* check next arg, if octal then use as offset */
				     rel_offset = cv_oct_check_ (command_arg, code);
				     if code = 0
				     then i = i + 1;/* if octal, advance arg index past it */
				     else rel_offset = 0;
						/* else leave arg index alone and use default of zero */
				end;
			end;
		     else if (command_arg = "-no_offset" | command_arg = "-nofs") & ^active_func
		     then offset_fmt = "0"b;
		     else if (command_arg = "-header" | command_arg = "-he") & ^active_func
		     then header = "1"b;
		     else if (command_arg = "-no_header" | command_arg = "-nhe") & ^active_func
		     then do;
			     header = "0"b;
			     arg_for_header_given = "1"b;
			end;
		     else if (command_arg = "-block" | command_arg = "-bk") & ^active_func
		     then do;
			     if i < argc
			     then do;		/* next argument is the block size */
				     call get_arg_ptr (i + 1);
				     block = cv_oct_check_ (command_arg, code);
				     if code = 0
				     then i = i + 1;
				     else call PRINT_ERROR (0, 4); /* block size is non-octal */
				end;		/* next argument is the block size */
			     else call PRINT_ERROR (error_table_$noarg, 7);    /* no argument given for the block size */
			end;
		     else if command_arg = "-name" | command_arg = "-nm"
		     then do;
			     if i < argc
			     then do;		/* next argument is the segment name */
				     call get_arg_ptr (i + 1);
				     tca = tc;	/* remember name of segment */
				     tpa = tp;	/* in seg_name        */
				     have_name = "1"b;
				     i = i + 1;
				end;		/* next argument is the segment name */
			     else call PRINT_ERROR (error_table_$noarg, 7);    /* no argument given with -name */
			end;
		     else if command_arg = "-entry_point" | command_arg = "-ep"
		     then do;
			     if i < argc
			     then do;
				     call get_arg_ptr (i + 1);
				     have_entry_point = "1"b;
				     entry_point_name = command_arg;
				     i = i + 1;
				end;
			     else call PRINT_ERROR (error_table_$noarg, 13);
			end;
		     else if command_arg = "-as" then do;
			     if i < argc
			     then do;
				     have_structure = "1"b;
				     call get_arg_ptr (i + 1);
				     structure_name = command_arg;
				     i = i + 1;
				end;
			     else call PRINT_ERROR (error_table_$noarg, 20);
			end;
		     else if command_arg = "-in" then do;
			     if i < argc
			     then do;
				     have_structure_path = "1"b;
				     call get_arg_ptr (i + 1);
				     structure_path = command_arg;
				     i = i + 1;
				end;
			     else call PRINT_ERROR (error_table_$noarg, 21);
			end;
		     else do;
			     if verify (command_arg, "-0123456789") = 0
			     then goto NON_CONTROL_ARG;
			     else call PRINT_ERROR (error_table_$badopt, 2);   /* bad control argument */
			end;
		end;				/* process control arguments */
	     else do;				/* process non-control arguments */

NON_CONTROL_ARG:
		     if ^have_name
		     then do;			/* segment name, number or virtual pointer is the first non-control argument */
			segno = cv_oct_check_ (command_arg, code);
			if code = 0
			then do;			/* segment number given */
			     if segno < 0 then call PRINT_ERROR (0, 17);
			     have_name = "1"b;
			     tca = tc;
			     tpa = tp;
			     seg_num = "1"b;
			     if segno < hcscnt
			     then do;		/* do check for a hc segment */
				if rz_call
				then hc_seg = "1"b;
				else call PRINT_ERROR (0, 6);
						/* rzd must be used to dump a hc segment */
				end;		/* do check for hc segment */
			     end;			/* segment number given */
			else do;			/* pathname or SLT name given */
			     have_name = "1"b;
			     tca = tc;		/* remember the segment name */
			     tpa = tp;		/* in seg_name         */
			     end;			/* pathname or SLT name given */
		          end;			/* segment name or number is the first non-control argument */
		     else if ^have_first
		     then do;			/* first word is the second non-control argument */
			     first = cv_oct_check_ (command_arg, code);
			     if code ^= 0
			     then call PRINT_ERROR (0, 4); /* non-octal number for first */
			     have_first = "1"b;
			end;			/* first word is the second non-control argument */
		     else if ^have_count
		     then do;			/* count is the third non-control argument */
			     count = cv_oct_check_ (command_arg, code);
			     if code ^= 0
			     then call PRINT_ERROR (0, 4); /* non-octal number for count */
			     if count < 0 then call PRINT_ERROR (0, 17);
			     have_count = "1"b;
			end;			/* count is the third non-control argument */
		     else call PRINT_ERROR (error_table_$too_many_args, 2); /* four non-control arguments is an error */
		end;				/* process non-control arguments */
	end;					/* do loop thru command arguments */

/* Check for legal formats and finish setting variables */

          if have_structure then
	   raw_data_fmt = (octal_fmt | hex8_fmt | hex9_fmt);

	if ^raw_data_fmt & ^interpreted_data_fmt & ^have_structure
	then call PRINT_ERROR (0, 10);		/* asked to do nothing */

	if have_structure & active_func		/* structures not allowed in AF output.*/
	then call PRINT_ERROR (0, 22);

	if raw_data & interpreted_data_fmt & active_func
	then call PRINT_ERROR (0, 11);		/* asked for both as an AF */

	if rest & have_count
	then call PRINT_ERROR (error_table_$inconsistent, 19);

          if raw_data_fmt & (^hex8_fmt & ^hex9_fmt & ^octal_fmt)
	then octal_fmt = "1"b;			/* default raw data */

	if interpreted_data_fmt & (^bit4_fmt & ^bcd_fmt & ^char_fmt & ^ebcdic8_fmt & ^ebcdic9_fmt)
	then char_fmt = "1"b;			/* default interpreted data */

	if ^have_name
	then call PRINT_ERROR (error_table_$noarg, 5);	/* segment must be specified */
	else do;					/* obtain information about specified segment */
		if seg_num
		then do;				/* segment was specified by number in segno */
			p = baseptr (segno);
			if segno < hcscnt
			then do;			/* this is a hc segment number */
				if rz_call
				then do;		/* rzd ok with hc segments */
					call ring0_get_$name (dirname, ename, p, code);
					if code ^= 0 then call PRINT_ERROR (code, 1);
					call set_max_from_SDW;
					cur_length = max_length;
				     end;		/* rzd ok with hc segments */
				else call PRINT_ERROR (0, 6); /* ds cannot be used with hc segments */
			     end;			/* this is a hc segment number */
			else if segno = active_all_rings_data_$stack_base_segno
			     then do;		/* special case stack_0 */
				     dirname = "";
				     ename = "stack_0";
				     call set_max_from_SDW;
				     cur_length = max_length;
				end;
			else do;			/* this is a user segment number */
				call hcs_$fs_get_path_name (p, dirname, dir_len, ename, code);
				if code ^= 0
				then do;		/* bad number specified */
					tp = tpa;
					tc = tca;
					call PRINT_ERROR (code, 2);
				     end;		/* bad number specified */
				if dirname = " "
				then dirname = ">"; /* handle the root special case */
				call set_curlng_and_rb;
			     end;			/* this is a user segment number */
		     end;				/* segment was specified by number in segno */
		else do;				/* segment was specified by SLT or pathname in seg_name */
			if rz_call
			then do;			/* try SLT name first for rzd call */
				call ring0_get_$segptr ("", seg_name, p, code);
				if p ^= null
				then do;		/* SLT name, get length from SDW */
					segno = fixed (baseno (p), 18);
					hc_seg = "1"b;
					call set_max_from_SDW;
					cur_length = max_length;
					ename = seg_name;
				     end;		/* SLT name, get length from SDW */
				else call process_name;  /* must be a pathname or a virtual pointer */
			     end;			/* try SLT name first for rzd call */
			else call process_name;	/* must be a pathname or virtual pointer */
		     end;				/* segment was specified by SLT or pathname in seg_name */
	     end;					/* obtain information about the specified segment */
	if have_entry_point
	then do;
		if hc_seg
		then do;
			call ring0_get_$definition (p, "", entry_point_name, entry_point_offset, entry_type, code);
			if code ^= 0 then call PRINT_ERROR (code, 14);
		     end;
		else do;
			call hcs_$status_minf (dirname, ename, 1, 0, bit_count, code);
			if code ^= 0
			then call PRINT_ERROR (code, 5);

			on not_in_read_bracket
			     call PRINT_ERROR (error_table_$lower_ring, 15);
			call object_info_$brief (p, bit_count, addr (obj_info), code);
			revert not_in_read_bracket;
			if code ^= 0
			then call PRINT_ERROR (code, 15);
			call get_definition_ (obj_info.defp, "", entry_point_name, defn_ptr, code);
			if code ^= 0 then call PRINT_ERROR (code, 15);
			entry_point_offset = binary (defn_ptr -> definition.value, 18);
		     end;
		if ^have_count & ^have_structure
		then do;				/* make it look like we did have a count of 1 word */
		          if ^have_first
			then do;
			          first = 0;
				have_first = "1"b;
			     end;
			count = 1;
			have_count = "1"b;
		     end;
	     end;
	if max_length = 0
	then do;					/* set max_length if it has'nt been done already */
		max_length = cur_length;		/* set highest dumped address to current length of */
						/* segment as guarenteed to be highest used page. */
	     end;					/* set max_length if it has'nt been done already */
	if have_structure & ^have_first
	then do;
		first = 0;
		have_first = "1"b;
	     end;

	if have_structure & ^have_count
	then do;
		count = cur_length - first;
		have_count = "1"b;
	     end;

	if ^have_first
	then do;					/* don't have first or count */
		if ^arg_for_header_given
		then header = "1"b;			/* include header when dumping the whole segment */
		first = 0;
		count = max_length;			/* default to seg length for command */
		have_first = "1"b;
	     end;					/* don't have first or count */
	else if ^have_count
	then do;					/* have first but don't have count */
		if rest
		then count = max_length;
		else count = 1;
		have_count = "1"b;
	     end;					/* have first but don't have count */
	first = first + entry_point_offset;
	if first >= max_length
	then call PRINT_ERROR (0, 9);			/* can't dump past the end of the segment */
	else if first < 0
	     then call PRINT_ERROR (0, 18);		/*   or before the beginning of the segment */
	if first + count > max_length
	then do;					/* only dump to max_length with no error indicated */
		count = max_length - first;
	     end;
	if block = 0 | block > count
	then block = count;				/* set words per block if it has'nt been done yet */

	if binary (rb2) < get_ring_ ()
	then do;					/* make a final access check */
		if rz_call
		then hc_seg = "1"b;
		else call PRINT_ERROR (0, 6);		/* error for ds call */
	     end;					/* make a final access check */

/* Now print what we are told to */


	if hc_seg
	then do;					/* output for hc segment */
		if count <= 64
		then hcsp (1) = addr (buffer);
		else do;				/* get a temp seg to copy the hc seg into */
			call get_temp_segments_ (me (binary (rz_call)), hcsp, code);
			if code ^= 0
			then call PRINT_ERROR (code, 1);	/* no temp segments available */
		     end;				/* get a temp seg to copy the hc seg into */
		call ring_zero_peek_ (addrel (p, first), hcsp (1), count, code);
		if code ^= 0
		then call PRINT_ERROR (code, 1);	/* we failed */

		if active_func
		then call return_dump (hcsp (1), first, count, cur_length, rel_offset);
		else call print_dump (hcsp (1), first, count, cur_length, block, rel_offset);

	     end;					/* output for hc segment */

	else do;					/* output for user segment */
		if active_func
		then call return_dump (addrel (p, first), first, count, cur_length, rel_offset);
		else call print_dump (addrel (p, first), first, count, cur_length, block, rel_offset);
						/* output for user segment */
	     end;					/* output for user segment */

	if active_func
	then return_arg = requote_string_ (rtrim (return_arg));
 /* fixed TR number 20051: want returned string without strailing spaces. */
CLEANUP:
	call cleaner_upper;
	return;
%page;
PRINT_ERROR:					/* come here to print all com_err_ messages. */
     proc (code, com_err_fmt_index);

dcl code fixed bin (35) parameter;
dcl com_err_fmt_index fixed bin parameter;

	if active_func
	then entry_var = active_fnc_err_;
	else entry_var = com_err_;
	if com_err_fmt_index = 3 then do;
		if code = error_table_$dirseg then do;
			bit_count = 0;
			call hcs_$status_minf (dirname, ename, 1, 0, bit_count, code);
			if code = 0
			then if bit_count ^= 0
			     then code = error_table_$msf;
			     else code = error_table_$dirseg;
			else code = error_table_$dirseg; /* couldn't get status on it, leave alone */
		     end;
	     end;
	if dirname = ">" then dirname = "";
	call entry_var (code, me (binary (rz_call)), com_err_fmt (com_err_fmt_index),
	     command_arg, dirname, ename, entry_point_name, first, max_length,
	     structure_name, have_structure_path, structure_path);
	goto CLEANUP;

	end PRINT_ERROR;
%page;

cleaner_upper:
     proc;

	if initsw & (^hc_seg)
	then call terminate_file_ (p, 0, TERM_FILE_TERM, code);
	if hcsp (1) ^= null
	then call release_temp_segments_ (me (binary (rz_call)), hcsp, code);
     end cleaner_upper;

%page;
process_name:
     proc;

/* Global variables used:
   Input:   seg_name char(tca) based(tpa)
	  hcscnt   fixed bin internal static
   Output:  dirname char (168)
	  ename   char (32)
	  p       pointer
	  segno   fixed bin (18)
	  initsw   bit (1)
	  hc_seg   bit (1)
*/

	tc = tca;					/* initialize for error messages */
	tp = tpa;

	call expand_pathname_ (seg_name, dirname, ename, code);
	if code = 0 then do;
	     call initiate_file_ (dirname, ename, R_ACCESS, p, (0), code);
	     if p ^= null then do;
		initsw = "1"b;
		segno = binary (baseno (p), 18);
		call set_curlng_and_rb;
		end;
	     else goto TRY_SEGNAME_AS_VIRTUAL_POINTER;
	     end;
	else do;
TRY_SEGNAME_AS_VIRTUAL_POINTER:
	     if rz_call				/* try through phcs_ */
	     then do;
		on linkage_error
		     call PRINT_ERROR (0, 2);		/* in case no access to gate */
		
		call phcs_$initiate (dirname, ename, "", 0, 0, p, code);
		revert linkage_error;

		if p = null
		then do;				/* try it as a virtual pointer */
		     p = cv_ptr_ (seg_name, code);
		     if code ^= 0
		     then call PRINT_ERROR (code, 2);
		     end;

		segno = binary (baseno (p), 18);
		call set_max_from_SDW;
		cur_length = max_length;
		end;
	     else do;
		p = cv_ptr_ (seg_name, code);
		if code ^= 0
		then call PRINT_ERROR (code, 2);

		call hcs_$fs_get_path_name (p, dirname, dir_len, ename, code);
		if code ^= 0
		then call PRINT_ERROR (code, 2);

		segno = binary (baseno (p), 18);
		call set_curlng_and_rb;
		end;
	     end;

	if segno < hcscnt
	then hc_seg = "1"b;				/* hardcore segment */

	if have_first
	then first = first + wordno (p);
	else do;
	     first = wordno (p);
	     have_first = (first ^= 0);
	     end;
	p = ptr (p, 0);				/* point p to base of segment */
	have_name, seg_num = "1"b;

	return;
     end process_name;
%page;
get_arg_ptr:
     proc (argno);

/* This procedure MUST be quick internal */

/* Uses as input

   active_func bit (1)
*/

/* Sets

   tp    pointer (command_arg)
   tc    fixed bin (command_arg)
   code  fixed bin (35)
*/

/* Entries */

	dcl     cu_$af_arg_ptr	 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));

/* Automatic */

	dcl     argno		 fixed bin;

	if active_func
	then call cu_$af_arg_ptr (argno, tp, tc, code);
	else call cu_$arg_ptr (argno, tp, tc, code);

     end get_arg_ptr;

%page;

set_curlng_and_rb:
     proc;

/* Uses as input

   dirname    char (168)
   ename        char (32)
   max_length   fixed bin (19)
*/

/* Sets and uses

   code fixed bin (35)
*/

/* Sets

   rb2		 bit (6)
   cur_length        fixed bin (19)
   com_err_fmt_index fixed bin
*/

/* Automatic */

%include branch_status;

/* External Variables */

	dcl     error_table_$root	 external;

/* Entries */

	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35));

	call hcs_$status_long (dirname, ename, 1, addr (branch_status), (null), code);
	if code = error_table_$root
	then do;					/* set cur_length of root using SDW */
		call set_max_from_SDW;		/* this is required because of a bug in hcs_$status_long */
		cur_length = max_length;
	     end;					/* set cur_length  of root using SDW */
	else if code = error_table_$no_s_permission | code = 0
						/* normal segment */
	then do;
		cur_length = fixed (branch_status.current_length, 12) * 1024;
		if cur_length = 0
		then cur_length = 1;
		if type = directory_type
		then rb2 = "0"b;			/* this is a dir so the rb given by status_ is a extended */
		else rb2 = ring_brackets (1);		/* other segment so ok */

/* ------------------------------------------------------------------------------------------------- */
/* The following must be eliminated when hcs_$status_ returns the ring brackets                    */

		if code = error_table_$no_s_permission
		then do;
			if rz_call
			then rb2 = "0"b;		/* assume ring_zero_peek must be used for rzd call */
			else do;			/* handle ds call */
				if mode ^= "0"b
				then rb2 = "111"b;	/* ds can look at it */
				else rb2 = "0"b;	/* ds cannot look at it */
			     end;			/* handle ds call */
		     end;

/* ------------------------------------------------------------------------------------------------- */
	     end;					/* normal segment */
	else call PRINT_ERROR (code, 3);		/* status failed for some reason */

     end set_curlng_and_rb;

%page;

set_max_from_SDW:
     proc;

/* Uses as input

   segno fixed bin (18)
*/

/* Sets

   code		 fixed bin (35)
   max_length	 fixed bin (19)
   com_err_fmt_index fixed bin
*/

	call ring_zero_peek_$get_max_length_ptr (baseptr (segno), max_length, code);
	if code ^= 0
	then call PRINT_ERROR (code, 1);		/* we failed */

	return;

     end set_max_from_SDW;

%page;
print_header:
     proc;

/* Uses as input

   header bit (1)
   segno  fixed bin (18)
   hcscnt fixed bin static
   dirname char (168)
   ename   char (32)
   p       pointer
*/

/* Sets and uses

   code fixed bin (35)
*/

/* Automatic */

	dcl     date_time		 char (24);
	dcl     name		 char (168);
	dcl     dlen		 fixed bin;

/* Entries */

	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     ring0_get_$name	 entry (char (*), char (*), ptr, fixed bin (35));


	call date_time_ (clock (), date_time);
	if segno < hcscnt
	then do;					/* header for hc seg */
		call ring0_get_$name ("", name, p, code);
		dlen = index (name, " ") - 1;
		name = "HARDCORE SEG -- " || substr (name, 1, dlen);
	     end;					/* header for hc seg */
	else if segno = active_all_rings_data_$stack_base_segno
	     then do;				/* special case stack_0 */
		name = "stack_0";
	     end;
	else do;					/* header for user seg */
		dlen = index (dirname, " ") - 1;
		if dlen <= 1
		then dlen = 0;			/* to avoid >>foo */
		if ename = "" & dirname = ""
		then name = "";			/* in case couldn't find the path out */
		else name = substr (dirname, 1, dlen) || ">" || ename;
	     end;					/* header for user seg */
	call ioa_$rs ("^/^2-^a^-^a^/", output_line, output_line_len, name, date_time);
	if active_func
	then return_arg = return_arg || substr (output_line, 1, output_line_len);
	else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code);

/* If no header is printed, no white space will be inserted  before the dump starts */

     end print_header;

%page;
translate_line_to_dump:
     proc (wds_in_line, line_ptr, translation);

/* Formal Parameters */

	dcl     wds_in_line		 fixed bin;
	dcl     line_ptr		 ptr;
	dcl     translation		 char (32) varying;

/* Automatic, structures for accessing the input line and subrutine return args */

	dcl     ascii_chars		 char (wds_in_line * 4) based (line_ptr);
	dcl     bcd_chars		 bit (wds_in_line * 36) based (line_ptr);
	dcl     ebcdic9_chars	 char (wds_in_line * 4) based (line_ptr);
	dcl     ebcdic8_chars	 bit (divide (wds_in_line * 9, 2, 17) * 36) based (line_ptr);
	dcl     fourbit_chars	 bit (wds_in_line * 36) based (line_ptr);

	dcl     overlay_return	 char (32);	/* used to make this a quick block */
	dcl     bcd_return		 char (wds_in_line * 6) based (addr (overlay_return));
	dcl     ebcdic9_return	 char (wds_in_line * 4) based (addr (overlay_return));
	dcl     ebcdic8_return	 char (divide (wds_in_line * 9, 2, 17)) based (addr (overlay_return));
	dcl     comp_8_return	 char (wds_in_line * 8) based (addr (overlay_return));

	dcl     i			 fixed bin;	/* character string index */
	dcl     temp_overlay	 char (32);	/* used to make this a quick block */
	dcl     temp_ascii		 char (length (ascii_chars)) based (addr (temp_overlay));
	dcl     temp_ebcdic9	 char (length (ebcdic9_chars)) based (addr (temp_overlay));

/* Constants */

	dcl     last_ascii		 char (1) aligned internal static options (constant) initial ("");
						/* last ascii char code */
	dcl     last_ebcdic		 char (1) aligned internal static options (constant) initial ("ÿ");
						/* last ebcdic char code */


/* Entries */

	dcl     bcd_to_ascii_	 entry (bit (*), char (*));
	dcl     ebcdic_to_ascii_	 entry (char (*), char (*));
	dcl     comp_8_to_ascii_	 entry (bit (*), char (*));
	dcl     ebcdic8_to_ascii_	 entry (bit (*), char (*));

	translation = "";

	if char_fmt
	then do;
		temp_ascii = ascii_chars;
		do i = 1 to length (ascii_chars) by 1;	/* set illegal characters to 0 */
		     if substr (ascii_chars, i, 1) > last_ascii
		     then substr (temp_ascii, i, 1) = "";
		end;				/* set illegal characters to 0 */
		translation = translate (temp_ascii, dots, nonprinting_chars);
	     end;

	else if bcd_fmt
	then do;
		call bcd_to_ascii_ (bcd_chars, bcd_return);
		translation = bcd_return;
	     end;

	else if ebcdic9_fmt
	then do;
		temp_ebcdic9 = ebcdic9_chars;
		do i = 1 to length (ebcdic9_chars) by 1;/* set illegal characters to 0 */
		     if substr (ebcdic9_chars, i, 1) > last_ebcdic
		     then substr (temp_ebcdic9, i, 1) = "";
		end;				/* set illegal characters to 0 */
		call ebcdic_to_ascii_ (temp_ebcdic9, ebcdic9_return);
		translation = translate (ebcdic9_return, dots, nonprinting_chars);
	     end;

	else if ebcdic8_fmt
	then do;
		call ebcdic8_to_ascii_ (ebcdic8_chars, ebcdic8_return);
		translation = translate (ebcdic8_return, dots, nonprinting_chars);
	     end;

	else if bit4_fmt
	then do;
		call comp_8_to_ascii_ (fourbit_chars, comp_8_return);
		translation = comp_8_return;
	     end;


     end translate_line_to_dump;

%page;
return_dump:
     proc (seg_ptr, first, count, cur_length, rel_offset);

/* Return the dump when used as an active function. The format of the returned
   ascii string is set such that if -ascii is used, then the ascii
   translation is returned, otherwise the returned string is the octal, hex,
   bcd or ebcdic form of the translation. */

/* Formal parameters */

	dcl     seg_ptr		 ptr;		/* to segment to dump */
	dcl     first		 fixed bin (18);	/* in words */
	dcl     count		 fixed bin (18);	/* in words */
	dcl     cur_length		 fixed bin (18);	/* in blocks of 1024 words */
	dcl     rel_offset		 fixed bin (18);	/* in words */

/* Based */

	dcl     seg_wds		 (0:262143) bit (36) based (seg_ptr);
	dcl     word_mask		 (1:1024) fixed bin (35) based (blockp);

/* Automatic */

	dcl     tailx		 fixed bin;
	dcl     block_addr		 fixed bin;
	dcl     block_lng		 fixed bin;
	dcl     last_block		 bit (1) aligned;
	dcl     wds_in_line		 fixed bin;
	dcl     blockp		 ptr;

/* Static */

	dcl     af_format		 (0:7) char (15) var options (constant) static
				 init ("^v(^.3b ^)", "^vs^a", "^v(^.4b ^)", "^vs^a", "^v(^a ^)", "^vs^a",
				 "", "^vs^a");

	wds_in_line = 8;				/* dump 8 words at a time */

	if interpreted_data_fmt
	then tailx = 1;
	else tailx = 0;
	if raw_data_fmt
	then if hex8_fmt
	     then tailx = tailx + 2;
	     else if hex9_fmt
	     then tailx = tailx + 4;
	     else if octal_fmt
	     then ;				/* default */
	     else ;
	else tailx = tailx + 6;

	line_format = af_format (tailx);

	block_lng = min (count, 1024);		/* process by 1024 (or count if seg is less than 1024 long) */
						/* words until last block */
	last_block = "0"b;

	do block_addr = first to first + count - block_lng - 1 by block_lng;
	     call return_block;
	end;

	last_block = "1"b;				/* now do the last block in the segment */

	if ^have_count
	then do;
		blockp = addrel (seg_ptr, block_addr);
		do block_lng = first + count - block_addr to 1 by -1
		     while (blockp -> word_mask (block_lng) = 0); /* look for last non_zero word */
		end;
		if block_lng = 0 then return;		/* was all zeros */
	     end;
	else block_lng = first + count - block_addr;

	call return_block;

	return;

%page;
return_block:
     proc;

/* Automatic */

	dcl     line_addr		 fixed bin;
	dcl     first_line		 bit (1) aligned;

	first_line = "0"b;
	do line_addr = block_addr to block_addr + block_lng - wds_in_line - 1 by wds_in_line;
	     call return_line (wds_in_line, line_addr + wds_in_line - 1);
	end;

/* Now handle the last line */

	if last_block
	then call return_line (block_addr + block_lng - line_addr, block_addr + block_lng - 1);
	return;

%page;
return_line:
     proc (wds_in_line, line_addr_limit);

/* Formal parameters */

	dcl     wds_in_line		 fixed bin parameter;
	dcl     line_addr_limit	 fixed bin (18) parameter;

/* Automatic */

	dcl     output_words	 (1:wds_in_line) bit (36) based (addr (line_to_dump));
	dcl     bits_to_dump	 bit (wds_in_line * 36) based (addr (line_to_dump));
	dcl     translation		 char (32) varying;
	dcl     hex9_line		 char (64);
	dcl     hex9_array		 (1:wds_in_line) char (8) based (addr (hex9_line));
	dcl     wrd_addr		 fixed bin (18);
	dcl     line_to_dump	 (1:8) bit (36);

	do wrd_addr = line_addr to line_addr_limit by 1;
	     if wrd_addr <= cur_length - 1
	     then line_to_dump (wrd_addr - line_addr + 1) = seg_wds (wrd_addr - first);
	     else line_to_dump (wrd_addr - line_addr + 1) = (36)"0"b;
	end;

	if interpreted_data_fmt
	then call translate_line_to_dump (wds_in_line, addr (line_to_dump), translation);
	if hex9_fmt
	then do;
		call translate_bytes_to_hex9_ (bits_to_dump, hex9_line);
		call ioa_$rsnnl (line_format, output_line, output_line_len, wds_in_line, hex9_array, translation);
	     end;
	else call ioa_$rsnnl (line_format, output_line, output_line_len, wds_in_line, output_words, translation);

	return_arg = return_arg || substr (output_line, 1, output_line_len);

     end return_line;

     end return_block;

     end return_dump;

%page;
print_dump:
     proc (seg_ptr, first, count, cur_length, block_lng, rel_offset);

/* Note for future improvments that there is a complete symmetry between blocks and lines:
   duplicates must be found; the first duplicate must print a message and subsequent ones
   are suppressed; the last one must be handled separately and always printed.             */

/* Formal  parameters */

	dcl     seg_ptr		 ptr;
	dcl     first		 fixed bin (18);
	dcl     count		 fixed bin (18);
	dcl     cur_length		 fixed bin (18);
	dcl     block_lng		 fixed bin (18);
	dcl     rel_offset		 fixed bin (18);

/* Based */

	dcl     seg_wds		 (0:262143) bit (36) based (seg_ptr);

/* Automatic */

	dcl     block_addr		 fixed bin (18);
	dcl     dup_block		 bit (1);
	dcl     first_block		 bit (1);
	dcl     first_dup_block	 bit (1);
	dcl     hfx		 fixed bin;
	dcl     i			 fixed bin;
	dcl     (j, k)		 fixed bin (18);
	dcl     last_block		 bit (1);
	dcl     shfx		 fixed bin;
	dcl     length_of_digit_field	 fixed bin;
	dcl     number_of_digit_fields fixed bin;
	dcl     tailx		 fixed bin;
	dcl     wds_in_line		 fixed bin;

/* Static */

	dcl     short_format	 (0:3) char (8) static init ("^6w^s", "^s^6w", "^6w^s", "^6w ^6w");
	dcl     head_format		 (0:7) char (12) var static init ("^2s",
						/* ^addr, ^off, ^short */
				 "^2s",		/* ^addr, ^off, short */
				 "^s^6w^x",	/* ^addr, off, ^short */
				 "^s^2w^x",	/* ^addr, off, short */
				 "^6w^x^s",	/* addr, ^off, ^short */
				 "^2w^x^s",	/* addr, ^off, short */
				 "^6w^x^6w^x",	/* addr, off, ^short */
				 "^2w^x^s");	/* addr, off, short */
	dcl     tail_format		 (0:7) char (15) var options (constant) static
				 init ("^v(^.3b ^)", "^v(^.3b ^)^vx^a", "^v(^.4b ^)", "^v(^.4b ^)^vx^a", "^v(^a ^)",
				 "^v(^a ^)^vx^a", "", "^vs^s^a");

	if header
	then call print_header;

	if long_fmt
	then wds_in_line = 8;
	else wds_in_line = 4;
	shfx = binary (substr (dump_segment_format, 1, 2), 2);
	hfx = binary (substr (dump_segment_format, 1, 3), 3);
	if interpreted_data_fmt
	then tailx = 1;
	else tailx = 0;
	if raw_data_fmt
	then if hex8_fmt
	     then tailx = tailx + 2;
	     else if hex9_fmt
	     then tailx = tailx + 4;
	     else if octal_fmt
	     then ;				/* default */
	     else ;
	else tailx = tailx + 6;

	line_format = head_format (hfx) || tail_format (tailx);

/* Set the length of the field that is used for printing the octal or hex
   information according to what type of info we're displaying. */

	if hex9_fmt
	then length_of_digit_field = 9;		/* hex9 data */
	else if hex8_fmt
	then length_of_digit_field = 10;		/* hex8 data */
	else length_of_digit_field = 13;		/* octal data */

/* Set the number of digit fields on a COMPLETE output line so we can
   later calculate how many spaces to put on the last line if it is not
   filled. */

	if long_fmt
	then number_of_digit_fields = 8;
	else number_of_digit_fields = 4;

	first_block = "1"b;
	first_dup_block = "1"b;
	last_block = "0"b;
	dup_block = "0"b;
	do block_addr = first to first + count - block_lng - 1 by block_lng;
	     if first_block
	     then do;				/* always print the first block */
		     if have_structure then
		     call print_structure;
		     if raw_data_fmt | interpreted_data_fmt
		     then call print_block;
		     if active_func			/* blank line between blocks */
		     then return_arg = return_arg || NL;
		     else call ioa_$ioa_switch (iocbp, " ");
		     first_block = "0"b;
		end;				/* always print the first block */
	     else do;				/* test subsequent blocks for duplicates */
		     if block_addr - block_lng <= cur_length - 1
		     then do;			/* check for dup blocks */
			     dup_block = "1"b;
			     do i = 0 to block_lng - 1;
				j = block_addr - block_lng + i;
				k = block_addr + i;
				if j <= cur_length - 1
				then do;		/* don't exceed the current length of old block */
					if k <= cur_length - 1
					then do;	/* don't exceed the current length of new block */
						if seg_wds (k - first) ^= seg_wds (j - first)
						then dup_block = "0"b;
					     end; /* don't exceed the current length of new block */
					else do;	/* use 0 past current length of new block */
						if "0"b ^= seg_wds (j - first)
						then dup_block = "0"b;
					     end; /* use 0 past current length of new block */
				     end;		/* don't exceed the current length of old block */
				else ;
			     end;
			end;			/* check for dup blocks */
		     else dup_block = "1"b;		/* must be duplicates */
		     if dup_block & first_dup_block
		     then do;			/* print message for first dup block */
			     if active_func
			     then return_arg = return_arg || "duplicate blocks" || NL || NL;
			     else call ioa_$ioa_switch (iocbp, "duplicate blocks^/");
			     first_dup_block = "0"b;
			     if have_structure then
			     call print_structure;
			     if raw_data_fmt | interpreted_data_fmt
			     then call print_block;
			end;			/* print message for first dup block */
		     else do;			/* check further before printing */
			     if ^dup_block
			     then do;		/* not a dup block, print it */
				     if have_structure then
				     call print_structure;
				     if raw_data_fmt | interpreted_data_fmt
				     then call print_block;
				     if active_func /* blank line between blocks */
				     then return_arg = return_arg || NL;
				     else call ioa_$ioa_switch (iocbp, " ");
				     first_dup_block = "1"b;
				end;		/* not a dup block, print it */
			     else ;		/* null because we don't print dup blocks  */
			end;			/* check further before printing */
		end;				/* test subsequent blocks for duplicates */
	end;

/* Now handle the last block */

	last_block = "1"b;
	block_lng = first + count - block_addr;
	if have_structure then
	call print_structure;
	if raw_data_fmt | interpreted_data_fmt
	then call print_block;			/* always print the last block */


%page;
print_block:
     proc;


/* Automatic */

	dcl     cur_line		 char (wds_in_line * 4) based (addrel (seg_ptr, line_addr - first));
						/* dcled char instead of bit since CMPC is faster than CMPB */
	dcl     dup_line		 bit (1);
	dcl     first_dup_line	 bit (1);
	dcl     first_line		 bit (1);
	dcl     line_addr		 fixed bin (18);
	dcl     offset_addr		 fixed bin (18);
	dcl     prev_addr		 fixed bin (18);	/* for use by print_line */
	dcl     prev_line		 char (wds_in_line * 4) based (addrel (seg_ptr, prev_line_addr - first));
						/* dcled char instead of bit since CMPC is faster than CMPB */
	dcl     prev_line_addr	 fixed bin (18);
	dcl     i			 fixed bin;
	dcl     (j, k)		 fixed bin (18);

	first_line = "1"b;
	first_dup_line = "1"b;
	offset_addr = rel_offset;
	prev_addr = block_addr;
	prev_line_addr = block_addr;
	do line_addr = block_addr to block_addr + block_lng - wds_in_line - 1 by wds_in_line;
	     if first_line
	     then do;				/* handle first line differently */
		     if last_block | ^dup_block
		     then do;			/* print first line unless a dup block */
			     call print_line (wds_in_line, line_addr + wds_in_line - 1);
			     first_line = "0"b;
			end;			/* print first line unless a dup block */
		end;				/* handle first line differently */
	     else do;				/* handle subsequent lines */
		     if line_addr - wds_in_line <= cur_length - 1
		     then do;			/* check for dup lines */
			     dup_line = "1"b;
			     if line_addr + wds_in_line <= cur_length - 1
			     then do;		/* everything less than cur_length */
				     if prev_line_addr ^= line_addr
				     then do;
					     if prev_line = cur_line
					     then dup_line = "1"b;
					     else dup_line = "0"b;
					end;
				end;		/* everything less than cur_length */
			     else do;		/* cross over cur_length */
				     do i = 0 to wds_in_line - 1;
					j = line_addr - wds_in_line + i;
					k = line_addr + i;
					if j <= cur_length - 1 & k <= cur_length - 1
					then do;
						if seg_wds (j - first) ^= seg_wds (k - first)
						then dup_line = "0"b;
					     end;
					else if j <= cur_length - 1
					then do;
						if seg_wds (j - first) ^= "0"b
						then dup_line = "0"b;
					     end;
					else ;	/* both words must be 0 so equal */
				     end;
				end;		/* cross over cur_length */
			end;			/* check for dup lines */
		     else dup_line = "1"b;		/* must be duplicates */
		     if dup_line & first_dup_line & suppress_dup_fmt
		     then do;			/* print message for first dup line */
			     if active_func
			     then return_arg = return_arg || "======" || NL;
			     else call ioa_$ioa_switch (iocbp, "======");
			     first_dup_line = "0"b;
			end;			/* print message for first dup line */
		     else if ^dup_line | ^suppress_dup_fmt
		     then do;			/* print this line */
			     call print_line (wds_in_line, line_addr + wds_in_line - 1);
			     first_dup_line = "1"b;
			end;			/* print this line */
		     else ;			/* null because we don't print dup lines */
		end;				/* handle subsequent lines */
	     offset_addr = offset_addr + wds_in_line;	/* keep offset_addr up with line_addr */
	     prev_line_addr = line_addr;
	end;

/* Now handle the last line */

	if last_block | ^dup_block
	then call print_line (block_addr + block_lng - line_addr, block_addr + block_lng - 1);
	return;

%page;
print_line:
     proc (wds_in_line, line_addr_limit);

/* Formal parameters */

	dcl     wds_in_line		 fixed bin;
	dcl     line_addr_limit	 fixed bin (18);

/* Automatic */

	dcl     addr_col		 fixed bin (18);
	dcl     line_to_dump	 (1:8) bit (36);
	dcl     offset_col		 fixed bin (18);
	dcl     wrd_addr		 fixed bin (18);
	dcl     output_words	 (1:wds_in_line) bit (36) based (addr (line_to_dump));
	dcl     bits_to_dump	 bit (wds_in_line * 36) based (addr (line_to_dump));
	dcl     translation		 char (32) varying;
	dcl     hex9_line		 char (64);
	dcl     hex9_array		 (1:wds_in_line) char (8) based (addr (hex9_line));

	addr_col = line_addr;
	offset_col = offset_addr;
	do wrd_addr = line_addr to line_addr_limit by 1;
	     if wrd_addr <= cur_length - 1
	     then line_to_dump (wrd_addr - line_addr + 1) = seg_wds (wrd_addr - first);
	     else line_to_dump (wrd_addr - line_addr + 1) = (36)"0"b;
	end;
	if short_fmt
	then do;					/* print out addresses if short format */
		addr_col = mod (line_addr, 64);
		offset_col = mod (offset_addr, 64);
		if line_addr >= prev_addr + (64 - mod (prev_addr, 64)) | line_addr = prev_addr
		then do;
			call ioa_$rs (short_format (shfx), output_line, output_line_len, line_addr, offset_addr);
			if active_func
			then return_arg = return_arg || substr (output_line, 1, output_line_len);
			else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code);
		     end;
		prev_addr = line_addr;
	     end;					/* print out addresses if short format */
	if interpreted_data_fmt
	then call translate_line_to_dump (wds_in_line, addr (line_to_dump), translation);
	if hex9_fmt
	then do;					/* translate words to dump into hex9 format */
		call translate_bytes_to_hex9_ (bits_to_dump, hex9_line);
		call ioa_$rs (line_format, output_line, output_line_len, addr_col, offset_col, wds_in_line, hex9_array,
		     (number_of_digit_fields - wds_in_line) * length_of_digit_field, translation);
		if active_func
		then return_arg = return_arg || substr (output_line, 1, output_line_len);
		else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code);
	     end;					/* translate words to dump into hex9 format */
	else do;
		call ioa_$rs (line_format, output_line, output_line_len, addr_col, offset_col, wds_in_line, output_words,
		     (number_of_digit_fields - wds_in_line) * length_of_digit_field, translation);
		if active_func
		then return_arg = return_arg || substr (output_line, 1, output_line_len);
		else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code);
	     end;

     end print_line;

     end print_block;
%page;
print_structure:
    proc();

	dcl     code	           fixed bin(35);
	dcl     full_name		 char(256);
	dcl     match_names		 (10) char (32) varying;
	dcl     n_match_names	 fixed bin;
	dcl     n_subscripts	 fixed bin;
	dcl     structure_ptr	 ptr;
	dcl     subscripts		 (2, 16) fixed bin(24);
	dcl     symbol_ptr		 ptr;
	dcl     unsubscripted_name	 char (256);

    if address_fmt then
       call ioa_$ioa_switch (iocbp, "^6w", block_addr);
    structure_ptr = addr(seg_wds(block_addr-first));
    call structure_ref_$parse ((structure_name), full_name, unsubscripted_name,
         subscripts, n_subscripts, match_names, n_match_names, code);
    if code ^= 0 then call PRINT_ERROR (code, 23);
    if have_structure_path
    then call structure_find_$pathname (structure_path, unsubscripted_name,
         symbol_ptr, code);
    else call structure_find_$search (unsubscripted_name, symbol_ptr, code);
    if code ^= 0 then call PRINT_ERROR (code, 24);
    call display_data_$for_azm (iocbp, ^long_fmt, match_names, n_match_names,
         null, structure_ptr, cur_length, structure_ptr, symbol_ptr,
         subscripts, n_subscripts, code);
    if code ^= 0 then call PRINT_ERROR (code, 25);
    end print_structure;

    end print_dump;

%page;



/* Parameters */

	dcl     a_old_format	 bit (6);

dump_seg_:
     entry (a_iocbp, a_ptr, a_first, a_count, a_old_format);

	if first_time
	then do;
		nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1);
		first_time = "0"b;
	     end;

	active_func, have_structure, have_structure_path = "0"b;
	iocbp = a_iocbp;
	unspec (dump_segment_format) = ""b;
	dump_segment_format = a_old_format;
	first = a_first;
	count = a_count;
	cur_length = first + count;
	block = count;
	rel_offset = 0;
	if (short_fmt & long_fmt) | (bcd_fmt & char_fmt)
	then do;
		string (dump_segment_format) = ""b;
		address_fmt = "1"b;
	     end;					/* set format to default */
	else if bcd_fmt | char_fmt
	then interpreted_data_fmt = "1"b;

	raw_data_fmt, octal_fmt = "1"b;
	command_output_fmt = "0"b;

	call print_dump (a_ptr, first, count, cur_length, block, rel_offset);
	return;

%page;

/* The following entry can be called by programs that want output in the same
   format as dump_segment. The arguments are:

   a_iocbp	a pointer to the I/O switch to use
   a_ptr		a pointer to the first word of data to dump
   a_blk_size	output dump in blocks of this number of words
   a_first	the offset of the first word to dump
   a_count	the number of words to dump
   a_format	a format control string (bit string) indicating the output mode

*/

/* Parameters */

	dcl     a_count		 fixed bin (18);
	dcl     a_first		 fixed bin (18);
	dcl     a_blk_size		 fixed bin;
	dcl     a_format		 bit (*);
	dcl     a_iocbp		 ptr;
	dcl     a_ptr		 ptr;
	dcl     MR10_FORMAT_LENGTH	 fixed bin int static options (constant) init (11);

dump_segment_:
     entry (a_iocbp, a_ptr, a_blk_size, a_first, a_count, a_format);

	if first_time
	then do;
		nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1);
		first_time = "0"b;
	     end;

	active_func, have_structure, have_structure_path = "0"b;
	iocbp = a_iocbp;
	unspec (dump_segment_format) = ""b;
	dump_segment_format = a_format;
	first = fixed (rel (a_ptr), 18, 0);
	count = a_count;
	if count <= 0
	then count = 1;
	cur_length = first + count;
	if a_blk_size <= 0
	then block = count;
	else block = min (a_blk_size, count);
	rel_offset = a_first;
	if (short_fmt & long_fmt) | (hex8_fmt & hex9_fmt)
	     | ((binary (bcd_fmt) + binary (char_fmt) + binary (ebcdic9_fmt) + binary (ebcdic8_fmt) + binary (bit4_fmt))
	     >= 2)
	then do;
		string (dump_segment_format) = ""b;
		address_fmt = "1"b;
	     end;					/* set format to default */

	if length (a_format) <= MR10_FORMAT_LENGTH
	then do;
		raw_data_fmt, suppress_dup_fmt = "1"b;
		if bcd_fmt | char_fmt | ebcdic9_fmt | ebcdic8_fmt | bit4_fmt
		then interpreted_data_fmt = "1"b;
		if ^hex8_fmt & ^hex9_fmt
		then octal_fmt = "1"b;
		header, command_output_fmt = "0"b;
	     end;

	call hcs_$fs_get_path_name (a_ptr, dirname, dir_len, ename, code);
	if code ^= 0
	then do;		/* bad number specified */
	     dirname = "";
	     ename = "";
	     end;

	call print_dump (a_ptr, first, count, cur_length, block, rel_offset);
	return;

%page;

/* The following entry can be called by programs that want output returned
   in the same format as dump_segment when used as an active function. The
   arguments are:

   a_string_ptr	a pointer to a varying char string
   a_string_length  maximum length of the char string
   a_ptr		a pointer to the first word of data to dump
   a_blk_size	output dump in blocks of this number of words
   a_first	the offset of the first word to dump
   a_count	the number of words to dump
   a_format	a format control string (bit string) indicating the output mode

*/

/* Parameters */

	dcl     a_string_ptr	 ptr;
	dcl     a_string_length	 fixed bin (21);

dump_segment_$string:
     entry (a_string_ptr, a_string_length, a_ptr, a_blk_size, a_first, a_count, a_format);

	if first_time
	then do;
		nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1);
		first_time = "0"b;
	     end;

	active_func = "1"b;
	ret_tc = a_string_length;
	ret_tp = a_string_ptr;
	if ret_tc <= 0 | ret_tp = null
	then return;
	return_arg = "";
	dump_segment_format = a_format;
	first = fixed (rel (a_ptr), 18, 0);
	count = a_count;
	if count <= 0
	then count = 1;
	cur_length = first + count;
	if a_blk_size <= 0
	then block = count;
	else block = min (a_blk_size, count);
	rel_offset = a_first;
	if short_fmt & long_fmt | hex8_fmt & hex9_fmt
	     | (binary (bcd_fmt) + binary (char_fmt) + binary (ebcdic9_fmt) + binary (ebcdic8_fmt) + binary (bit4_fmt))
	     >= 2
	then do;
		string (dump_segment_format) = ""b;
		address_fmt = "1"b;
	     end;					/* set format to default */

	call hcs_$fs_get_path_name (a_ptr, dirname, dir_len, ename, code);
	if code ^= 0
	then do;		/* bad number specified */
	     dirname = "";
	     ename = "";
	     end;

	if command_output_fmt
	then call print_dump (a_ptr, first, count, cur_length, block, rel_offset);
	else call return_dump (a_ptr, first, count, cur_length, rel_offset);

	return_arg = requote_string_ ((return_arg));

	return;
%page;
/* This subroutine is really cv_ptr_, but we have to modify it to work on
   inner ring segments because cv_ptr_ doesn't do that. When it does, then
   we can remove this routine and call cv_ptr_ instead. */

cv_ptr_:	procedure (string, Acode)
	returns 	(ptr);

     dcl						/*	Parameters			*/
     	string			char (*),		/* virtual pointer character string. (In)	*/
	Acode			fixed bin(35);	/* status code. (Out)			*/

     dcl						/*	Automatic Variables			*/
         (Lbit_offset, Lsegment_id, Lword_offset)
				fixed bin,	/* length of various parts of virtual pointer.	*/
         (Pbit_offset, Psegment_id, Pword_offset, Pdelim)
				ptr,		/* pointer to various parts of virtual pointer.	*/
	P			ptr,		/* returned pointer.			*/
	Pdef			ptr,		/* pointer to entry point definition structure.	*/

	bc			fixed bin(24),	/* bit count of target segment.		*/
         (bit, segno, word)		fixed bin(35),	/* numeric parts of virtual pointer.		*/
	code			fixed bin(35),
	dir			char(168),	/* dir part of segment's pathname.		*/
	ent			char(32),		/* entry part of segment's pathname.		*/
	entry_point_offset		fixed bin (18),
	i			fixed bin,
	id_case			fixed bin,	/* type of segment identifier in virtual pointer.	*/
						/*   1 = PATHNAME, 2 = REF_NAME, 3 = SEGNO.	*/
	inner_ring_segment		bit (1) aligned,	/* determines whether we can terminate the segment in the user ring */
	offset_case		fixed bin,	/* type of offset value in virtual pointer.	*/
						/*   5 = MISSING, 6 = WORD, 7 = WORD_AND_BIT,	*/
						/*   8 = ENTRY_PT.				*/
	1 oi			aligned like object_info,
	segp			ptr;

     dcl						/*	Based Variables			*/
     	bit_offset		char(Lbit_offset) based (Pbit_offset),
	bit_offset_array (Lbit_offset) char(1) based(Pbit_offset),
     	bits (36)			bit(1) unaligned based,
	delim			char(1) based (Pdelim),
	segment_id		char(Lsegment_id) based (Psegment_id),
	string_array (length(string))	char(1) based (addr (string)),
	word_offset		char(Lword_offset) based (Pword_offset),
	word_offset_array (Lword_offset)
				char(1) based (Pword_offset);
 
     dcl						/*	Entries				*/
	cv_dec_check_		entry (char(*), fixed bin(35)) returns (fixed bin(35)),
	cv_oct_check_		entry (char(*), fixed bin(35)) returns (fixed bin(35)),
	expand_pathname_		entry (char(*), char(*), char(*), fixed bin(35)),
	get_definition_		entry (ptr, char(*), char(*), ptr, fixed bin(35)),
	hcs_$fs_get_path_name	entry (ptr, char(*), fixed bin, char(*), fixed bin(35)),
	hcs_$fs_get_seg_ptr		entry (char(*), ptr, fixed bin(35)),
	hcs_$initiate_count		entry (char(*), char(*), char(*), fixed bin(24),
				       fixed bin(2), ptr, fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	object_info_$brief		entry (ptr, fixed bin(24), ptr, fixed bin(35));

     dcl  length			builtin;

     dcl						/*	Static Variables and Constants	*/
         (PATHNAME			init(1),		/* acceptable values which id_case may take on.	*/
	REF_NAME			init(2),
	SEGNO			init(3),
	MISSING			init(5),		/* acceptable values offset_case may take on.	*/
	WORD			init(6),
	WORD_AND_BIT		init(7),
	ENTRY_PT			init(8)) fixed bin int static options(constant),
         (TEXT			init ("000"b),	/* values which definition.class may take on.	*/
	LINKAGE			init ("001"b),
	SYMBOL			init ("010"b),
	STATIC			init ("100"b)) bit(3) int static options(constant),
	V_BAR			char(1) int static options(constant) init("|"),
         (error_table_$bad_class_def,
	error_table_$bad_conversion,
	error_table_$bigarg,
	error_table_$entlong,
	error_table_$lower_ring,
          error_table_$improper_data_format,
	error_table_$out_of_bounds)	fixed bin(35) ext static,
	sys_info$max_seg_size	fixed bin(35) ext static;


%include definition;

%include object_info;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Acceptable virtual pointer strings have the following forms:			*/
	/*									*/
	/* CASES									*/
	/*  I O	FORM			COMMENT					*/
	/* -----	-----------------------	------------------------------------------	*/
	/*  1 5	path			= path|0(0)				*/
	/*  1 5	path|			= path|0(0)				*/
	/*  1 6	path|W			= path|W(0)				*/
	/*  1 7	path|W(B)			octal word W, decimal bit B of path		*/
	/*  1 8	path|entry_pt		word identified by entry point entry_pt in path	*/
	/*  1 8	path$entry_pt		word identified by entry point entry_pt in seg	*/
	/*				with pathname pat				*/
	/*									*/
	/*  2 5	ref_name$			= ref_name$0(0)				*/
	/*  2 6	ref_name$W		= ref_name$W(0)				*/
	/*  2 7	ref_name$W(B)		octal word W, decimal bit B of seg with reference	*/
	/*				name ref_name.				*/
	/*  2 8	ref_name$entry_pt		word identified by entry point entry_pt in seg	*/
	/*				with reference name ref_name			*/
	/*									*/
	/*  3 5	segno			= segno|0(0)				*/
	/*  3 5	segno|			= segno|0(0)				*/
	/*  3 6	segno|W			= segno|W(0)				*/
	/*  3 7	segno|W(B)		octal word W, decimal bit B of seg known by segno	*/
	/*  3 8	segno|entry_pt		word identified by entry point entry_pt in seg	*/
	/*				known by segno				*/
	/*									*/
	/* CASES:  I = segment identifier case (id_case), O = offset value case (offset_case).	*/
	/*	 I = 1 => PATHNAME			O = 5 => MISSING (no offset given)	*/
	/*	   = 2 => REF_NAME			  = 6 => WORD			*/
	/*	   = 3 => SEGNO			  = 7 => WORD_AND_BIT		*/
	/*					  = 8 => ENTRY_PT			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Acode = 0;				/* initialize return code.			*/
	code = error_table_$improper_data_format;	/* initialize format error code.		*/
	id_case = PATHNAME;				/* start by assuming we have a path segment	*/
	offset_case = MISSING;			/*   identifier, and no offset value.		*/

	Psegment_id = addr(string);			/* Split identifier into seg_id, delim, & offset. */
	i = search (reverse(string), "|$");		/* Look for the delimiter.			*/
	if i > 0 then i = length(string) - (i-1);
	if i = 0 then do;				/* CASE: No delimiter.			*/
	     Pdelim = addr(V_BAR);			/*   Assume |.				*/
	     Lsegment_id = length(rtrim(string));	/*   Address seg_id.			*/
	     Pword_offset = addr(Pword_offset);		/*   Indicate no word offset.			*/
	     Lword_offset = 0;
	     end;
	else do;					/* CASE: Delimiter found.			*/
	     Pdelim = addr(string_array(i));		/*   Remember delimiter.			*/
	     Lsegment_id = i-1;			/*   Address seg_id.			*/
	     Lsegment_id = length(rtrim(segment_id));
	     if i < length(string) then do;		/*   Look for word offset.			*/
		Pword_offset = addr(string_array(i+1)); /*     Remember where word offset is.		*/
		Lword_offset = length(string) - i;
		Lword_offset = length(rtrim(word_offset));
		i = verify(word_offset, " ");
		if i > 1 then do;
		     Pword_offset = addr(word_offset_array(i));
		     Lword_offset = Lword_offset - (i-1);
		     end;
		end;
	     else do;				/*   No word offset.			*/
		Pword_offset = addr(Pword_offset);
		Lword_offset = 0;
		end;
	     end;

	if verify (segment_id, "01234567") = 0 then	/* check for segno identifier.		*/
	     id_case = SEGNO;
	else if segment_id = "-1" then		/*     this includes null pointer segno.	*/
	     id_case = SEGNO;

	if  (delim = "$") & (search (segment_id, "><") > 0)  then do;
	     if id_case ^= PATHNAME then call ERROR;	/* CASE: seg_id is a pathname.		*/
	     if length(segment_id) > 168 then do;
		code = error_table_$bigarg;
		call ERROR;
		end;
	     end;
	else if delim = "$" then do;			/* CASE: seg_id is a ref_name.		*/
	     id_case = REF_NAME;
	     if length(segment_id) > 32 then do;
		code = error_table_$entlong;
		call ERROR;
		end;
	     end;
	else if delim = "|" then;			/* CASE: seg_id is path or segno.		*/
	else call ERROR;				/* CASE: seg_id followed by bad delim.  We should	*/
						/*   never get to this line.			*/

	if length(word_offset) > 0 then do;		/* Evaluate word offset.			*/
	     offset_case = WORD;			/*   Start by assuming word offset.		*/
	     i = verify (word_offset, "01234567");	/*   Check for octal word offset.		*/
	     if i = 0 then;				/*   CASE: only word offset given.		*/
	     else if (word_offset_array(i) = "(")  then do;
		code = error_table_$bad_conversion;
		offset_case = WORD_AND_BIT;
		if word_offset_array(Lword_offset) ^= ")" then
		     call ERROR;
		Pbit_offset = addr(word_offset_array(i+1));
		Lbit_offset = Lword_offset - i - 1;	/*     Overlay the bit offset.		*/
		Lbit_offset = length(rtrim(bit_offset));
		Lword_offset = i - 1;		/*     Exclude bit from word offset.	*/
		Lword_offset = length(rtrim(word_offset));
		i = verify(bit_offset, " ");
		if i > 1 then do;
		     Pbit_offset = addr(bit_offset_array(i));
		     Lbit_offset = Lbit_offset - (i-1);
		     end;
		if verify (bit_offset, "0123456789") ^= 0 then do;
		     code = error_table_$bad_conversion;
		     call ERROR;
		end;
	     end;
	     else do;				/*   CASE: no word offset, just entry_pt.	*/
		offset_case = ENTRY_PT;
		if length(word_offset) > 256 then do;	/*     Validate entry point length.		*/
		     code = error_table_$entlong;
		     call ERROR;
		     end;
		end;
	     end;
	if  (delim = "$") & (id_case = PATHNAME) & (offset_case ^= ENTRY_PT) then do;
	     code = error_table_$improper_data_format;
	     call ERROR;
	     end;

	if id_case = PATHNAME then do;		/* id_case = PATHNAME			*/
	     call expand_pathname_ (segment_id, dir, ent, code);
	     if code ^= 0 then call ERROR;		/*     Expand the pathname given in virtual ptr.	*/
	     end;

	else do;
	     if id_case = REF_NAME then do;		/* id_case = REF_NAME.			*/
		call hcs_$fs_get_seg_ptr (segment_id, P, code);
		if code ^= 0 then do;		/*     Convert reference name to a pointer.	*/
		     call ring0_get_$segptr ("", segment_id, P, code);
		     if code ^= 0 then call ERROR;
		     end;
		end;
	     else do;				/* id_case = SEGNO				*/
		segno = cv_oct_check_ (segment_id, code);
		if code ^= 0 then do;
		     code = error_table_$bad_conversion;
		     call ERROR;
		     end;
		P = baseptr (segno);		/*     Convert segment number to a pointer.	*/
		if (segment_id = "-1") | (segment_id = "77777") | (segment_id = "777777") then do;
						/*     Special case null pointers.		*/
		     if offset_case = MISSING then return (null);
		     if offset_case = ENTRY_PT then do;
			code = error_table_$improper_data_format;
			call ERROR;
			end;
		     go to OFFSET;
		     end;
		end;

	     segp = P;
	     call hcs_$fs_get_path_name (segp, dir, (0), ent, code);
	     if code ^= 0 then do;			/* try in inner ring */
		segno = binary (baseno (P));
		if segno < hcscnt
		then do;
		     call ring0_get_$name (dir, ent, segp, code);
		     if code ^= 0 then call ERROR;	/*     Convert pointer to a pathname.		*/
		     end;
		else if segno = active_all_rings_data_$stack_base_segno
		     then do;
			code = 0;
			dir = "";
			ent = "stack_0";
			end;
		else call ERROR;
		goto OFFSET;
		end;
	     end;

	call hcs_$initiate_count (dir, ent, "", bc, 0, segp, code);
						/* Initiate segment identified by pathname	*/
						/*   with a null reference name.		*/
	if segp = null then do;			/* try in an inner ring */

	     on linkage_error call ERROR;
	     call phcs_$initiate (dir, ent, "", 0, 0, segp, code);
	     revert linkage_error;

	     if segp = null then call ERROR;
	     P = segp;
	     inner_ring_segment = "1"b;
	     end;
	else inner_ring_segment = "0"b;

OFFSET:	if offset_case = MISSING then;		/* No offset was given.			*/
	else if offset_case = ENTRY_PT then do;		/* An entry point was given.			*/
	     oi.version_number = object_info_version_2;	/*     Call object_info_ to get ptr to obj defs.	*/
	     call object_info_$brief (P, bc, addr(oi), code);
	     if code = error_table_$lower_ring
	     then do;				/* try in a lower ring */
		call ring0_get_$definition (P, ent, word_offset, entry_point_offset, (0), code);
		if code ^= 0 then call ERROR;
		P = ptr (P, entry_point_offset);
		end;
	     else if code ^= 0 then call ERROR;
	     else do;
		if id_case = REF_NAME then		/*     Get ptr to definition for entry point.	*/
		     call get_definition_ (oi.defp, segment_id, word_offset, Pdef, code);
		else call get_definition_ (oi.defp, ent, word_offset, Pdef, code);
		if code ^= 0 then call ERROR;
		if      Pdef -> definition.class = TEXT then	/*     Apply definition to get word offset.	*/
		     P = addrel (oi.textp, Pdef -> definition.value);
		else if Pdef -> definition.class = LINKAGE then
		     P = addrel (oi.linkp, Pdef -> definition.value);
		else if Pdef -> definition.class = SYMBOL then
		     P = addrel (oi.symbp, Pdef -> definition.value);
		else if Pdef -> definition.class = STATIC then
		     P = addrel (oi.statp, Pdef -> definition.value);
		else do;
		     code = error_table_$bad_class_def;
		     call ERROR;
		     end;
		end;
	     end;
	else do;					/* A word, or word and bit offset was given.	*/
	     word = cv_oct_check_ (word_offset, code);	/*     Convert/validate word offset.		*/
	     if code ^= 0 then do;
		code = error_table_$bad_conversion;
		call ERROR;
		end;
	     if (0 <= word) & (word <= sys_info$max_seg_size) then;
	     else do;
		code = error_table_$out_of_bounds;
		call ERROR;
		end;
	     P = ptr (P, word);			/*     Apply word offset to pointer.		*/
	     if offset_case = WORD_AND_BIT then do;	/*     A bit offset was also given.		*/
		bit = cv_dec_check_ (bit_offset, code);	/*	 Convert/validate bit offset.		*/
		if code ^= 0 then do;
		     code = error_table_$bad_conversion;
		     call ERROR;
		     end;
		if (0 <= bit) & (bit <= 35) then;
		else do;
		     code = error_table_$out_of_bounds;
		     call ERROR;
		     end;
		P = addr (P -> bits (bit+1));		/*     Apply the bit offset.			*/
		end;
	     end;

RETURN_TO_CALLER:

	if ^inner_ring_segment
	then call hcs_$terminate_noname (segp, (0));
	return (P);				/* return the pointer.			*/

ERROR:
     proc;

	Acode = code;
	P = null;					/* return a null pointer, with the error code.	*/
	goto RETURN_TO_CALLER;
	end ERROR;

	end cv_ptr_;
%page;
%include definition;
%page;
%include object_info;
%page;
%include terminate_file;
%page;
%include access_mode_values;

     end dump_segment;




		    enter_retrieval_request.pl1     10/17/88  1532.7r w 10/17/88  1427.1       97443



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


enter_retrieval_request: err: proc;


/* This command  submits retrieval requests to the volume retriever.  It queues these requests
   in one of three queues which the caller may specify(the default queue is 3) in a the directory
   >daemon_dir_dir>volume_backup(except in the test entry case). At some latter time operations will log in the
   retriever and process the requests. */

/*
   Modified by D. Vinograd to improve argument and access checks, use system msg header,
   and support msg ids.
   Modified: August 1983 by GA Texada to fix -to bug (phx13941 phx14299).
*/
dcl  code fixed bin (35);
dcl  ms_count fixed bin;
dcl  long_id bit (1);
dcl  brief bit (1);
dcl  to_specified bit (1);
dcl  rqid char (19);
dcl  narg fixed bin;
dcl  type fixed bin (2);
dcl (bmode, pmode) fixed bin (5);
dcl  i fixed bin;
dcl  ac fixed bin;
dcl  argp ptr;
dcl  argl fixed bin;
dcl  test_dir char (*);
dcl  arg char (argl) based (argp);
dcl  clock_value fixed bin (71);
dcl  prev_arg char (32);
dcl  queue_seg char (32) ;
dcl  q fixed bin;
dcl  dates_array (5) bit (36);

dcl  myname char (32) static int init ("enter_retrieval_request") options (constant);
dcl  retrieval fixed bin int static init (4) options (constant);
dcl  vdtd fixed bin static init (5);
dcl  dtm fixed bin static init (2);

dcl 1 local_retv_request aligned like retv_request;

dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$nostars ext fixed bin (35);

dcl  message_segment_$get_message_count_file entry (char (*), char (*), fixed bin, fixed bin (35));
dcl  request_id_ entry (fixed bin (71)) returns (char (19));
dcl  get_ring_ entry returns (fixed bin);
dcl  hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
dcl  hcs_$get_dates entry (char (*) aligned, char (*) aligned, (5) bit (36), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ioa_ entry options (variable);
dcl  message_segment_$add_file entry (char (*), char (*), ptr, fixed bin, bit (36), fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  check_star_name_$entry entry (char (*) aligned, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35));
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));

dcl  addr builtin;
dcl  fixed builtin;
dcl  clock builtin;
dcl  substr builtin;
dcl  size builtin;
dcl  bit builtin;

%include queue_msg_hdr;
%include retv_request;
%include retv_data_;
%include status_structures;

	requestp = addr (local_retv_request);		/* initialize */
	long_id = "0"b;
	brief = "0"b;
	to_specified = "0"b;
	retv_request.bits = "0"b;
	retv_request.fixed_bin = 0;
	retv_request.chars = "";
	retv_request.version = retv_request_version_2;
	retv_request.msg_time = clock;
	retv_request.hdr_version = queue_msg_hdr_version_1;
	retv_request.message_type = retrieval;
	retv_request.std_length = size (retv_request);
	retv_request.bit_flags = "0"b;
	retv_request.orig_queue = 3;
	retv_request.state = STATE_UNPROCESSED;

	call cu_$arg_ptr (1, argp, argl, code);		/* get pathname of object/node */
	if code ^= 0 then do;
argerr:	     call com_err_ (0, myname, " Usage is ^a pathname [-subtree] [-from time] [-to time] [-notify] [-queue q] [-new_path pathname] [-multi_segment_file]", myname);
	     goto finish;
	end;
	if substr (arg, 1, 1) = "-" then goto argerr;
	call expand_pathname_ (arg, retv_request.dirname, retv_request.ename, code);
	if code ^= 0 then do;
expand_err:    call com_err_ (code, myname, "^a", arg);
	     goto finish;
	end;
	call check_star_name_$entry (retv_request.ename, code);
	if code ^= 0 then do;
	     call com_err_ (error_table_$nostars, myname, " Use -subtree.");
	     goto finish;
	end;
	call check_access ((retv_request.dirname), (retv_request.ename));
	ac = 1;
	call cu_$arg_count (narg);
	do while (ac < narg);
	     ac = ac + 1;
	     call cu_$arg_ptr (ac, argp, argl, code);
	     if code ^= 0 then do;
no_next_arg:	call com_err_ (code, myname, "Unable to access argument after ^a", arg);
		return;
	     end;
	     if arg = "-previous" | arg = "-prev" then retv_request.previous = "1"b;
	     else if arg = "-long_id" then long_id = "1"b;
	     else if arg = "-brief" | arg = "-bf" then brief = "1"b;
	     else if arg = "-subtree" | arg = "-subt" | arg = "-multi_segment_file" | arg = "-msf" then
		retv_request.subtree = "1"b;
	     else if arg = "-notify" | arg = "-nt" then retv_request.notify = "1"b;
	     else if arg = "-to" | arg = "-from" | arg = "-fm" then do;
		prev_arg = arg;
		ac = ac + 1;
		call cu_$arg_ptr (ac, argp, argl, code);
		if code ^= 0 then goto no_next_arg;
		call convert_date_to_binary_ (arg, clock_value, code);
		if code ^= 0 then do;
		     call com_err_ (code, myname, "^a", arg);
		     goto finish;
		end;
		if clock_value > clock then do;
		     call com_err_ (0, myname, "Date ^a is in the future", arg);
		     return;
		end;
		if prev_arg = "-to" then do;
		     to_specified = "1"b;
		     retv_request.to_time = clock_value;
		     end;
		else retv_request.from_time = clock_value;
	     end;
	     else if arg = "-queue" | arg = "-q" then do;
		ac = ac + 1;
		call cu_$arg_ptr (ac, argp, argl, code);
		if code ^= 0 then goto no_next_arg;
		q = cv_oct_check_ (arg, code);
		if code ^= 0 | (q > 3 | q < 1) then do;
		     call com_err_ (0, myname,
			"Invalid queue number ^a", arg);
		     goto finish;
		end;
		retv_request.orig_queue = q;
	     end;
	     else if arg = "-new_path" then do;
		ac = ac + 1;
		call cu_$arg_ptr (ac, argp, argl, code);
		if code ^= 0 then goto no_next_arg;
		call expand_pathname_ (arg, retv_request.new_dirname, retv_request.new_ename, code);
		if code ^= 0 then goto expand_err;
		call hcs_$status_minf ((retv_request.dirname), (retv_request.ename), 1, type, 0, code);
		if code ^= 0 then do;
		     call com_err_ (code, myname, "Unable to cross retrieve object.");
		     goto finish;
		end;
		if type = Directory then do;
		     call com_err_ (0, myname, "Directory cross retrieval not allowed.");
		     goto finish;
		end;
		call hcs_$get_user_effmode ((retv_request.dirname), (retv_request.ename), "", get_ring_ (), bmode, code);
		if (bit (bmode) & "01010"b) ^= "01010"b then do;
		     call com_err_ (0, myname, "Incorrect access to segment ^a>^a to cross retrieve.",
			retv_request.dirname, retv_request.ename);
		     goto finish;
		end;
		call hcs_$get_user_effmode ((retv_request.new_dirname), "", "", get_ring_ (), pmode, code);
		if (bit (pmode) & "01010"b) ^= "01010"b then do;
		     call com_err_ (0, myname, "Incorrect access to append to new path ^a.", retv_request.new_dirname);
		     goto finish;
		end;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, myname, "^a", arg);
		goto finish;
	     end;
	end;
	if retv_request.previous & (to_specified | retv_request.from_time ^= 0) then do;
	     call com_err_ (0, myname, "-previous control arg not allowed with -from and or -to");
	     goto finish;
	end;

	if to_specified then
	     if retv_request.to_time < retv_request.from_time then do;
		call com_err_ (0, myname, "-to DATE preceeds -from DATE");
		goto finish;
	     end;

	dates_array (*) = "0"b;
	call hcs_$get_dates (retv_request.dirname, retv_request.ename, dates_array, code);
	if code ^= 0 then do;
	     if retv_request.previous then do;
		call com_err_ (code, myname, "Unable to obtain data about ^a>^a for -previous control arg",
		     retv_request.dirname, retv_request.ename);
		goto finish;
	     end;
	end;
	else do;
	     if (dates_array (dtm) >= dates_array (vdtd)) then do;
		if (retv_request.previous | retv_request.from_time ^= 0 | to_specified) then ;
		else do;
		     call com_err_ (0, myname,
			"More recent copy online. Use -previous or -from or -to if you desire dump copy.");
		     goto finish;
		end;
		if ^to_specified then retv_request.to_time = fixed (dates_array (dtm) || (16) "0"b, 71);
	     end;
	     else if dates_array (vdtd) >= dates_array (dtm) then do;
		if ^to_specified then
		     if retv_request.previous then retv_request.to_time = fixed (dates_array (dtm) || (16) "0"b, 71);
	     end;
	end;
     if ^retv_request.previous & ^to_specified then retv_request.to_time = clock;

	call ioa_$rsnnl ("volume_retriever_^d.ms", queue_seg, i, retv_request.orig_queue); /* select queue and put  message in queue */
	call message_segment_$add_file (queue_dir, queue_seg, requestp, size (retv_request) * 36, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, myname, "Unable to queue retrieval request.");
	     goto finish;
	end;
	if ^brief then do;
	     rqid = request_id_ (retv_request.msg_time);
	     if ^long_id then rqid = substr (rqid, 7, 8);
	     call message_segment_$get_message_count_file (queue_dir, queue_seg, ms_count, code);
	     ms_count = max (0, ms_count-1);
	     call ioa_ ("ID: ^a^[;^x^d already requested.^]", rqid, (code = 0), ms_count);
	end;

finish:
	return;


test:	entry (test_dir);
	queue_dir = test_dir;
	return;

check_access: proc (dirname, ename);
dcl (dirname, ename) char (*);
dcl  tdirname char (168) aligned;
dcl  tename char (32) aligned;
	     call hcs_$status_minf (dirname, ename, 1, type, 0, code);
	     if code ^= 0 then do;
		call expand_pathname_ (dirname, tdirname, tename, code);
		if code ^= 0 then do;
		     call com_err_ (0, myname, "Unable to determine access to object.");
		     goto finish;
		end;
		if tename = "" & tdirname = ">" then do;
		     goto no_acc;
		end;
		call check_access ((tdirname), (tename));
	     end;
	     call hcs_$get_user_effmode (dirname, ename, "", get_ring_ (), bmode, code);
	     call hcs_$get_user_effmode (dirname, "", "", get_ring_ (), pmode, code);
	     if (bit (bmode) & "01010"b) = "01010"b
	     | (bit (pmode) & "01010"b) = "01010"b then return;
	     else do;
no_acc:		call com_err_ (0, myname, "Incorrect access to retrieve object ^a^[>^]^a.",
		     retv_request.dirname, retv_request.dirname ^= ">", retv_request.ename);
		goto finish;
	     end;
	end check_access;
     end enter_retrieval_request;




		    exponent_control.pl1            11/04/82  1951.6rew 11/04/82  1627.8       60147



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



/* exponent_control

   Command interface for fim exponent flags

*/

exponent_control:
     procedure options (variable);

/* Date Changed (and reason) */
/* Coded February 28 1980 Benson I. Margulies */

dcl  hcs_$get_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned);
dcl  hcs_$set_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned, fixed bin (35));

dcl  cu_$arg_count entry () returns (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);

dcl  arg_ptr ptr;
dcl  arg_len fixed bin (21);
dcl  argument char (arg_len) based (arg_ptr);

dcl  nargs fixed bin;
dcl  current_argument fixed bin;
dcl  code fixed bin (35);
dcl (looking_for, processing) fixed bin;
dcl  print_sw bit (1) aligned;
dcl  put_reqd bit (1) aligned;
dcl  happy bit (1) aligned;				/* no further arguments required */

dcl (restart_underflow, restart_overflow) bit (1) aligned;
dcl  overflow_value float bin (63);

dcl (error_table_$bad_conversion,
     error_table_$bad_arg,
     error_table_$inconsistent,
     error_table_$noarg) static external fixed bin (35);
dcl  conversion condition;

dcl ((Control_argument init (1),
     Keyword init (2),
     Control_argument_or_keyword init (3),
     Value_or_control_argument init (4),
     Restart init (5),
     Fault init (6),
     Value init (7)) fixed bin,			/* not really used at the moment */
     Myname init ("exponent_control") character (16)) internal static options (constant);

%include exponent_control_info;

dcl (convert, unspec) builtin;

/*  */
	call GET_CURRENT_VALUES;			/* almost always the command needs them */
	nargs = cu_$arg_count ();
	if nargs = 0 then do;
	     call com_err_ (error_table_$noarg, Myname,
		"^/Usage: exponent_control {-pr}|{-rt|-flt overflow|underflow} {-ovfv value}");
	     return;
	end;
	happy = ""b;
	put_reqd, print_sw = ""b;
	looking_for = Control_argument;
	do current_argument = 1 to nargs;
	     call get_argument;
	     if /* case */ looking_for = Control_argument_or_keyword then
		if substr (argument, 1, 1) = "-" then goto CONTROL_ARG;
		else goto KEYWORD;

	     else if looking_for = Value_or_control_argument then
		if substr (argument, 1, 1) = "-" then goto CONTROL_ARG;
		else goto VALUE;

	     else if looking_for = Control_argument then do;
		if substr (argument, 1, 1) ^= "-" then do;
		     call com_err_ (error_table_$bad_arg, Myname, "Unknown or misplaced keyword ^a.", argument);
		     goto ERROR;
		end;
CONTROL_ARG:	if argument = "-restart" | argument = "-rt" then call process_restart;
		else if argument = "-fault" | argument = "-flt" then call process_fault;
		else if argument = "-overflow_value" | argument = "-ovfv" then call process_value;
		else if argument = "-print" | argument = "-pr" then call process_print;
		else do;
		     call com_err_ (error_table_$bad_arg, Myname,
			"unrecognized control argument ^a.", argument);
		     goto ERROR;
		end;
	     end;
	     else if looking_for = Keyword then do;
KEYWORD:		looking_for = Control_argument_or_keyword;
		happy = "1"b;			/* having found a keyword nothing else required */
		if argument = "overflow" then
		     if processing = Restart then restart_overflow = "1"b;
		     else restart_overflow = "0"b;
		else if argument = "underflow" then
		     if processing = Restart then restart_underflow = "1"b;
		     else restart_underflow = "0"b;
		else do;
		     call com_err_ (error_table_$bad_arg, Myname, "Unrecognized keyword ^a.", argument);
		     goto ERROR;
		end;
	     end;
	     else if looking_for = Value then do;
VALUE:		looking_for = Control_argument;
		happy = "1"b;
		on conversion begin;
		     call com_err_ (error_table_$bad_conversion,
			Myname, "Could not convert ^a to a floating point value.", argument);
		     goto ERROR;
		end;
		overflow_value = convert (overflow_value, argument);
	     end;
	end;
	if ^happy then do;
	     call com_err_ (error_table_$noarg, Myname, "The ^a control argument requires a value.", argument);
	     goto ERROR;
	end;

	if print_sw & put_reqd then do;		/* can't do both */
	     call com_err_ (error_table_$inconsistent, Myname,
		"Can't print while setting any value.");
	     return;
	end;
	else if print_sw then
	     call ioa_ ("Underflows are ^[restart^;fault^]ed;^/Overflows are ^[restart^;fault^]ed;^/Overflow value is ^f.",
	     restart_underflow, restart_overflow, overflow_value);
	else call PUT_CURRENT_VALUES;
	return;

GET_CURRENT_VALUES:
	procedure;

dcl  overflow_bits bit (72) aligned;

	     call hcs_$get_exponent_control (restart_underflow, restart_overflow, overflow_bits);
	     unspec (overflow_value) = overflow_bits;
	     return;

PUT_CURRENT_VALUES:
	     entry;

	     overflow_bits = unspec (overflow_value);
	     call hcs_$set_exponent_control (restart_underflow, restart_overflow, overflow_bits, code);
	     if code ^= 0 then do;
		call com_err_ (code, Myname, "When setting new values.");
		goto ERROR;
	     end;
	     return;
	end;
						/*  */
process_restart:
	procedure;
	     happy = ""b;
	     looking_for = Keyword;
	     processing = Restart;
	     put_reqd = "1"b;
	     return;
	end;

process_fault:
	procedure;
	     happy = ""b;
	     looking_for = Keyword;
	     processing = Fault;
	     put_reqd = "1"b;
	     return;
	end;

process_value:
	procedure;
	     happy = "1"b;				/* we have a default */
	     overflow_value = Default_exponent_control_overflow_value;
	     looking_for = Value_or_control_argument;
	     put_reqd = "1"b;
	     return;
	end;

process_print:
	procedure;
	     happy = "1"b;
	     looking_for = Control_argument;
	     print_sw = "1"b;
	     return;
	end;

get_argument:
	procedure;
	     if current_argument > nargs then do;
		call com_err_ (error_table_$noarg, Myname, "following ^a.", argument);
		goto ERROR;
	     end;
	     call cu_$arg_ptr (current_argument, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, Myname, "Error on argument # ^d.", current_argument);
		goto ERROR;
	     end;
	     return;
	end;

ERROR:	return;					/* regardless of where in the internal procs */

     end;






		    exponent_control_.pl1           09/24/92  2252.7r w 09/24/92  2234.7       31725



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






/****^  HISTORY COMMENTS:
  1) change(91-10-25,Schroth), approve(91-11-28,MECR0015),
     audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001):
     Correct MR12.4 source code corruption.
  2) change(92-05-14,Schroth), approve(91-11-25,MCR8251),
     audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016):
     Replace MECR0015: Correct MR12.4 source code corruption.
                                                   END HISTORY COMMENTS */



/* exponent_control_

   subroutine interface to exponent control flags

*/

exponent_control_:
     proc;

	return;

/* Date Changed (and reason) */
/* Coded February 28 1980 Benson I. Margulies */

dcl  hcs_$get_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned);
dcl  hcs_$set_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned, fixed bin (35));

dcl (restart_underflow, restart_overflow) bit (1) aligned;
dcl  overflow_value float bin (63);
dcl (a_code, code) fixed bin (35);

dcl  bool_mask bit (3) aligned;
dcl  bool_op bit (4) aligned;

%include exponent_control_info;

/*  */
fault_underflow:
	entry (a_code);

	bool_mask = "010"b;				/* ^underflow, overflow, ^value */
	goto FAULT_COMMON;

fault_overflow:
	entry (a_code);

	bool_mask = "100"b;				/* underflow, ^overflow, ^value */

FAULT_COMMON:
	bool_op = "1"b4;				/* and */
	goto COMMON;

restart_underflow:
	entry (a_code);

	bool_mask = "100"b;				/* underflow, ^overflow, ^value */
	goto RESTART_COMMON;

restart_overflow:
	entry (a_code);

	bool_mask = "010"b;				/* ^underflow, overflow, ^value */
	goto RESTART_COMMON;

restart_overflow_value:
	entry (New_value, a_code);

dcl  New_value float bin (63) parameter;

	bool_mask = "011"b;				/* ^underflow, overflow, value */

RESTART_COMMON:
	bool_op = "7"b4;				/* or */

COMMON:	call GET_CURRENT_VALUES;

	restart_underflow = bool (restart_underflow, substr (bool_mask, 1, 1), bool_op);
	restart_overflow = bool (restart_overflow, substr (bool_mask, 2, 1), bool_op);

	if bool_op = "7"b4 then			/* setting restart flags */
	     if substr (bool_mask, 2, 1) then		/* overflow flag */
		if substr (bool_mask, 3, 1) then	/* value flag */
		     overflow_value = New_value;
		else overflow_value = Default_exponent_control_overflow_value;

	call PUT_CURRENT_VALUES;
	a_code = 0;
	return;

/*  */
GET_CURRENT_VALUES:
	procedure;

dcl  overflow_bits bit (72) aligned;

	     call hcs_$get_exponent_control (restart_underflow, restart_overflow, overflow_bits);
	     unspec (overflow_value) = overflow_bits;
	     return;

PUT_CURRENT_VALUES:
	     entry;

	     overflow_bits = unspec (overflow_value);
	     call hcs_$set_exponent_control (restart_underflow, restart_overflow, overflow_bits, code);
	     if code ^= 0 then do;
		a_code = code;
		goto exit;
	     end;
	     return;
	end;

exit:	return;

     end;





		    fdoc_et_.alm                    11/05/86  1236.3r w 11/04/86  1038.0       17361



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
" FDOC_ET_ - Status code table for format_document_
" Written 83-03-24 by Paul W. Benjamin
" Modified 83-06-09 by PWB to add no_hyphenate_word.
" Modified 83-11-22 by PWB to add no_sign_allowed.
"
	maclist	off
	macro	maclist
	&end

	include	et_macros



	et	fdoc_et_



ec  indent_too_far_left,indtflft,
	(Attempt to indent past left margin, resetting to left margin.)
ec  indent_too_far_right,indtfrgt,
	(Attempt to indent past right margin, resetting to right margin.)
ec  line_length_too_small,lnlntsml,
          (Effective line length less than 1, quitting.)
ec  line_too_long,lntoolng,
	(Located a string of more than 256 characters without blank or newline.)
ec  no_hyphenate_word,nohypwrd,
	(Hyphenation has been requested but no hyphenate_word_ found.)
ec  no_parameter_allowed,noparalw,
	(This control supports no parameters.)
ec  no_sign_allowed,nosngalw,
	(This control does not allow signed paramaters.)
ec  nonnumeric_parameter,nonumpar,
	(Non-numeric parameter.)
ec  page_length_lt_13,pglnlt13,
	(Given page length too small, resetting to current minimum of 13.)
ec  page_length_lt_14,pglnlt14,
	(Given page length too small, resetting to current minimum of 14.)
ec  page_width_exceeds_max,pgwdxmax,
	(Computed page width too large, resetting to specified maximum.)
ec  text_too_long_for_line,txttulng,
	(Text too long for output line.)
ec  undent_too_far_left,undtflft,
	(Attempt to undent past left margin, resetting to left margin.)
ec  undent_too_far_right,undtfrgt,
	(Attempt to undent past right margin, resetting to right margin.)
ec  unsupported_control,unsupctl,
	(Unsupported control.)

	end




		    format_document_.pl1            10/06/92  0049.2r w 10/06/92  0045.0      479691



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



/****^  HISTORY COMMENTS:
  1) change(90-03-14,Kallstrom), approve(90-03-27,MCR8150),
     audit(90-04-03,Zimmerman), install(90-04-11,MR12.4-1003):
     Added an rtrim after CRs and VTs are removed.
  2) change(92-09-14,Vu), approve(92-09-14,MCR8260), audit(92-09-23,Zimmerman),
     install(92-10-06,MR12.5-1024):
     format_document_ looses characters and generates unwanted new paragraph.
                                                   END HISTORY COMMENTS */


format_document_:
	proc (dnamin, enamin, dnamout, enamout, optptr, code);
	
/* subroutine to format text a la compose and runoff.  Used by 
   format_document (fdoc) command.  There are 3 entries:

	format_document_              takes input and output pathnames.
          format_document_$string       takes input and output strings.
          format_document_$switch       takes input pathname and writes to
                                        an i/o switch.

   Command written 79.01.12 by Paul W. Benjamin.
   Subroutine interface added 80.02.14 by PWB.
   Re-Written 81.02.10 by PWB.
   Modified 81.04.20 by PWB to supress compression of leading spaces.
   Modified 81.04.20 by PWB to fix bug where page numbers not centered 
		        properly.
   Modified 81.06.26 by PWB to fix 2 more bugs relating to leading spaces.
   Modified 81.08.14 by PWB to fix bug where extra NL written to end when store
		        is empty.
   Modified 81.10.22 by PWB to avoid storage condition when compressing blanks
		        in long (truncated to 508 chars) strings.
   Modified 81.10.22 by PWB to fix bug where lines beginning with ". " or ".." 
                            interpreted as undent controls (!)
   Modified 82.07.16 by PWB to initially null 3 pointers before checking 
		        version
   Modified 82.07.16 by PWB to remove nonlocal goto on cleanup.
   Modified 82.09.02 by PWB to prevent backing up into left margin when looking
		        looking for a place to break an overlength line.
   Modified 82.10.18 by PWB to add support for dont_compress_sw.
   Modified 83.02.15 by PWB to add support for break_word_sw and 
		        max_line_length_sw.
   Modified 83.02.22 by PWB to stop truncating input lines at 508 chars.
   Modified 83.03.01 by PWB to implement dont_break_indented_lines_sw.
   Modified 83.03.03 by PWB to implement sub_err_sw.
   Modified 83.06.07 by PWB to implement dont_fill_sw.
   Modified 83.06.08 by PWB to implement hyphenation.
   Modified 83.08.30 by PWB to fix bug where words that were larger than the
		        line length didn't get hyphenated.
   Modified 83.11.17 by PWB to have dont_break_indented_lines imply "don't
		        do compression or sentence formatting on indented
		        lines, either."
   Modified 83.11.23 by PWB to add the names: .inl to .in, .unl to .un and to
		        add the .spf control.
   Modified 83.11.28 by PWB for various minor changes in response to audit.
   Modified 83.12.01 by PWB to add .brf and .brp.
   Modified 84.01.24 by PWB to fix bug introduced in MR10.2 that caused callers
		        using version_1 to possibly have random values for
		        the option switches that were new in that release.
   Modified 84.02.08 by PWB to apply defaults for dont_compress, break_word,
		        dont_break_indented_lines, sub_err, dont_fill
		        and hyphenation for version_1 callers.
*/

/* parameters */

dcl  code fixed bin (35) parameter;			/* output system status code */
dcl  dnamin char (*) parameter;			/* input file directory */
dcl  dnamout char (*) parameter;			/* output file directory */
dcl  enamin char (*) parameter;			/* input file name */
dcl  enamout char (*) parameter;			/* output file name */
dcl  instring char (*) parameter;			/* input string for string entry */
dcl  iocbptr ptr parameter;				/* output switch for switch entry */
dcl  optptr ptr parameter;				/* input ptr to options structure */
dcl  outlen fixed bin (21) parameter;			/* output string length for string entry */
dcl  outstring char (*) parameter;			/* output string for string entry */
	
/* entries */

dcl  canonicalize_ entry (ptr, fixed bin(21), ptr, fixed bin(21),
	fixed bin(35));
dcl  convert_status_code_ entry (fixed bin(35), char(8) aligned,
	char(100) aligned);
dcl  cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
dcl  hyphenate_word_ entry (char(*), fixed bin, fixed bin, fixed bin(35));
dcl  ioa_$rs entry() options(variable);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24),
	fixed bin(35));
dcl  msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35));
dcl  sub_err_ entry() options(variable);
dcl  tssi_$finish_file entry (ptr, fixed bin, fixed bin(24),
	bit(36) aligned, ptr, fixed bin(35));
dcl  tssi_$get_file	entry (char(*), char(*), ptr, ptr, ptr, fixed bin(35));

/* external static */

dcl  error_table_$smallarg fixed bin(35) ext static;
dcl  error_table_$fatal_error external static fixed bin (35);
dcl  error_table_$improper_data_format external static fixed bin(35);
dcl  error_table_$noentry fixed bin(35) ext static;
dcl  error_table_$recoverable_error fixed bin(35) ext static;
dcl  error_table_$unimplemented_version	external static fixed bin(35);
dcl  error_table_$zero_length_seg fixed bin(35) ext static;
dcl  fdoc_et_$indent_too_far_left fixed bin(35) ext static;
dcl  fdoc_et_$indent_too_far_right fixed bin(35) ext static;
dcl  fdoc_et_$line_length_too_small fixed bin(35) ext static;
dcl  fdoc_et_$line_too_long fixed bin(35) ext static;
dcl  fdoc_et_$no_hyphenate_word fixed bin(35) ext static;
dcl  fdoc_et_$no_parameter_allowed fixed bin(35) ext static;
dcl  fdoc_et_$no_sign_allowed fixed bin(35) ext static;
dcl  fdoc_et_$nonnumeric_parameter fixed bin(35) ext static;
dcl  fdoc_et_$page_length_lt_13 fixed bin(35) ext static;
dcl  fdoc_et_$page_length_lt_14 fixed bin(35) ext static;
dcl  fdoc_et_$page_width_exceeds_max fixed bin(35) ext static;
dcl  fdoc_et_$text_too_long_for_line fixed bin(35) ext static;
dcl  fdoc_et_$undent_too_far_left fixed bin(35) ext static;
dcl  fdoc_et_$undent_too_far_right fixed bin(35) ext static;
dcl  fdoc_et_$unsupported_control fixed bin(35) ext static;
dcl  iox_$error_output ptr ext static;
dcl  sys_info$max_seg_size fixed bin (19) ext static;
	
/* automatic */

dcl  aclinfoptr ptr;				/* required for tssi_$get_file */
dcl  adj_line_out char (508) varying;			/* temporary output line for adjust_line proc */
dcl  adjust bit (1) aligned;				/* ON = in adjust mode */
dcl  bc fixed bin (24);				/* required for various calls */
dcl  blank_lines_to_be_written fixed bin;		/* user used .spf N and this has value N */
dcl  breaking_words bit (1) aligned;			/* user specified break_word_sw */
dcl  bsndx fixed bin;				/* index of backspace in line */
dcl  bsndx1 fixed bin;				/* used when incrementing bsndx */
dcl  bscnt fixed bin;				/* number of backspaces in line */
dcl  buf char (256) varying;				/* input buffer */
dcl  buf_len21 fixed bin (21);			/* length of buf -- needed for call to canonicalize_ */
dcl  char_cnt fixed bin (21);				/* position of next char to be written */
dcl  component_ends_wo_NL bit;			/* ON = component ends without a newline */
dcl  continued_line bit (1);
dcl  ctl char (5);					/* user specified control */
dcl  ctl_index fixed bin;				/* index of ctl into ctl_list */
dcl  current_syllable_size fixed bin;			/* syllable size as currently adjusted */
dcl  default_syllable_size fixed bin;			/* syllable size as originally specified */
dcl  dont_break_indented_lines bit (1) aligned;		/* user specified dont_break_indented_lines_sw */
dcl  dont_compress bit (1) aligned;			/* user specified dont_compress_sw */
dcl  elen fixed bin (21);				/* length of error message */
dcl  error bit (1) aligned;				/* ON = an error has occurred */
dcl  error_lines char (508);				/* error message */
dcl  errtxt char (100) aligned;			/* output from convert_status_code_ */
dcl  fill bit (1) aligned;				/* ON = fill mode */
dcl  filout bit (1) aligned;				/* ON = main entry or string entry */
dcl  fit bit (1) aligned;				/* used in bs_rtn: can use portion of line as is */
dcl  galley_mode bit (1) aligned;			/* user specified galley_sw */
dcl  h fixed bin;					/* index for do-group */
dcl  hyph_len fixed bin (21);				/* length of based variable hyph_word */
dcl  hyph_point fixed bin;				/* where to hyphenate, output from hyphenate_word_ */
dcl  hyph_ptr ptr;					/* pointer to based variable hyph_word */
dcl  hyph_space fixed bin;				/* how much space in which to hyphenate */
dcl  hyphenating bit (1) aligned;			/* caller has requested hyphenation */
dcl  hyphenation_routine_state fixed bin;		/* = 0 hyphenate_word_ not looked for yet */
						/* = 1 hyphenate_word_ found */
						/* = 2 hyphenate_word_ not found */
dcl  hyphenate_entry entry variable;			/* dummy entry to test for linkage error */
dcl  i fixed bin;					/* index for do-group */
dcl  in_comp_no fixed bin;				/* current input component number */
dcl  ind fixed bin;					/* current indentation value */
dcl  ind_minus_und fixed bin;				/* current calculation of ind - und */
dcl  indptr ptr;					/* ptr to initial indentation string */
dcl  infcbptr ptr;					/* ptr to fcb for input file */
dcl  initial_ind fixed bin;				/* initial indentation value */
dcl  initial_inlen fixed bin (21);			/* length of input component */
dcl  initial_inptr ptr;				/* pointer to beginning of input component */
dcl  initial_line_length fixed bin;			/* user specified line_length */
dcl  initial_outptr ptr;				/* pointer to beginning of output component */
dcl  inlen fixed bin (21);				/* length of remainder of input component */
dcl  inplnctr fixed;				/* current line in input file */
dcl  inptr ptr;					/* current position in input file */
dcl  ioxbuf char (508);				/* output buffer for switch entry */
dcl  j fixed bin;					/* index for do-group */
dcl  k fixed bin;					/* index for do-group */
dcl  last_blank fixed bin;				/* position of blank in line for bs_rtn */
dcl  left bit (1) aligned;				/* ON = start adjusting from left side */
dcl  line_began_with_blank bit (1) aligned;		/* exactly what it says */
dcl  literal_mode bit (1) aligned;			/* user specified literal_sw */
dcl  ll fixed bin;					/* current linelength */
dcl  lnctr fixed bin;				/* output line counter */
dcl  long_line_and_no_blank bit (1) aligned;		/* used in bs_rtn when having problems breaking line */
dcl  maxcnt fixed bin (21);				/* position of first character past end of segment */
dcl  maximum_line_length bit (1) aligned;		/* user specified max_line_length_sw */
dcl  new_adjust bit (1) aligned;			/* new value for adjust */
dcl  new_fill bit (1) aligned;			/* new value for fill */
dcl  new_ind fixed bin;				/* new value for ind */
dcl  new_und fixed bin;				/* new value for und */
dcl  nlindex fixed bin;				/* index of next newline in input component */
dcl  out_comp_no fixed bin;				/* current output component number */
dcl  outline char (508) varying;			/* line to be written out */
dcl  outfcbptr ptr;					/* ptr to fcb for output file */
dcl  outptr ptr;					/* ptr to next character position in output file */
dcl  outstringlen fixed bin (21);			/* length of output string for string entry */
dcl  pads fixed;					/* number of spaces for adjust_line to fill in */
dcl  param char (100) varying;			/* parameter to ctl */
dcl  paramfb fixed bin;				/* fixed bin version of param */
dcl  pgctr fixed bin;				/* last output page number */
dcl  pgctra char (10) varying;			/* ascii representation of pgctr */
dcl  pgno bit;					/* ON = end page with centered page number */
dcl  pl fixed bin;					/* current output page length */
dcl  retval fixed bin (35);				/* meaningless but required by sub_err_ */
dcl  signed bit;					/* ON = param has optional leading sign */
dcl  space_available fixed bin;			/* characters remaining in output string or component */
dcl  space_pos (100) fixed;				/* where adjust_line keeps track of spaces in line */
dcl  spaces fixed;					/* number of spaces in line found by adjust_line */
dcl  spindex fixed bin;				/* index of space in line */
dcl  spindex1 fixed bin;				/* used when incrementing spindex */
dcl  store char (508) varying;			/* characters read but not yet written */
dcl  string_entry bit;				/* ON = entry via format_document_$string */
dcl  subcode fixed bin (35);				/* used in call to sub_err_ */
dcl  tabfill fixed bin;				/* number of spaces needed to replace tab */
dcl  tabndx fixed bin;				/* index of first tab in line */
dcl  temp_code fixed bin (35);			/* temporary code used at cleanup time */
dcl  tlen fixed bin;				/* length of text in write_file */
dcl  trash char (8) aligned;				/* unused output from convert_status_code_ */
dcl  und fixed bin;					/* current undentation value */
dcl  using_sub_err bit (1) aligned;			/* user asked for the usage of sub_err_ */
dcl  vlen fixed bin;				/* virtual length (width) of line */
dcl  vtabndx fixed bin;				/* virtual position of tab in line */

dcl  1 error_info like format_document_error;

/* based */

dcl  hyph_word char (hyph_len) based (hyph_ptr);		/* word passed to hyphenate_word_ */
dcl  indstr char (initial_ind) based (indptr);		/* initial indentation string */
dcl  in_chars (inlen + 2) char (1) based (inptr);		/* infile: one char at a time */
						/* (the +2 is to avoid a subscriptrange) */
dcl  infile char (inlen) based (inptr);			/* remainder of input component */
dcl  initial_in_chars (initial_inlen) char (1) 
	based (initial_inptr);			/* input component */
dcl  out_chars (sys_info$max_seg_size * 4) char (1) 
	based (initial_outptr);			/* output component */
dcl  outfile char ((sys_info$max_seg_size * 4) + 1 - char_cnt) 
	based (outptr);				/* remainder of output component */

dcl  1 buf_structure based (addr (buf)),		/* to look at buf as non-varying */
       2 buf_len fixed bin (35),
       2 buf_chars (256) char (1);
dcl  1 store_structure based (addr (store)),		/* to look at store one character at a time */
       2 store_len fixed bin (35),
       2 store_char (508) char (1);

/* internal static */

dcl  BS char (1) internal static options (constant) init ("");
dcl  BS_or_HT char (2) internal static options (constant) init ("	");
dcl  BS_or_HT_or_SP char (3) internal static options (constant) init ("	 ");
dcl  BUFFER_SIZE fixed internal static options (constant) init (256);
dcl  BUFFER_SIZE_PLUS_ONE fixed internal static options (constant) init (257);
dcl  CR char (1) internal static options (constant) init ("");
dcl  CR_or_VT char (2) internal static options (constant) init ("");
dcl  DEFAULT_LINE_LENGTH fixed internal static options (constant) init (65);
dcl  DEFAULT_PAGE_LENGTH fixed internal static options (constant) init (66);
dcl  FF char (1) internal static options (constant) init ("");
dcl  HT char (1) internal static options (constant) init ("	");
dcl  HT_or_SP char (2) internal static options (constant) init ("	 ");
dcl  HT_or_NL_or_SP char (3) internal static options (constant) init ("	 
");
dcl  HYPHEN char (1) internal static options (constant) init ("-");
dcl  NL char (1) internal static options (constant) init ("
");
dcl  VT char (1) internal static options (constant) init ("");
dcl  ctl_list char (83) internal static options (constant) init 
	("   .un .in .alb.all.fin.fif.pdw.pdl.hy .hyf.hyn.inl.unl.spf.   ..  ... .....brf.brp");
	
	
/* builtins */

dcl (addr, after, before, char, copy, decat, divide, index, length, ltrim, 
	mod, null, reverse, rtrim, search, substr, translate, verify) builtin;

/* condition */

dcl (cleanup, linkage_error) condition;
	

/* include file */

%include format_document_options;

%include format_document_error;

%include sub_err_flags;

/* program */

/* main entry -- format_document_ */

          error = "0"b;
	indptr = null ();
	infcbptr = null ();
	outfcbptr = null ();
          format_document_options_ptr = optptr;
	format_document_options.file_sw = "0"b;
	call check_version_and_set_options;
	if format_document_options.switches.mbz ^= "0"b
	     then do;
	     code = error_table_$improper_data_format;
	     goto done;
	end;
	filout = "1"b;
	string_entry = "0"b;

	on cleanup call done_proc;
	call msf_manager_$open (dnamin, enamin, infcbptr, code);
	if code ^= 0
	     then goto done;
	call msf_manager_$get_ptr (infcbptr, 0, "0"b, inptr, bc, code);
	if inptr = null ()
	     then goto done;
	if bc = 0
	     then do;
	     code = error_table_$zero_length_seg;
	     goto done;
	end;
	inlen = divide (bc, 9, 21, 0);
	call tssi_$get_file (dnamout, enamout, outptr, aclinfoptr, outfcbptr, code);
	if code ^= 0
	     then do;
	     format_document_options.file_sw = "1"b;
	     goto done;
	end;
	out_comp_no = 0;
	initial_outptr = outptr;
	code = 0;
	goto process;

string:	entry (instring, outstring, outlen, optptr, code);

	error = "0"b;
	indptr = null ();
	infcbptr = null ();
	outfcbptr = null ();
          format_document_options_ptr = optptr;
	format_document_options.file_sw = "0"b;
	call check_version_and_set_options;
	if format_document_options.switches.mbz ^= "0"b
	     then do;
	     code = error_table_$improper_data_format;
	     goto done;
	end;
	code = 0;
	filout = "1"b;
	inlen = length (instring);
	inptr = addr (instring);
	outptr, initial_outptr = addr (outstring);
	outstringlen = length (outstring);
	string_entry = "1"b;
	on cleanup call done_proc;
	goto process;

switch:	entry (dnamin, enamin, iocbptr, optptr, code);

	error = "0"b;
	indptr = null ();
	infcbptr = null ();
	outfcbptr = null ();
          format_document_options_ptr = optptr;
	format_document_options.file_sw = "0"b;
	call check_version_and_set_options;
	if format_document_options.switches.mbz ^= "0"b
	     then do;
	     code = error_table_$improper_data_format;
	     goto done;
	end;
	filout = "0"b;
	string_entry = "0"b;

	on cleanup call done_proc;
	call msf_manager_$open (dnamin, enamin, infcbptr, code);
	if code ^= 0
	     then goto done;
	call msf_manager_$get_ptr (infcbptr, 0, "0"b, inptr, bc, code);
	if inptr = null ()
	     then goto done;
	if bc = 0
	     then do;
	     code = error_table_$zero_length_seg;
	     goto done;
	end;
	inlen = divide (bc, 9, 21, 0);
	code = 0;

process:
	char_cnt = 1;
	component_ends_wo_NL = "0"b;
          continued_line = "0"b;
	current_syllable_size = default_syllable_size;
	hyphenation_routine_state = 0;
	in_comp_no = 0;
	ind = 0;
	ind_minus_und = 0;
	inplnctr = 0;
	left = "1"b;
	lnctr = 0;
	maxcnt = (sys_info$max_seg_size * 4) + 1;
	pgctr = 0;
	pl = DEFAULT_PAGE_LENGTH;
	store = "";
	und = 0;
	if hyphenating
	     then call look_for_hyphenation_routine;
          allocate indstr;
	indstr = copy (" ", initial_ind);
process_one_component:
	initial_inlen = inlen;
	initial_inptr = inptr;
	do while (inlen > 0);			/* while there is more input */
	     nlindex = index (infile, NL);
	     inplnctr = inplnctr + 1;
               continued_line = "0"b;
	     if nlindex = 0
		then nlindex = inlen + 1;
	     if nlindex > BUFFER_SIZE_PLUS_ONE		/* line longer than internal buffer */
		then do;				/* find someplace to break it */
                    continued_line = "1"b;
		if length (rtrim (substr (infile, 1, nlindex - 1), HT_or_SP)) <= BUFFER_SIZE
                    /* line merely had a lot of trailing blanks */
		     then buf = rtrim (substr (infile, 1, nlindex - 1), HT_or_SP);
		else do;
		     spindex = BUFFER_SIZE_PLUS_ONE - index (reverse (substr (infile, 1, BUFFER_SIZE_PLUS_ONE)), " ");
		     if spindex ^= BUFFER_SIZE_PLUS_ONE /* and break it there */
			then do;
			buf = rtrim (substr (infile, 1, spindex), HT_or_SP);
			nlindex = spindex + 1;
		     end;
		     else if breaking_words
			then do;
			buf = substr (infile, 1, ll);
			nlindex = ll;
		     end;
		     else do;			/* no place to break it */
			if store_len ^= 0		/* write out store if not empty */
			     then do;
			     store = copy (" ", ind_minus_und) || store;
			     call write (store);
			     store = "";
			end;
			call err_reporter (fdoc_et_$line_too_long); /* report as (recoverable) error */
			call write ((substr (infile, 1, nlindex - 1)));	/* and write it as is */
			goto continue;
		     end;
		end;
	     end;
	     else buf = rtrim (substr (infile, 1, nlindex - 1), HT_or_SP); /* get the next line into buf */

               if ^literal_mode & buf_len > 0 
                    & ^continued_line                       /* literal_sw says ignore controls */
		then if buf_chars (1) = "."
		then do;
		buf = translate (buf, " ", HT);	/* quasi- */
		do while (index (buf, "  ") ^= 0);	/* canonicalize */
		     buf = before (buf, "  ") || " " || after (buf, "  ");
		end;
		ctl = before (buf, " ");
		if index (ctl, " ") = 0		/* ctl is 1 char longer than the longest ctl */
		     then do;			/* so it better end in a space or two */
		     call err_reporter (fdoc_et_$unsupported_control);
		     goto continue;
		end;
		code = 0;
		param = (after (buf, " "));
		if length (param) ^= 0
		     then do;
		     signed = (verify (substr (param, 1, 1), "+-") = 0);
		     paramfb = cv_dec_check_ ((param), code);
		end;
		ctl_index = divide (index (ctl_list, substr (ctl, 1, 4)), 4, 17, 0);
		if ctl_index = 0
		     then do;
		     call err_reporter (fdoc_et_$unsupported_control);
		     goto continue;
		end;
		goto process_ctl (ctl_index);

process_ctl (1):					/* undent */
process_ctl (13):	if code ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$nonnumeric_parameter);
		     goto continue;
		end;
		if length (param) = 0
		     then new_und = ind;
		else do;
		     new_und = paramfb;
		     if new_und > ind
			then do;
			call err_reporter (fdoc_et_$undent_too_far_left);
			new_und = ind;
		     end;
		     else if (ll -ind) + new_und < 0
			then do;
			call err_reporter (fdoc_et_$undent_too_far_right);
			new_und = ind - ll;
		     end;
		end;
		goto process_break;

process_ctl (2):					/* indent */
process_ctl (12):	if code ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$nonnumeric_parameter);
		     goto continue;
		end;
		if length (param) = 0
		     then new_ind = 0;
		else do;
		     if signed 
			then do;
			new_ind = paramfb + ind;
			if new_ind < 0
			     then do;
			     call err_reporter (fdoc_et_$indent_too_far_left);
			     new_ind = 0;
			end;
		     end;
		     else new_ind = paramfb;
		     if new_ind > ll
			then do;
			call err_reporter (fdoc_et_$indent_too_far_right);
			new_ind = ll;
		     end;
		end;
		goto process_break;

process_ctl (3):					/* allign both */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		new_adjust = "1"b;
		goto process_break;

process_ctl (4):					/* allign left */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		new_adjust = "0"b;
		goto process_break;
process_ctl (5):					/* fill on */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		new_fill = "1"b;
		goto process_break;
process_ctl (6):					/* fill off */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		new_fill = "0"b;
		goto process_break;

process_ctl (7):					/* page width */
		if code ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$nonnumeric_parameter);
		     goto continue;
		end;
		if length (param) = 0
		     then ll = DEFAULT_LINE_LENGTH;
		else if signed
		     then ll = ll + paramfb;
		else ll = paramfb;
		if maximum_line_length
		     & ll > initial_line_length
		     then do;
		     ll = initial_line_length;
		     call err_reporter (fdoc_et_$page_width_exceeds_max);
		end;
		goto continue;
process_ctl (8):					/* page length */
		if code ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$nonnumeric_parameter);
		     goto continue;
		end;
		if length (param) = 0
		     then pl = DEFAULT_PAGE_LENGTH;
		else if signed
		     then pl = pl + paramfb;
		else pl = paramfb;
		if ^pgno & pl < 13
		     then do;
		     pl = 13;
		     call err_reporter (fdoc_et_$page_length_lt_13);
		end;
		else if pgno & pl < 14
		     then do;
	               pl = 14;
		     call err_reporter (fdoc_et_$page_length_lt_14);
		end;
		goto continue;

process_ctl (9):					/* hyphenate default */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		hyphenating = format_document_options.hyphenation_sw;
		current_syllable_size = default_syllable_size;
		if hyphenating
		     then if hyphenation_routine_state = 0
		     then call look_for_hyphenation_routine;
		else if hyphenation_routine_state = 2
		     then hyphenating = "0"b;
		goto continue;


process_ctl (10):					/* hyphenate off */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		hyphenating = "0"b;
		goto continue;


process_ctl (11):					/* hyphenate on */

		if code ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$nonnumeric_parameter);
		     goto continue;
		end;

		if length (param) ^= 0
		     then if signed
		     then do;
		     call err_reporter (fdoc_et_$no_sign_allowed);
		     goto continue;
		end;
		
		hyphenating = "1"b;
		if hyphenation_routine_state = 0
		     then call look_for_hyphenation_routine;
		else if hyphenation_routine_state = 2
		     then hyphenating = "0"b;
		if length (param) ^= 0
		     then current_syllable_size = paramfb;
		else current_syllable_size = default_syllable_size;
		goto continue;

process_ctl (14):					/* space-format */
		if code ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$nonnumeric_parameter);
		     goto continue;
		end;
		if length (param) ^= 0
		     then if signed
		     then do;
		     call err_reporter (fdoc_et_$no_sign_allowed);
		     goto continue;
		end;
		if length (param) = 0
		     then blank_lines_to_be_written = 1;
		else blank_lines_to_be_written = paramfb;    
		goto process_break;			
			     

process_ctl (15):					/* . */
process_ctl (16):					/* .. */
process_ctl (17):					/* ... */
process_ctl (18):					/* .... */
		goto process_text;			/* these are text */		

process_ctl (19):					/* break-format */
process_ctl (20):					/* break-page */
		if length (param) ^= 0
		     then do;
		     code = 0;
		     call err_reporter (fdoc_et_$no_parameter_allowed);
		     goto continue;
		end;
		goto process_break;			/* which is currently the next statement */

process_break:		
/* We have hit a control break, must write out anything left */
		if store_len ^= 0 
		     then do;
		     store = copy (" ", ind_minus_und) || store;     /* indent */
		     call write (store);		/* write it */
		     store = "";			/* clear out save area */
		end;
		
/* NOW apply specified control */
		if ctl_index = 2			/* .in  */
		     | ctl_index = 12		/* .inl */
		     then ind = new_ind;
		else if ctl_index = 1		/* .un  */
		     | ctl_index = 13		/* .unl */
		     then und = new_und;
		else if ctl_index = 3		/* .alb */
		     | ctl_index = 4		/* .all */
		     then adjust = new_adjust;
		else if ctl_index = 5		/* .fin */
		     | ctl_index = 6		/* .fif */
		     then fill = new_fill;
		else if ctl_index = 14		/* .spf */
		     then do i = 1 to blank_lines_to_be_written;
		     call write ("");
		end;
		else if ctl_index = 20		/* .brp */
		     then if ^galley_mode
		     then do;
		     if lnctr ^= 0			/* maybe the break caused a new page already */
			then do;
			if pgno 
			     then do i = lnctr to pl - 8;
			     call write ("");		
			end;
			else if filout
			     then do;
			     lnctr = pl - 7;	
			     call write ("");
			end;
			else /* ^pgno & ^filout */ 
			     do i = lnctr to pl - 7;
			     call write ("");
			end;
		     end;				
		end;
				
		ind_minus_und = ind - und;
		goto continue;			/* go process another line */
	     end;

process_text:  
	     if search (buf, CR_or_VT) ^= 0 
		then do;				/* discard VT or CR */
		do while (index (buf, VT) ^= 0);
		     buf = decat (buf, VT, "101"b);
		end;
		do while (index (buf, CR) ^= 0);
		     buf = decat (buf, CR, "101"b);
		end;
		buf = rtrim (buf, HT_or_SP);            /* rtrim buf in case there are now blanks at the end */
	     end;

	     if search (buf, BS_or_HT) ^= 0 
		then do;				/* Input may not be canonical */
		bsndx = index (buf, BS);		/* Or may need tabs expanded */
		if bsndx = 0 
		     then goto tab_check;
		else if bsndx = 1
		     then goto call_canon;		/* BS in pos 1 is uncanonical */
		do while ("1"b);
		     if bsndx = length (buf)
			then goto call_canon;	/* As is BS in last pos */
		     if search (buf_chars (bsndx - 1), BS_or_HT_or_SP) ^= 0
			then goto call_canon;
		     if search (buf_chars (bsndx + 1), BS_or_HT_or_SP) ^= 0
			then goto call_canon;
		     bsndx1 = bsndx + index (substr (buf, bsndx + 1), BS);
		     if bsndx = bsndx1
			then goto tab_check;	/* No more BSs */
		     bsndx = bsndx1;
		end;

tab_check:	tabndx = index (buf, HT);
		do while (tabndx ^= 0);		/* While there are tabs */
		     vtabndx = tabndx;
		     do i = 2 to tabndx;		/* Determine virtual position of tab in line */
			if buf_chars (i) = BS	/* BS means line is virtually */
			     then do;		/* 2 less characters wide than seems */
			     vtabndx = vtabndx - 2;
			     i = i + 1;		/* Next char is not BS */
			end;
		     end;
		     tabfill = 11 - mod (vtabndx, 10);	/* See how many spaces to fill in */
		     if tabfill = 11 
			then tabfill = 1;	
		     buf = substr (buf, 1, tabndx - 1)	/* Fill 'em in */
			|| copy (" ", tabfill)
			|| substr (buf, tabndx + 1);
		     tabndx = index (buf, HT);
		end;
		goto dont_canon;

call_canon:	call canonicalize_ (addr (buf_chars (1)), (buf_len), addr (buf_chars (1)), buf_len21, code);
		if code ^= 0 
		     then goto done;
		buf_len = buf_len21;
dont_canon:    end;

	     line_began_with_blank = "0"b;

	     if ^fill 
		then do;				/* No fill, just write it */
		store = buf;
		store = copy (" ", ind_minus_und) || store;
		call write (store);
		store = "";
		goto check_length;
	     end;

	     else if length (buf) = 0 
		then do;				/* null line? */
		if store_len ^= 0 
		     then do;			/* if there is something left */
		     store = copy (" ", ind_minus_und) || store;     /* then indent */
		     call write (store);		/* and write it */
		end;
		call write (buf);			/* now write out null line */
		store = "";			/* clear out save area */
		goto check_length;
	     end;
	     else if buf_chars (1) = " " 
		then do;				/* leading blank cause break */
		line_began_with_blank = "1"b;
		if store_len ^= 0 
		     then do;			/* if save area not empty */
		     store = copy (" ", ind_minus_und) || store;     /* indent it */
		     call write (store);		/* and write it */
		end;
		store = buf;			/* move buffer to save area */
	     end;
	     else do;
		if component_ends_wo_NL		/* special handling */
		     then do;			/* when spanning msf */
		     component_ends_wo_NL = "0"b;	/* components */
		     store = store || buf;
		end;
		else do;				/* concatenate buffer to end of save area */
		     if store_len > 0
                              then store = store || " ";
		     store = store || buf;
		end;
	     end;

/* The following code enforces the convention of 2 spaces after certain 
   punctuation.  What appears to be a serious flirtation with stringrange is
   actually a firm knowledge that store has been rtrimmed of spaces. */

	     if ^dont_compress
		then do;
		if dont_break_indented_lines & line_began_with_blank
		     then if nlindex >= inlen		/* if next line blank or this is eof */
		     then goto check_length;		/* don't do any compression */
		else if search (in_chars (nlindex + 1), HT_or_NL_or_SP) ^= 0
		     then goto check_length;
		spindex = index (store, " ");		
		if spindex = 1			/* Don't mess with leading spaces */
		     then do;			/* Find first space after non-blank char */
		     spindex = verify (store, " ");
		     spindex1 = index (substr (store, spindex), " ");
		     if spindex1 = 0
			then spindex = 0;
		     else spindex = spindex + spindex1 - 1;
		end;
		if spindex ^= 0			
		     then do while (index (substr (store, spindex), " ") ^= 0);
		     if verify (store_char (spindex - 1), ":.!?)") = 0
			then do;
			if store_char (spindex - 1) = ")"
			     then do;
			     if spindex < 3
				then goto compress_blanks;
			     if verify (store_char (spindex - 2), "!?.") ^= 0
				then goto compress_blanks;
			end;
			if store_char (spindex + 1) ^= " " /* should be 2 spaces */
			     then store = substr (store, 1, spindex) || " " || substr (store, spindex + 1);
			else do while (store_char (spindex + 2) = " ");	/* and only 2 */
			     store = substr (store, 1, spindex + 1) || substr (store, spindex + 3);
			end;
			spindex = spindex + 2;	/* look at next char past spaces */
		     end;
		     else do;				
compress_blanks:		do while (store_char (spindex + 1) = " ");
			     store = substr (store, 1, spindex) || substr (store, spindex + 2);
			end;
			spindex = spindex + 1;	/* skip over space */
		     end;
		     spindex1 = index (substr (store, spindex), " ");
		     if spindex1 = 0
			then goto check_length;
		     else spindex = spindex + spindex1 - 1;
		end;
	     end;
	     	     	     	     
check_length:  if ll - ind_minus_und < 1		/* negative effective linelength */
		then do;
		call err_reporter (fdoc_et_$line_length_too_small);
		code = error_table_$fatal_error;
		goto done;
	     end;

	     do while (length (rtrim (store)) + ind_minus_und > ll - 1);	/* if line long enough, deal with it */

/* check for backspaces */
/* if there are backspaces in the line we got problems, and therefore branch to a special routine */
		if index (store, BS) < ll - ind_minus_und + 2 & index (store, BS) ^= 0 
		     then goto bs_rtn;
		store = copy (" ", ind_minus_und) || store;	/* indent */
		if line_began_with_blank & dont_break_indented_lines
		     then do;			/* called by Gary Palter */
		     if nlindex < inlen		/* don't break the line if is followed by a blank line */
						/* or an indented line or the end of the file */
			then if search (in_chars (nlindex + 1), HT_or_NL_or_SP) = 0
			then goto process_normally;
		     call write (store);
		     store = "";
		     goto continue;
		end;

process_normally:	if store_len = ll 
		     then do;			/* line is exactly the right size */
		     outline = rtrim (store);		/* put it in the output buffer */
		     store = "";			/* clear save area */
		     call write (outline);		/* write it out */
		end;
		else if store_char (ll + 1) = " " 
		     then do;			/* blank at ll + 1 */
		     outline = rtrim (substr (store, 1, ll)); /* put first ll chars in out buffer */
		     store = ltrim (substr (store, ll + 2)); /* let save area have the rest */
                         if outline ^= "" then do;
                              if adjust & length (outline) < ll	/* needs adjusted */
			then call adjust_line (outline, ll);
		          call write (outline);		/* and write */
                         end;
		end;
		else do;

/* find first blank counting left from ll */
		     spindex = ll - index (reverse (substr (store, 1, ll)), " ");
		     if spindex ^= ll &
			(spindex - ind) > 0		/* don't wanna go into the left margin */
			then do;
			if hyphenating
			     then if ll - spindex > current_syllable_size + 1
			     then do;
			     hyph_ptr = addr (store_char (spindex + 2));
			     hyph_len = search (substr (store, spindex + 2), " ") - 1;
			     if hyph_len = -1		/* no spaces */
				then hyph_len = store_len - spindex - 1;
			     hyph_space = ll - spindex - 1;
			     call hyphenate_word_ (hyph_word, hyph_space, hyph_point, code);
			     if code ^= 0 
				then goto done;
			     if hyph_point > current_syllable_size - 1
				then do;
				outline = rtrim (substr (store, 1, spindex + hyph_point + 1));
				outline = outline || HYPHEN;
				store = ltrim (substr (store, spindex + hyph_point + 2));
				goto adjust_check;
			     end;
			end;
			outline = rtrim (substr (store, 1, spindex)); /* save off chars up to that blank */
			store = ltrim (substr (store, spindex + 2)); /* put rest in save area */
adjust_check:		if adjust 
			     then call adjust_line (outline, ll); /* call space filling rtn */
		     end;

						/* no blanks from 1 to ll */
		     else do;

			if hyphenating		/* try hyphenating first */
			     then do;
			     hyph_ptr = addr (store_char (1));
			     hyph_len = store_len;
			     hyph_space = ll;
			     call hyphenate_word_ (hyph_word, hyph_space, hyph_point, code);
			     if code ^= 0
				then goto done;
			     if hyph_point >= current_syllable_size
				then do;
				outline = substr (store, 1, hyph_point);
				outline = outline || HYPHEN;
				store = substr (store, hyph_point + 1);
				goto write_here;
			     end;
			end;
			if breaking_words
			     then do;		/* either cut it off in mid-word */
			     outline = substr (store, 1, ll);
			     store = substr (store, ll + 1);
			end;
			else do;
			     if index (substr (store, ind + 1), " ") ^= 0
						/* or cut it off at first blank past ll */
			     then do;
			          outline = substr (store, 1, index (store, " ") - 1);
				store = ltrim (substr (store, index (store, " ") + 1));
			     end;
			     else do;		/* no blanks anywhere in line */
				outline = store;
				store = "";
			     end;
			     call err_reporter (fdoc_et_$text_too_long_for_line);	/* too much data for output line */
			end;
		     end;
write_here:	     call write (outline);		/* and finally write */
		end;
still_in_write_loop_with_more_to_process:		/* come back here from bs_rtn */
	     end;
	     goto continue;				/* branch around backspace code */

bs_rtn:

/* At this point we think we have more than ll characters, but we know we have
   backspaces.  We have to find out how many print positions we actually have
   and if it's still more than ll, we have to locate where to break the line
   apart.  vlen is the actual number of print positions. */
	     
	     store = copy (" ", ind_minus_und) || store;/* indent */
	     last_blank = 0;
	     vlen = 0;
	     bscnt = 0;
	     long_line_and_no_blank = "0"b;
	     fit = "0"b;
	     do k = 1 to store_len while (^fit);
		if store_char (k) = BS
		     then do;
		     k = k + 1;
		     bscnt = bscnt + 1;
		end;
		else vlen = vlen + 1;
		if store_char (k) = " "
		     then do;
		     if long_line_and_no_blank 
			then do;
			outline = substr (store, 1, k - 1);
			store = ltrim (substr (store, k));
			call err_reporter (fdoc_et_$text_too_long_for_line);
			call write (outline);
			goto still_in_write_loop_with_more_to_process;
		     end;
		     last_blank = k;
		     if vlen > ll
			then do;
			outline = substr (store, 1, k - 1);
			store = ltrim (substr (store, k));
			call err_reporter (fdoc_et_$text_too_long_for_line);
			call write (outline);
			goto still_in_write_loop_with_more_to_process;
		     end;
		end;
		if vlen = ll
		     then do;
		     if k < store_len
			then if store_char (k + 1) = BS
			then k = k + 2;
		     if k = store_len
			then fit = "1"b;
		     if k < store_len
			then if store_char (k + 1) = " "
			then fit = "1"b;
		     else if last_blank ^= 0
			then do;
			do h = last_blank + 1 to k - 1;
			     if store_char (h) = BS
				then bscnt = bscnt - 1;
			end;
			k = store_len;
		     end;
		     else if breaking_words
			then do;
			outline = substr (store, 1, k);
			store = substr (store, k + 1);
			call write (outline);
			goto still_in_write_loop_with_more_to_process;
		     end;
		     else long_line_and_no_blank = "1"b;
		end;
	     end;

	     if long_line_and_no_blank
		then do;
		outline = store;
		store = "";
		call err_reporter (fdoc_et_$text_too_long_for_line);
		call write (outline);
		goto continue;
	     end;
	     else if vlen < ll			/* print position count < ll */
		then do;
		store = substr (store, (ind + 1) - und);/* undo indentation */
		goto continue;			/* get another line */
	     end;
	     else if fit
		then do;
		outline = substr (store, 1, k - 1);
		if k - 1 ^= store_len
		     then store = ltrim (substr (store, k));
		else store = "";
		call write (outline);
	     end;
	     else do;
		if line_began_with_blank & dont_break_indented_lines
		     then do;			/* see the comments that proceed */
		     if nlindex < inlen		/* the label "process_normally" */
			then if search (in_chars (nlindex + 1), HT_or_NL_or_SP) = 0
			then goto process_backspaces_normally;
		     call write (store);
		     store = "";
		     goto continue;
		end;
process_backspaces_normally:
		outline = rtrim (substr (store, 1, last_blank - 1)); /* move printable portion to buffer */
		store = ltrim (substr (store, last_blank + 1)); /* make rest contents of store */
		if adjust 
		     then call adjust_line (outline, ll + bscnt * 2);  /* call space fill rtn */
		call write (outline);		/* and write */
	     end;
	     goto still_in_write_loop_with_more_to_process;

continue:
	     if nlindex ^= 0			/* if there is more data */
		then do;
		inptr = addr (in_chars (nlindex + 1));	/* move input ptr past next NL */
		inlen = inlen - nlindex;		/* change length to reflect what is left */
                    if continued_line
                           then do;
                           spindex = verify (infile, " ");
                           inptr = addr (in_chars (spindex));
                           inlen = inlen - spindex + 1;
                    end;
	     end;
	     else goto no_more_data;			/* end of component, maybe end of file */
	end;

/* Almost done, now clean up. */

no_more_data:
	if string_entry				/* input string can't be MSF */
	     then goto no_more_components;
	in_comp_no = in_comp_no + 1;			/* try next component */
	call msf_manager_$get_ptr (infcbptr, in_comp_no, "0"b, inptr, bc, code);
	if inptr = null
	     then if code = error_table_$noentry	/* we have processed last component */
	     then do;
		code = 0;
		goto no_more_components;
	     end;
	else goto done;				/* msf_manager_ crapped out */
	component_ends_wo_NL = (initial_in_chars (initial_inlen) ^= NL);
	inlen = divide (bc, 9, 21, 0);
	goto process_one_component;			/* here we go again */
	
no_more_components:
	if store_len ^= 0
	     then do;
	     store = copy (" ", ind_minus_und) || store;/* indent */
	     call write (store);			/* write out last line */
	end;
	if lnctr ^= 0 & ^galley_mode			/* if a partial */
	     then do;				/* page has been written */
	     if pgno 
		then do;
		do k = 1 to ((pl - 5) - lnctr);
		     if filout 
			then call write_file (NL);	/* add blank line */
		     else do;
			ioxbuf = NL;
			call iox_$put_chars (iocbptr, addr (ioxbuf), 1, code);
			if code ^= 0
			     then goto done;
		     end;
		end;
		pgctr = pgctr + 1;			/* bump page counter */
		pgctra = ltrim (char (pgctr));
						/* and write page number */
		if filout 
		     then call write_file (indstr 
		     || copy (" ", divide (ll - length (pgctra), 2, 17, 0))
		     || pgctra || FF);
		else do;
		     ioxbuf = indstr 
			|| copy (" ", divide (ll - length (pgctra), 2, 17, 0))
			|| pgctra || copy (NL, 5);
		     call iox_$put_chars (iocbptr, addr (ioxbuf), length (rtrim (ioxbuf)), code);
		     if code ^= 0
			then goto done;
		end;
	     end;
	     else do;
		if filout & char_cnt ^= 1
		     then do;
		     outptr = addr (out_chars (char_cnt - 1)); /* back up outptr 1 position */
		     char_cnt = char_cnt - 1;
		     call write_file (FF);		/* replace trailing NL with FF */
		end;
		else if ^filout
		     then do k = 1 to (pl - lnctr);
		     ioxbuf = NL;
		     call iox_$put_chars (iocbptr, addr (ioxbuf), 1, code);
		     if code ^= 0
			then goto done;
		end;
	     end;
	end;
	if string_entry 
	     then outlen = char_cnt - 1;

check_version_and_set_options:
	proc;
		
	if format_document_options.version_number = format_document_version_1
	     then do;				/* assign defaults */
	     dont_compress, breaking_words, maximum_line_length, 
		dont_break_indented_lines, using_sub_err, hyphenating = "0"b;
	     fill = "1"b;
	     default_syllable_size = 2;		/* old version has no syllable size, assign one */
	end;
	else if format_document_options.version_number = format_document_version_2
	     then do;				/* this guy knows what he is doing */
		dont_compress = format_document_options.switches.dont_compress_sw;
		breaking_words = format_document_options.switches.break_word_sw;
		maximum_line_length = format_document_options.switches.max_line_length_sw;
		dont_break_indented_lines = format_document_options.switches.dont_break_indented_lines_sw;
		using_sub_err = format_document_options.switches.sub_err_sw;
		fill = ^format_document_options.switches.dont_fill_sw;
		hyphenating = format_document_options.switches.hyphenation_sw;
		default_syllable_size = format_document_options.syllable_size;
	     end;
	else do;
	     code = error_table_$unimplemented_version;
	     goto done;
	end;

	adjust = format_document_options.switches.adj_sw;
	galley_mode = format_document_options.switches.galley_sw;
	initial_ind = format_document_options.indentation;
	initial_line_length = format_document_options.line_length;
	literal_mode = format_document_options.literal_sw;
	ll = format_document_options.line_length;
	pgno = format_document_options.switches.pgno_sw;

     end check_version_and_set_options;

write:	proc (line);
dcl  line char (*) varying parameter;

	und = 0;					/* get rid of undent, it only applies to one line */
	ind_minus_und = ind;
	if lnctr = 0 & ^galley_mode
	     then do;				/* BEGIN PAGE */
	     if filout 
		then call write_file (copy (NL, 3));
	     else do;
		ioxbuf = copy (NL, 6);
		call iox_$put_chars (iocbptr, addr (ioxbuf), 6, code);
		if code ^= 0
		     then goto done;
	     end;
	     lnctr = 6;
	end;

	if filout 				/* WRITE LINE */
	     then call write_file (indstr||line||NL);     /* add a newline */
	else do;
	     ioxbuf = indstr||line||NL;
	     call iox_$put_chars (iocbptr, addr (ioxbuf), length (rtrim (ioxbuf)), code);
	     if code ^= 0
		then goto done;
	end;

	if ^galley_mode				/* END PAGE */
	     then do;
	     lnctr = lnctr + 1;			/* bump line counter */
	     if pgno
		then if lnctr = (pl - 7)
		then do;
		pgctr = pgctr + 1;   		/* bump page counter */
		lnctr = 0;			/* roll the line counter */
		pgctra = ltrim (char (pgctr));


		if filout				/* write page number */
		     then call write_file (copy (NL, 2) || indstr 
		     || copy (" ", divide (ll - length (pgctra), 2, 17, 0))
		     || pgctra || FF);
		else do;
		     ioxbuf = copy (NL, 2) || indstr
			|| copy (" ", divide (ll - length (pgctra), 2, 17, 0))
			|| pgctra || copy (NL, 5);
		     call iox_$put_chars (iocbptr, addr (ioxbuf), length (rtrim (ioxbuf)), code);
		     if code ^= 0
			then goto done;
		end;
	     end;
	     else;
	     else if lnctr = (pl - 6)
		then do;
		lnctr = 0;
		if filout & char_cnt ^= 1
		     then out_chars (char_cnt - 1) = FF; /* overwrite LF with FF */
		else if ^filout
		     then do;
		     ioxbuf = copy (NL, 6);
		     call iox_$put_chars (iocbptr, addr (ioxbuf), 6, code);
		     if code ^= 0
			then goto done;
		end;
	     end;
	end;
     end write;

write_file:
     proc (text);
dcl  text char (*) parameter;

     tlen = length (text);
     char_cnt = char_cnt + tlen;

     if string_entry
	then do;
	if (char_cnt - 1) > outstringlen		/* can't write past end of string */
	     then do;
	     space_available = outstringlen + tlen + 1 - char_cnt;	/* write what you can */
	     substr (outfile, 1, space_available) = substr (text, 1, space_available);
	     outlen = outstringlen;
	     code = error_table_$smallarg;		/* and go boom */
	     goto done;
	end;
	else substr (outfile, 1, tlen) = text;		/* normal write */
     end;

     else if char_cnt > maxcnt			/* can't write past end of component */
	then do;
	space_available = tlen + maxcnt - char_cnt;	/* write what you can */
	substr (outfile, 1, space_available) = substr (text, 1, space_available);
	out_comp_no = out_comp_no + 1;		/* get another component */
	call msf_manager_$get_ptr (outfcbptr, out_comp_no, "1"b, outptr, bc, code);
	if outptr = null ()				/* msf_manager_ burped */
	     then do;
	     format_document_options.file_sw = "1"b;
	     goto done;
	end;
	initial_outptr = outptr;			/* write rest to next component */
	substr (outfile, 1, tlen - space_available) = substr (text, space_available + 1);
	char_cnt = (tlen - space_available) + 1;
     end;
     else substr (outfile, 1, tlen) = text;		/* normal write */

     outptr = addr (out_chars (char_cnt));		/* move output ptr to next available position */
end write_file;

adjust_line: proc (adj_line, linelength);

/* routine to fill spaces into line that is less than ll long */
dcl  adj_line char (508) varying parameter;
dcl  linelength fixed parameter;

	     spaces = 0;
	     adj_line_out = adj_line;
	     pads = linelength - length (adj_line);	/* how many spaces to fill */
	     do i = verify (adj_line, " ") to length (adj_line);
		spindex = index (substr (adj_line, i), " ");
		if spindex = 0
		     then i = length (adj_line);
		else do;
		     spaces = spaces + 1;		/* add to count of spaces in line */
		     i = i + spindex - 1;
		     space_pos (spaces) = i;		/* mark position of space */
		end;
	     end;

/* fill spaces in adjacent to existing spaces starting from left on first line
   (starting again on left if necessary) and then reverse the procedure to 
   start from the right the next time 
*/
	     if spaces ^= 0 
		then do;
		if left 
		     then do i = 1 to pads;		/* adjust from left */
		     j = mod (i, spaces);
		     if j = 0 
			then j = spaces;
		     adj_line_out = substr (adj_line_out, 1, space_pos (j) + j - 1)||" "||substr (adj_line_out, space_pos (j) + j);
		     space_pos (j) = space_pos (j) + j;
		     left = "0"b;
		end;
		else do;				/* adjust from right */
		     k = spaces;
		     do i = pads to 1 by -1;
			if k = 0 
			     then k = spaces;
			adj_line_out = substr (adj_line_out, 1, space_pos (k))||substr (adj_line_out, space_pos (k));
			do j = k to spaces;
			     space_pos (j) = space_pos (j) + 1;
			end;
			left = "1"b;
			k = k - 1;
		     end;
		end;
	     end;
	     adj_line = adj_line_out;
	end adjust_line;

look_for_hyphenation_routine: 
	     proc;

	     on linkage_error 
		begin;
		hyphenating = "0"b;	
		hyphenation_routine_state = 2;	/* not found */
		call err_reporter (fdoc_et_$no_hyphenate_word);
		goto reversion;
	     end;
	     hyphenate_entry = hyphenate_word_;
	     hyphenation_routine_state = 1;		/* found */
reversion:
	     revert linkage_error;
	end look_for_hyphenation_routine;

err_reporter:
	     proc (errcode);
dcl errcode fixed bin (35) parameter;

	     error = "1"b;
	     errtxt = "";

	     if format_document_options.error_sw
		then do;
		call convert_status_code_ (errcode, trash, errtxt);
		call ioa_$rs ("line ^d^-^a^[^s^;^/^a^]",
		     error_lines,
		     elen,
		     inplnctr,
		     errtxt,
		     ((^filout) & 
			((errcode = fdoc_et_$text_too_long_for_line)) | 
			(errcode = fdoc_et_$line_too_long) | 
			(errcode = fdoc_et_$no_hyphenate_word)),
		     buf);

		call iox_$put_chars (iox_$error_output, addr (error_lines), elen, code);
		if code ^= 0
		     then goto done;
	     end;
	     
	     if using_sub_err
		then do;
		if errtxt ^= ""
		     then call convert_status_code_ (errcode, trash, errtxt);
		if errcode = fdoc_et_$line_length_too_small
		     then subcode = error_table_$fatal_error;
		else subcode = error_table_$recoverable_error;
		error_info.version_number = format_document_error_version_1;
		error_info.error_code = errcode;
		error_info.line_number = inplnctr;
		if errcode = fdoc_et_$no_hyphenate_word
		     then error_info.text_line = "";
		else error_info.text_line = buf;
		call sub_err_ (subcode, 
		     "format_document_", 
		     (ACTION_CAN_RESTART | ACTION_DEFAULT_RESTART | ACTION_QUIET_RESTART),
		     addr (error_info), 
		     retval,
		     errtxt);
	     end;

	end err_reporter;

done_proc:     
	proc;					/* clean up time */

	if indptr ^= null ()
	     then free indstr;
	if code = 0 & error
	     then code = error_table_$recoverable_error;
	if infcbptr ^= null ()
	     then call msf_manager_$close (infcbptr);
	if outfcbptr ^= null ()
	     then do;
	     call tssi_$finish_file (outfcbptr, out_comp_no, ((char_cnt - 1) * 9), "101"b, aclinfoptr, temp_code);
	     if code = 0				/* don't want to clobber code so use a temporary */
		then code = temp_code;		/* and then assign it if code was zero */
	end;
     end done_proc;
     
done:
	call done_proc;
	
     end format_document_;




		    format_string.pl1               11/01/84  1411.7r w 11/01/84  1303.8      162936



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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: format_string, fstr							*/
	/*									*/
	/*   This command/af does fill and adjust processing for a string, using		*/
	/* format_document_$string.							*/
	/*									*/
	/* History:								*/
	/* 0) Created: December 1983 by G. C. Dixon					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

format_string:
fstr:	proc options(variable);
	
    dcl	Ifirst_string_arg		fixed bin,	/* arg no of the first string argument.  It and	*/
						/*   all remaining args are strings to be 	*/
						/*   formatted.				*/
       	Presult			ptr,		/* ptr to resulting output from format_document_	*/
	Pstr			ptr,		/* ptr to input to format_document_$string.	*/
	Pstr_nonvar		ptr,		/* ptr to nonvarying representation of input.	*/
	Pundent_line		ptr,		/* ptr to portion of first line of result which	*/
						/*   must be indented or undented.		*/
	Sadjust			bit(1),		/* On if output to be right-adjusted.		*/
	Sbreak_word		bit(1),		/* On if over-length words can be broken across	*/
						/*   lines.				*/
	Shyphenate		bit(1),		/* On if hyphenation should be performed.	*/
	code			fixed bin(35),
         (hyphenate_word_part, indent, line_length, starting_column, undent)
				fixed bin,	/* Control argument operand values.		*/
         (result_len, str_length)	fixed bin(21);	/* Length of input and output strings.		*/

    dcl	Lstr_nonvar		fixed bin(21) based(Pstr),
	result			char(result_len) based(Presult),
	result_array (result_len)	char(1) based (Presult),
	str			char(str_length) varying based (Pstr),
	str_nonvar		char(Lstr_nonvar) based(Pstr_nonvar),
	undent_line		char(line_length) varying based (Pundent_line);
	
    dcl  (abs, addr, addrel, copy, currentsize, index,
	length, null, substr, wordno)
				builtin;

    dcl  (cleanup, sub_error_)	condition;

    dcl   format_document_$string	entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35)),
         (get_temp_segment_, release_temp_segment_)
				entry (char(*), ptr, fixed bin(35)),
	ioa_$nnl			entry() options(variable),
	requote_string_		entry (char(*)) returns(char(*));

    dcl  (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	NL			char(1) int static options(constant) init("
"),
	SP			char(1) int static options(constant) init(" "),
         (error_table_$badopt,
	error_table_$inconsistent,
	error_table_$noarg)		fixed bin(35) ext static,
	ME			char(13) int static options(constant) init("format_string"),
	sys_info$max_seg_size	fixed bin(35) ext static;

	call get_invocation_type (Saf);		/* Find out how we were invoked, get count of args*/

	Sadjust = FALSE;				/* Initialize control argument values.		*/
	Sbreak_word = TRUE;
	Shyphenate = FALSE;
	hyphenate_word_part = 2;
	indent = 0;
	line_length = 65;
	starting_column = 1;
	str_length = 0;
	undent = 0;

	do while (get_arg());			/* Process control arguments, and figure length	*/
	   if index(arg, "-") = 1 then do;		/*   of text string.			*/

	      if arg = "-line_length" | arg = "-ll" then do;
	         if get_op ("^a requires a line length operand.", arg) then do;
		  line_length = cv_int$pos (op, "^a requires a positive line length operand.", arg);
		  end;
	         end;

	      else if arg = "-indent" | arg = "-ind" | arg = "-in" then do;
	         if get_op ("^a requires a line indentation operand.", arg) then do;
		  indent = cv_int$nonneg (op, "^a requires a nonnegative indentation count.", arg);
		  end;
	         end;

	      else if arg = "-undent" | arg = "-und" | arg = "-un" then do;
	         if get_op ("^a requires a first line undentation operand.", arg) then do;
		  undent = cv_int (op, "^a requires an integer undentation operand.", arg);
		  end;
	         end;

	      else if arg = "-column" | arg = "-col" then do;
	         if get_op ("^a requires a starting column position operand.", arg) then do;
		  starting_column = cv_int$pos (op, "^a requires a positive column position.", arg);
		  end;
	         end;

	      else if arg = "-adjust" | arg = "-adj" then
	         Sadjust = TRUE;
	      else if arg = "-no_adjust" | arg = "-nadj" then
	         Sadjust = FALSE;

	      else if arg = "-break_word" then
	         Sbreak_word = TRUE;
	      else if arg = "-no_break_word" then
	         Sbreak_word = FALSE;

	      else if arg = "-hyphenate" | arg = "-hph" then do;
	         Shyphenate = TRUE;
	         if get_op ("", arg) then do;
		  hyphenate_word_part = cv_int$pos (op, "", arg);
		  if hyphenate_word_part = -9999 then do;
		     call put_op();			/* -9999 indicates conversion error occurred.	*/
		     hyphenate_word_part = 2;		/* Assumed -hph operand is really another ctl arg.*/
		     end;
		  end;
	         end;
	      else if arg = "-no_hyphenate" | arg = "-nhph" then
	         Shyphenate = FALSE;

	      else if arg = "-string" | arg = "-str" then do;
	         if get_arg () then go to STRING_ARG;
	         end;

	      else
	         call error (error_table_$badopt, ME, arg);
	      end;

	   else do;				/* first text string argument.		*/
STRING_ARG:     Ifirst_string_arg = Iarg;
	      str_length = str_length + length(arg);
	      do while (get_arg());			/*   All remaining args are text strings.	*/
	         str_length = str_length + length(SP) + length(arg);
	         end;
	      end;
	   end;
	
	if str_length = 0 then			/* Check argument consistency.		*/
	   call error (error_table_$noarg, ME, "Need a string to be formatted.");
	if (indent > 0 & indent >= line_length) then
	   call error (error_table_$inconsistent, ME, "^/-line_length ^d -indent ^d", line_length, indent);
	if (undent > 0 & undent > indent) then
	   call error (error_table_$inconsistent, ME, "^/-indent ^d -undent ^d", indent, undent);
	if (undent < 0 & indent-undent > line_length) then
	   call error (error_table_$inconsistent, ME, "^/-line_length ^d ^[-indent ^d ^;^s^]-undent ^d",
	      line_length, indent > 0, indent, undent);
	if (starting_column > line_length) then
	   call error (error_table_$inconsistent, ME, "^/-line_length ^d -column ^d",
	      line_length, starting_column);
	if Serror then return;

	str_length = str_length + abs(undent) + starting_column;
						/* Add room to text string for undent space	*/
						/*   and starting column filler.		*/

	Pstr = null;				/* Get temp seg to hold string, undent_line and	*/
	on cleanup begin;				/*   result.				*/
	   call release_temp_segment_ (ME, Pstr, code);
	   end;
	call get_temp_segment_ (ME, Pstr, code);
	Serrors_are_fatal = TRUE;
	call error (code, ME, "Getting a temp segment.");

	Pstr_nonvar = addrel(Pstr, 1);		/* Overlay str (which is a varying string)	*/
						/*   with its nonvarying representation.	*/

	fdo.version_number = format_document_version_2;	/* Fill in format_document_ info structure.	*/
	fdo.indentation = indent;
	fdo.line_length = line_length - indent;
	fdo.switches = FALSE;
	fdo.adj_sw = Sadjust;
	fdo.galley_sw = TRUE;
	fdo.literal_sw = TRUE;
	fdo.break_word_sw = Sbreak_word;
	fdo.max_line_length_sw = TRUE;
	fdo.sub_err_sw = TRUE;
	fdo.hyphenation_sw = Shyphenate;
	fdo.syllable_size = hyphenate_word_part;

	str = "";					/* Prepare to fill in string from arguments.	*/
	if undent < 0 then				/* For indented first line, add a place holder.	*/
	   str = copy ("~", -undent);

	call reprocess_args(Ifirst_string_arg);		/* Reprocess arguments to fill in text args into  */
	do while (get_arg());			/*   string variable.			*/
	   str = str || arg;
	   do while (get_arg());
	      str = str || SP;
	      str = str || arg;
	      end;
	   end;

	Pundent_line = addrel (Pstr, currentsize(str));
	if undent > 0 then do;			/* For undented first line, save portion of string*/
	   undent_line = copy(SP, indent-undent);	/*   to be undented, removing it from input.	*/
	   if length(str) > undent then do;
	      undent_line = undent_line || substr (str, 1, undent);
	      str = substr(str, undent+1);
	      end;
	   else do;
	      undent_line = undent_line || str;
	      str = copy (SP, undent-length(str)+1);
	      end;
	   end;

	Presult = addrel (Pundent_line, currentsize(undent_line));
	result_len = sys_info$max_seg_size*4 - wordno(Presult);

	on sub_error_ call sub_error_handler();
	call format_document_$string (str_nonvar, result,
	   result_len, addr(fdo), code);		/* Call format_document_ to do the fill/adj work. */
	revert sub_error_;
	if code ^= 0 then
	   call error (code, ME, "While formatting the string.");

	else do;					/* If no errors occurred:			*/
	   if undent < 0 then			/*   remove placeholder for indented first line.	*/
	      substr (result, indent+1, -undent) = "";
	   else if undent > 0 then			/*   or add undented part of first line to result.*/
	      substr (result, 1, indent) = undent_line;
	   if starting_column > 1 then do;		/* If other text already appears on first line:	*/
	      if starting_column-1 <= indent-undent then do;
	         Presult = addr (result_array(starting_column));
	         result_len = result_len - (starting_column-1);
	         end;				/*   remove indent spaces on first line to	*/
						/*   accommodate assumed text; or		*/
	      else do;				/*   force output to begin on a new line.	*/
	         result_len = result_len + length(NL);
	         result = NL || substr(result, 1, result_len-length(NL));
	         end;
	      end;
	   if Saf then do;				/* AF: return unquoted result, without final NL.	*/
	      result_len = result_len - length(NL);
	      call set_return_arg (requote_string_(result));
	      end;
	   else					/* COMMAND: print final result.		*/
	      call ioa_$nnl ("^a", result);
	   end;

RETURN:	if Pstr ^= null then			/* Give back the temp segment.		*/
	   call release_temp_segment_ (ME, Pstr, code);
	return;

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

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


cv_int:	proc (op, str, arg1) returns (fixed bin);	/* Convert control arg operand to integer.	*/

    dcl	op			char(*),
	str			char(*),
	arg1			char(*);

    dcl   Smust_be_nonnegative	bit(1),
	Smust_be_positive		bit(1),
	number			fixed bin;

    dcl	convert			builtin;

    dcl  (conversion, size)		condition;
	
    dcl  (error_table_$bad_conversion,
          error_table_$out_of_bounds)	fixed bin(35) ext static;

	Smust_be_nonnegative = FALSE;
	Smust_be_positive = FALSE;

CV_NUM:	on conversion, size begin;
	   code = error_table_$bad_conversion;
	   if str = "" then go to BAD_NUM_OK;		/* operand optional: no error message.		*/
	   go to BAD_NUM;
	   end;
	number = convert (number, op);
	revert conversion, size;
	if (number < 0 & Smust_be_nonnegative) |
	   (number < 1 & Smust_be_positive) then do;
	   code = error_table_$out_of_bounds;
BAD_NUM:	   call error (code, ME, "^a ^a^/" || str, arg1, op, arg1);
	   return (1);
	   end;
	return (number);

BAD_NUM_OK:
	return (-9999);

cv_int$nonneg:
	entry (op, str, arg1) returns(fixed bin);

	Smust_be_nonnegative = TRUE;
	Smust_be_positive = FALSE;
	go to CV_NUM;

cv_int$pos:
	entry (op, str, arg1) returns(fixed bin);

	Smust_be_nonnegative = FALSE;
	Smust_be_positive = TRUE;
	go to CV_NUM;

	end cv_int;

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


    dcl	Serror			bit(1),		/* On if fatal error has occurred.		*/
       	Serrors_are_fatal		bit(1);		/* On if errors are fatal.			*/

error: 	proc options(variable);			/* Procedure to report errors via com_err_ or	*/
						/*   active_fnc_err_, as appropriate.  This proc	*/
						/*   has same calling sequence as com_err_.	*/

    dcl	code			fixed bin(35) based (Pcode),
	Pcode			ptr;

    dcl	cu_$arg_list_ptr		entry returns(ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$generate_call		entry (entry, ptr);

	call cu_$arg_ptr (1, Pcode, 0, 0);		/* Access error table code argument.		*/
	if code = 0 then return;			/* If non-zero, this ISN'T an error.		*/
	Serror = TRUE;				/* Record fact that an error occurred.		*/
	call cu_$generate_call (err, cu_$arg_list_ptr()); /* Actually call com_err_ or active_fnc_err_.	*/
	if Serrors_are_fatal then
	   go to RETURN;

	end error;

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


    dcl	Iarg			fixed bin,	/* Current argument being processed.		*/
	Larg			fixed bin(21),	/* Length of current argument.		*/
	Lop			fixed bin(21),	/* Length of current ctl arg operand.		*/
	Lret			fixed bin(21),	/* Max length of AF return value.		*/
	Nargs			fixed bin,	/* Number of arguments.			*/
	Parg			ptr,		/* Ptr to current argument.			*/
	Parg_list			ptr,		/* Ptr to command/af's argument list.		*/
	Pop			ptr,		/* Ptr to current operand.			*/
	Pret			ptr,		/* Ptr to AF return value.			*/
	Saf			bit(1),		/* On if invoked as an active function.		*/
	arg			char(Larg) based(Parg),
	op			char(Lop) based(Pop),
	ret			char(Lret) varying based(Pret),
         (arg_ptr			variable,
	cu_$af_arg_ptr_rel,
	cu_$arg_ptr_rel)		entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
       	cu_$arg_list_ptr		entry returns(ptr),
         (err			variable,
	active_fnc_err_,		
	com_err_)			entry() options(variable);
	

get_invocation_type:				/* Were we invoked as command or af?  Arg count?	*/
	proc (Saf);

    dcl	Saf			bit(1);

	Serrors_are_fatal = FALSE;
	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;
	   Saf = TRUE;
	   arg_ptr = cu_$af_arg_ptr_rel;
	   err = active_fnc_err_;
	   ret = "";
	   end;
	else do;
	   Saf = FALSE;
	   arg_ptr = cu_$arg_ptr_rel;
	   err = com_err_;
	   end;
	Iarg = 0;					/* No args processed so far.			*/
	Serror = FALSE;				/* No errors so far.			*/
	Parg_list =  cu_$arg_list_ptr();		/* Remember arg list ptr for subrs below.	*/

	end get_invocation_type;
       

get_arg:	proc returns(bit(1));			/* Returns TRUE if another argument exists.	*/
						/*   Its value is accessible via arg variable.	*/

	if Iarg+1 > Nargs then
	   return(FALSE);
	Iarg = Iarg + 1;
	call arg_ptr (Iarg, Parg, Larg, code, Parg_list);
	return(TRUE);

get_op:	entry (str, arg1) returns(bit(1));		/* Returns TRUE if another argument exists.	*/
						/*   Its value is accessible via op variable.	*/

    dcl	str			char(*),
	arg1			char(*);

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

	if Iarg+1 > Nargs then do;
	   if str ^= "" then
	      call error (error_table_$noarg, ME, str, arg1);
	   return(FALSE);
	   end;
	Iarg = Iarg + 1;
	call arg_ptr (Iarg, Pop, Lop, code, Parg_list);
	if op = "" then do;
	   if str ^= "" then
	      call error (error_table_$smallarg, ME, """^va""^/" || str, length(op), op, arg1);
	   return(FALSE);
	   end;
	return(TRUE);


put_op:	entry;					/* Return operand to list of unprocessed args.	*/

	Iarg = Iarg - 1;
	return;


reprocess_args:					/* Reprocess argument list again, starting with	*/
	entry (Ith_arg);				/*   the Ith argument.			*/

    dcl	Ith_arg			fixed bin;

	Iarg = Ith_arg - 1;				/* get_arg adds 1 before reading an arg.	*/
	return;


set_return_arg:					/* Set AF return value.			*/
	entry (str);

	ret = str;
	return;

	end get_arg;

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


sub_error_handler:
	proc;

    dcl	code			fixed bin(35),
	continue_to_signal_		entry (fixed bin(35)),
	error_table_$unimplemented_version
				fixed bin(35) ext static,
       	find_condition_info_	entry (ptr, ptr, fixed bin(35));

	condition_info_ptr = addr (auto_condition_info);
	condition_info.version = condition_info_version_1;
	call find_condition_info_ (null(), addr(condition_info), code);
	if code ^= 0 then
	   call error (code, ME, "Handling sub_error_ condition from format_document_$string.");

	sub_error_info_ptr = condition_info.info_ptr;
	if sub_error_info.version ^= sub_error_info_version_1 then
	   call error (error_table_$unimplemented_version, ME, "
Version ^d of sub_error_info structure isn't supported.",
	      sub_error_info.version);
	if sub_error_info.name ^= "format_document_" then do;
	   call continue_to_signal_ (code);
	   return;
	   end;

	format_document_error_ptr = sub_error_info.info_ptr;
	if format_document_error.version_number ^= format_document_error_version_1 then 
	   call error (error_table_$unimplemented_version, ME, "
Version ^d of format_document_error structure isn't supported.",
	      format_document_error.version_number);
	call error (format_document_error.error_code, ME);
	return;

%include condition_info;

    dcl	1 auto_condition_info	aligned like condition_info;

%include condition_info_header;
%include sub_error_info;

%include format_document_error;

	end sub_error_handler;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include format_document_options;

    dcl	1 fdo			aligned like format_document_options;

	end format_string;




		    indent.pl1                      12/17/85  1305.1rew 12/16/85  1652.7      428265



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


/****^  HISTORY COMMENTS:
  1) change(69-06-01,VanVleck), approve(), audit(), install():
     created from a
     MAD (Michigan Algorithmic Decode) Stan Dutton's CTSS program.
  2) change(73-06-01,Morris), approve(), audit(), install():
     modified to know
     about IF statements.
  3) change(73-12-01,VanVleck), approve(), audit(), install():
     heavily
     modified to take advantage of EIS instruction set.
  4) change(74-08-01,Casey), approve(), audit(), install():
     modified to -
     check for missing quotes and other errors that are really caused by
     missing quotes; and - refuse to replace the original segment when such
     errors are detected; - rewrite argument processing to use less code and
     allow control arguments anywhere on the line.
  5) change(76-03-01,LJohnson), approve(), audit(), install():
     modified to fix
     bugs in indenting multiple line strings, to improve <NP> character
     handling, and to support .cds suffix.
  6) change(77-06-14,May), approve(), audit(), install():
     modified to add
     processing of source for the reduction_compiler, to generalize somewhat
     for other possible dialects, and to fix a bug indenting factored structure
     entries.
  7) change(85-08-02,GDixon), approve(85-09-27,MCR7261), audit(85-09-27,GWMay),
     install(85-12-16,MR12.0-1001):
     support format_pl1's unchangeable comment syntax, which is a comment
     beginning with /****^.  This is needed to prevent indent from messing up
     history comments.
                                                   END HISTORY COMMENTS */


indent: ind: proc;

/* The INDENT command indents PL1 programs to make them more readable.

   Each DO, BEGIN, or PROCEDURE statement causes an additional level of indentation
   until a corresponding END is encountered. (Multiple closure is not permitted.)
   An IF statement or ELSE statement which is continued over multiple lines will also
   indent its subsequent lines.

   Comments are lined up in a standard column. A comment will be placed in column 1 if
   it is the first thing on the line and if the preceding line was blank or another such comment.

   Declaration statements are indented in a standard form, so that factoring and
   structure nesting are exhibited.

   Multiple spaces or tabs are replaced by a single space, except for the content of strings
   and for non-leading spaces and tabs in comments.
   Spaces are inserted around the operators = -> ^= >= and <=, after commas,
   and before left parentheses and after right parentheses.
   Spaces are removed if found before a comma or right paren, or after a left paren.
   Tabs are used wherever possible to conserve space in the segment.

   Parentheses are counted, and must balance at every semicolon. A warning will be printed.
   Lines longer than 350 characters will be split with a warning message.
   Illegal characters or non-pl1 characters not contained in a string will be commented upon.

   Some uses of the identifiers begin, end, proc, procedure, do, if, then, and else
   as variable names may cause the command to become confused. This is bad programming anyway.
   The command knows when a new statement may begin and can complain about some obvious syntax errors.
   */

dcl  suffixes (3) char (4) init (".pl1", ".cds", ".rd"),	/* all the known dialects */
     suffix_lengths (3) fixed bin init (4, 4, 3),		/* and their lengths */
     suffix_len fixed bin;				/* one of the preceding */

dcl  rd_source_sw bit (1),				/* flag for source to the reduction_compiler */
     copy_this_comment_unchanged bit (1);		/* flag to copy current comment without change */

dcl (n1, n2) char (168) aligned,			/* input and output segment pathnames */
     dn char (168) aligned,				/* directory name */
     en char (32) aligned,				/* entry name */
     temp_en char (32) aligned,			/* entry name of temp seg. */
     ap ptr,					/* ptr to argument */
     al fixed bin,					/* lth of argument */
     an fixed bin,					/* current arg number */
     nargs fixed bin,				/* number of arguments */
     expecting fixed bin init (0),			/* ^=0 if expecting a numeric arg following a control arg */
     bchr char (al) based (ap) unaligned,		/* based char string */
    (linno, indent, ntab) fixed bin,			/* misc counters */
     ec fixed bin (35) init (0),			/* error code */
     offset fixed bin (24),				/* char offset in input */
    (string_offset, line_offset) fixed bin (24),		/* offsets where current string and line started */
     string_len fixed bin,				/* length of current string, for error checking */
    (p, p1) ptr,					/* pointers to input, output */
    (icb, ice, icol) fixed bin,			/* indices in line */
    (chars, temchars) char (400),			/* Working storage */
     char char (1),					/* temp */
     n fixed bin,					/* length of working line */
     lth fixed bin (24),				/* number of chars in input */
    (lth1, lth2) fixed bin,				/* length of args */
     end_count fixed bin,				/* number of END on this line */
     if_count fixed bin,				/* count of IF's encountered */
     old_if_count fixed bin,				/* previous value. */
    (scolsw,					/* TRUE if semicolon on line */
     dclfnd,					/* TRUE if DECLARE statement on line. */
     dclsw,					/* TRUE if in a declaration */
     condsw,					/* TRUE if now in if statement. */
     ifsw,					/* TRUE for if but not for else. */
     begin_ok,					/* TRUE if in an ON statement. */
     else_ok,					/* TRUE if else is now permitted. */
     strut,					/* TRUE if in structure */
     sixty,					/* TRUE if comment is to be pushed to col. 60 */
     bos,						/* TRUE if current char could be beginning of stmnt */
     blsw,					/* TRUE if preceding line blank */
     comment,					/* TRUE if currently in comment. */
     newpage,					/* TRUE if line contains newpage character */
     string,					/* TRUE if currently in string */
     pstring) bit (1) aligned,			/* TRUE if previous line ended in string */
     bfsw bit (1) aligned init ("0"b),			/* Brief mode switch */
     string_error bit (1) aligned init ("0"b),
    (false init ("0"b), true init ("1"b)) int static options (constant) bit (1) aligned, /* named bit values */
    (in, dent, dclind) fixed bin,			/* indentation */
     LMARGIN fixed bin init (11),			/* left margin */
     IN fixed bin init (5),				/* subsequent indent */
     CMC fixed bin init (61),				/* comment column */
     TABCOL fixed bin init (60),			/* nearest mult of 10 < CMC */
     NTAB fixed bin init (6),				/* number of tabs to get to TABCOL */
     nout fixed bin (24),				/* number of chars in output */
     colpos fixed bin,				/* Column pointer in output line. (last filled col) */
     parct fixed bin init (0),			/* paren count. must be 0 at semicolon */
     pdlx fixed bin,
     ifdent fixed bin,
     suffix char (4),
     suffix_assumed bit (1) init ("0"b),		/* set if indent is assuming the suffix */
    (i, j, k, kk, m) fixed bin (24);

dcl 1 pdl (1024) aligned,				/* Pushdown list. */
    2 nif fixed bin (33) unal,			/* IF count. */
    2 swc bit (1) unal,				/* Conditional switch. IF and ELSE */
    2 sw bit (1) unal;				/* IF switch. */

dcl  NP_NL_SP char (3) init static init ("
 ");
dcl  SP char (1) int static init (" ");			/* Single space. */
dcl  SP_TAB char (2) int static init ("	 ");		/* Tab and space, for verify etc. */
dcl  SP_LP_NOT char (3) int static init (" (^");
dcl  NOT_LES_GRT char (3) int static init ("^<>");
dcl  SP_TAB_COM_SEMI char (4) int static init (" ,;	");
dcl  SP_TAB_SEMI_NL char (4) int static init ("	 ;
");
dcl  SP_TAB_SEMI_LP_NL char (5) int static init (" ;	(
");
dcl  NL char (1) int static init ("
");
dcl  TABS char (40) int static init ((40)"	");

dcl  bcs char (lth) based (p) aligned;
dcl  bcso char (1048576) based (p1) aligned;

dcl  cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin),
     ioa_ entry options (variable),
     com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cu_$arg_count entry (fixed bin),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$delentry_seg entry (ptr, fixed bin (35)),
     hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5),
     ptr, fixed bin (35)),
     hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
     fixed bin (2), ptr, fixed bin (35)),
     get_pdir_ entry () returns (char (168) aligned),
     hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));

dcl (output_path_given, error_occurred) bit (1) aligned init ("0"b);



dcl  moveseg char (nout) based aligned;			/* For copy of whole segment. */

dcl  err_msg char (100) varying;

dcl  error_table_$bad_arg fixed bin (35) ext;		/* Illegal command argument */
dcl  error_table_$badopt fixed bin (35) ext;		/* Specified control arg not implemented by this command */
dcl  error_table_$noarg fixed bin (35) ext;		/* Expected argument missing */
dcl  error_table_$noentry fixed bin (35) ext;

dcl (addr, divide, fixed, length, mod, min, null, substr, index, reverse,
     search, verify, unspec) builtin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


	call cu_$arg_count (nargs);			/* get number of args */
	if nargs = 0 then do;			/* gripe if no args */
	     call com_err_ (0, "indent", "Usage: indent n1 -n2- -lm nn -in mm -cm kk -brief");
	     return;
	end;

	lth1, lth2 = 0;				/* so we can tell if we have the pathnames yet */
arg_loop:	do an = 1 to nargs;
	     call cu_$arg_ptr (an, ap, al, ec);		/* pick off next arg */

	     if ec ^= 0 then do;
print_bad_arg:	err_msg = "^a";			/* control string to just print argument */
arg_error:	call com_err_ (ec, "indent", err_msg, bchr);
		return;
	     end;

	     if expecting ^= 0 then do;

		en = bchr;			/* cv_dec_check_ needs aligned arg */
		i = cv_dec_check_ (en, ec);

		if expecting = 1 then do;		/* expecting left margin */
		     expecting = 0;
		     if ec ^= 0 then do;
blm:			err_msg = "illegal left margin arg ^a";
cv_dec_error:		ec = 0;			/* cv_dec_check_ does not return an error_table_ code */
			goto arg_error;		/* go call com_err_ */
		     end;
		     if i < 1 then goto blm;
		     if i > 100 then goto blm;
		     LMARGIN = i;
		end;

		else if expecting = 2 then do;	/* expecting indent spaces */
		     expecting = 0;
		     if ec ^= 0 then do;
bint:			err_msg = "illegal indent arg ^a";
			goto cv_dec_error;
		     end;
		     if i < 0 then goto bint;
		     if i > 100 then goto bint;
		     IN = i;
		end;

		else do;				/* must be expecting comment column */
		     expecting = 0;
		     if ec ^= 0 then do;
bcmc:			err_msg = "illegal comment column arg ^a";
			goto cv_dec_error;
		     end;
		     if i < 1 then goto bcmc;
		     if i > 350 then goto bcmc;
		     CMC = i;
		     TABCOL = 10 * divide (CMC-1, 10, 17, 0);
		     NTAB = divide (TABCOL, 10, 17, 0);
		end;

	     end;					/* end of expecting argument do group */

	     else do;				/* not-expected-argument */

		if substr (bchr, 1, 1) = "-" then do;	/* Control argument? */
		     if bchr = "-brief" then bfsw = true;
		     else if bchr = "-bf" then bfsw = true;
		     else if bchr = "-lmargin" then expecting = 1;
		     else if bchr = "-lm" then expecting = 1;
		     else if bchr = "-indent" then expecting = 2;
		     else if bchr = "-ind" then expecting = 2;
		     else if bchr = "-in" then expecting = 2;
		     else if bchr = "-comment" then expecting = 3;
		     else if bchr = "-cm" then expecting = 3;
		     else do;
			ec = error_table_$badopt;
			goto print_bad_arg;
		     end;
		end;

		else do;				/* Not control arg, must be filename */
		     if lth1 = 0 then do;		/* if we don't have input filename then this is it */
			n1 = bchr;		/* Pick up arg 1, input name */
			lth1 = al;		/* Remember length for expand path */
		     end;
		     else if lth2 = 0 then do;	/* if we don't have output filename, this is it */
			n2 = bchr;		/* User gave second name. Set it up. */
			lth2 = al;		/* Set length of second arg. */
			output_path_given = "1"b;
		     end;
		     else do;
			ec = error_table_$bad_arg;	/* "Illegal command argument" */
			goto print_bad_arg;		/* go call com_err_ to print the bad arg */
		     end;
		end;
	     end;					/* end of not-expected-argument do group */
	end arg_loop;				/* end of argument processing do group */

	if lth1 = 0 then do;			/* if input filename not given */
	     err_msg = "pathname of input file";
noarg_err:     ec = error_table_$noarg;
	     goto arg_error;
	end;

	if expecting ^= 0 then do;
	     err_msg = "after ^a";
	     goto noarg_err;
	end;

	if lth2 = 0 then do;			/* if output path not given, use input path */
	     n2 = n1;
	     lth2 = lth1;
	end;


/* END OF ARGUMENT PROCESSING */

/* Initialization */

	rd_source_sw, copy_this_comment_unchanged = false; /* flags for source to reduction_compiler */
						/* and for unchangable comments. */
	in, ifdent, if_count, old_if_count = 0;
	strut, dclsw, condsw, ifsw, begin_ok, else_ok, comment, sixty, string, pstring = false;
	bos, blsw = true;				/* Pretend line zero was empty. */
	pdlx = 1;					/* Set pushdown list to empty. */
	linno = 1;				/* This is line 1. */
	offset, nout = 1;				/* read and write pointers */

	i = index (reverse (substr (n1, 1, lth1)), ".");	/* get last component */
	if i = 0 | i > 4 then go to in_suffix;		/* wrong size, don't bother */
	suffix = substr (n1, lth1 - i + 1, i);		/* includes "." */
	do j = 1 to 3;				/* .pl1, .cds, .rd */
	     if suffix = suffixes (j)
	     then do;
		suffix_len = suffix_lengths (j);	/* for later suffix processing */
		go to good_suffix;
	     end;
	end;

/* Didn't match list of good suffices */

in_suffix: suffix = ".pl1";				/* a good guess */
	suffix_len = 4;
	substr (n1, lth1+1, suffix_len) = suffix;	/* add to name */
	lth1 = lth1+suffix_len;			/* adjust length */
	suffix_assumed = "1"b;			/* remember, this was only a guess */

good_suffix:
	if suffix = ".rd" then rd_source_sw = "1"b;	/* remember to check for rd parse in comments */

	call expand_path_ (addr (n1), lth1, addr (dn), addr (en), ec);
	if ec ^= 0 then go to error;
	call hcs_$initiate_count (dn, en, "", lth, 0, p, ec);
	if p = null then do;			/* didn't find input seg */
	     if ^suffix_assumed then go to error;	/* user gave suffix. Nothing more to try */
	     if ec ^= error_table_$noentry then go to error; /* foo.pl1 not found is the only reason to continue */
	     i = 34 - suffix_len - verify (reverse (en), " "); /* find suffix in entry name */
	     suffix = ".cds";			/* try new suffix */
	     suffix_len = 4;
	     substr (en, i, suffix_len) = substr (suffix, 1, suffix_len);
	     call hcs_$initiate_count (dn, en, "", lth, 0, p, ec);
	     if p = null then do;			/* trouble with foo.cds too */
		if ec = error_table_$noentry then
		     go to error;			/* if foo.cds not found, print error about foo.pl1 */
		substr (n1, lth1 - (suffix_len-1), suffix_len) = substr (suffix, 1, suffix_len);
						/* for other errors, print message aboout foo.cds */
		go to error;
	     end;
	end;
	if lth2 < 4 then go to out_suffix;		/* out name shorter than x.rd, need suffix */
	else if substr (n2, lth2 - (suffix_len-1), suffix_len) ^= substr (suffix, 1, suffix_len)
	then do;					/* output suffix must match input */
out_suffix:    substr (n2, lth2+1, suffix_len) = substr (suffix, 1, suffix_len);
	     lth2 = lth2+suffix_len;
	end;
	lth = divide (lth+8, 9, 17, 0);		/* compute bit count of input seg */

	temp_en = en;				/* Generate name of temp file. */
	i = 34 -suffix_len - verify (reverse (temp_en), " "); /* Locate end. */
	substr (temp_en, i, 4) = ".ind";
	call hcs_$make_seg ((get_pdir_ ()), temp_en, "", 1010b, p1, ec);
	if p1 = null then go to error;
	call expand_path_ (addr (n2), lth2, addr (dn), addr (en), ec);
	if ec ^= 0 then go to error;

/* This is the loop for each line in the input segment. Starting at "offset" a line of "n" chars
   is moved to the temporary buffer "chars". Trailing tabs and blanks are trimmed. */

loop:	pstring = string;				/* remember if previous line ended inside quotes */
	if offset > lth then go to eof;
	i = index (substr (bcs, offset), NL);		/* Find length of line. */
	if i = 0 then i = lth - offset + 1;		/* .. in case did not end in NL */
	else if i = 1 then do;			/* Check for empty line. */
	     substr (bcso, nout, 1) = NL;		/* insert in output */
	     nout = nout + 1;
	     linno = linno + 1;
	     offset = offset + 1;
	     blsw = true;
	     go to loop;
	end;
	k = i - 1;
	if k > 385 then do;				/* Line too big? */
	     k, i = 385;				/* Take first 385 chars. */
	     call ioa_ ("indent: line ^d of ""^a"" was too long & has been split.", linno, en);
	     error_occurred = "1"b;
	end;
	chars = substr (bcs, offset, k);		/* Pick up line. */
	substr (chars, k+1, 1) = NL;			/* Put in NL */
	line_offset = offset;			/* remember where line started */
	offset = offset + i;			/* Increase index. */
	n = k + 1;				/* Set up length of line. */
	if n = 1 then go to lemp;			/* Empty line? */
	if ^pstring then				/* if not in string */
	     if substr (chars, 1, 1) = "%" then do;	/* Is this an "include" line? */
lemp:		blsw = true;			/* Yes, set switch. */
		go to cpy;			/* And just copy line. */
	     end;

	icb, ice, icol, dent, end_count = 0;		/* Set up for loop. */
	scolsw, dclfnd, newpage = false;

/* The following section examines each character in the current line in "chars".
   In this section, "i" is the character index which may be from 1 to "n". */

	if pstring then do;				/* If we are now in a string, */
	     kk = index (substr (chars, 1, n-1), """");	/* .. See if it ends on this line. */
	     if kk = 0 then go to cpy;		/* Nope. Can't touch line at all. */
	     else i = kk;				/* Yes. Skip string content. */
	end;
	else i = 1;				/* Examine each character in line. */
l2s:	char = substr (chars, i, 1);			/* Pick up a character. */
	if string then do;				/* Now in a string ? */
	     if char = """" then do;			/* Watch for end */
		string = false;			/* not any more */
						/* While this ignoring of possible double quotes within a
						   string works ok for indenting, it throws off string
						   length checking. However, since this checking is to
						   help locate missing quotes, it is not really necessary
						   to check for double quotes here. */
		string_len = line_offset+i-string_offset-1; /* compute length, excluding the quotes */
		if string_len > 254 then		/* if string is too long, report line number
						   to aid user in finding missing quote */
		     if ^bfsw then			/* but only if user wants to be warned */
			if ^string_error then do;	/* report only the first one - if there is a missing quote,
						   there are probably a lot more long strings */
			     call ioa_
				("indent: possible syntax error in line ^d of ^a: string length (^d) > pl1 max.",
				linno, en, string_len);
			     string_error = "1"b;	/* remember not to report any more of these */
			     error_occurred = "1"b;
			end;
	     end;
	     go to l2e;				/* ... leaving all other chars */
	end;
	if comment then do;				/* are we now in a comment? */
	     if substr (chars, i, 2) = "*/" then do;	/* Comment ends? */
		comment = false;			/* Turn off switch. */
		if copy_this_comment_unchanged then	/* Are we in rd reductions or in unchangable	*/
						/* comment?  Then we are done with the comment.	*/
		     copy_this_comment_unchanged = false;
		else do;				/* Not in unchangable comment?		*/
		     if i > 1 then if index (SP_TAB, substr (chars, i-1, 1)) = 0
						/* chars on line prior to comment end delimiter?	*/
			then call inb (i);		/* insert blank prior to comment end delimiter	*/
		     if i < n-2 then		/* Chars on line after comment end delimiter?	*/
			if index (SP_TAB_COM_SEMI, substr (chars, i+2, 1)) = 0 then
			     call inb (i+2);	/* Nice blank after comment */
		end;
		ice = i;				/* save index of end of comment. */
		i = i + 1;			/* Don't scan slash again. */
		go to l2e;			/* Comment leaves state unchanged. */
	     end;
	     if i = 1 then do;			/* Continue comment. Trim leading blanks and tabs. */
		k = verify (substr (chars, 1, n-1), SP_TAB) - 1;
		if k = -1 then do;			/* if line of just white space inside comment */
		     chars = "";			/* replace it wich just a newline */
		     substr (chars, 1, 1) = NL;
		     n = 1;
		     go to cpy;
		end;
		if ^copy_this_comment_unchanged	/* don't disturb rd parse controls */
		then do;
		     substr (temchars, 1, n-k) = substr (chars, k+1, n-k);
		     substr (chars, 1, 3) = "";	/* Stick in three blanks. */
		     substr (chars, 4, n-k) = substr (temchars, 1, n-k);
		     i = 4;
		     n = n - k + 3;
		end;
	     end;
	     kk = index (substr (chars, i, n-i), "*/");	/* Character inside comment. Skip out to end. */
	     if kk = 0 then i = n-1;
	     else i = i + kk - 2;			/* Set so we scan the comment end next. */
	     go to l2e;
	end;
	k = fixed (unspec (char), 9);			/* See if char is ASCII */
	if k < 0 then go to ilchr;
	if k > 126 then go to ilchr;
	go to case (k);				/* Dispatch on character. */

/* Handlers for each character. */

/* Punctuation. */

case (009):					/* HT, octal 011 */
	substr (chars, i, 1) = SP;
case (032):					/* blank, octal 040 */
	if i = 1 then go to squidge;
	if substr (chars, i-1, 1) = SP then do;
squidge:	     k = verify (substr (chars, i, n-i), SP_TAB) - 1;
	     if k > 0 then call outb (i, k);		/* Remove multiple blanks and tabs. */
	end;
	go to l2e;				/* Ignore blank */
case (034):					/* quote, octal 042 */
	string = true;				/* now in string */
	string_offset = line_offset+i;		/* remember where it started, for length checking */
	kk = index (substr (chars, i+1, n-i), """");	/* Does string end on this line? */
	if kk > 0 then i = i + kk - 1;		/* Yes. Skip string contents. */
	else i = n-1;				/* No. Skip rest of line. */
	go to cbs;
case (040):					/* "(", octal 050 */
	parct = parct + 1;				/* Increase count. */
	if i > 1 then if index (SP_LP_NOT, substr (chars, i-1, 1)) = 0 then call inb (i);
	if i < n-1 then if index (SP_TAB, substr (chars, i+1, 1)) ^= 0 then call outb (i+1, 1);
	go to nxchr;				/* Condition prefix begins with paren. */
case (041):					/* ")", octal 051 */
	if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1);
	parct = parct - 1;				/* decrease parenthesis count. */
	if parct < 0 then do;			/* Check for more closes than opens. */
	     call ioa_ ("indent: line ^d of ""^a"" has an extra "")"".", linno, en);
	     error_occurred = "1"b;
	     parct = 0;
	end;
	go to cbs;
case (044):					/* ",", octal 054 */
	if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1);
	if i < n-1 then if substr (chars, i+1, 1) ^= SP then call inb (i+1);
	go to cbs;
case (045):					/* "-", octal 055 */
	if substr (chars, i+1, 1) = ">" then do;	/* Is this a pointer digraph? */
	     if i > 1 then if substr (chars, i-1, 1) ^= SP then call inb (i);
	     if i < n-2 then if substr (chars, i+2, 1) ^= SP then call inb (i+2);
	end;
	go to cbs;
case (047):					/* "/", octal 057 */
	if substr (chars, i+1, 1) = "*" then do;	/* Comment begins? */
	     comment = true;			/* Now in comment. */
	     if i - length ("/") + length ("/****^") + length (NL) <= n
	     then if substr (chars, i, length ("/****^")) = "/****^" then
		     copy_this_comment_unchanged = true; /* check for comments which cannot be changed. */
	     if ^copy_this_comment_unchanged then do;
		if i > 1 then if substr (chars, i-1, 1) ^= SP then call inb (i);
		if i < n - length ("/") - length (NL)
		then if index (SP_TAB, substr (chars, i+2, 1)) = 0 /* need a blank? */
		     then if ^rd_source_sw		/* check first for rd parse control */
			then call inb (i+2);
			else if substr (chars, i+2, 2) = "++"
						/* beginning of rd parse specification? */
			then copy_this_comment_unchanged = true;
						/* yes. remember, and don't insert blank */
			else call inb (i+2);	/* just a normal comment */
	     end;
	     icb = i;				/* Remember where comment began. */
	     kk = index (substr (chars, i+2, n-i-2), "*/"); /* Search for end of comment. */
	     if kk = 0 then i = n-1;			/* Not scanning content of comment. */
	     else i = i + kk;			/* ... */
	     go to l2e;				/* Leave "bos" as it was when comment began. */
	end;
	go to cbs;				/* Statement don't begin with slash */
case (058):					/* ":", octal 072 */
	if parct > 0 then go to nxchr;		/* Label can't be in parentheses. */
	if bos then go to cbs;			/* Null label ? */
	bos = true;				/* This is label. keyword ok */
	icol = i + 1;				/* Save index. */
	if i < n-1 then if index (SP_TAB, substr (chars, i+1, 1)) = 0 then call inb (i+1);
	go to l2e;
case (059):					/* ";", octal 073 */
	scolsw, bos = true;				/* Semicolon. End of statement. */
	begin_ok = false;
	if condsw then do;				/* Does this end an IF? */
	     old_if_count = if_count;			/* Save proper indent level for ELSE */
	     if pdlx = 1 then if_count = 0;		/* Reset if_count */
	     else if_count = pdl (pdlx-1).nif;		/* Set back to base for this level. */
	     condsw = false;			/* Not now in conditional */
	     else_ok = true;
	end;
	else old_if_count = 0;			/* End of some other statement. */
	ifsw = false;				/* Not in IF now. */
	if parct > 0 then do;			/* Parenthesis count should be zero. */
	     call ioa_ ("indent: ^d extra ""(""s at line ^d of ""^a"".",
		parct, linno, en);			/* Complain. */
	     error_occurred = "1"b;
	     parct = 0;				/* Start over on count. */
	end;
	go to l2e;
case (061):					/* "=", octal 075 */
	if i < n-1 then if substr (chars, i+1, 1) ^= SP then call inb (i+1);
	m = 1;
	if i > 1 then if index (NOT_LES_GRT, substr (chars, i-1, 1)) ^= 0 then m = 2;
	if i > m then if substr (chars, i-m, 1) ^= SP then call inb (i-m+1);
	go to cbs;

/* This section checks for reserved words by looking at the first letter. */

case (098):					/* letter "b", octal 142 */
	if ^bos then if ^begin_ok then go to nxchr;	/* Must be at begin of statement or in ON */
	if parct > 0 then go to nxchr;		/* ignore begins in parens */
	if i <= n-5 then if substr (chars, i, 5) = "begin" then
		if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 6 then do;
		     i = i + 4;			/* Skip over rest of word. */
in_found:		     if ifsw then if_count = if_count - 1; /* Don't do extra indent. */
		     pdl (pdlx).sw = ifsw;		/* Push down current if switch. */
		     pdl (pdlx).swc = condsw;		/* .. and conditional switch. */
		     pdl (pdlx).nif = if_count;	/* .. and if indentation. */
		     pdlx = pdlx + 1;		/* .. */
		     if pdlx = 1024 then do;		/* If nesting depth too great, die. */
			call com_err_ (0, "indent", "FATAL ERROR. Line ^d of ""^a"" nesting depth > 1024",
			     linno, en);
			return;
		     end;
		     condsw = false;		/* Now not in IF */
		     ifsw = false;
		     dent = dent + 1;		/* Increase indentation level. */
		end;
	go to nxchr;
case (100):					/* letter "d", octal 144 */
	if parct > 0 then go to nxchr;		/* reserved word not in parens */
	if ^bos then go to nxchr;			/* Must be at beginning of statement. */
	kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL);
	if kk = 3 then if substr (chars, i, 2) = "do" then do;
		i = i + 1;			/* Found DO statement. */
		go to in_found;
	     end;
	if condsw then go to nxchr;			/* Declaration cannot be inside an IF */
	if i = 1 then do;				/* declare stm must start in col 1 ... */
	     if kk = 4 then if substr (chars, i, 3) = "dcl" then do;
		     dclfnd = true;			/* Found DCL statement. */
		     i = i + 2;
		     dclind = 4;
		     go to nxchr;
		end;
	     if kk = 8 then if substr (chars, i, 7) = "declare" then do;
		     dclfnd = true;			/* Found DECLARE statement. */
		     i = i + 6;
		     dclind = 8;
		     go to nxchr;
		end;
	end;
	go to nxchr;
case (101):					/* letter "e", octal 145 */
	if parct > 0 then go to nxchr;		/* keyword not appear in parens. */
	if ^bos then go to nxchr;			/* Must be in beginning-of-statment state. */
	kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL);
	if else_ok then if kk = 5 then if substr (chars, i, 4) = "else" then do;
		     if_count = old_if_count - 1;	/* Restore old IF indentation. */
		     ifdent = old_if_count - 1;	/* Outdent the ELSE to the corresponding IF */
		     else_ok = false;		/* ELSE may not follow ELSE. */
		     if if_count > 0 then condsw = true; /* But may follow after semi. */
		     bos = true;			/* Statement may follow ELSE. */
		     i = i + 3;
		     go to l2e;
		end;
	if condsw then go to nxchr;			/* Cannot say "then end" */
	if kk = 4 then if substr (chars, i, 3) = "end" then do;
		end_count = end_count + 1;		/* Found END statement. */
		if pdlx > 1 then do;		/* Unstack IF state. */
		     pdlx = pdlx - 1;		/* .. */
		     ifsw = pdl (pdlx).sw;		/* .. */
		     condsw = pdl (pdlx).swc;		/* ... */
		     if_count = pdl (pdlx).nif;	/* .. */
		     if ifsw then if_count = if_count + 1;
		end;
		if (in - end_count + dent) < 0 then do; /* Too many END's? */
		     call ioa_ ("indent: line ^d of ""^a"" has an extra ""end"".", linno, en);
		     dent, in, end_count = 0;		/* Start over on indents */
		     error_occurred = "1"b;
		end;
		i = i + 2;
	     end;
	go to nxchr;
case (105):					/* letter "i", octal 151 */
	if parct > 0 then go to nxchr;
	if ^bos then go to nxchr;
	if i <= n-2 then if substr (chars, i, 2) = "if" then
		if search (substr (chars, i, n-i+1), SP_TAB_SEMI_LP_NL) = 3 then do;
		     condsw = true;			/* Set IF encountered flag. */
		     ifsw = true;
		     i = i + 1;
		end;
	go to nxchr;
case (116):					/* letter "t", octal 164 */
	if parct > 0 then go to nxchr;		/* Look for THEN keyword. */
	if bos then go to nxchr;			/* THEN cannot begin a statement. */
	if ^ifsw then go to nxchr;			/* and some IF must have come up. */
	if i ^= 1 then if substr (chars, i-1, 1) ^= SP then go to nxchr;
	if i <= n-4 then if substr (chars, i, 4) = "then" then
		if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 5 then do;
		     bos = true;			/* Found THEN. Statement may follow. */
		     i = i + 3;
		     if_count = if_count + 1;
		     go to l2e;
		end;
	go to nxchr;
case (111):					/* letter "o", octal 157 */
	if ^bos then go to nxchr;			/* Check for ON statement. */
	if parct > 0 then go to nxchr;
	if i <= n-2 then if substr (chars, i, 2) = "on" then
		if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 3 then do;
		     begin_ok = true;		/* ON statement may contain BEGIN */
		     i = i + 1;
		end;
	go to nxchr;
case (112):					/* letter "p", octal 160 */
	if parct > 0 then go to nxchr;
	if ^bos then go to nxchr;
	if condsw then go to nxchr;			/* Cannot say "then proc" */
	k = 3;
	kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_LP_NL);
	if kk = 5 then if substr (chars, i, 4) = "proc" then go to procfnd;
	k = 8;
	if kk = 10 then if substr (chars, i, 9) = "procedure" then do;
procfnd:		i = i + k;			/* Skip scan of keyword. */
		go to in_found;			/* Increase indentation level */
	     end;
	go to nxchr;

/* Illegal characters. Squawk and continue. */

case (000):					/* NUL, octal 000 */
case (001):					/* undefined, octal 001 */
case (002):					/* undefined, octal 002 */
case (003):					/* undefined, octal 003 */
case (004):					/* undefined, octal 004 */
case (005):					/* undefined, octal 005 */
case (006):					/* undefined, octal 006 */
case (007):					/* BEL, octal 007 */
case (008):					/* BS, octal 010 */
case (013):					/* CR, octal 015 */
case (014):					/* RRS, octal 016 */
case (015):					/* BRS, octal 017 */
case (016):					/* undefined, octal 020 */
case (017):					/* undefined, octal 021 */
case (018):					/* undefined, octal 022 */
case (019):					/* undefined, octal 023 */
case (020):					/* undefined, octal 024 */
case (021):					/* undefined, octal 025 */
case (022):					/* undefined, octal 026 */
case (023):					/* undefined, octal 027 */
case (024):					/* undefined, octal 030 */
case (025):					/* undefined, octal 031 */
case (026):					/* undefined, octal 032 */
case (027):					/* undefined, octal 033 */
case (028):					/* undefined, octal 034 */
case (029):					/* undefined, octal 035 */
case (030):					/* undefined, octal 036 */
case (031):					/* EGM, octal 037 */
ilchr:	call ioa_ ("indent: warning: illegal character (octal ^3.3b) in line ^d of ""^a""",
	     unspec (substr (chars, i, 1)), linno, en);
	error_occurred = "1"b;
	go to l2e;

case (033):					/* "!", octal 041 */
case (035):					/* sharp, octal 043 */
case (039):					/* "'", octal 047 */
case (063):					/* "?", octal 077 */
case (064):					/* at-sign, octal 100 */
case (091):					/* "[", octal 133 */
case (092):					/* escape (backslash), octal 134 */
case (093):					/* "]", octal 135 */
case (096):					/* "`", octal 140 */
case (123):					/* "{", octal 173 */
case (125):					/* "}", octal 175 */
case (126):					/* tilde, octal 176 */
	if ^bfsw then do;				/* Unless brief mode, gripe */
	     call ioa_ ("indent: warning: non-pl1 char ""^a"" outside string in line ^d of ""^a""",
		substr (chars, i, 1), linno, en);
	     error_occurred = "1"b;
	end;
	go to l2e;

/* Chars which are legal but cannot begin a statement. */

case (036):					/* "$", octal 044 */
case (038):					/* "&", octal 046 */
case (042):					/* "*", octal 052 */
case (043):					/* "+", octal 053 */
case (046):					/* ".", octal 056 */
case (048):					/* digit "0", octal 060 */
case (049):					/* digit "1", octal 061 */
case (050):					/* digit "2", octal 062 */
case (051):					/* digit "3", octal 063 */
case (052):					/* digit "4", octal 064 */
case (053):					/* digit "5", octal 065 */
case (054):					/* digit "6", octal 066 */
case (055):					/* digit "7", octal 067 */
case (056):					/* digit "8", octal 070 */
case (057):					/* digit "9", octal 071 */
case (060):					/* "<", octal 074 */
case (062):					/* ">", octal 076 */
case (094):					/* circumflex, octal 136 */
case (095):					/* underscore, octal 137 */
case (124):					/* "|", octal 174 */
cbs:	if bos then if ^bfsw then do;
		call ioa_ ("indent: possible syntax error in line ^d of ^a detected at char ""^a""",
		     linno, en, substr (chars, i, 1));
		error_occurred = "1"b;
	     end;

/* Chars which are legal beginnings of statement. */

case (037):					/* "%", octal 045 */
case (065):					/* letter "A", octal 101 */
case (066):					/* letter "B", octal 102 */
case (067):					/* letter "C", octal 103 */
case (068):					/* letter "D", octal 104 */
case (069):					/* letter "E", octal 105 */
case (070):					/* letter "F", octal 106 */
case (071):					/* letter "G", octal 107 */
case (072):					/* letter "H", octal 110 */
case (073):					/* letter "I", octal 111 */
case (074):					/* letter "J", octal 112 */
case (075):					/* letter "K", octal 113 */
case (076):					/* letter "L", octal 114 */
case (077):					/* letter "M", octal 115 */
case (078):					/* letter "N", octal 116 */
case (079):					/* letter "O", octal 117 */
case (080):					/* letter "P", octal 120 */
case (081):					/* letter "Q", octal 121 */
case (082):					/* letter "R", octal 122 */
case (083):					/* letter "S", octal 123 */
case (084):					/* letter "T", octal 124 */
case (085):					/* letter "U", octal 125 */
case (086):					/* letter "V", octal 126 */
case (087):					/* letter "W", octal 127 */
case (088):					/* letter "X", octal 130 */
case (089):					/* letter "Y", octal 131 */
case (090):					/* letter "Z", octal 132 */
case (097):					/* letter "a", octal 141 */
case (099):					/* letter "c", octal 143 */
case (102):					/* letter "f", octal 146 */
case (103):					/* letter "g", octal 147 */
case (104):					/* letter "h", octal 150 */
case (106):					/* letter "j", octal 152 */
case (107):					/* letter "k", octal 153 */
case (108):					/* letter "l", octal 154 */
case (109):					/* letter "m", octal 155 */
case (110):					/* letter "n", octal 156 */
case (113):					/* letter "q", octal 161 */
case (114):					/* letter "r", octal 162 */
case (115):					/* letter "s", octal 163 */
case (117):					/* letter "u", octal 165 */
case (118):					/* letter "v", octal 166 */
case (119):					/* letter "w", octal 167 */
case (120):					/* letter "x", octal 170 */
case (121):					/* letter "y", octal 171 */
case (122):					/* letter "z", octal 172 */
nxchr:	bos = false;				/* No longer at beginning of statement. */
	else_ok = false;				/* ELSE no longer legal. */
	go to l2e;

/* Chars which do not preclude beginning of statement. */

case (012):					/* NP, octal 014 */
	newpage = "1"b;				/* remember line contained NP */
case (010):					/* NL, octal 012 */
case (011):					/* VT, octal 013 */
l2e:	i = i + 1;				/* Increase index in working array. */
	if i < n then go to l2s;			/* If any chars left, go thru again. */

/* come here when all characters in line examined */

	i = 1;					/* "i" will be the index in the "chars" buffer. */
	if newpage then do;				/* special test if newpage encountered */
	     if verify (substr (chars, 1, n), NP_NL_SP) = 0 then do; /* if line is all spaces, newpages, and newlines */
		n = 2;				/* make new short line */
		chars = substr (NP_NL_SP, 1, 2);	/* of newpage and newline */
		blsw = true;			/* this is a blank line */
		go to cpy;
	     end;
	end;
	if icb = 1 then do;				/* Does line start with comment? */
	     if blsw then do;			/* Yes. Previous line empty? */
		sixty = false;			/* Yes, start in column 1. */
		go to cpy;			/* Just copy line. */
	     end;
push:	     sixty = true;				/* Comment goes in column 60. */
	     ntab = NTAB;
	     i = 1;
	     go to nimcom;
	end;
	if icb = 0 then if (comment | ice > 0) then do;	/* Continuation of comment? */
		if sixty then go to push;		/* Do we indent it? */
cpy:		substr (bcso, nout, n) = substr (chars, 1, n); /* Copy whole line. */
		nout = nout + n;
		go to finish_line;
	     end;

/* This section computes the left margin for each line. */

	blsw = false;				/* Not empty line. */
	if pstring then do;
	     indent = 0;				/* don't indent inside quoted string */
	     icol = 0;
	end;
	else if dclfnd then do;			/* Does line begin with DCL? */
	     dclfnd = false;			/* Yes. */
	     dclsw = true;				/* We are in a declaration now. */
	     if index ("0123456789", substr (chars, dclind+1, 1)) ^= 0 then strut = true; else strut = false;
	     icol = dclind;				/* Copy first dclind chars without indent. */
	     if strut then indent = dclind+1;		/* Indent dclind+1 in structure */
	     else if substr (chars, dclind+1, 1) = "(" then indent = dclind+1;
						/* ... or in factored dcl, */
	     else indent = dclind+2;			/* ... otherwise dclind+2. */
	end;
	else if dclsw then do;			/* Are we in old declaration? */
	     icol = 0;				/* Yes. */
	     kk = index ("0123456789", substr (chars, 1, 1)) - 1;
	     if strut & kk >= 0 then do;		/* If structure, use level number. */
		k = kk;				/* Convert to number. */
		kk = index ("0123456789", substr (chars, 2, 1)) - 1;
		if kk >= 0 then k = k*10 + kk;
		indent = dclind + k + k - 3;		/* calculate proper indentation */
	     end;					/* typically, this yields
						   .	dcl 1 s,
						   .	    2 l1,
						   .	    2 l2,
						   .	      3 l3; etc.	 */

	     else if substr (chars, 1, 1) = "("
	     then do;
		if strut
		then do;				/* we have factored level declarations */
		     k = index ("0123456789", substr (chars, 2, 1)) - 1;
		     if k > 0			/* better be */
		     then do;
			kk = index ("0123456789", substr (chars, 3, 1)) - 1; /* look for level > 9 */
			if kk > 0 then k = 10 * k + kk;
			indent = dclind + k + k - 4;	/* subtract 1 more to allow for paren */
		     end;

/* should report the following, but can't tell the difference between missing level number and just initialize...
   else call ioa_ ("indent: No level number follows ""("" in structure. Line ^d in ""^a"". Continuing.", linno, en); */
		end;
		else indent = dclind + 1;		/* no structure */
	     end;

	     else indent = dclind+2;			/* No. */
	end;
	else do;					/* Normal statement. */
	     k = min (end_count, dent);		/* May be both do and end on same line. */
	     end_count = end_count - k;		/* If so, do not "outdent" */
	     dent = dent - k;			/* ... */
	     indent = (in + ifdent - end_count - 1) * IN + LMARGIN; /* Compute indentation. */
	     if indent < 0 then indent = 0;		/* No negative indent. */
	end;

/* This section copies the line into the output seg, inserting blanks and tabs. */

	if icol >= n then go to cpy;			/* If line is just a label, do it the easy way. */
	colpos = 0;				/* Remember where started. */
	if icol ^= 0 then do;
	     substr (bcso, nout, icol) = substr (chars, 1, icol); /* Copy label section if any. */
	     nout = nout + icol;			/* Increase offset. */
	     colpos = colpos + icol;			/* and column. */
	end;
	i = icol + 1;
	if i ^= icb then				/* Handle case of just label and comment. */
	     if indent > icol then do;		/* Must insert blanks. */
		if substr (chars, icol, 1) = SP then do; /* a blank was included in icol for labels */
		     icol = icol - 1;		/* Back up by one char, to prevent space-tab. */
		     colpos = colpos - 1;
		     nout = nout - 1;
		end;
		k = indent - icol - 1;		/* Calculate number of blanks required. */
		colpos = colpos + k;		/* Calculate new column position in output. */
		if colpos >= 10 then do;		/* Replace blanks by tabs if possible. */
		     kk = divide (colpos, 10, 17, 0) - divide (icol, 10, 17, 0);
		     if kk > 0 then do;
			substr (bcso, nout, kk) = substr (TABS, 1, kk);
			nout = nout + kk;
			k = mod (colpos, 10);	/* Tab column might not be multiple of 10 */
		     end;
		end;
		if k ^= 0 then do;
		     substr (bcso, nout, k) = "";	/* Run in blanks. */
		     nout = nout + k;
		end;
	     end;
	if ice ^= 0 then if ice = n-2 then go to havcom;	/* If comment is last thing on line, */
	if ice ^= 0 then if ice = n-3 then if substr (chars, n-1, 1) = ";" then go to havcom;
						/* or if comment is last on line except end of statement, */
	if ice = 0 then if icb > 0 then do;		/* or if comment starts on this line and doesn't end.. */
havcom:		sixty = true;			/* Yes, move comment to column 60. */
		k = icb-i;			/* Copy statement part. */
		if k ^= 0 then do;
		     substr (bcso, nout, k) = substr (chars, i, k);
		     nout = nout + k;
		     colpos = colpos + k;		/* Keep track of column. */
		     i = i + k;
		end;
		if colpos < TABCOL then do;		/* If statement does not reach to col. 60, */
		     if substr (bcso, nout-1, 1) = SP then do; /* Avoid space-tab sequence. */
			nout = nout - 1;
			colpos = colpos - 1;
		     end;
		     if substr (chars, i, 1) = SP then i = i + 1; /* ... */
		     ntab = divide (TABCOL-colpos-1, 10, 17, 0) + 1; /* Compute number of tabs to get there. */
nimcom:		     if ntab ^= 0 then do;
			substr (bcso, nout, ntab) = substr (TABS, 1, ntab);
			nout = nout + ntab;
		     end;
		     colpos = TABCOL;
		end;
		k = CMC - colpos - 1;		/* In case tab column not 10 * x + 1 */
		if k > 0 then do;
		     substr (bcso, nout, k) = "";	/* Run in blanks */
		     nout = nout + k;
		end;
	     end;
	k = n - i + 1;
	if k ^= 0 then do;
	     substr (bcso, nout, k) = substr (chars, i, k); /* Copy remainder of line. */
	     nout = nout + k;
	end;

	in = in - end_count + dent;			/* Adjust indentation base for next line. */
	ifdent = if_count;				/* Set IF's to indent. */
	if ^bos then if ^ifsw then ifdent = ifdent + 1;	/* .. if statement is continued, indent 5 more. */
	dclsw = dclsw & ^ scolsw;			/* In declaration if were in and no semicolon. */

/* Finished with the line. Go get another. */

finish_line:
	linno = linno + 1;				/* Count line. */
	if nout ^> 2 then go to loop;			/* too short to check */
	i = verify (reverse (substr (bcso, 1, nout-2)), SP_TAB); /* check for trailing white space in line copied */
	if i = 1 then go to loop;			/* there was none */
	if i = 0 then i = nout - 2;			/* there was a lot */
	else i = i - 1;				/* there was some */
	if string then do;				/* if in a string, bad news because its invisible */
	     if ^bfsw then call ioa_
		("indent: Line ^d of ""^a"" contains trailing white space that is part of a string.",
		linno - 1, en);
	     go to loop;				/* Don't change */
	end;
	nout = nout - i;				/* back up end over white space */
	substr (bcso, nout-1, 1) = NL;		/* put in a new newline */
	unspec (substr (bcso, nout, i)) = "0"b;		/* clean out the extra stuff that was moved in */
	go to loop;

/* Control comes here when the input segment is exhausted. */

eof:	if in > 0
	then if ^(rd_source_sw & in = 1)		/* rd source should be missing one "end" */
	     then do;
		call ioa_ ("indent: ""^a"" has ^d too few ""end""s.", en, in);
		error_occurred = "1"b;
	     end;
	     else;
	else if rd_source_sw
	then do;
	     call ioa_ ("indent: The reduction_compiler source ""^a"" has one too many ""end""s.", en);
	     error_occurred = "1"b;
	end;
	if string then do;
	     call ioa_ ("indent: ""^a"" ends in a string.", en);
	     error_occurred = "1"b;
	end;
	if comment then do;
	     call ioa_ ("indent: ""^a"" ends in a comment.", en);
	     error_occurred = "1"b;
	end;
	if parct > 0 then do;
	     call ioa_ ("indent: ""^a"" has ^d extra ""(""s.", en, parct);
	     error_occurred = "1"b;
	end;

	call hcs_$terminate_noname (p, ec);		/* Terminate input segment. */

	lth = 9 * (nout-1);				/* Compute bit count. */
	call hcs_$set_bc_seg (p1, lth, ec);		/* Set bit count on temp, in case of error. */

	if error_occurred then
	     if ^output_path_given then do;
		call com_err_ (0, "indent", "Input segment not replaced. Indented copy is in [pd]>^a", temp_en);
		return;
	     end;

	call hcs_$make_seg (dn, en, "", 1011b, p, ec);	/* Get ptr to final output. Make if necessary */
	if p = null then go to error1;
	call hcs_$truncate_seg (p, 0, ec);		/* Truncate target. */
	if ec ^= 0 then do;
error1:	     call com_err_ (ec, "indent", "Cannot copy ^a from [pd]>^a", en, temp_en);
	     return;
	end;
	p -> moveseg = p1 -> moveseg;			/* Zap. */
	call hcs_$set_bc_seg (p, lth, ec);		/* Set bit count. */
	call hcs_$terminate_noname (p, ec);		/* Terminate output. */
	call hcs_$delentry_seg (p1, ec);		/* Delete scratch segment. */
	return;					/* Happy return. */

error:	call com_err_ (ec, "indent", n1);		/* Here to gripe to user */
	return;					/* And give up */

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

/* Insert a blank at "ix" */

inb:	proc (ix);
dcl  ix fixed bin (24);				/* Index in work array where blank goes. */
	     substr (temchars, 1, n-ix+1) = substr (chars, ix, n-ix+1);
	     substr (chars, ix+1, n-ix+1) = substr (temchars, 1, n-ix+1);
	     substr (chars, ix, 1) = SP;		/* Insert blank. */
	     n = n + 1;				/* Up the line length. */
	     if ix <= i then i = i + 1;		/* did we change the character looked at? */
	end inb;

/* This procedure removes "nn" blanks starting at "ix" */

outb:	proc (ix, nn);
dcl  ix fixed bin (24);
dcl  nn fixed bin (24);

	     substr (temchars, 1, n-ix-nn+1) = substr (chars, ix+nn, n-ix-nn+1);
	     substr (chars, ix, n-ix-nn+1) = substr (temchars, 1, n-ix-nn+1);
	     n = n - nn;
	     if ix = i then i = i - 1;		/* Back up one if now looking at new char. */
	     else if ix < i then i = i - nn;
	end outb;

     end indent;




		    ma_analyze_.pl1                 11/04/82  1951.6rew 11/04/82  1609.2       74970



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


ma_analyze_: proc (a_maip); default (fixed&^precision&^constant) precision (21); /* DEFAULT */
default (constant&real&^decimal) binary;

/* MA_ANALYZE_ prints divergent text, and call the editor if need be. */

/* Recoded Spring '77 RE Mullen */
/* Modified 11/10/80 Jay Pattin for cpa -output_file */

%include merge_ascii_info;
/*  */

dcl  a_maip ptr;

dcl  nd bit (1) aligned;				/* if ^nd then only print new, sans old, context, commentary */
dcl  i fixed bin;
dcl  j fixed bin;
dcl  first_zero fixed bin;
dcl  autox fixed bin;
dcl  ch char (999) based;
dcl  varch char (100) varying;
dcl  context_type char (16);
dcl  Context_type char (16);
dcl  skipchars (0:1) char (1) unal based;
dcl  NL char (1) init ("
");
dcl  ma_edit_ entry (ptr);
dcl (ioa_$ioa_switch, ioa_$ioa_switch_nnl) entry options (variable);

/*  */

/* If we are doing a merge, extra white space improves readability. */
/* This is because we enter the editor between sucessive sets of differences */
/* If we are doing a comparison, more white space is confusing. */

	ma_info_ptr = a_maip;

	nd = ^print_new_lines;			/* nd = non-discriminatory */

	if synchlen = 0 then do;
	     context_type = "at end.";
	     Context_type = "At end";
	end;
	else do;
	     context_type = "preceding:";
	     Context_type = "Preceding:";
	end;

	if have_orig then do;
	     if have_output then do;
		autox = AUTOX ();
		if autox ^= 0 then do;
		     call take_diff (autox);		/* pick up the change */
		     return;			/* all done */
		end;
	     end;
	     if nd then call ioa_$ioa_switch (output_iocb_ptr, "");
	     if difflen (lo) > 0 then do;		/* [a] non null */
		if nd then call print_diff (lo);
		do i = lo + 1 to hi;
		     if difflen (i) > 0 & same_as (i) = 0 then do; /* change */
			if nd then do;
			     varch = textid (i);
			     call set_same_varch (i);
			     if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
			     call ioa_$ioa_switch (output_iocb_ptr,"Changed by ^a to:", varch);
			end;
			call print_diff (i);
		     end;
		end;
		if nd then do;
		     varch = "";			/* note unchanged texts */
		     call set_same_varch (lo);
		     if varch ^= "" then do;
			if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
			call ioa_$ioa_switch (output_iocb_ptr, "Unchanged by ^a", varch);
		     end;
		     call set_varch_zero;		/* note deletes */
		     if varch ^= "" then do;
			if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
			call ioa_$ioa_switch (output_iocb_ptr, "Deleted by ^a, ^a", varch, context_type);
			call print_context (first_zero);
		     end;
		end;
	     end;
	     else do;				/* [a] null: inserts only */
		do i = lo + 1 to hi;
		     if difflen (i) > 0 & same_as (i) = 0 then do; /* insert */
			if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
			if nd then do;
			     varch = textid (i);
			     call set_same_varch (i);
			     call ioa_$ioa_switch (output_iocb_ptr, "Inserted in ^a:", varch);
			end;
			call print_diff (i);
		     end;
		end;
		if nd then do;
		     call set_varch_zero;
		     if varch ^= "" then do;
			if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
			call ioa_$ioa_switch (output_iocb_ptr, "Nothing inserted in ^a", varch);
		     end;
		     if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
		     call ioa_$ioa_switch (output_iocb_ptr, "^a", Context_type);
		     call print_context (lo);
		end;
	     end;
	     if nd then call ioa_$ioa_switch (output_iocb_ptr, "");
	     if have_output then call ma_edit_ (ma_info_ptr);
	     return;
	end;

	else do;					/* no original */
	     call ioa_$ioa_switch (output_iocb_ptr, "");
	     do i = lo to hi;
		if difflen (i) > 0 & same_as (i) = 0 then do;
		     if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
		     varch = textid (i);
		     call set_same_varch (i);
		     call ioa_$ioa_switch (output_iocb_ptr, "Present in ^a:", varch);
		     call print_diff (i);
		end;
	     end;
	     varch = "";
	     call set_varch_zero;
	     if varch ^= "" then do;
		if have_output then call ioa_$ioa_switch (output_iocb_ptr, "");
		call ioa_$ioa_switch (output_iocb_ptr, "Nothing present in ^a, ^a", varch, context_type);
		call print_context (first_zero);
	     end;
	     call ioa_$ioa_switch (output_iocb_ptr, "");
	     if have_output then call ma_edit_ (ma_info_ptr);
	end;

/*  */
print_diff: proc (x);				/* IP to print diff block if interesting */

dcl  xp ptr;
dcl  x fixed bin;
dcl  sax fixed bin;
dcl (i, j, k) fixed bin;

	     xp = cp (x);
	     k = 0;
	     do i = 1 to difflines (x);
		j = index (substr (xp -> ch, k+1, difflen (x) - k), NL);
		if j = 0 then j = difflen (x) - k;
		if no_line_numbers then
		     call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a",
		     substr (xp -> ch, k+1, j));

		else call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a^d^-^a",
		     textid (x), line (x)+i-1, substr (xp -> ch, k+1, j));

		k = k + j;
	     end;
	     if k ^= difflen (x) then call ioa_$ioa_switch (output_iocb_ptr, "print_diff: k ^= difflen");

	end print_diff;



/*  */
print_context: proc (x);				/* IP to print lines following insert|delete */

dcl  x fixed bin;
dcl (i, j, k) fixed bin;
dcl  restlen fixed bin;
dcl  restline fixed bin;
dcl  restp ptr;
dcl  restrel fixed bin;

	     if synchlen = 0 then return;
	     restlen = len (x) - difflen (x);
	     restrel = 0;
	     restline = line (x) + difflines (x);
	     restp = addr (cp (x) -> skipchars (difflen (x)));

	     do i = 1 to min (synchlines, 5);
		j = index (substr (restp -> ch, restrel+1, restlen), NL);
		if j = 0 then j = restlen;
		if no_line_numbers then
		     call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a",
		     substr (restp -> ch, restrel+1, j));

		else call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a^d^-^a",
		     textid (x), restline, substr (restp -> ch, restrel+1, j));
		if j > 1 then return;
		restline = restline + 1;
		restrel = restrel + j;
		restlen = restlen - j;
	     end;

	end print_context;


/*  */
take_diff: proc (tdi);				/* IP to pick up changed text */

dcl  tdi fixed bin;

	     if difflen (tdi) = 0 then return;		/* evid was deletion */

	     substr (cp (1) -> ch, 1, difflen (tdi))
		= substr (cp (tdi) -> ch, 1, difflen (tdi));
	     cp (1) = addr (cp (1) -> skipchars (difflen (tdi)));
	     tchars (1) = tchars (1) + difflen (tdi);
	     tlines (1) = tlines (1) + difflines (tdi);

	end take_diff;


/*  */
AUTOX:	proc returns (fixed bin);

dcl (ai, aj, ak) fixed bin;

	     aj, ak = 0;

	     do ai = lo + 1 to hi;			/* set ai to first text that changed */
		if same_as (ai) = 0 then do;
		     aj = ai;
		     go to a_other;
		end;
	     end;
	     call ioa_$ioa_switch (output_iocb_ptr, "ma_analyze_: called when blocks dont differ. Non-fatal.");
	     return (lo);				/* take any, eg orig */

a_other:
	     do ai = aj+1 to hi;			/* see if 2nd distinct change OR ident change to ai */
		if same_as (ai) = 0 then return (0);	/* 2nd distinct change, bomb */
		else if same_as (ai) = aj then if ^convergence_ok then return (0);
	     end;

	     if edit (aj) then return (0);
	     else return (aj);

	end AUTOX;

/*  */

set_varch_zero: proc;				/* IP to set varch to zero_len B-G */

dcl  szvi fixed bin;
	     varch = "";
	     do szvi = 3 to hi;
		if difflen (szvi) = 0 then do;
		     if varch = "" then do;
			varch = textid (szvi);
			first_zero = szvi;
		     end;
		     else varch = varch || ", " || textid (szvi);
		end;
	     end;
	end set_varch_zero;


set_same_varch: proc (ssvi);				/* IP to set varch to B-G same as param */

dcl (ssvi, ssvj) fixed bin;

	     do ssvj = ssvi + 1 to hi;
		if same_as (ssvj) = ssvi then do;
		     if varch = "" then varch = textid (ssvj);
		     else varch = varch || ", " || textid (ssvj);
		end;
	     end;

	end set_same_varch;



     end ma_analyze_;




		    ma_edit_.pl1                    11/04/82  1951.6rew 11/04/82  1627.5      101592



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


ma_edit_: proc (a_info_ptr); default (fixed&^precision&^constant) precision (21); /* DEFAULT */
	default (constant&real&^decimal) binary;

/* MA_EDIT_ performs simple editing for merge_ascii subsystem */
/* Recoded RE Mullen Spring '77 */
/* Modified "x" request to print archive cpt THVV 1980 */

dcl  a_info_ptr ptr;

dcl (i, j, k) fixed bin;
dcl  code fixed bin (35);
dcl (ioa_, ioa_$nnl) entry options (variable);
dcl (iox_$user_input, iox_$user_output) ptr ext;
dcl  iox_$control entry (ptr, char (*) aligned, ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35), fixed bin);
dcl  cu_$cp entry (ptr, fixed bin, fixed bin (35));

dcl  skipchars (0:1) char (1) unal based;
dcl  ch char (999) based;

dcl (start_line, end_line) fixed bin;
dcl  nl char (1) init ("
");

dcl  temp_ptr ptr;					/* temps for dealing with block of text */
dcl  dirn char (168);
dcl  en char (32);
dcl  cpt char (32);
dcl  temp_chars fixed bin;
dcl  temp_lines fixed bin;


dcl (rbuff, buff) char (200);
dcl (rnc, nc) fixed bin;
dcl  n fixed bin;
dcl  req char (n) based (addr (buff));
						/* ENDCL */

/*  */
%include merge_ascii_info;
/*  */

	ma_info_ptr = a_info_ptr;

	difflen (1) = 0;
	difflines (1) = 0;
	line (1) = tlines (1) + 1;

pedit:	call ioa_ ("EDIT");
	rnc = 0;

read_loop:

/* DEBUGGING */
/*
   call ioa_ ("
   i	tp	tl	tc	cp	dl	dc	line");
   do i = 1 to hi;
   call ioa_ ("^10d  ^p^-^10d^10d  ^p^-^10d^10d^10d",
   i,
   tptr (i), tlines (i), tchars (i), cp (i), difflines (i), difflen (i), line (i));
   end;
   /* END DEBUGGING */
	if rnc = 0 then do;
	     call iox_$get_line (iox_$user_input, addr (rbuff), 200, rnc, code);
	end;

	if substr (rbuff, 1, 2) = "e " then do;		/* EXECUTE --- call cp with rest of line */
	     substr (rbuff, 1, 1) = "";
	     call cu_$cp (addr (rbuff), rnc, code);
	     rnc = 0;
	     go to read_loop;
	end;

	nc = index (substr (rbuff, 1, rnc), " ");
	if nc = 0 then nc = rnc;
	substr (buff, 1, nc) = substr (rbuff, 1, nc);
	if nc ^= rnc then substr (rbuff, 1, rnc-nc)
	     = substr (rbuff, nc + 1, rnc-nc);		/* shift whats left */
	rnc = rnc - nc;				/* accout for what we took */

	n = nc - 1;				/* get real number of chars in req */


	if req = "" then;				/* ignore null req */
	else if n = 1 then do;			/* some one char req */
	     if req = "x" then do;			/* STATUS --- relate texids to paths, etc. */
		call ioa_ ("text   line nos.^-path");
		do i = 2 to ma_max_texts, 1;
		     if tptr (i) ^= null () then do;
			if i = 1 then do;		/* print true output path, not temp */
			     dirn = op_dirname;
			     en = op_ename;
			     cpt = "";
			end;
			else do;
			     dirn = dirname (i);
			     en = ename (i);
			     cpt = component (i);
			end;
			if difflines (i) = 0 then
			     call ioa_ ("^a^-^-^a>^a^[::^a^;^s^]",
			     textid (i), dirn, en, (cpt ^= ""), cpt);
			else if difflines (i) = 1 then
			     call ioa_ ("^a^9d^-^a>^a^[::^a^;^s^]",
			     textid (i), line (i), dirn, en, (cpt ^= ""), cpt);
			else call ioa_ ("^a^9d,^d^-^a>^a^[::^a^;^s^]",
			     textid (i), line (i), line (i) + difflines (i) - 1, dirn, en, (cpt ^= ""), cpt);
		     end;
		end;
	     end;
	     else go to UNREQ;			/* no other single char is valid req */
	end;
	else if req = "input" then do;		/* INPUT --- accept "none of the above" */
	     if rnc > 0 then go to MB_LAST;
	     call ioa_ ("INPUT");
i_loop:	     call iox_$get_line (iox_$user_input, addr (rbuff), 200, rnc, code);
	     if rnc = 2 then if substr (rbuff, 1, 1) = "." then go to pedit;
	     substr (cp (1) -> ch, difflen (1) + 1, rnc) = substr (rbuff, 1, rnc);
	     tchars (1) = tchars (1) + rnc;
	     tlines (1) = tlines (1) + 1;
	     difflen (1) = difflen (1) + rnc;
	     difflines (1) = difflines (1) + 1;
	     go to i_loop;
	end;
	else if req = "go" then do;			/* GO --- return from editor to compare loop */
	     if rnc > 0 then do;
MB_LAST:		call ioa_ ("^a must be the last request on a line.", req);
		go to RESET;
	     end;
	     cp (1) = addr (cp (1) -> skipchars (difflen (1)));
	     return;
	end;
	else if req = "help" then do;			/* HELP --- tell requests possible */
	     call ioa_ ("Edit requests:");
	     call ioa_ ("bk	copy previously printed block from text b.");
	     call ioa_ ("bx,yk	copy lines x though y from segment b.");
	     call ioa_ ("bx,yp	print lines x through y from segment b.");
	     call ioa_ ("md	undo all edit requests since changes last displayed.");
	     call ioa_ ("input	enter input mode.");
	     call ioa_ (".	return from input mode to edit mode.");
	     call ioa_ ("go	exit editor and continue comparison.");
	     call ioa_ ("quit	abort merge.");
	     call ioa_ ("e <command_line> execute rest of line.");
	     call ioa_ ("x	provide text status.");
	     call ioa_ ("help	provide help to user.");
	end;
	else if req = "quit" then do;			/* QUIT --- abort this merge */
	     if rnc > 0 then go to MB_LAST;
	     go to abort_label;
	end;
	else if substr (req, n, 1) = "p" then do;	/* PRINT --- display lines */
	     call GET_ADDR;
	     call PRINTEMPS (i);
	end;
	else if substr (req, n, 1) = "k" then do;	/* KOPY --- take specified lines */
	     call GET_ADDR;
	     call TAKE_TEMPS;
	end;
	else if substr (req, n, 1) = "d" then do;	/* DELETE --- undo recent choices */
	     if n ^= 2 then do;
DELIMP:		call ioa_ ("cannot ""^a"": the only delete request possible is ""md""", req);
		go to RESET;
	     end;
	     if substr (req, 1, 1) ^= "m" then go to DELIMP;
	     tchars (1) = tchars (1) - difflen (1);
	     tlines (1) = tlines (1) - difflines (1);
	     difflen (1), difflines (1) = 0;
	end;
	else do;					/* LOSE */
UNREQ:	     call ioa_ ("cannot ""^a"": unrecognized request", req);
	     go to RESET;
NO_BLOCK:	     call ioa_ ("cannot ""^a"": current block is empty", req);
	     go to RESET;
RESET:	     code = 0;
	     rnc = 0;
	     call iox_$control (iox_$user_input, "resetread", null (), 0);
	end;
	go to read_loop;

/*  */

GET_ADDR:	proc;					/* IP to determine addressed lines */

	     i = index (ma_text_ids, substr (req, 1, 1));
	     if i = 0 then do;
BAD_TID:		call ioa_ ("cannot ""^a"": invalid text identifier ""^a""", req, substr (req, 1, 1));
		go to RESET;
	     end;
	     if tptr (i) = null () then go to BAD_TID;
	     if n = 2 then do;			/* entire block */
		if difflen (i) = 0 then go to NO_BLOCK; /* null block */
		temp_chars = difflen (i);
		temp_lines = difflines (i);
		temp_ptr = cp (i);
		start_line = line (i);
	     end;
	     else do;
		call READ_LINNOS (i, 1);
		call SET_TEMPS (i);
	     end;

	end GET_ADDR;

/*  */

TAKE_TEMPS: proc ;					/* IP to pick up changed text */


	     if temp_chars = 0 then return;		/* evid was nothing there */

	     substr (cp (1) -> ch, difflen (1) + 1, temp_chars)
		= substr (temp_ptr -> ch, 1, temp_chars);
	     tchars (1) = tchars (1) + temp_chars;
	     tlines (1) = tlines (1) + temp_lines;
	     difflen (1) = difflen (1) + temp_chars;
	     difflines (1) = difflines (1) + temp_lines;

	end TAKE_TEMPS;

/*  */

READ_LINNOS: proc (segx, oplen);
dcl  segx fixed bin;				/* segment index */
dcl  oplen fixed bin;				/* length of operator: eg "p" */
dcl  LC fixed bin;
dcl  cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin);

dcl  x fixed bin;

	     LC = n - oplen - 1;			/* subtract oplen and textid from req len */

	     if difflen (segx) = 0 then do;		/* "<" and ">" are undefined */
		if index (substr (buff, 2, LC), "<") > 0 then go to NO_BLOCK;
		else if index (substr (buff, 2, LC), ">") > 0 then go to NO_BLOCK;
	     end;

	     x = index (substr (buff, 2, LC), ",");
	     if x = 1 then do;
		call ioa_ ("cannot ""^a"": no numeral before comma", req);
		go to RESET;
	     end;
	     else if x = LC then do;
		call ioa_ ("cannot ""^a"": no numeral after comma", req);
		go to RESET;
	     end;
	     else if x = 0 then do;			/* only one number given */
		if substr (buff, 2, LC) = "<" then start_line = line (segx);
		else if substr (buff, 2, LC) = ">" then start_line = line (segx) + difflines (segx) -1;
		else do;
		     start_line = cv_dec_check_ (substr (buff, 2, LC), code);
		     if code ^= 0 then do;
			call ioa_ ("cannot ""^a"": bad line number ^a", req, substr (buff, 2, LC));
			go to RESET;
		     end;
		end;
		end_line = start_line;
	     end;
	     else do;				/* comma and two numbers? */
		if substr (buff, 2, x-1) = "<" then start_line = line (segx);
		else do;				/* ">,N" not accepted */
		     start_line = cv_dec_check_ (substr (buff, 2, x-1), code);
		     if code ^= 0 then do;
			call ioa_ ("cannot ""^a"": bad line number ^a", req, substr (buff, 2, x-1));
			go to RESET;
		     end;
		end;
		if substr (buff, 2+x, LC-x) = ">" then end_line = line (segx) + difflines (segx) - 1;
		else do;				/* "N,<" not accepted */
		     end_line = cv_dec_check_ (substr (buff, 2+x, LC - x), code);
		     if code ^= 0 then do;
			call ioa_ ("cannot ""^a"": bad line number ^a", req, substr (buff, 2+x, LC-x));
			go to RESET;
		     end;
		end;
	     end;

	     if start_line <= 0 then do;
		call ioa_ ("cannot ""^a"": neg line number ^d", req, start_line);
		go to RESET;
	     end;

	     if end_line - start_line < 0 then do;
		call ioa_ ("cannot ""^a"": start ^d  > end ^d", req, start_line, end_line);
		go to RESET;
	     end;

	end READ_LINNOS;

/*  */

SET_TEMPS: proc (x);				/* IP to set (global) tp, tc, temp_lines  */
dcl  x fixed bin;
dcl  xptr ptr;
dcl  xchars fixed bin;				/* total chars */
						/* */
dcl  tsc fixed bin;
dcl  N fixed bin;

dcl (i, j, k) fixed bin;

	     xptr = tptr (x);
	     xchars = tchars (x);
	     k = 0;

	     do i = 1 to end_line;
		if k >= xchars then do;
		     call ioa_ ("cannot ""^a"": seg ^a has ^d lines", req, textid (x), i - 1);
		     go to RESET;
		end;
		if i = start_line then do;		/* make temp_ptr point at start of this line */
		     temp_ptr = addr (xptr -> skipchars (k));
		     tsc = k;
		end;
		j = index (substr (xptr -> ch, k + 1, xchars - k), nl);
		if j = 0 then j = xchars - k;		/* take all if no newline */
		k = k + j;
	     end;

	     temp_chars = k - tsc;
	     temp_lines = end_line - start_line + 1;

	end SET_TEMPS;


/*  */

PRINTEMPS: proc (x);				/* IP to print (temp_ptr , temp_chars) */

dcl (i, j, k) fixed bin;
dcl  x fixed bin;

	     k = 0;

	     do i = 1 to temp_lines;
		j = index (substr (temp_ptr -> ch, k+1, temp_chars - k), nl);
		if j = 0 then j = temp_chars - k;
		call ioa_$nnl ("^a^d^-^a",
		     textid (x), start_line + i - 1, substr (temp_ptr -> ch, k+1, j));
		k = k + j;
	     end;
	     if k ^= temp_chars then call ioa_ ("PRINTEMPS: k ^= temp_chars"); /* DEBUG */

	end PRINTEMPS;


     end ma_edit_;




		    ma_resynch_.pl1                 11/04/82  1951.6rew 11/04/82  1627.6      100089



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


ma_resynch_: proc (a_info_ptr); default (fixed&^precision&^constant) precision (21); /* DEFAULT */
default (constant&real&^decimal) binary;

/* This program is part of the merge_ascii/compare_ascii subsystem. */
/* It is called with a pointer to a control structure which */
/* describes a number of texts, and the place in each */
/* at which synchronization was lost. RESYNCH_ fills in information */
/* indicating where it found it possible to get back in synch. */

/* Coded by RE Mullen */

dcl  a_info_ptr ptr;

dcl  i fixed bin;
dcl  EOF bit (1) aligned init (""b);
dcl  blocklen (8) fixed bin;
dcl  blocklines (8) fixed bin;
dcl  depth (8) fixed bin;				/* chars past cp(i) where block(i) created */
dcl  xiny (8, 8) fixed bin;				/* xiny(i,j) is chars past cp(j) where block(i) found */
dcl  votes (8) fixed bin;				/* est value of synch on block (i) */


dcl  cp_i ptr;					/* for loops */
dcl  len_i fixed bin;
dcl  depth_i fixed bin;
dcl  blocklen_i fixed bin;
dcl  blocklines_i fixed bin;
dcl  votes_i fixed bin;
dcl  i_in (8) fixed bin;

dcl (best, best_votes) fixed bin;
dcl  n_blocks fixed bin;

dcl  NL char (1) aligned int static options (constant) init ("
");
dcl  ch char (999) based;
dcl  skipchars (0:1) char (1) unal based;
dcl  ioa_ entry options (variable);

dcl  synch bit (1) aligned;

/*  */
%include merge_ascii_info;
/*  */

/* this program finds the next point at which the text are back in synch.
   If no resynch point is found, we say that we are "in synch at the ends",
   and set the global switch ma_info.eof.

   It is the contract of this program to also set the following global variables:
   ma_info.difflen(i) is set to the number of chars which differ in each text.
   ma_info.difflines(i) is set to the number of lines which differ in each text.
   ma_info.synchlen is set to the number of characters which are in the resynched block.
   ma_info.synchlines is set to the number of lines which are in the resynched block.
   ma_info.same_as(i) is set to the seg_index of the lowest numbered segment
   with a difference matching that present in text(i).
   If no lower numbered text has a matching difference then same_as(i) is set to zero.

   Note that no variables in ma_info are set by any internal procedures.
   Note that this program does not modify any variables it uses to regain synch,
   it advances no pointers, it does not reduce the remaining lengths.
*/
	ma_info_ptr = a_info_ptr;			/* copy pointer at least, to automatic */

	do i = lo to hi;
	     depth (i) = 0;
	end;

/* We start out not in synch.  Each call to try_deeper_resynch
   defines a block of lines in each segment which begins one
   line deeper in the remaining text.  The variable depth(i) is the number
   of characters between where synch was lost and the first character of
   the line starting the defined block. */
	synch = ""b;
	do while (^synch);
	     call try_deeper_resynch;
	end;

/* Finally in SYNCH again.
   Got in synch at blocks: substr(cp(*)->ch, xiny(best,*)+1, synchlen)
   If EOF then we must setup a zero_length resynched block at the end of each text.
   We then strip matching lines off the tail of the alleged differences.
   Finally we determine difflines(*) and which differences match.
*/
	ma_info.eof = EOF;

/* Set synchlen, synchlines, difflen (*) */
	do i = lo to hi;
	     if EOF then do;			/* at synch at ends */
		difflen (i) = len (i);		/* difference is entire rest */
		synchlen, synchlines = 0;		/* resynch block is empty */
	     end;
	     else do;				/* set lenght of differences */
						/* synchlen, synchlines already set correctly by check_synch */
		difflen (i) = xiny (best, i);
	     end;
	end;

	call shrink_diff;				/* strip matching chars */

	do i = lo to hi;
	     difflines (i) = DIFFLINES (i);
	     same_as (i) = SAME_AS (i);		/* seg index of lowest matching text, or zero */
	end;


/*  */
try_deeper_resynch: proc;

dcl (i, j, k) fixed bin;


	     n_blocks = 0;

	     do i = lo to hi;			/* setup blocks in each text, scan others  */

/* init useful vars */
		cp_i = cp (i);
		depth_i = depth (i);
		len_i = len (i);
		votes_i = 1;
						/* go deeper */
		k = index (substr (cp_i -> ch, depth_i+1, len_i-depth_i), NL);
		if k = 0 then depth_i = len_i;
		else depth_i = depth_i + k;


/* setup block */
		blocklen_i, blocklines_i = 0;		/* block is null so far */
gb_small:
		k = index (substr (cp_i -> ch, (depth_i+blocklen_i)+1, len_i- (depth_i+blocklen_i)), NL);
		if k > 0 then do;			/* was able to grow by another line */
		     blocklen_i = blocklen_i + k;
		     blocklines_i = blocklines_i + 1;

		     if blocklen_i < minchars
		     | blocklines_i < minlines then go to gb_small;
		     n_blocks = n_blocks + 1;		/* one more defined */
		end;
		else do;				/* not able to define block */
		     blocklen_i, blocklines_i = 0;
		     votes_i = 0;
		end;



/* scan other texts for block(i) */
		do j = lo to hi while (votes_i ^= 0);
		     if i = j then i_in (j) = depth_i;
		     else do;
						/* scan one */
			if substr (cp (j) -> ch, 1, blocklen_i)
			= substr (cp_i -> ch, depth_i+1, blocklen_i) then do;
			     i_in (j) = 0;		/* found at top */
			     votes_i = votes_i + 1;	/* favor inserts/deletes if tie */
			end;
			else do;
			     i_in (j) = index (substr (cp (j) -> ch, 1, depth (j)+blocklen_i),
				substr (cp_i -> ch, depth_i, blocklen_i+1));
			     if i_in (j) = 0 then votes_i = 0; /* not present */
			end;
		     end;
		end;


/* scan for block (i) is done, nb. */
		depth (i) = depth_i;
		votes (i) = votes_i;
		if votes (i) > 0 then do;		/* worth remembering? */
		     blocklen (i) = blocklen_i;
		     blocklines (i) = blocklines_i;
		     do j = lo to hi;
			xiny (i, j) = i_in (j);
		     end;
		end;
	     end;

	     if n_blocks = 0 then do;			/* at EOF in all texts */
		synch = "1"b;
		EOF = "1"b;
		return;
	     end;

	     synch = ""b;				/* VALIDATE SYNCH */
	     do while (^synch);
		call get_best;
		if best = 0 then return;
		call check_synch;			/* sets synch, synchlen, synchlines */
		if ^synch then votes (best) = 0;
	     end;

	end try_deeper_resynch;


/*  */
check_synch: proc;					/* IP to see if block (best) is unique in each text */

dcl (i, j, k) fixed bin;
dcl  lo_ptr ptr;
dcl  restlen_all_same bit (1);
dcl  restlen fixed bin;

	     lo_ptr = addr (cp (lo) -> skipchars (xiny (best, lo)));
	     synchlen = blocklen (best);		/* this many chars in synch block so far */
	     synchlines = blocklines (best);

	     restlen_all_same = "1"b;
	     i_in (lo) = xiny (best, lo);
	     restlen = -i_in (lo) - synchlen + len (lo);
	     do i = lo + 1 to hi;
		i_in (i) = xiny (best, i);
		if restlen > len (i) - i_in (i) - synchlen then do;
		     restlen = len (i) - i_in (i) - synchlen;
		     restlen_all_same = ""b;
		end;
	     end;

grow_loop:					/* first make block as big as possible */
	     j = index (substr (lo_ptr -> ch, synchlen+1, restlen), NL);
	     if j = 0 then do;
		if restlen_all_same then j = restlen;
		if j = 0 then go to grow_done;	/* was not another NL in range */
	     end;
	     do i = lo + 1 to hi;
		if substr (lo_ptr -> ch, synchlen+1, j)
		^= substr (cp (i) -> ch, i_in (i)+synchlen+1, j) then go to grow_done;
	     end;
	     synchlen = synchlen + j;			/* grow synched chars */
	     synchlines = synchlines + 1;		/* grow synched lines */
	     restlen = restlen - j;
	     if restlen > 0 then go to grow_loop;

grow_done:					/* here when can't grow synched block further */
	     if synchlen = 0 then go to real_synch;	/* in "synch" at EOF (*) */

/* now see if stuff is unique */

	     do i = lo to hi;
		if index (substr (cp (i) -> ch, i_in (i)+synchlen, len (i)-i_in (i)-synchlen),
		substr (lo_ptr -> ch, 1, synchlen)) ^= 0 then go to pseudo_synch;
	     end;

real_synch:
	     synch = "1"b;
	     return;

pseudo_synch:
	     synch = ""b;
	     return;

	end check_synch;


/*  */
DIFFLINES: proc (di) returns (fixed bin);		/* IP to count lines in difflen(*) */

dcl  dc fixed bin;					/* chars left in diff */
dcl  dl fixed bin;					/* lines in diff counted */
dcl  dj fixed bin;					/* length of one line */
dcl  di fixed bin;					/* text seg in question */
dcl  dp ptr;					/* ptr to rest of diff */
dcl  dch char (dc) based (dp);

	     dc = difflen (di);
	     dp = cp (di);
	     dl = 0;
	     do while (dc > 0);
		dj = index (dch, NL);
		if dj = 0 then dj = dc;
		dc = dc - dj;
		dp = addr (dp -> skipchars (dj));
		dl = dl + 1;
	     end;
	     return (dl);

	end DIFFLINES;


SAME_AS:	proc (si) returns (fixed bin);		/* IP to det if diff matches other diff */

dcl  si fixed bin;					/* text seg in question */
dcl  sas fixed bin;					/* one other diff, being compared */
dcl  sap ptr;					/* ptr to diff */
dcl  sac fixed bin;					/* chars in diff */
dcl  sa_ch char (sac) based;				/* handy template */

	     sap = cp (si);
	     sac = difflen (si);
	     do sas = lo to si - 1;			/* loop over segs with lower indices */
		if sac = difflen (sas) then
		     if sap -> sa_ch = cp (sas) -> sa_ch then
			return (sas);
	     end;
	     return (0);				/* evid not same as any other */

	end SAME_AS;

/*  */
get_best:	proc;					/* IP to choose among synchs */

dcl  gbi fixed bin;

	     best, best_votes = 0;

	     do gbi = lo to hi;
		if votes (gbi) > best_votes then do;
		     best = gbi;
		     best_votes = votes (best);
		end;
	     end;

	end get_best;


/*  */
shrink_diff: proc;					/* IP to avoid "abcdef" changed to "xyzef" foolishness */
dcl (shi, shj, shk) fixed bin;

dcl  max_same fixed bin;
dcl  chars_same fixed bin;
dcl  lines_same fixed bin;

	     chars_same = 0;
	     lines_same = 0;
	     max_same = difflen (lo);
	     do shi = lo + 1 to hi;
		if difflen (shi) < max_same then max_same = difflen (shi);
	     end;
	     if max_same = 0 then return;		/* nothing to compress */

	     do while (chars_same < max_same);
		shj = index (reverse (substr
		     (cp (lo) -> ch, difflen (lo)-max_same+1, max_same-chars_same-1)), NL);
		if shj = 0 then go to sh_done;
		do shi = lo + 1 to hi;
						/* compare complete lines bracketed by NL */
		     if substr (cp (lo) -> ch, difflen (lo)-chars_same-shj, shj+1)
		     ^= substr (cp (shi) -> ch, difflen (shi)-chars_same-shj, shj+1)
		     then go to sh_done;		/* not the same */
		end;
		chars_same = chars_same + shj;	/* discovered more the same */
		lines_same = lines_same + 1;
	     end;
sh_done:
	     if chars_same ^= 0 then do;
		do shi = lo to hi;
		     difflen (shi) = difflen (shi) - chars_same;
		end;
		synchlen = synchlen + chars_same;
		synchlines = synchlines + lines_same;
	     end;

	end shrink_diff;

     end ma_resynch_;




		    manage_volume_pool.pl1          10/19/92  1601.6r w 10/19/92  1555.9     1479852



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

manage_volume_pool: mvp: mvp_: manage_volume_pool_: proc;

/*

   Written 02/18/76 by Richard Bratt

   Last Modified:

   09/10/76 by R. Bratt to add use and print requests.
   2/1/77 by D. Vinograd to lock data base, interface to volume dumper, and to be a bit more
   9/79 by D. Vinograd to add entries list and check for consistences uses by volume dumper
   and to reformat volume pool.
   11/81 by B. Braun to add subroutine move_to_head so volumes are kept in descending order.
   08/03/82 by B. Braun to correct fatal error (phx13239 phx13215), to correct $set_pool_path entry (phx11528), 
   correct $check_reserved (phx11548).
   12/01/82 by B. Braun to extensively change the command interface as defined by MCRs 5898 and 6056.  This 
   includes new keys, new control arguments and support of volume sets.
   10/31/83 by B. Braun to fix error in convert routine resulting in trashed volume pools.
   11/22/83 by B. Braun to fix another error in convert routine resulting in the list key printing a garbage line (phx16394).
   12/02/83 by B. Braun to fix the bit_count calculation and truncate the pool int finish procedure.
   12/05/83 by B. Braun to change volume_pool structure to take up less room (version 3). Fix a SERIOUS
   bug in add_key where set secondary_idx and primary_idx to no_link.
   12/21/83 by B. Braun to set variable retl to chars not words.
   04/16/84 by B. Braun to improve list performance by not buffering to a temp seg first (phx17312). 
   This also fixes a possible size condition bug as the temp seg is not used (mcr6783).
   04/18/84 by B. Braun to add control args -allocate and -reserve to the list key. To complain about
   incompatable args with the "list -total". Fix bug so "[mvp ls -com -edt]" works.
*/


/****^  HISTORY COMMENTS:
  1) change(88-07-02,GDixon), approve(88-07-25,MCR7937),
     audit(88-07-28,Lippard), install(88-08-01,MR12.2-1072):
     Change the set key to add -state_date, allowing the user to set the
     state_date field to an explicit value.  This can be important to the reuse
     operation.
  2) change(91-10-25,Schroth), approve(91-11-28,MECR0015),
     audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001):
     Correct MR12.4 source code corruption.
  3) change(92-05-14,Schroth), approve(91-11-25,MCR8251),
     audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016):
     Replace MECR0015: Correct MR12.4 source code corruption.
  4) change(92-09-16,WAAnderson), approve(92-09-16,MCR8262),
     audit(92-10-06,Vu), install(92-10-19,MR12.5-1028):
     The active function call [mvp l -tt] on very large volume pools failed due
     to insufficient stack space. This occurred due to a misplaced call to
     shorten_stack.  Also checked to make sure request was made as an active
     function and the totals were not wanted before adding volume names into
     the return string.
                                                   END HISTORY COMMENTS */


/*
   manage_volume_pool provides a simple librarian to keep track of a user's volumes. It uses a segment named
   <personid>.volumes in the  user's home directory. as its data base.

   USAGE: manage_volume_pool {key} {-control_args}

   where key may be:

   "add" or "a" to add volumes to the library.
   "allocate" or "alloc" marks volumes as in use.
   "append_volume_set" or "appvs" to increase the size of a volume set.
   "delete" or "dl" to delete volumes from the library.
   "free"  returns volumes to the free pool.
   "list" or "l" to list specific volumes in the library. If no arguments are
      given then all volumes owned by the user are listed. 
   "print" or "pr" or "p" prints the pathname of the volume pool currently in use.
   "pv_expire" or "pvexp" marks volumes as physically expired in the pool.
   "remove_volume_set" or "rmvs" removes volumes from a volume set thereby shrinking the volume set.
   "reserve" or "rsv" marks a volume as reserved. A reserved volume is not free and can be allocated
      in the normal manner.
   "reuse" frees and re-allocates an allocated volume set.
   "set"  is the means to set the expiration dates and comment fields of a volume set.
   "test" tests whether a volume is in a given state.
   "use" or "u" specifies that a different volume pool is to be used.

   The state of a volume is validated to be consistent with a request before
   the request is honored. To facilitate use of this proc, all the entries
   may be invoked as an active functions.

   USAGE: [manage_volume_pool alloc volume_requested] returns the volume assigned

   A volume may also be tested to see if it is free by using the test entry which returns "true" or "false".

   USAGE: [manage_volume_pool test volume_requested] returns "true" or "false"

*/


dcl  Plisted			ptr;
dcl  Pvolume			ptr;
dcl  Ptvol			ptr;
dcl  a_code			fixed bin (35);
dcl  a_comment			char (*);
dcl  a_match_str			char (*) varying;
dcl  a_most_recent			bit(1);
dcl  a_number			fixed bin;
dcl  a_path			char (*);
dcl  a_requested			char (*);
dcl  a_state			fixed bin;
dcl  a_time			fixed bin (71);
dcl  a_volid			bit (36);
dcl  a_volname			char (*);
dcl  a_volumes			char (*) var;
dcl  a_vpp			ptr;
dcl  abort_sw			bit(1);
dcl  ac				fixed bin;
dcl  active_fnc			bit (1);
dcl  al				fixed bin(21);
dcl  ala				fixed bin(21);
dcl  all_states			bit (1);
dcl  all_sw			bit(1);
dcl  alloc_sw			bit (1);
dcl  alp				ptr;
dcl  ap				ptr;
dcl  apa				ptr;
dcl  areap			ptr;
dcl  arg				char (al) based (ap);
dcl  arg2				char (ala) based (apa);
dcl  asterisk_cnt			fixed bin;
dcl  asterisk_sw			bit(1);
dcl  based_area			area based (areap);
dcl  bit_count			fixed bin(24);
dcl  brief_sw			bit(1);
dcl  code				fixed bin (35);
dcl  com_len			fixed bin(21);
dcl  com_ptr			ptr;
dcl  comment_str			char(com_len) based (com_ptr);
dcl  comment_sw			bit(1);
dcl  compare			char (64);
dcl  dfmt_sw			bit(1);
dcl  ecode			fixed bin (35);
dcl  edt_sw			bit(1);
dcl  expire_len			fixed bin(21);
dcl  expire_ptr			ptr;
dcl  expire_str			char(expire_len) based (expire_ptr);
dcl  expire_sw			bit(1);
dcl  first_sw			bit(1);
dcl  first_last_sw			bit(1);
dcl  fexp_sw			bit(1);
dcl  force_sw			bit(1);
dcl  free_sw			bit (1);
dcl  header_output			char (256) var;
dcl  header_len			fixed bin;
dcl  header_to_be_printed		bit(1);
dcl  header_sw			bit (1);
dcl  ignore			fixed bin (35);
dcl  last_sw			bit(1);
dcl  listed_flag (1:volume_pool.n_vol)  bit(1) based (Plisted);
dcl  lock				bit (1);
dcl  match_string			char (64) var;
dcl  match_sw			bit (1);
dcl  most_recent			bit(1);
dcl  myname			char (32);
dcl  name_sw			bit (1);
dcl  narg				fixed bin init(-1);
dcl  new_vpp			ptr;
dcl  noaction_msg			char(256) var;
dcl  noaction_cnt			fixed bin;
dcl  noaction_str			bit(volume_cnt) based (addr(volume.noaction));
dcl  none_sw			bit(1);
dcl  output			char (256) var;
dcl  output_len			fixed bin;
dcl  pvedt_sw			bit(1);
dcl  pvexp_str			char(pvexp_len) based (pvexp_ptr);
dcl  pvexp_len			fixed bin(21);
dcl  pvexp_ptr			ptr;
dcl  pvexp_sw			bit(1);
dcl  requoted_output                    char (512) var;
dcl  reserve_sw			bit(1);
dcl  ret				char (retl) var based (retp);
dcl  retl				fixed bin(21);
dcl  retp				ptr;
dcl  sdt_sw			bit (1);
dcl  state_dt_clock			fixed bin(71);
dcl  state_dt_str			char(state_dt_len) based (state_dt_ptr);
dcl  state_dt_len			fixed bin(21);
dcl  state_dt_ptr			ptr;
dcl  state_dt_sw			bit (1);
dcl  state_sw			bit (1);
dcl  tcnt				fixed bin;
dcl  total_cnt			fixed bin;
dcl  totals_wanted			bit(1);
dcl  vol_msg_list			char(256) var;
dcl  vol_msg_cnt			fixed bin;
dcl  volume_cnt			fixed bin;
dcl  vs_sw			bit(1);
dcl  vs_size			fixed bin;
dcl  specified_states(4)		bit(1) unal;
dcl  state_string			bit(4) unal based (addr(specified_states));
dcl  svol_sw			bit(1);
dcl  subroutine			bit (1);
dcl  tdir				char (168);
dcl  tname			char (32);
dcl  tvlx				fixed bin;
dcl  vlx				fixed bin (17);
dcl  vol_cnt			fixed bin;
dcl  volume_sw			bit(1);
dcl  volume_state			fixed bin;
dcl  vp_bc			fixed bin(24);
dcl  vpp				ptr;
dcl  want_str			bit(volume_cnt) based (addr(volume.want_it));
dcl  word_count			fixed bin(19);
dcl yes_sw			bit(1);

dcl  1 vol_list(1:17)		aligned,
       2 name			char(256) var,
       2 cnt			fixed bin;

dcl  1 tvol			aligned based (Ptvol),
       2 name(tcnt)			char(32),
       2 indx(tcnt)			fixed bin,
       2 switches,
         3 noaction(tcnt)		bit(1) unal,
         3 want_it(tcnt)		bit(1)unal;

dcl  1 volume			aligned based (Pvolume),
       2 name(volume_cnt)		char(32),
       2 indx(volume_cnt)		fixed bin,
       2 switches,
         3 noaction(volume_cnt)	bit(1) unal,
         3 want_it(volume_cnt)	bit(1)unal;

dcl 1 volume_pool_header		aligned,
    2 version			fixed bin,	/* version 3 structure			*/
    2 lock			bit (36),
    2 n_vol			fixed bin (17),	/* number of volume slots in the pool, free and occupied */
    2 volume_count			fixed bin(17),	/* number of volumes in the pool		*/
    2 head			fixed bin (17),	/* index into first volume in pool		*/
    2 tail			fixed bin (17),     /* index to last volume in pool		*/
    2 free_head			fixed bin (17),     /* index to first empty slot in array		*/
    2 pad				bit (36);

dcl 1 volume_pool_entry		aligned,	   /* volume pool entry. each volume has one assoc. with it */
      2 name			char (32),	/* name of volume set			*/
      2 id			bit (36),		/* used by volume dumper only			*/
      2 state			fixed bin,	/* state of the volume			*/
      2 state_date			fixed bin (71),	/* date the volume was last acted upon		*/
      2 pv_expire_date		fixed bin(71),      /* physical volume expiration date		*/
      2 expire_date			fixed bin(71),      /* allocated volume expiration date		*/
      2 processid			bit (36),		/* used when reserving volume			*/
      2 comment			char (64),
      2 switches			unaligned,
        3 secondary_vol		bit(1),	/* true if volume is a part of a multiple volume set */
        3 pv_expire			bit(1),	/* true if a physical volume expiration date is assoc. with the volume */
        3 expire			bit(1),   /* true if an expire date is associated with the volume	*/
        3 already_printed		bit(1),   /* used in listing purposes				*/
        3 pad1			bit(32),
      2 vs_count			fixed bin,	/* volume set count, includes primary and secondary volumes	*/
      2 next			fixed bin(17),      /* index to next node or volume in the pool	*/
      2 previous			fixed bin(17),      /* index to previous volume in pool		*/
      2 primary_idx			fixed bin(17),      /* index of primary volume in a set               */
      2 secondary_idx		fixed bin(17),      /* index to next secondary volume in a set	*/
      2 pad2			bit (36);

dcl 1 volume_pool			aligned based (vpp), /* This is the CURRENT volume pool structure */
    2 header			like volume_pool_header,
    2 vpe		(divide(sys_info$max_seg_size - size(volume_pool_header), size(volume_pool_entry), 17)
			refer (volume_pool.header.n_vol)) like volume_pool_entry;

/* internal static  variables  */

dcl  vol_ename			char (32) int static init ("");
dcl  vol_dir			char (168) int static init ("");

dcl  (ascii_state (4)		char (5)  int init ("FREE", "ALOC", "RESV", "PVEXP"),
      blank_NL			char (2)  int init(" 
"),
      allocated_state		fixed bin int init (2),
      free_state			fixed bin int init (1),
      reserved_state		fixed bin int init (3),
      pvexp_state			fixed bin int init (4),
      no_link			fixed bin int init (-1),
      paired_args			bit (1)   int init ("1"b),
      single_arg			bit (1)   int init ("0"b),
      volume_pool_version_3		fixed bin init (3),
      volume_pool_version_2		fixed bin init (2),
      volume_pool_version_1		fixed bin init (1),
      use				char (3) init ("use"),
      truebits			bit(4)    int init ("1111"b) unal,
      True			bit(1)    int init ("1"b),
      False			bit(1)    int init ("0"b),
      lock_interval			fixed bin int init (60))
				static  options (constant);

dcl (already_alloc			init("1000000000000000"b),
     already_free			init("0100000000000000"b),
     already_reg			init("0010000000000000"b),
     already_sec_vol		init("0001000000000000"b),
     cant_delete			init("0000100000000000"b),
     cant_pvexp			init("0000010000000000"b),
     not_alloc			init("0000001000000000"b),
     not_free			init("0000000100000000"b),
     not_exp			init("0000000010000000"b),
     not_reg			init("0000000001000000"b),
     not_updated			init("0000000000100000"b),
     rsv_by_another			init("0000000000010000"b),
     sec_not_found			init("0000000000001000"b),
     check_pvexp			init("0000000000000100"b),
     vol_pvexp			init("0000000000000010"b),
     sec_vol			init("0000000000000001"b))
				bit(16) unal int static options(constant);
dcl (fb_already_alloc		init(1),
     fb_already_free		init(2),
     fb_already_reg			init(3),
     fb_already_sec_vol		init(4),
     fb_cant_delete			init(5),
     fb_cant_pvexp			init(6),
     fb_not_alloc			init(7),
     fb_not_free			init(8),
     fb_not_exp			init(9),
     fb_not_reg			init(10),
     fb_not_updated			init(11),
     fb_rsv_by_another		init(12),
     fb_sec_not_found		init(13),
     fb_check_pvexp		init(14),
     fb_vol_pvexp			init(15),
     fb_prim_name			init(17))
				fixed bin unal int static options(constant);

dcl err_msg(1:15)			char(100)var int static options(constant) init(
    " Volume set^[s^] ^a ^[are^;is^] already allocated.", 
    " Volume set^[s^] ^a ^[are^;is^] already free.",
    " Volume set^[s^] ^a ^[are^;is^] already registered in the pool.",
    " Volume^[s^] ^a ^[are^;is a^] secondary volume^[s^] of volume set ^a.", 
    " Volume set^[s^] ^a ^[are^;is^] allocated and can not be deleted.", 
    " Volume set^[s^] ^a ^[are^;is^] allocated and can not be physically expired.",
    " Volume set^[s^] ^a ^[are^;is^] not allocated.",
    " Volume set^[s^] ^a ^[are^;is^] not free.",
    " Allocated volume set^[s^] ^a ^[are^;is^] not expired.",
    " Volume^[s^] ^a ^[are^;is^] not registered.",
    " Volume set^[s^] ^a ^[are^;is^] not allocated. It has not been updated.",
    " Volume set^[s^] ^a ^[are^;is^] not reserved by your process.",
    " Secondary volume^[s^] ^a not found in set ^a.", 
    " Physical volume^[s^] ^a ^[have^;has^] expired.", 
    " Volume set^[s^] ^a ^[are^;is^] physically expired.");
					  

dcl  cleanup			condition;

/* Entries */

dcl  clock_			entry() returns(fixed bin(71)),
     command_query_$yes_no		entry() options(variable),
     convert_date_to_binary_		entry (char(*), fixed bin(71), fixed bin(35)),
     cu_$af_arg_ptr_rel		entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr),
     cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
     cu_$arg_list_ptr		entry (ptr),
     cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin(21), fixed bin (35), ptr),
     date_time_			entry (fixed bin (71), char (*) aligned),
     expand_pathname_		entry (char (*), char (*), char (*), fixed bin (35)),
     get_arg			variable entry (fixed bin, ptr, fixed bin(21), fixed bin (35), ptr),
     get_process_id_		entry returns (bit (36) aligned),
     get_ring_			entry() returns(fixed bin(3)),
     get_system_free_area_		entry returns (ptr),
     get_temp_segment_		entry (char (*), ptr, fixed bin (35)),
     hcs_$fs_move_seg		entry (ptr, ptr, fixed bin, fixed bin (35)),
     hcs_$fs_get_path_name		entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$get_user_effmode		entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)),
     hcs_$make_seg			entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     hcs_$set_bc			entry (char(*), char(*), fixed bin(24), fixed bin(35)),
     hcs_$terminate_noname		entry (ptr, fixed bin (35)),
     hcs_$truncate_file		entry (char(*), char(*), fixed bin(19), fixed bin(35)),
     hcs_$validate_processid		entry (bit (36) aligned, fixed bin (35)),
     initiate_file_		entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)),
     release_temp_segment_		entry (char (*), ptr, fixed bin (35)),
     requote_string_		entry (char (*)) returns (char (*)),
     set_lock_$lock			entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock		entry (bit (36) aligned, fixed bin (35)),
     suffixed_name_$make		entry (char (*), char (*), char (*), fixed bin (35)),
     user_info_$homedir		entry (char (*));
					  
dcl (active_fnc_err_,
     com_err_,
     ioa_,
     ioa_$nnl,
     ioa_$rsnnl,
     user_info_)			entry options (variable);
dcl (a_error_rnt,
     abort_proc,
     error_rnt,
     msg_proc)			entry variable options (variable);

dcl (error_table_$action_not_performed,
     error_table_$badopt,
     error_table_$boundviol,
     error_table_$inconsistent,
     error_table_$invalid_lock_reset,
     error_table_$locked_by_this_process,
     error_table_$lock_not_locked,
     error_table_$noarg,
     error_table_$process_unknown,
     error_table_$unimplemented_version)
				ext fixed bin (35);

/* builtins */

dcl (addr, clock, convert, currentsize, hbound, index, 
     length, max, mod, null, 
     rtrim, substr, verify)		builtin;


	subroutine = False;
	call setup;
	on cleanup call finish;
	call get_arg (1, ap, al, (0), alp);
	if arg = "l" | arg = "ls" | arg = "list" then call list_key();
	else if arg = "al" | arg = "alloc" |  arg = "allocate" then call determine_alloc_version();
	else if arg = "f" | arg = "free" then call free_key();
	else if arg = "a" | arg = "add" then call add_key(); 
	else if arg = "d" | arg = "dl" | arg = "delete" then call delete_key();
	else if arg = "r" | arg = "rsv" | arg = "reserve" then call reserve_key();
	else if arg = "t" | arg = "test" then call test_key();
	else if arg = "appvs" | arg = "append_volume_set" then call append_volume_set();
	else if arg = "rmvs" | arg = "remove_volume_set" then call remove_volume_set();
	else if arg = "reuse" then call reuse();
	else if arg = "set" then call set_key();
	else if arg = "pvexp" | arg = "pv_expire" then call pv_expire_key();
	else if arg = "u" | arg = "use" then call use_key();
	else if arg = "c" | arg = "change"                /* obsolete key */
	then call process (paired_args, change);
	else if arg = "cm" | arg = "comment"              /* obsolete key */
	then call process (single_arg, comment);
	else if arg = "p" | arg = "pr" | arg = "print"
	then do;
	     if active_fnc then ret = path(vol_dir,vol_ename);
	     else call msg_proc (-1, "^a", path (vol_dir, vol_ename));
	end;
	else call abort_proc (error_table_$badopt, arg);
return_to_caller:
	call finish;

	return;


reserve:	entry (a_vpp, a_error_rnt, a_requested, a_comment, a_volname, a_code);

	volume_state = reserved_state;
	goto alloc_common;

allocate:	entry (a_vpp, a_error_rnt, a_requested, a_comment, a_volname, a_code);

	volume_state = allocated_state;
alloc_common:
	subroutine = True;
	call setup;
	on cleanup call finish;
	ap = addr (a_requested);
	al = length (rtrim (a_requested));
	apa = addr (a_comment);
	ala = length (rtrim (a_comment));
	call search (arg);
	if vlx = 0
	then if arg ^= "*" then call add;
	     else call abort_proc (0, "No free volumes.");
	call allocate;
	a_volname = vpe (vlx).name;
	goto return_to_caller;

force_allocate:	entry (a_vpp, a_error_rnt, a_number, a_most_recent, a_match_str, a_volumes, a_code);

/* This entry point is to facilitate TR backup and retrievals of the Trouble Report system */

dcl volx				fixed bin;

	subroutine = True;
	call setup;
	on cleanup call finish;
          if volume_pool.volume_count < a_number then do;	/* asking for too many?			*/
	   a_code = error_table_$boundviol;
	   goto return_to_caller;
	   end;
	vol_cnt = 0;
          volume_cnt = a_number;
          if a_match_str = "" then match_sw = False;
	else match_sw = True;
	areap = get_system_free_area_();
	allocate volume in (based_area) set (Pvolume);
	if a_most_recent then do;
	   volx = volume_pool.head;
	   do while ((volx ^= no_link) & (vol_cnt < volume_cnt));	/* like -first N means return the "latest" N	*/
	      if vpe(volx).state = allocated_state & vpe(volx).vs_count = 1 then do;
	         if match_sw then do;
	            if (index (vpe(volx).comment, a_match_str) > 0) then do;
		     vol_cnt = vol_cnt + 1;
		     volume(vol_cnt).indx = volx;
		     volume(vol_cnt).name = vpe(volx).name;
		     end;
		  end; 

	         else do; /* no match str specified */
		  vol_cnt = vol_cnt + 1;
		  volume(vol_cnt).indx = volx;
		  volume(vol_cnt).name = vpe(volx).name;
		  end;
	         end;
	      volx = vpe(volx).next;
	      end;
	   end;

	else do;
	   volx = volume_pool.tail;
	   do while ((volx ^= no_link) & (vol_cnt < volume_cnt)); 	/* got to be like -last reuse oldest N		*/
	      if vpe(volx).state = allocated_state & vpe(volx).vs_count = 1 then do;
	         if match_sw then do;
	            if (index (vpe(volx).comment, a_match_str) > 0) then do;
		     vol_cnt = vol_cnt + 1;
		     volume(vol_cnt).indx = volx;
		     volume(vol_cnt).name = vpe(volx).name;
		     end;
		  end; 

	         else do;  /* no match str specified */
	            vol_cnt = vol_cnt + 1;
		  volume(vol_cnt).indx = volx;
		  volume(vol_cnt).name = vpe(volx).name;
		  end;
	         end;
	      volx = vpe(volx).previous;
	      end;
             end;

	if (vol_cnt = 0) | (vol_cnt < volume_cnt) then do;
	   a_code = error_table_$action_not_performed;
	   goto return_to_caller;
	   end;

          a_volumes = "";
	do volx = 1 to vol_cnt;
	   a_volumes = a_volumes || rtrim(volume(volx).name) || " ";
	   call move_to_head(volume(volx).indx);
	   end;

          goto return_to_caller;  

free:	entry (a_vpp, a_error_rnt, a_requested, a_code);
	subroutine = True;
	call setup;
	on cleanup call finish;
	ap = addr (a_requested);
	al = length (rtrim (a_requested));
	call search (arg);
	call free;
	goto return_to_caller;

delete:	entry (a_vpp, a_error_rnt, a_requested, a_code);
	subroutine = True;
	call setup;
	on cleanup call finish;
	ap = addr (a_requested);
	al = length (rtrim (a_requested));
	call search (arg);
	call delete;
	goto return_to_caller;

set_volid: entry (a_vpp, a_error_rnt, a_volname, a_volid, a_code);

/* This entry point is used by Volume Dumper */

	subroutine = True;
	call setup;
	on cleanup call finish;
	ap = addr (a_volname);
	al = length (rtrim (a_volname));
	call search (arg);
	if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg);
	vpe (vlx).id = a_volid;
	goto return_to_caller;

check_reserved: entry (a_vpp, a_error_rnt, a_code);
	subroutine = True;
	call setup;
	on cleanup call finish;
	vlx = volume_pool.head;
	do while (vlx ^= no_link);
	   if vpe (vlx).state = reserved_state then do;
	      if reserved_by_another_process(vlx) then;  /* skip it */
	      else do;
	         vpe (vlx).state = free_state;
	         vpe (vlx).processid = "0"b;
	         call move_to_head(vlx);
	         end;
	      end;
	   vlx = vpe(vlx).next;
	   end;
	goto return_to_caller;

status:	entry (a_vpp, a_error_rnt, a_requested, a_comment, a_time, a_state, a_code);
	subroutine = True;
	call setup;
	on cleanup call finish;
	ap = addr (a_requested);
	al = length (rtrim (a_requested));
	call search (arg);
	if vlx = 0 then
	     call abort_proc (0, "Volume ^a is not registered.", arg);
	a_comment = vpe (vlx).comment;
	a_time = vpe (vlx).state_date;
	a_state = vpe (vlx).state;
	goto return_to_caller;

set_pool_path: entry (a_error_rnt, a_path, a_vpp, a_code);

/* Returns a pointer to the volume pool specified by pathname. */

	subroutine = True;
	a_vpp = null;
	ap = addr (use);
	al = length (use);
	call setup;
	on cleanup call finish;
	ap = addr (a_path);
	al = length (rtrim (a_path));
	call setup_pool_path("1"b);
	goto return_to_caller;

get_pool_path: entry (a_vpp, a_error_rnt, a_path, a_code);

/* Returns the pathname of volume pool given a pointer */

	subroutine = True;
	call setup;
	on cleanup call finish;
	call hcs_$fs_get_path_name (vpp, tdir, (0), tname, code);
	if code ^= 0
	then call abort_proc (code, "Unable to deterime pool pathname.");
	else call ioa_$rsnnl ("^a", a_path, (0), path (tdir, tname));
	goto return_to_caller;
%page;
abort:	proc (err) ;
dcl  argp ptr;
dcl  err fixed bin (35);
dcl  str char (256);
dcl  str_len fixed bin;

     if subroutine
     then do;
	if err = 0 then a_code = error_table_$action_not_performed;
	else a_code = err;
     end;
     call cu_$arg_list_ptr (argp);
						/* convert args to message */
     call ioa_$general_rs (argp, 2, 3, str, str_len, "0"b, "0"b);
     if lock then call set_lock_$unlock (volume_pool.lock, ignore);
     call error_rnt (err, myname, substr (str, 1, str_len));
     goto return_to_caller;
end abort;


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

add:	proc();
 
/* old add used for subroutines only */

       if vlx ^= 0 then call abort_proc(0, "Volume ^a is already registered.", arg);
       vlx = get_node();
       vpe (vlx).name = arg;
       vpe (vlx).state = free_state;
       vpe (vlx).comment = "";
       vpe (vlx).switches = False;
       vpe (vlx).expire_date = 0;
       vpe (vlx).pv_expire_date = 0;
       vpe (vlx).secondary_idx, vpe (vlx).primary_idx = no_link;
       vpe (vlx).vs_count = 1;
       call insert_node(vlx);
    return;
end add;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

add_key: 	proc();

/* Used by the command, add_key adds volumes to the pool */

dcl pv_clock			fixed bin(71),
    (volx, vol_cnt, i)		fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("0"b),
      2  last			init ("0"b),
      2  force			init ("1"b),
      2  vs			init ("0"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("1"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("1"b),	/* requires a date after -pvexp		*/
      2  state_dt			init ("0"b)) bit(1);

    if narg < 2 then call abort_proc (error_table_$noarg, "^/Usage: add volume_names {-control_arg}");

    pv_clock = 0;

    call process_ctl_args(addr(args_allowed), 2, vol_cnt); 

    if vol_cnt = 0 then   call abort_proc(0, "No volume names specified.");
    if pvexp_sw then do;
       call convert_date_to_binary_(pvexp_str, pv_clock, code);
       if code ^= 0 then call abort_proc(code, pvexp_str);
       end;

    call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, already_reg);

    call evaluate_volumes_wanted("added", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
    if none_sw | abort_sw then do;
       if active_fnc then do;
	ret = "false";
	return;
	end;
       if none_sw then  call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
       else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);
      end;

    /* add volumes specified */

    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if volume(i).noaction then;   /* skip */
          else do;
	   volx = get_node();
	   vpe (volx).name = volume(i).name;
	   vpe (volx).state = free_state;
	   vpe (volx).comment = "";
	   vpe (volx).switches = False;
	   vpe (volx).pv_expire = pvexp_sw;
	   vpe (volx).pv_expire_date = pv_clock;
	   vpe (volx).expire_date = 0;
	   vpe (volx).secondary_idx, vpe (volx).primary_idx = no_link;
	   vpe (volx).vs_count = 1;
	   call insert_node(volx);
	   end;
          end;
       end;

    if active_fnc then  ret = "true";
    else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg);

    return;

end add_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

allocate:	proc;

/* old allocate used by subroutine allocate and "mvp al vol_name1 comment_1 vol_name2 comment_2 ... vol_nameN comment_N" 
   command line */

	     if vlx = 0
	     then if arg = "*"
		then call abort_proc (0, "No free volumes.");
		else call abort_proc (0, "Volume ^a is not registered.", arg);
	     if vpe (vlx).state = allocated_state then call abort_proc (0, "Volume ^a is already allocated.", arg);
	     vpe (vlx).comment = arg2;
	     if subroutine then do;
		vpe (vlx).state = volume_state;
		if volume_state = reserved_state then
		     vpe (vlx).processid = get_process_id_ ();
		else vpe (vlx).processid = "0"b;
	     end;
	     else do;
		vpe (vlx).state = allocated_state;
		vpe (vlx).processid = "0"b;
	     end;
	     if active_fnc then ret = vpe (vlx).name;
	     else if arg = "*" & ^subroutine then call msg_proc (0, "Volume ^a allocated", vpe (vlx).name);
 	     call move_to_head(vlx); 
	     return;
	end allocate;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

allocate_key:   proc();

/* Used by the mvp command to allocate volume sets in the pool. */

dcl exp_clock			fixed bin (71);
dcl (i, vol_cnt, volx)		fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("1"b),
      2  last			init ("1"b),
      2  force			init ("1"b),
      2  vs			init ("1"b),
      2  com			init ("1"b),
      2  expire			init ("1"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("1"b),	/* requires a date after -exp		          */
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

     /* first process list control args */

     exp_clock = 0;

     call process_ctl_args(addr(args_allowed), 2, vol_cnt);

    if volume_sw & (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, 
         "volume_names ^[-volume_size^;^]^[-first^;-last^]", vs_sw, most_recent);

    if expire_sw then do;
       call convert_date_to_binary_(expire_str, exp_clock, code);
       if code ^= 0 then call abort_proc(code, expire_str);
       end;

    if vol_cnt = 0 then vol_cnt = 1;			/* vol_cnt hasn't been set yet.		*/
 
    if ^(volume_sw) then do;				/* structure needs to be allocated		*/
       specified_states(free_state) = True;
       volume_cnt = vol_cnt;
       allocate volume in (based_area) set (Pvolume);
       volume.want_it = False;
       call get_volumes_specified ("allocated", specified_states, Pvolume, vol_cnt, vs_size, most_recent);
      end;

    else do; /* volume names were specified */

       call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, 
                             not_reg | rsv_by_another | already_alloc | vol_pvexp | sec_vol | check_pvexp);
       end;

    call evaluate_volumes_wanted("allocated", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
    if none_sw then  call abort_proc(error_table_$action_not_performed, 
             "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
    else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);

    /* allocate volumes specified */

    vol_msg_list = "";
    do i = 1 to vol_cnt;
       if volume(i).want_it then do;			/* else just skip over it 			*/
          if ^(volume(i).noaction) then do;
             volx = volume(i).indx;
	   if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx;
	   if vpe(volx).state = reserved_state then vpe(volx).processid = "0"b;
	   vpe (volx).state = allocated_state;
	   if comment_sw then vpe (volx).comment = comment_str;
	   else vpe (volx).comment = "";
	   vpe (volx).expire_date = exp_clock;
	   vpe (volx).expire = expire_sw;
             if active_fnc then ret = ret || " " || rtrim(vpe(volx).name);
	   else if (first_last_sw) then vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name);
	   call move_to_head(volx); 
	   end;
	end;
       end;

    if ^active_fnc then do;
       if vol_msg_list ^= "" then 
          call msg_proc(0, "Volume set^[s^] ^a ^[has^;have^] been allocated. ^[^a^;^s^]",
               (vol_cnt > 1), vol_msg_list, (vol_cnt = 1), noaction_msg ^= "", noaction_msg);  
       else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg ); 
       end;

end allocate_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

append_secondary_volumes:   proc(old_primary_idx, new_primary_idx, last_volume_idx);

/* called by append_volume_set when appending a multiple volume set.
   old_primary_idx: references the volume set to be appended. (input)
   new_primary_idx: is the volume set to be appended to.   (input)
   last_volume_idx: index to the last volume in the volume set after the set is appended on.  (output)
*/

dcl (old_primary_idx, 
     new_primary_idx,
     last_vol,
     next_vol,
     last_volume_idx)		fixed bin;

    next_vol = vpe(old_primary_idx).secondary_idx;
    last_vol = old_primary_idx;
    do while (next_vol > 0);
       if active_fnc then ret = ret || " " || rtrim(vpe(next_vol).name);
       vpe(last_vol).secondary_idx = next_vol;
       vpe(last_vol).vs_count = 1;
       vpe(last_vol).previous, vpe(last_vol).next = no_link;
       vpe(next_vol).primary_idx = new_primary_idx;
						/* update volume set count of volume set appending to. */
       vpe(new_primary_idx).vs_count = vpe(new_primary_idx).vs_count + 1;
       last_vol = next_vol;
       next_vol = vpe(next_vol).secondary_idx;
       end;

    vpe(last_vol).secondary_idx = no_link;
    vpe(last_vol).vs_count = 1;
    vpe(last_vol).previous, vpe(last_vol).next = no_link;
    last_volume_idx = last_vol;

end append_secondary_volumes;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

append_volume_set:   proc();

/* procedure called for key append_volume_set. Appends volume sets to the set designated by the primary volume name */

dcl i,
    vol_cnt,
    last_vol,
    next_vol,
    primary_idx			fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("1"b),
      2  last			init ("1"b),
      2  force			init ("1"b),
      2  vs			init ("1"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1); 

    if narg < 3 then call abort_proc (error_table_$noarg, 
                    "^/Usage: mvp appvs primary_volume_name {secondary_volume_names} {-control_args} ");

    /* first get primary_volume_name */

    ac = 2;
    call get_arg (ac, ap, al, (0), alp);
    if ^(volume_in_pool((arg), primary_idx)) then call abort_proc(error_table_$action_not_performed, 
                                  "Specified primary volume is not in the pool. " || arg);
    else if vpe(primary_idx).secondary_vol then call abort_proc(error_table_$action_not_performed, 
                   "^/Specified primary volume ^a is a secondary volume of set ^a.", arg, 
	         vpe(vpe(primary_idx).primary_idx).name);

    /* now look at secondary volumes specified or  control args  */

    call process_ctl_args(addr(args_allowed), 3, vol_cnt);

    if (vs_sw | first_last_sw) & volume_sw then call abort_proc(error_table_$inconsistent,
                                                       "secondary_volumes and -control_args");

    if vol_cnt = 0 then  vol_cnt = 1;              /* vol_cnt hasn't been set yet.		*/

    if ^(volume_sw) then do;			/* structure needs to be allocated		*/
       specified_states(free_state) = True;
       volume_cnt = vol_cnt;
       allocate volume in (based_area) set (Pvolume);
       volume.want_it = False;
       call get_volumes_specified ("freed", specified_states, Pvolume, vol_cnt, vs_size, most_recent);
      end;

    else do;  /* secondary volumes were specified */
       /* validate volumes and label whether we want them or not */

       call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | not_free | already_sec_vol | check_pvexp);
       end;

    call evaluate_volumes_wanted("appended", Pvolume, narg, vol_cnt, none_sw, abort_sw);
    if none_sw then call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
    else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);

    /* append the volumes */

    vol_msg_list = "";
    last_vol = last_volume_in_set(primary_idx);
    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
	   if active_fnc then ret = ret || " " || rtrim(volume(i).name);
	   next_vol = volume(i).indx;
	   vpe(last_vol).secondary_idx = next_vol;
	   vpe(next_vol).primary_idx = primary_idx;
	   vpe(next_vol).secondary_vol = True;
	   if next_vol = volume_pool.head then volume_pool.head = vpe(next_vol).next;
             else if vpe(next_vol).previous ^= no_link then vpe(vpe(next_vol).previous).next = vpe(next_vol).next;
  	   if next_vol = volume_pool.tail then volume_pool.tail = vpe(next_vol).previous;
	    else if vpe(next_vol).next ^= no_link then vpe(vpe(next_vol).next).previous = vpe(next_vol).previous;
             vpe(next_vol).next, vpe(next_vol).previous = no_link;
	   if (first_last_sw) then do;
	      vol_msg_list = vol_msg_list || " " || rtrim(vpe(next_vol).name);
                end; 
	   if vpe(next_vol).vs_count > 1 then call append_secondary_volumes(next_vol, primary_idx, last_vol);
	   else last_vol = next_vol;
	   vpe(primary_idx).vs_count = vpe(primary_idx).vs_count + 1;
	   end;
	end;
        end;

    vpe(last_vol).secondary_idx = no_link;
    call move_to_head(primary_idx);

    if ^active_fnc then do;
       if vol_msg_list ^= "" then 
          call msg_proc(0, "Volume^[s^] ^a ^[has^;have^] been appended.",
               (vol_cnt > 1), vol_msg_list, (vol_cnt = 1));  

       if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg);
   end;

end append_volume_set;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

bad_arg:	proc (arg) returns (bit (1));

/* used in key verification */

dcl  arg char (*);
dcl  keyx fixed bin;
dcl  keys (35) char (32) static options (constant) init ("a", "add", "l", "ls", "list", "p", "pr", "print", "al", 
     "alloc", "allocate", "f", "free", "d", "dl", "delete", "c", "change", "r", "rsv", "reserve", "t", "test",
     "cm", "comment", "u", "use", "appvs", "append_volume_set", "reuse", "pv_expire",
     "pvexp", "remove_volume_set", "rmvs", "set");

     do keyx = 1 to hbound (keys, 1);
        if arg = keys (keyx) then return (False);
        end;
     return (True);

end bad_arg;

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

change:	proc;

/* obselete key that must still be supported. change changes the comment of a volume specified by volume name */

	     if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg);
	     if vpe (vlx).state = free_state then call abort_proc (0, "Volume ^a is free.", arg);
	     vpe (vlx).comment = arg2;
 	     call move_to_head(vlx);
	     return;
	end change;

%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

check_first_then_convert:  proc();

dcl VERSION_MSG			char(171) int init(
"Most likely an older version of mvp is being used which doesn't recognize all mvp structure versions.^/Recommendation is to copy the pool before converting or answer 'no'.") static options(constant);
		       

if volume_pool.version = volume_pool_version_1  | volume_pool.version = volume_pool_version_2 then 
   call convert_volume_pool();
else do;
   /* before assuming this is the original old volume_pool structure with no version associated with it, 
      we will ask the user, and then go merrily along converting it  */

    /* but before we query the user, is this just a zero length seg? */
     
        if vp_bc = 0 then do;   /* must be zero seg */
           call convert_volume_pool();
	 return;
           end;

     if subroutine then  /* report problem, dont query */
	call abort_proc(error_table_$action_not_performed, "Unrecognizable volume_pool version ^d.", volume_pool.version);

     call command_query_$yes_no (yes_sw, 0, "mvp", VERSION_MSG, 
 "The volume pool ^a ^/has an unrecognizable mvp structure version ^d.^/Do you want to TRY converting to the current version ^d?",
          path(vol_dir, vol_ename), volume_pool.version, volume_pool_version_3 );

     if yes_sw then call convert_volume_pool();
     else call abort_proc(error_table_$unimplemented_version, "Unrecognizable volume_pool version ^d", volume_pool.version);
     end;

end check_first_then_convert;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

check_for_errors:  proc(aptr, asize, vol_cnt, primary_idx, check);

/* checks for preliminary errors for various keys  */
/* aptr:   pointer to volume structure containing the volume names (input).
   asize:  size of structure volume (input).
   vol_cnt: actual count of valid volume names in the structure (input).
   primary_idx: primary_idx of the set if its a secondary volume, else its just 0 (input).
   check: 16-bit code specifying which errors to check for.
*/

dcl check				bit(16);
dcl error_found			bit(16);
dcl  1 volume			aligned based (aptr),
       2 name(asize)		char(32),
       2 indx(asize)		fixed bin,
       2 switches,
         3 noaction(asize)		bit(1) unal,
         3 want_it(asize)		bit(1)unal;

dcl (asize, vol_cnt,
     primary_idx, i, volx)		fixed bin;
dcl aptr				ptr;
dcl just_expired			bit(1);

       error_found = "0000000000000000"b;
       just_expired = False;
       volume.want_it = True;
       volume.noaction = False;

       do i = 1 to vol_cnt by 1;
          if ^(volume_in_pool ((volume(i).name), volx)) then do;
	   if check & not_reg then do;
   	      volume(i).noaction = True;
	      substr(error_found, fb_not_reg, 1) = True;
	      vol_list.name(fb_not_reg) = vol_list.name(fb_not_reg)  || " " || rtrim(volume(i).name);
	      vol_list.cnt(fb_not_reg) = vol_list.cnt(fb_not_reg) + 1;
                end;
	   end;
          else do;
             volume(i).indx = volx;

	   if (check & sec_not_found) then do;
   	      if ^(volume_in_volume_set((volume(i).name), primary_idx, volx)) then do;
   	         volume(i).noaction = True;
	         substr(error_found, fb_sec_not_found, 1) = True;
	         vol_list.name(fb_sec_not_found) = vol_list.name(fb_sec_not_found)  || " " || rtrim(volume(i).name);
	         vol_list.cnt(fb_sec_not_found) = vol_list.cnt(fb_sec_not_found) + 1;
	         vol_list.name(fb_prim_name) = rtrim(vpe(primary_idx).name);
	         goto END_CHECK;
	         end;
    	      end;

	   if check & already_reg then do;
   	      volume(i).noaction = True;
	      substr(error_found, fb_already_reg, 1) = True;
	      vol_list.name(fb_already_reg) = vol_list.name(fb_already_reg)  || " " || rtrim(volume(i).name);
	      vol_list.cnt(fb_already_reg) = vol_list.cnt(fb_already_reg) + 1;
	      goto END_CHECK;
                end;

	   if vpe(volx).secondary_vol then do;
	      if (check & sec_vol) then volx = vpe(volx).primary_idx;
    	      else if (check & already_sec_vol)then do;
	         volume(i).noaction = True;
	         substr(error_found, fb_already_sec_vol, 1) = True;
	         vol_list.name(fb_already_sec_vol) = vol_list.name(fb_already_sec_vol)  || " " || rtrim(volume(i).name);
	         vol_list.cnt(fb_already_sec_vol) = vol_list.cnt(fb_already_sec_vol) + 1;
	         vol_list.name(fb_prim_name) = rtrim(vpe(vpe(volx).primary_idx).name);
	         goto END_CHECK;
                   end;
               end;

             if (check & rsv_by_another) then if vpe (volx).state = reserved_state then do;
	      if reserved_by_another_process(volx) then do;
	         volume(i).noaction = True;
	         substr(error_found, fb_rsv_by_another, 1) = True;
	         vol_list.name(fb_rsv_by_another) = vol_list.name(fb_rsv_by_another)  || " " || rtrim(volume(i).name);
	         vol_list.cnt(fb_rsv_by_another) = vol_list.cnt(fb_rsv_by_another) + 1;
	         goto END_CHECK;
	         end;
	       end;

	    if vpe (volx).state = allocated_state then do;
	       if (check & already_alloc) then do;
		volume(i).noaction = True;
	          substr(error_found, fb_already_alloc, 1) = True;
	          vol_list.name(fb_already_alloc) = vol_list.name(fb_already_alloc)  || " " || rtrim(volume(i).name);
	          vol_list.cnt(fb_already_alloc) = vol_list.cnt(fb_already_alloc) + 1;
		goto END_CHECK;
		end;
                 else if (check & cant_delete) then do;
		volume(i).noaction = True;
	          substr(error_found, fb_cant_delete, 1) = True;
	          vol_list.name(fb_cant_delete) = vol_list.name(fb_cant_delete)  || " " || rtrim(volume(i).name);
	          vol_list.cnt(fb_cant_delete) = vol_list.cnt(fb_cant_delete) + 1;
		goto END_CHECK;
		end;

                 else if (check & cant_pvexp) then do;
		volume(i).noaction = True;
	          substr(error_found, fb_cant_pvexp, 1) = True;
	          vol_list.name(fb_cant_pvexp) = vol_list.name(fb_cant_pvexp)  || " " || rtrim(volume(i).name);
	          vol_list.cnt(fb_cant_pvexp) = vol_list.cnt(fb_cant_pvexp)+ 1;
		goto END_CHECK;
		end;

                 if (check & not_exp) then if vpe(volx).expire then do;
	          if vpe(volx).expire_date < clock() | fexp_sw then do;
		   call check_for_pvexp(volx, brief_sw, just_expired);
		   if just_expired then do;
		      volume(i).noaction = True;
		      goto END_CHECK;
		      end;
	             end; 
	          else do; /* allocated volume hasn't expired yet */
	             volume(i).noaction = True;
		   if brief_sw then do;
		      if active_fnc then  do;
    	                   substr(error_found, fb_not_exp, 1) = True;
		         vol_list.name(fb_not_exp) = vol_list.name(fb_not_exp)  || " " || rtrim(volume(i).name);
		         vol_list.cnt(fb_not_exp) = vol_list.cnt(fb_not_exp)+ 1;
		         goto END_CHECK;
		         end;
		      end;
		   else do;
    	                substr(error_found, fb_not_exp, 1) = True;
	                vol_list.name(fb_not_exp) = vol_list.name(fb_not_exp)  || " " || rtrim(volume(i).name);
	                vol_list.cnt(fb_not_exp) = vol_list.cnt(fb_not_exp)+ 1;
		      goto END_CHECK;
		      end;
                       end;
	          end;
                 end;

              if (check & vol_pvexp) then if vpe(volx).state = pvexp_state then do;
	       volume(i).noaction = True;
	       substr(error_found, fb_vol_pvexp, 1) = True;
	       vol_list.name(fb_vol_pvexp) = vol_list.name(fb_vol_pvexp)  || " " || rtrim(volume(i).name);
	       vol_list.cnt(fb_vol_pvexp) = vol_list.cnt(fb_vol_pvexp) + 1;
	       goto END_CHECK;
                 end;

	    if  (check & not_free) then if vpe(volx).state ^= free_state then do;
	       volume(i).noaction = True;
	       substr(error_found, fb_not_free, 1) = True;
	       vol_list.name(fb_not_free) = vol_list.name(fb_not_free)  || " " || rtrim(volume(i).name);
	       vol_list.cnt(fb_not_free) = vol_list.cnt(fb_not_free) + 1;
	       goto END_CHECK;
                 end;

	    if  (check & not_alloc) then if vpe(volx).state ^= allocated_state then do;
	       volume(i).noaction = True;
	       substr(error_found, fb_not_alloc, 1) = True;
	       vol_list.name(fb_not_alloc) = vol_list.name(fb_not_alloc)  || " " || rtrim(volume(i).name);
	       vol_list.cnt(fb_not_alloc) = vol_list.cnt(fb_not_alloc) + 1;
	       goto END_CHECK;
                 end;

	    if (check & already_free) then if vpe(volx).state = free_state then do;
	       volume(i).noaction = True;
	       substr(error_found, fb_already_free, 1) = True;
	       vol_list.name(fb_already_free) = vol_list.name(fb_already_free)  || " " || rtrim(volume(i).name);
	       vol_list.cnt(fb_already_free) = vol_list.cnt(fb_already_free) + 1;
	       goto END_CHECK;
                 end;

	    if (check & not_updated) then if (expire_sw & vpe(volx).state ^= allocated_state) then do;
	       volume(i).noaction = True;
	       substr(error_found, fb_not_updated, 1) = True;
	       vol_list.name(fb_not_updated) = vol_list.name(fb_not_updated)  || " " || rtrim(volume(i).name);
	       vol_list.cnt(fb_not_updated) = vol_list.cnt(fb_not_updated) + 1;
	       goto END_CHECK;
                 end;

	   if (check & check_pvexp) then do;
                call check_for_pvexp(volx, False, just_expired);
	      if just_expired then do;
	         volume(i).noaction = True;
	         substr(error_found, fb_check_pvexp, 1) = True;
	         end;
	      end;
             end;
END_CHECK:  
          end;   /* end of do loop */

     call construct_msg(error_found);

end check_for_errors;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

check_for_pvexp:  proc(vol_idx, no_print, just_expired);

/* checks to see if a volume is physically expired.
   vol_idx: index of volume to be checked. (input)
   no_print: designates whether to report the expiration or not. (input)
   just_expired: set to true if the volume
                 is physically expired, ie. the pv_expire date is less than the current date/time. (output)
*/

dcl vol_idx			fixed bin;
dcl (no_print, just_expired)		bit(1);

   just_expired = False;	/* assume not expired */

   if vpe(vol_idx).pv_expire then do;
      if vpe(vol_idx).pv_expire_date < clock() | pvexp_secondary_vol_check(vol_idx) then do;
         if active_fnc then do;  /* always want message flagged when AF whether no_print is specified or not */
	  vol_list.name(fb_check_pvexp) = vol_list.name(fb_check_pvexp)  || " " || rtrim(vpe(vol_idx).name);
	  vol_list.cnt(fb_check_pvexp) = vol_list.cnt(fb_check_pvexp) + 1;
	  end;
         else if ^no_print then do;
	  vol_list.name(fb_check_pvexp) = vol_list.name(fb_check_pvexp)  || " " || rtrim(vpe(vol_idx).name);
	  vol_list.cnt(fb_check_pvexp) = vol_list.cnt(fb_check_pvexp) + 1;
            end;
         call pvexp_volume(vol_idx);
         just_expired = True;
         end;
      end;

end check_for_pvexp;



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

comment:	proc;

/* obselete key that must still be supported. It prints the comment of a specified volume name.  */

	     if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg);
	     if active_fnc then ret = vpe (vlx).comment;
	     else call msg_proc (0, "Volume ^a", vpe (vlx).comment);
	end comment;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

construct_msg: proc(a_check);

/* called by check_for_errors. Constructs the actual error messages if errors were found.
   a_check: 16 bit code which maps to err_msg array and flags the errors found  */

dcl position			fixed bin;
dcl a_check			bit(16);
dcl check				bit(16);
dcl  output_msg			char(256) var;
dcl  output_len			fixed bin;

    check = a_check;
    position = index(check, "1"b);
    do while (position ^= 0);
       if position = fb_sec_not_found then
          call ioa_$rsnnl(err_msg(position), output_msg, output_len, (vol_list.cnt(position) > 1), 
               vol_list.name(position), vol_list.name(fb_prim_name));

       else if position = fb_already_sec_vol then
               call ioa_$rsnnl(err_msg(position), output_msg, output_len, (vol_list.cnt(position) > 1), 
               vol_list.name(position), vol_list.cnt(position) > 1, vol_list.cnt(position) > 1, 
	     vol_list.name(fb_prim_name));

       else if (position = fb_not_exp | position = fb_check_pvexp) & brief_sw then do;
               if active_fnc then   /* print msg when its an active function regardless brief_sw specified 	*/
	     call ioa_$rsnnl(err_msg(position), output_msg, output_len, vol_list.cnt(position) > 1, 
                               vol_list.name(position), vol_list.cnt(position) > 1);
            end;
       else call ioa_$rsnnl(err_msg(position), output_msg, output_len, vol_list.cnt(position) > 1, 
                 vol_list.name(position), vol_list.cnt(position) > 1);

       noaction_msg = noaction_msg || output_msg;
       substr(check, position, 1)  = False;
       position = index(check, "1"b);
       end;

end construct_msg;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

convert_volume_pool: proc;

/* This procedure converts a volume pool to the new format */

dcl 1 volume_pool_old		aligned based (vpp),
    2 lock			bit (36),
    2 pad (7)			bit (36),
    2 n_vol			fixed bin (17),
    2 vpe_old (1:1 refer (volume_pool_old.n_vol)) aligned,
      3 name			char (32),
      3 id			bit (36),
      3 state			fixed bin (8) unaligned,
      3 flags			bit (27) unaligned,
      3 time			char (16) unaligned,
      3 comment			char (64);

dcl 1 volume_pool_old_1		aligned based (vpp),
    2 version			fixed bin,
    2 lock			bit (36),
    2 n_vol			fixed bin (17),
    2 pad (5)			bit (36),
    2 vpe_old_1 (1:1 refer (volume_pool_old_1.n_vol)) aligned,
      3 name			char (32),
      3 id			bit (36),
      3 state			fixed bin,
      3 processid			bit (36),
      3 time			fixed bin (71),
      3 comment			char (64),
      3 pad1 (8)			bit (36);

dcl 1 volume_pool_header_2		aligned,
    2 version			fixed bin,	/* version 2 structure			*/
    2 lock			bit (36),
    2 n_vol			fixed bin (17),	/* number of volume slots in the pool, free and occupied */
    2 volume_count			fixed bin(17),	/* number of volumes in the pool		*/
    2 head			fixed bin (17),	/* index into first volume in pool		*/
    2 tail			fixed bin (17),     /* index to last volume in pool		*/
    2 free_head			fixed bin (17),     /* index to first empty slot in array		*/
    2 pad (2)			bit (36);

dcl 1 volume_pool_entry_2		aligned,	   /* volume pool entry. each volume has one assoc. with it */
      2 name			char (32),	/* name of volume set			*/
      2 id			bit (36),		/* used by volume dumper only			*/
      2 state			fixed bin,	/* state of the volume			*/
      2 processid			bit (36),		/* used when reserving volume			*/
      2 state_date			fixed bin (71),	/* date the volume was last acted upon		*/
      2 comment			char (64),
      2 switches			unaligned,
        3 secondary_vol		bit(1),	/* true if volume is a part of a multiple volume set */
        3 pv_expire			bit(1),	/* true if a physical volume expiration date is assoc. with the volume */
        3 expire			bit(1),   /* true if an expire date is associated with the volume	*/
        3 already_printed		bit(1),   /* used in listing purposes				*/
        3 pad1			bit(31),
      2 pv_expire_date		fixed bin(71),      /* physical volume expiration date		*/
      2 expire_date			fixed bin(71),      /* allocated volume expiration date		*/
      2 vs_count			fixed bin,	/* volume set count, includes primary and secondary volumes	*/
      2 next			fixed bin(17),      /* index to next node or volume in the pool	*/
      2 previous			fixed bin(17),      /* index to previous volume in pool		*/
      2 primary_idx			fixed bin(17),      /* index of primary volume in a set               */
      2 secondary_idx		fixed bin(17);      /* index to next secondary volume in a set	*/

dcl 1 volume_pool_2			aligned based(vpp),      /* This is the CURRENT volume pool structure */
    2 header			like volume_pool_header_2,
    2 vpe_2		(divide(sys_info$max_seg_size - size(volume_pool_header_2), size(volume_pool_entry_2), 17)
			refer (volume_pool_2.header.n_vol)) like volume_pool_entry_2;


     if volume_pool.version = volume_pool_version_2 then 
        /* convert version_2 to version_3 */
        call set_lock_$lock (volume_pool_2.lock, lock_interval, code);

     else if volume_pool.version = volume_pool_version_1 then 
        /* convert version_1 to version_3 */
        call set_lock_$lock (volume_pool_old_1.lock, lock_interval, code);

     else      /* convert old version to version 3 */
        call set_lock_$lock (volume_pool_old.lock, lock_interval, code);

     if code ^= 0 then do;
        if ^(code = error_table_$invalid_lock_reset | code = error_table_$locked_by_this_process) then
           call abort_proc (code, "Attempting to convert volume pool.^/Contact owner of pool ^a", path(vol_dir, vol_ename));
        end;

     if ^(subroutine | active_fnc) then call ioa_("Converting volume pool ^a from version ^d to version ^d.", vol_ename, volume_pool.version, volume_pool_version_3 );
     call get_temp_segment_ (myname, new_vpp, code);
     if code ^= 0 then call abort_proc (code, "Unable to get temp seg - volume pool conversion of ^a failed",
	       path (vol_dir, vol_ename));

     new_vpp -> volume_pool.version = volume_pool_version_3;
     new_vpp -> volume_pool.header.pad = "0"b;
 
     if volume_pool.version = volume_pool_version_2 then do;
        /* convert header stuff first */
        new_vpp -> volume_pool.head         = vpp -> volume_pool_2.head;
        new_vpp -> volume_pool.volume_count = vpp -> volume_pool_2.volume_count;
        new_vpp -> volume_pool.tail         = vpp -> volume_pool_2.tail;
        new_vpp -> volume_pool.free_head    = vpp -> volume_pool_2.free_head;
        new_vpp -> volume_pool.n_vol        = vpp -> volume_pool_2.n_vol;
        /* now copy each entry */
        do vlx = 1 to new_vpp -> volume_pool_2.n_vol;
           new_vpp -> vpe (vlx).name       = vpp -> vpe_2(vlx).name;
	 new_vpp -> vpe (vlx).id	   = vpp -> vpe_2(vlx).id;
	 new_vpp -> vpe (vlx).state	   = vpp -> vpe_2(vlx).state;
	 new_vpp -> vpe (vlx).state_date = vpp -> vpe_2(vlx).state_date;
	 new_vpp -> vpe (vlx).comment	   = vpp -> vpe_2(vlx).comment;
	 new_vpp -> vpe (vlx).vs_count   = vpp -> vpe_2(vlx).vs_count;
	 new_vpp -> vpe (vlx).pv_expire  = vpp -> vpe_2(vlx).pv_expire;
	 new_vpp -> vpe (vlx).expire     = vpp -> vpe_2(vlx).expire;
	 new_vpp -> vpe (vlx).pv_expire_date = vpp -> vpe_2(vlx).pv_expire_date;
	 new_vpp -> vpe (vlx).expire_date    = vpp -> vpe_2(vlx).expire_date;
	 new_vpp -> vpe (vlx).secondary_idx  = vpp -> vpe_2(vlx).secondary_idx;
	 new_vpp -> vpe (vlx).primary_idx    = vpp -> vpe_2(vlx).primary_idx;
	 new_vpp -> vpe (vlx).next           = vpp -> vpe_2(vlx).next;
	 new_vpp -> vpe (vlx).previous       = vpp -> vpe_2(vlx).previous;

	 new_vpp -> vpe (vlx).secondary_vol   = vpp -> vpe_2(vlx).secondary_vol;
	 new_vpp -> vpe (vlx).pv_expire       = vpp -> vpe_2(vlx).pv_expire;
	 new_vpp -> vpe (vlx).expire	        = vpp -> vpe_2(vlx).expire;
	 new_vpp -> vpe (vlx).already_printed = vpp -> vpe_2(vlx).already_printed;
	 new_vpp -> vpe (vlx).pad2 = "0"b;
	 end;
        goto CONVERT_FINISH;
        end;

     if volume_pool.version = volume_pool_version_1 then do;
        /* convert version_1 to version_3 */

        new_vpp -> volume_pool.head = 1;
        new_vpp -> volume_pool.volume_count = volume_pool_old_1.n_vol;
        new_vpp -> volume_pool.tail = volume_pool_old_1.n_vol;
        new_vpp -> volume_pool.free_head,
        new_vpp -> volume_pool.n_vol = volume_pool_old_1.n_vol + 1;
        do vlx = 1 to new_vpp -> volume_pool.volume_count;
           new_vpp -> vpe (vlx).name = vpe_old_1 (vlx).name;
	 new_vpp -> vpe (vlx).id = vpe_old_1 (vlx).id;
	 new_vpp -> vpe (vlx).state = vpe_old_1 (vlx).state;
	 new_vpp -> vpe (vlx).state_date = vpe_old_1 (vlx).time;
	 new_vpp -> vpe (vlx).comment = vpe_old_1 (vlx).comment;
	 new_vpp -> vpe (vlx).switches =  False;
	 new_vpp -> vpe (vlx).vs_count =  1;
	 new_vpp -> vpe (vlx).pv_expire, new_vpp -> vpe (vlx).expire =  False;
	 new_vpp -> vpe (vlx).pv_expire_date, new_vpp -> vpe (vlx).expire_date =  0;
	 new_vpp -> vpe (vlx).secondary_idx = no_link;
	 new_vpp -> vpe (vlx).primary_idx = no_link;
	 new_vpp -> vpe (vlx).next = vlx + 1;
	 new_vpp -> vpe (vlx).previous = vlx - 1;
	 new_vpp -> vpe (vlx).pad2 = "0"b;
	 end;
        end;

     else do;  /* converting from old version to version 3 */
        new_vpp -> volume_pool.head = 1;
        new_vpp -> volume_pool.volume_count = volume_pool_old.n_vol;
        new_vpp -> volume_pool.tail = volume_pool_old.n_vol;
        new_vpp -> volume_pool.free_head,
        new_vpp -> volume_pool.n_vol = volume_pool_old.n_vol + 1;
        if volume_pool_old.n_vol = 0 then do;
	 /* the volume pool is either empty or initially created via the create command, not by mvp use     */
	 new_vpp -> volume_pool.n_vol = 1;
	 new_vpp -> volume_pool.volume_count = 0;
	 new_vpp -> volume_pool.tail = 1;
	 new_vpp -> volume_pool.free_head = 1;
	 new_vpp -> volume_pool.head = no_link;
	 new_vpp -> vpe(new_vpp ->volume_pool.n_vol).next = no_link;
	 new_vpp -> vpe(new_vpp ->volume_pool.n_vol).previous = no_link;
	 goto CONVERT_FINISH;
	 end;
        do vlx = 1 to new_vpp -> volume_pool.volume_count;
           new_vpp -> vpe (vlx).name = vpe_old (vlx).name;
	 new_vpp -> vpe (vlx).id = vpe_old (vlx).id;
	 new_vpp -> vpe (vlx).state = vpe_old (vlx).state;
	 call convert_date_to_binary_ (vpe_old (vlx).time, new_vpp -> vpe (vlx).state_date, code);
	 if code ^= 0 then do;
	    new_vpp -> vpe (vlx).state_date = clock_();
	    if ^(subroutine | active_fnc) then 
	       call msg_proc (code, "Unable to convert state date of volume ^a. It will be set to the current date.", 
	            new_vpp -> vpe(vlx).name);
	    end;
	 new_vpp -> vpe (vlx).comment = vpe_old (vlx).comment;
	 new_vpp -> vpe (vlx).switches =  False;
	 new_vpp -> vpe (vlx).vs_count =  1;
	 new_vpp -> vpe (vlx).pv_expire, new_vpp -> vpe (vlx).expire =  False;
	 new_vpp -> vpe (vlx).pv_expire_date, new_vpp -> vpe (vlx).expire_date =  0;
	 new_vpp -> vpe (vlx).secondary_idx = no_link;
	 new_vpp -> vpe (vlx).primary_idx = no_link;
	 new_vpp -> vpe (vlx).next = vlx + 1;		/* need to link all the volumes together	*/
	 new_vpp -> vpe (vlx).previous = vlx - 1;
	 new_vpp -> vpe (vlx).pad2 = "0"b;
	 end;
        end;
   
     /* initialize the free (ie. next available) node in the volume_pool */
     new_vpp -> vpe(new_vpp->volume_pool.n_vol).next = no_link; /* designates end of volume list 		*/
     new_vpp -> vpe(new_vpp->volume_pool.n_vol).previous = no_link; 
     new_vpp -> vpe(new_vpp->volume_pool.n_vol).secondary_idx = no_link;
     new_vpp -> vpe(1).previous = no_link;	          /* start of volume list, no previous volume       */
						/* end of volume list, no next volume  		*/
     new_vpp -> vpe(new_vpp->volume_pool.volume_count).next = no_link;

CONVERT_FINISH:
     call hcs_$fs_move_seg (new_vpp, vpp, 1, code);
     if code ^= 0 then call abort_proc (code, "Unable to move temp file.- volume pool conversion of ^a failed",
	path (vol_dir, vol_ename));
     call release_temp_segment_ (myname, new_vpp, (0));
     return;

end convert_volume_pool;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


create_pool:  proc();

       call hcs_$make_seg (vol_dir, vol_ename, "", RW_ACCESS_BIN, vpp, code);
       if code = 0 then do;
          if subroutine then call ioa_ ("^a: Volume pool ^a created.", myname, path (vol_dir, vol_ename));  
	else call msg_proc (0, "Volume pool ^a created", path (vol_dir, vol_ename));
	vpp -> volume_pool.version = volume_pool_version_3;
	vpp -> volume_pool.n_vol, vpp -> volume_pool.free_head = 1;
	vpp -> vpe(vpp ->volume_pool.n_vol).next = no_link;
	vpp -> vpe(vpp ->volume_pool.n_vol).previous = no_link;
	vpp -> volume_pool.head = no_link;
	vpp -> volume_pool.tail = 1;
	vpp -> volume_pool.volume_count = 0;
	end; 
       else do;
	  if vpp = null then call abort_proc (code, "Unable to create ^a", path (vol_dir, vol_ename));
	  end;

end create_pool;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

delete:	proc;

/* used only for subroutine delete only */

	     if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg);
	     if vpe (vlx).state = allocated_state then 
                    call abort_proc (0, "Volume ^a is in use and can not be deleted.", arg);
               call free_node(vlx);
	     return;
	end delete;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

delete_key:	proc();

/* Used by mvp command, it deletes the designated volumes from the pool. */

dcl (volx, i, vol_cnt)		fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("0"b),
      2  last			init ("0"b),
      2  force			init ("1"b),
      2  vs			init ("0"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1); 

    if narg < 2 then call abort_proc (error_table_$noarg, "^/Usage: delete volume_names {-control_arg}");

    call process_ctl_args(addr(args_allowed), 2, vol_cnt);
    if vol_cnt = 0 & ^asterisk_sw then call abort_proc (0, "No volumes specified.");

    if asterisk_sw then do;
       call msg_proc(-1, "The asterisk '*' is obsolete.");
       specified_states(free_state) = True;
       specified_states(pvexp_state) = True;
       specified_states(reserved_state) = True;
       tcnt = asterisk_cnt;
       allocate tvol in (based_area) set (Ptvol);
       tvol.want_it = False;
       call get_volumes_specified ("deleted", specified_states, Ptvol, tcnt, vs_size, most_recent);
       end;

   if volume_sw then 
      call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | cant_delete | sec_vol | check_pvexp);

    if asterisk_sw then do;
       if ^(volume_sw) then do;
          vol_cnt = 0;
          volume_cnt = tcnt;
	allocate volume in (based_area) set (Pvolume);
	end;
       do i = 1 to tcnt;
          volume(vol_cnt + 1).name = tvol(i).name;
	volume(vol_cnt + 1).indx = tvol(i).indx;
	volume(vol_cnt + 1).want_it = tvol(i).want_it;
	vol_cnt = vol_cnt + 1;
          end;
       end;

    call evaluate_volumes_wanted("deleted", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
    if none_sw | abort_sw then do;
       if active_fnc then do;
	ret = "false";
	return;
	end;
       if none_sw then  call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
       else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);
      end;


   /* delete volumes specified */

    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
	   volx = volume(i).indx;
             if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx;
	   call free_node(volx);
	   end;
          end;
       end;

   if active_fnc then ret = "true";
   else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg);

end delete_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

determine_alloc_version:	proc();

/* as the old allocate format is supported but undocumented, this procedure determines whether we are dealing with 
   the new or old format.  This is determined by the following guidelines:

  (a) If first argument is an asterisk "*", assume old version.
  (b) Check for an odd or even number of arguments.  If an odd
      number, then assume new version.
  (c) If control arguments -comment, -com, -volume_set, -vs, -first,
      -ft, -last, -lt are specified, assume new version.
  (d) If any even argument (the key "alloc" is not considered an arg)
      is a volume existing in the pool, assume new version.
  (e) If any argument is an asterisk (*), assume old version.
*/

dcl even_arg			bit(1);

    if narg < 2 then call abort_proc (error_table_$noarg, "Usage: mvp alloc {volume_names} {-control_args}");

    /* first check for an asterisk '*' arg. If found then assume old version. 			    */

    call get_arg (2, ap, al, (0), alp);
    if arg = "*" then goto old_version;

    /* Do we have an odd number of args?  Use narg - 1 as the key "alloc" isn't included as an argument */

    if mod(narg-1, 2) = 1 then goto new_version;

    /* check further for which version */
    even_arg = False;
    do ac=2 to narg;
       call get_arg (ac, ap, al, (0), alp);
       if arg = "-com" | arg = "-comment" 
          | arg = "-vs" | arg = "-volume_size" 
          | arg = "-ft" | arg = "-first" 
	| arg = "-lt" | arg = "-last" then goto new_version;
       else if even_arg then do;
	     if volume_in_pool(arg, 0) then goto new_version;
	     end;
       else if arg = "*" then goto old_version;
       even_arg = ^(even_arg);
       end;


/* if we get here it means we fell out of loop by default and it's most likely the old version */
/* ie. essentially the even args specified were not volumes known to the pool so we  assume it's a comment */

old_version:
    call process (paired_args, allocate);  
    return;

new_version:
    call allocate_key(); 
    return;

end determine_alloc_version;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

evaluate_volumes_wanted:    proc(action, aptr, asize, vol_cnt, none_sw, abort_sw);
		        
/* called by various keys to determine, out of the volumes specified, which ones are to be acted upon and whether 
   to query the user or not .
   action: action requested in query message. (input)
   aptr:  pointer to volume structure (input)
   asize: size of the volume array (input)
   vol_cnt: number of volumes to be considered. (input)
   none_sw: true when no volumes are found. (output)
   abort_sw: true when all volumes specified cannot be acted upon or when the response to the query is no . (output)
*/

dcl action			char(*);
dcl (abort_sw, none_sw)		bit(1);
dcl aptr				ptr,
    (asize,		
    i,
    vol_cnt,
    want_cnt,
    noaction_cnt)			fixed bin;
		        
dcl  1 volume			aligned based (aptr),
       2 name(asize)		char(32),
       2 indx(asize)		fixed bin,
       2 switches,
         3 noaction(asize)		bit(1) unal,
         3 want_it(asize)		bit(1)unal;
dcl continue			bit(1);

    none_sw, abort_sw = False;
    if index(want_str, "1"b) = 0 then do;
       none_sw = True;
       return;
       end;

    if (index (want_str & noaction_str, "1"b) > 0) then do;

       /* only query when some of the volumes wanted, some have noaction bit True, and others have noaction bit false */

       continue = False;
       if asize > 1 then do;
	want_cnt = 0;
	noaction_cnt = 0;
	do i = 1 to vol_cnt;
	   if volume(i).want_it then do;
	      want_cnt = want_cnt + 1;
	      if volume(i).noaction then noaction_cnt = noaction_cnt + 1;
	      end;
	   end;
       
           if (want_cnt = noaction_cnt) then do;
	    abort_sw = True;
	    return;
	    end;
	 else  call query_to_continue(action, "", force_sw, continue);
	 end;

       if ^(continue) then abort_sw = True;
       end;

end evaluate_volumes_wanted;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

finish:	proc();

     if lock then do;
        if vpp ^= null() then do;
           word_count = currentsize(volume_pool);
           bit_count = word_count*36;
           call hcs_$set_bc(vol_dir, vol_ename, bit_count, code);
           if code ^= 0 then call abort_proc (code, "Unable to set bit count of volume pool ^a", path (vol_dir, vol_ename));
	 call hcs_$truncate_file (vol_dir, vol_ename, word_count, code);
           if code ^= 0 then call abort_proc (code, "Unable to trucncate volume pool ^a", path (vol_dir, vol_ename));
           end;

        call set_lock_$unlock (volume_pool.lock, ignore);
        end;

     if vpp ^= null & ^subroutine then call hcs_$terminate_noname (vpp, ignore);
     if Pvolume ^= null() then free volume in (based_area);
     if Ptvol ^= null() then free tvol in (based_area);

end finish;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

format_print_output:	proc(vol_idx, secondary_volume);

/* formats all the many flavors of outputing the volume pool info via the list key.
   vol_idx: index to the volume to be listed. (input)
   secondary_volume: true when the volume is a secondary volume of a set. (input)
*/ 

dcl vol_idx			fixed bin parameter;
dcl (go_ahead, secondary_volume)	bit(1);

    go_ahead = True;
    if secondary_volume then do;
       if pvedt_sw & vpe(vol_idx).pv_expire then;
       else do;				/* secondary volumes are listed only when -dfmt, -nm are    */
          output = "";			/* specified, and when the volume has a pvexp date associated */
	go_ahead = False;                       /* with it and -pvedt was specified.                        */
	end;
       end;

    if dfmt_sw & ^(pvedt_sw | edt_sw) then do;
       if header_to_be_printed & ^active_fnc then do;
          call ioa_$rsnnl("^/Volume^1-^5xState Date^1-^5xState^3xComment", header_output, header_len);
	header_to_be_printed = False;
	end;
       if secondary_volume then call ioa_$rsnnl ("^1x^a", output, output_len, vpe(vol_idx).name); 
       else call ioa_$rsnnl ("^a^[^/^]^[^1x^;^13t^]^20a^[^1x^;^36t^]^a^[^1x^;^44t^]^a", output, output_len,
	              vpe (vol_idx).name,
                        (index(vpe(vol_idx).name, "  ") > 12) & ^active_fnc,
		    active_fnc, time_string_ (vpe (vol_idx).state_date),
		    active_fnc, ascii_state (vpe (vol_idx).state),
		    active_fnc, vpe (vol_idx).comment);
       end;

    else if dfmt_sw & ((pvedt_sw | edt_sw ) & ^(pvedt_sw & edt_sw )) then do;
	            /*  one or the other.....but not both       */
            if header_to_be_printed & ^active_fnc then do;
               call ioa_$rsnnl ("^/Volume^1-^5xState Date^1-^5xState^7x^[Expires Date^;PV Expires  ^]^6xComment",
	                   header_output, header_len, edt_sw);
	     header_to_be_printed = False;
	     end;
	  if secondary_volume then 
                  call ioa_$rsnnl ("^1x^a^[^[^1x^;^13t^31x^]^a^;^2s^]", output, output_len, vpe(vol_idx).name, go_ahead, 
                                  active_fnc, time_string_(vpe(vol_idx).pv_expire_date));
            else call ioa_$rsnnl 
                ("^a^[^/^]^[^1x^;^13t^]^20a^[^1x^;^36t^]^a^[^1x^;^44t^]^[^20a^;^s^]^[^1x^s^;^[^20x^]^]^[^20a^;^s^]^[^1x^s^;^[^20x^]^]^[^1x^;^2x^]^a", 
	              output, output_len,
	              vpe (vol_idx).name,
                        (index(vpe(vol_idx).name, "  ") > 12) & ^active_fnc,
		    active_fnc, time_string_ (vpe (vol_idx).state_date),
		    active_fnc, ascii_state (vpe (vol_idx).state),
		    active_fnc, ^(pvedt_sw) & (edt_sw & vpe (vol_idx).expire),
		    (time_string_ (vpe (vol_idx).expire_date)),	
		    active_fnc, ^(pvedt_sw) & (edt_sw & ^(vpe (vol_idx).expire)),
		    ^(edt_sw) & (pvedt_sw & vpe (vol_idx).pv_expire),
		    (time_string_ (vpe (vol_idx).pv_expire_date)),
		    active_fnc, ^(edt_sw) & (pvedt_sw & ^(vpe (vol_idx).pv_expire)),
		    active_fnc, vpe (vol_idx).comment);
            end;

    else if dfmt_sw & pvedt_sw & edt_sw then do;
            if header_to_be_printed & ^active_fnc then do;
	      call ioa_$rsnnl ("^/Volume^1-^5xState Date^1-^9xExpires Date^1-^1xPV Expires^/^13tState^34tComment", header_output, header_len);
	      header_to_be_printed = False;
	      end;
	  if secondary_volume then 
                  call ioa_$rsnnl ("^1x^a^[^[^1x^;^59t^]^a^;^2s^]", output, output_len, vpe(vol_idx).name, go_ahead, 
                                  active_fnc, time_string_(vpe(vol_idx).pv_expire_date));
             else call ioa_$rsnnl 
                  ("^a^[^/^]^[^1x^;^13t^]^20a^[^1x^s^;^[^3x^]^]^[^20a^s^;^s^[^23x^]^]^[^1x^s^;^[^3x^]^]^[^20a^s^;^s^[^23x^]^]^[^1x^;^/^13t^]^a^[^1x^;^34t^]^a",  
	              output, output_len,
	              vpe (vol_idx).name,
                        (index(vpe(vol_idx).name, "  ") > 12) & ^active_fnc,
		    active_fnc, time_string_ (vpe (vol_idx).state_date),
		    active_fnc, (vpe (vol_idx).expire), (vpe (vol_idx).expire),
		    (time_string_ (vpe (vol_idx).expire_date)),	
		    ^active_fnc, active_fnc,
		    (vpe (vol_idx).pv_expire), (vpe (vol_idx).pv_expire),
		    (time_string_ (vpe (vol_idx).pv_expire_date)),
		    ^active_fnc, active_fnc,
		    ascii_state (vpe (vol_idx).state),
		    active_fnc, vpe (vol_idx).comment);
         end;

    else if ^(dfmt_sw) then do;   /* only individual output fields specified */
            if header_to_be_printed & ^active_fnc then do;
	     call ioa_$rsnnl
               ("^/^[Volume^1-^5x^]^[State Date^1-^5x^]^[State^3x^]^[Expires Date^1-^6x^]^[PV Expires  ^9x^]^[Comment^]",
	      header_output, header_len, name_sw,  sdt_sw, state_sw, edt_sw, pvedt_sw, comment_sw);
	     header_to_be_printed = False;
	     end;

            if name_sw then do;
               call ioa_$rsnnl("^[^1x^]^a^[^/^]", output, output_len, secondary_volume, vpe(vol_idx).name, 
              (index(vpe(vol_idx).name, "  ") > 12) & (sdt_sw | comment_sw | pvedt_sw | edt_sw | state_sw) & (^active_fnc));
               if sdt_sw & go_ahead then 
                  call ioa_$rsnnl("^a^[^1x^;^13t^]^20a^[^1x^;^3x^]", output, output_len, (output), active_fnc, 
                                  time_string_ (vpe (vol_idx).state_date), active_fnc);
               if state_sw & go_ahead then 
                  call ioa_$rsnnl("^a^[^1x^s^;^[^36t^;^16t^]^]^a", output, output_len, (output), active_fnc, sdt_sw,
                        ascii_state (vpe (vol_idx).state));
               if edt_sw & go_ahead then call ioa_$rsnnl
                 ("^a^[^1x^s^;^[^43t^]^]^[^1x^s^;^[^35t^]^]^[^1x^s^;^[^22t^;^13t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]",
	              output, output_len, (output),
	              active_fnc, sdt_sw & state_sw,
	              active_fnc, sdt_sw & ^state_sw,
		    active_fnc, state_sw & ^sdt_sw,
		    vpe (vol_idx).expire, 
		    time_string_ (vpe (vol_idx).expire_date),
		    active_fnc);
               if pvedt_sw & go_ahead then call ioa_$rsnnl
                 ("^a^[^1x^s^;^[^22t^]^]^[^1x^s^;^[^43t^]^]^[^1x^s^;^[^58t^]^]^[^1x^s^;^[^36t^;^13t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]", 
	              output, output_len, (output),
	              active_fnc, state_sw & ^(sdt_sw & edt_sw),
		    active_fnc, state_sw & sdt_sw & ^edt_sw,
	              active_fnc, sdt_sw & edt_sw & ^state_sw,
		    active_fnc, (sdt_sw | edt_sw) & ^state_sw,
		    vpe (vol_idx).pv_expire, 
		    time_string_ (vpe (vol_idx).pv_expire_date),
		    active_fnc);

               if comment_sw & go_ahead  then
                  call ioa_$rsnnl
	        ("^a^[^1x^3s^;^[^66t^2s^;^[^58t^1s^;^[^37t^]^]^]^]^[^1x^2s^;^[^43t^1s^;^[^67t^]^]^]^[^1x^3s^;^[^24t^2s^;^[^45t^s^;^[^67t^;^16t^]^]^]^]^a",
                        output, output_len, (output),
	              active_fnc, ^state_sw & (sdt_sw & pvedt_sw & edt_sw),
	              ^state_sw & ((sdt_sw & edt_sw) | (sdt_sw & pvedt_sw) | (pvedt_sw & edt_sw)),
		    ^state_sw & (sdt_sw | pvedt_sw | edt_sw),
                        active_fnc, 
		    sdt_sw & state_sw & ^(pvedt_sw | edt_sw),
		    sdt_sw & state_sw & (pvedt_sw | edt_sw),
		    active_fnc, state_sw & ^(sdt_sw | pvedt_sw | edt_sw),
		    ^sdt_sw & state_sw & (pvedt_sw | edt_sw),
		    ^sdt_sw & state_sw & (pvedt_sw & edt_sw),
                        vpe(vol_idx).comment); 
               end; /* end if name_sw */
    
            else if sdt_sw  then do;
                    if go_ahead then call ioa_$rsnnl("^20a", output, output_len, time_string_ (vpe (vol_idx).state_date));
                    if state_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^26t^]^a", output, output_len, (output), 
                              active_fnc, ascii_state (vpe (vol_idx).state));
                    if edt_sw & go_ahead then call ioa_$rsnnl
                       ("^a^[^1x^s^;^[^32t^;^24t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]", output, output_len, (output),
	              active_fnc, state_sw,
		    vpe (vol_idx).expire, 
		    time_string_ (vpe (vol_idx).expire_date),
		    active_fnc);
                    if pvedt_sw & go_ahead then call ioa_$rsnnl
                      ("^a^[^1x^s^;^[^32t^]^]^[^1x^s^;^[^55t^]^]^[^1x^s^;^[^46t^]^]^[^1x^s^;^[^24t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]",
	              output, output_len, (output),
	              active_fnc, state_sw & ^edt_sw,
	              active_fnc, state_sw & edt_sw,
	              active_fnc, ^state_sw & edt_sw,
	              active_fnc, ^state_sw & ^edt_sw,
		    vpe (vol_idx).pv_expire, 
		    time_string_ (vpe (vol_idx).pv_expire_date), active_fnc);
                    if comment_sw & go_ahead then do;
                       if active_fnc then call ioa_$rsnnl("^a^1x^a", output, output_len, (output), vpe(vol_idx).comment);
		   else call ioa_$rsnnl("^a^[^34t^]^[^70t^]^[^70t^]^[^59t^]^[^57t^]^[^47t^]^[^26t^]^a",
                        output, output_len, (output), 
	              state_sw & ^(pvedt_sw | edt_sw),
	              state_sw & pvedt_sw & edt_sw,
	              ^state_sw & (pvedt_sw & edt_sw),
	              state_sw &  edt_sw,
	              state_sw & pvedt_sw,
	              ^state_sw & (pvedt_sw | edt_sw),
		    ^state_sw & ^pvedt_sw & ^edt_sw,
                        vpe(vol_idx).comment); 
		   end;

              end; /* end if sdt_sw */

            else if state_sw  then do;
                    if go_ahead then call ioa_$rsnnl("^[^1x^]^5a^[^1x^;^3x^]", output, output_len, active_fnc, 
                                                     ascii_state (vpe (vol_idx).state), active_fnc);
                    if edt_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^9t^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", 
                        output, output_len, (output), 
                        active_fnc, vpe (vol_idx).expire, 
		    time_string_ (vpe (vol_idx).expire_date), active_fnc);
                    if pvedt_sw & go_ahead then 
		   call ioa_$rsnnl("^a^[^1x^s^;^[^36t^;^9t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", 
                        output, output_len, (output),
	              active_fnc, edt_sw,
		    vpe (vol_idx).pv_expire, 
		    time_string_ (vpe (vol_idx).pv_expire_date),
		    active_fnc);
                    if comment_sw & go_ahead then
		   call ioa_$rsnnl("^a^[^1x^s^;^[^57t^]^]^[^1x^2s^;^[^37t^s^;^[^31t^;^9t^]^]^]^a",
	              output, output_len, (output),
	              active_fnc, edt_sw & pvedt_sw,
	              active_fnc, edt_sw, pvedt_sw,
                        vpe(vol_idx).comment); 
              end; /* end if state_sw  */

            else if edt_sw then do;
                    if go_ahead then call ioa_$rsnnl("^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len,
		    vpe (vol_idx).expire, 
		    time_string_ (vpe (vol_idx).expire_date), active_fnc);

                    if pvedt_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^24t^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]",
		    output, output_len, (output),
		    active_fnc, vpe (vol_idx).pv_expire, 
		    time_string_ (vpe (vol_idx).pv_expire_date), active_fnc);
                    if comment_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^s^;^[^48t^;^27t^]^]^a",
		    output, output_len, (output),
	              active_fnc, pvedt_sw,
		    vpe(vol_idx).comment);

	          end; /* of edt_sw  */

            else if pvedt_sw & go_ahead then do;
                    call ioa_$rsnnl("^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len,
		    vpe (vol_idx).pv_expire, 
		    time_string_ (vpe (vol_idx).pv_expire_date), active_fnc);

                    if comment_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^22t^]^a", output, output_len, (output),
		    active_fnc, vpe(vol_idx).comment);

	          end; /* of if pvedt_sw  */

            else if comment_sw & go_ahead then do;
                    call ioa_$rsnnl("^a^[^1x^]", output, output_len, vpe (vol_idx).comment, active_fnc);
	          end; 
         end;

end format_print_output;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

free:	proc();

/*  called by free subroutine only */

	     if vlx = 0 then call abort_proc (0, "Volume ^a is not registered", arg);
	     if vpe (vlx).state = free_state then call abort_proc (0, "Volume ^a is already free.", arg);
	     vpe (vlx).state = free_state;
	     vpe (vlx).expire = False;
	     call move_to_head(vlx); 
	     return;
	     end free;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

free_key:  	proc();

/* Used by the mvp command, it frees volumes by changing the state to free */

dcl (found, just_expired)		bit(1);
dcl (i, volx, vol_idx, vol_cnt)	fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("0"b),
      2  last			init ("0"b),
      2  force			init ("1"b),
      2  vs			init ("0"b),
      2  com			init ("0"b),
      2  expire			init ("1"b),
      2  brief			init ("1"b),
      2  fexp			init ("1"b),
      2  match			init ("1"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

    if narg < 2 then call abort_proc (error_table_$noarg, "Usage: mvp free {volume_names} {-control_args}");

    /* process control arguments */

    call process_ctl_args(addr(args_allowed), 2, vol_cnt);

    if volume_sw & (expire_sw | match_sw) then call abort_proc(error_table_$inconsistent, 
                                     "volume names and ^[-expire^;^] ^[-match^;^]", expire_sw, match_sw);

    /* -expire control arg case */

    if expire_sw then do;

       volume_cnt = volume_pool.n_vol;
       allocate volume in (based_area) set (Pvolume);
       volume.want_it, volume.noaction = False;

       do vol_idx = 1 to volume_pool.n_vol by 1;
          if vpe(vol_idx).state = allocated_state then do;  /* check expires date */
               if vpe(vol_idx).expire then do;
	        if vpe(vol_idx).expire_date < clock() | fexp_sw then do;
		 call check_for_pvexp(vol_idx, brief_sw, just_expired);
		 if ^(just_expired) then do;
                        vol_cnt = vol_cnt +1;
	              volume(vol_cnt).name = vpe(vol_idx).name;
	              volume(vol_cnt).indx = vol_idx;
		    volume(vol_cnt).want_it =True;
		    end;
                     end;
	        end;
	     end;   /* end if allocate state */
	end;  /* loop */
       if vol_cnt = 0 then call abort_proc(error_table_$action_not_performed,
                                            "No allocated volume sets found with overdue expiration dates.");
       if just_expired then call construct_msg(check_pvexp);
       end;

    if match_sw then do;
       if vol_cnt = 0 then do;			/* -expire wasn't specified			*/
          volume_cnt = volume_pool.n_vol;
          allocate volume in (based_area) set (Pvolume);
          volume(*).want_it = False;

	do i = 1 to volume_pool.n_vol;
             if index (vpe(i).comment, match_string) > 0  then do; /* found a match			*/
	      call check_for_pvexp(i, brief_sw, just_expired); 
	      if ^(just_expired) then do;		/* not expired? we want it			*/
	         vol_cnt = vol_cnt + 1;
	         volume(vol_cnt).name = vpe(i).name;
	         volume(vol_cnt).indx = i;
	         volume(vol_cnt).want_it = True;
	         end;
	      end; 
             end;  /* do loop */
          if vol_cnt = 0 then call abort_proc(error_table_$action_not_performed,
                                        "^/No volume sets found with comment string matching ^a.", match_string);
          if just_expired then call construct_msg(check_pvexp);
          end;
       else do;  /* -expire was specified and -expire criteria has already been met successfully		*/
          volume(*).want_it, found = False;
          do i = 1 to vol_cnt;
	   if index (vpe(i).comment, match_string) > 0  then volume(i).want_it, found = True;
	   end;
          if ^(found) then call abort_proc(error_table_$action_not_performed,
                     "^/No expired volume sets found with comment string matching ^a.", match_string);
          end;
       end; /* if match_sw */

    /* here's the case where volume names were specified */

    else if volume_sw then call check_for_errors
            (Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | rsv_by_another | already_free | not_exp | check_pvexp);

    call evaluate_volumes_wanted("freed", Pvolume, narg, vol_cnt, none_sw, abort_sw);
    if none_sw then call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
    else if abort_sw then if noaction_msg ^= "" then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);


    /* now free the volumes */

    vol_msg_list = "";
    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
             volx = volume(i).indx;
             if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx;
	   if active_fnc then ret = ret || " " || rtrim(vpe(volx).name);
	   vpe(volx).state = free_state;
	   vpe(volx).expire = False;
	   if vpe(volx).state = pvexp_state then  vpe(volx).pv_expire = False;
	   if ((expire_sw | match_sw | first_last_sw) & ^brief_sw) then 
	      vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name);
             call move_to_head(volx);
	   end;
          end;
       end;

    if ^active_fnc then do;
       if vol_msg_list ^= "" then 
          call msg_proc(0, "Volume set^[s^] ^a ^[has^;have^] been freed. ^[^a^;^s^]",
               (vol_cnt > 1), vol_msg_list, (vol_cnt = 1), (noaction_msg ^= ""), noaction_msg ); 
       else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg ); 
       end;
  
end free_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

free_node:  proc(volx);

/* free_node unlinks the volume_pool array entry specified by volx from the volume list 
   and relinks it into the free list of array nodes available for reuse.  This effectively
   deletes a volume from the pool.
*/

dcl volx				fixed bin;

     if volume_pool.head = volume_pool.tail then do;
        /* freeing the last volume set in the pool, so set conditions as for an empty pool */
        volume_pool.n_vol = 1;
        volume_pool.volume_count = 0;
        volume_pool.tail = 1;
        volume_pool.free_head = 1;
        volume_pool.head = no_link;
        vpe(volume_pool.n_vol).next = no_link;
        vpe(volume_pool.n_vol).previous = no_link;
        goto END_FREE_NODE;
        end;

     if volx = volume_pool.tail then do;
        volume_pool.tail = vpe(volx).previous;
        vpe(volume_pool.tail).next = vpe(volx).next;
        end;
     else if volx = volume_pool.head then do;
        volume_pool.head = vpe(volx).next;
        vpe(volume_pool.head).previous = vpe(volx).previous;
        end;
     else do;  /* in middle of volume list chain, relink it to exclude volume specified by volx 		*/
        vpe(vpe(volx).previous).next = vpe(volx).next;
        vpe(vpe(volx).next).previous = vpe(volx).previous;
        end;

     /* now chain the just freed node into the free node list */

     vpe(volx).next = volume_pool.free_head;
     vpe(volx).previous = no_link;		/* backwards index references are not used in the free node linked list */
     volume_pool.free_head = volx;
     volume_pool.volume_count = volume_pool.volume_count - 1;

END_FREE_NODE:
     return;
end free_node;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_list_names:     proc(aptr, asize, vs_size, most_recent);
		  
/* Called by list_key procedure, get_list_names fills in the volume
   structure with the name and index 
   of the desired volumes.
   aptr: Pointer to volume structure (input).
   asize: Size of structure (input).
   vs_size: Specifies what size of volume sets to look for (input).
   most_recent: true when the most recently updated volumes are wanted.
*/

dcl  1 volume			aligned based (aptr),
       2 name(asize)		char(32),
       2 indx(asize)		fixed bin,
       2 switches,
         3 noaction(asize)		bit(1) unal,
         3 want_it(asize)		bit(1)unal;

dcl (asize, vs_size, volx, vol_idx)		fixed bin;
dcl aptr				ptr;
dcl most_recent			bit(1);

    if most_recent then do;  /* -first */
       vol_idx = 0;
       volx = volume_pool.head;
       do while ((volx ^= no_link) & (vol_idx < asize));
	if get_names_check_switches(volx, vs_size) then do;
	   vol_idx = vol_idx + 1;
	   volume(vol_idx).name = vpe(volx).name;
	   volume(vol_idx).indx = volx;
	   volume(vol_idx).want_it = True;
	   end;
	volx = vpe(volx).next;
          end;
       end;
    else do;  /* -last specified */
       vol_idx = asize;
       volx = volume_pool.tail;
       do while ((volx ^= no_link) & (vol_idx > 0));
	if get_names_check_switches(volx, vs_size) then do;
	   volume(vol_idx).name = vpe(volx).name;
	   volume(vol_idx).indx = volx;
	   volume(vol_idx).want_it = True;
	   vol_idx = vol_idx - 1;
	   end;
	volx = vpe(volx).previous;
          end;
       end;

end get_list_names;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_names_check_switches:  proc(volx, vs_size) returns(bit(1));
     
/* Called by get_list_names, this procedure determines whether a volume meets the criteria specifed and 
   returns true, else false.
   volx: Index of volume to look at.
   vs_size: Size of volume set to be considered.
*/

dcl (volx, vidx, vs_size)		fixed bin;

    if listed_flag(volx) then return(False);      /* did we already print this?                            */
    vidx = volx;
    if vpe(vidx).secondary_vol then               /* set vidx to primary volume as he has all the info.    */
       vidx = vpe(vidx).primary_idx;

    if ^(specified_states(vpe (vidx).state)) then return(False);

    if vs_size = -1 then;   /* get volume_sets of any size */
    else if (vpe(vidx).vs_count) ^= vs_size then return(False);

    if expire_sw then do;
       /* want only those whose expire_date is < clock */
       if ^(vpe(vidx).expire) then return(False);
       if vpe(vidx).expire_date > clock() then return(False);
       end;

    if match_sw then do;
       compare = vpe (vidx).comment;
       if ((index (compare, match_string) = 0) | (index (compare, match_string) = 64)) then return(False);
       end;

return(True);

end get_names_check_switches;


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

get_next_arg: proc(Arg_expected, ap1, al1);

/*  This guy gets the next argument from the argument string, complaining if it's not there  */

dcl Arg_expected			char(*);
dcl (ap1				ptr,
     al1				fixed bin(21));
	    
	if (ac + 1) > narg then do;
	     call abort_proc(error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg);
	     return;
	     end;
	ac = ac + 1;
	call get_arg (ac, ap1, al1, (0), alp);
     
end get_next_arg;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_node:  proc() returns (fixed bin);

/* Called by add procedures, get_node looks for the next available, or empty node in the volume pool structure, 
   and returns the index of this node to the caller.  */

dcl volx				fixed bin;

     volx = volume_pool.free_head;
     volume_pool.free_head = vpe(volume_pool.free_head).next;
     if volume_pool.free_head = no_link then do;
        volume_pool.free_head, volume_pool.n_vol = volume_pool.n_vol + 1;
        vpe(volume_pool.free_head).next = no_link;
        vpe(volume_pool.free_head).previous = no_link;
        vpe(volume_pool.free_head).secondary_idx = no_link;
        end;

     return(volx);
end get_node;

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

get_number:    proc() returns(fixed bin);

/* Called when processing arguments for various keys, get_number returns the number specified for 
   control args -first, -last, -vs_size.   */

dcl arg_fb			fixed bin;

    if ac = narg then return(1);  /* this is the default */
    ac = ac + 1;
    call get_arg (ac, ap, al, (0), alp);
    if verify(arg, "0123456789") = 0 then do;
        arg_fb = convert(arg_fb, arg);
        if arg_fb = 0 then call abort_proc(error_table_$action_not_performed, " 0 volume set size specified.");
        return(arg_fb);
        end;
    else do;
       ac = ac - 1;	  /* reset arg pointer */
       return(1);   
       end;

end get_number;     
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_volumes_specified:     proc(requestor, a_states, aptr, asize, vs_size, most_recent);
		  
/* Called by the various key procedures, get_volumes_specified fills in the volume structure with volumes
   meeting specified criteria, querying the user and reporting errors when appropriate.
   requestor: The action required by the caller, used in querying (input).
   a_states:  Defines the states possible for a volume to be considered (input).
*/
dcl requestor			char(*);
dcl a_states(4)			bit(1) parameter;
dcl  1 volume			aligned based (aptr),
       2 name(asize)		char(32),
       2 indx(asize)		fixed bin,
       2 switches,
         3 noaction(asize)	bit(1) unal,
         3 want_it(asize)	bit(1)unal;

dcl (asize, vs_size, i, vol_idx)	fixed bin;
dcl aptr				ptr;
dcl (continue, 
     most_recent,
     just_expired)			bit(1);
dcl msg				char(256);
dcl msg_len			fixed bin;

    vol_idx = 0;
    if most_recent then do;
       i = volume_pool.head;
       do while ((i ^= no_link) & (vol_idx < asize));
          call get_volumes_specified_loop();
	i = vpe(i).next;
          end;
       end;
    else do;  /* get the volumes with the oldest state_date */
       i = volume_pool.tail;
       do while ((i ^= no_link) & (vol_idx < asize));
          call get_volumes_specified_loop();
	i = vpe(i).previous;
          end;
       end;

    if just_expired then call construct_msg(check_pvexp);

    if vol_idx = 0 then call abort_proc(0,
            "No ^[free^s^;^[allocated^]^] volume sets ^[of size ^d^;specified^] exist in the pool.^[ Allocate reserved volumes by name.^]", 
            a_states(free_state), a_states(allocated_state), vs_size > 0, vs_size, requestor = "allocated" );

    else if vol_idx < asize then do;
       /* query when some but not all volumes specified are found for -lt and -ft			*/
       continue = False;
       call ioa_$rsnnl("Only ^d volume set^[s^] ^[of size ^d ^;^s^]can be ^a.", msg, msg_len, vol_idx, vol_idx > 1, 
                       vs_size > 0, vs_size, requestor);

       call query_to_continue("", msg, force_sw, continue);
       if ^(continue) then call abort_proc(0,
	     "The ^d volume sets specified ^[of size ^d ^]are not in the pool. ", asize, vs_size > 0, vs_size);
       end;


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

get_volumes_specified_loop:  proc();

   if a_states(vpe(i).state) then do;  
      if (vpe(i).vs_count = vs_size) | vs_size = -1 then do;
         if vpe(i).state = free_state then do;  
            call check_for_pvexp(i, brief_sw, just_expired);
	  if ^just_expired then do;
               vol_idx = vol_idx + 1;
	     volume(vol_idx).indx = i;
	     volume(vol_idx).name = vpe(i).name;
	     volume(vol_idx).want_it = True;
	     end;
	  end;
         else do;
            vol_idx = vol_idx + 1;
	  volume(vol_idx).name = vpe(i).name;
	  volume(vol_idx).indx = i;
	  volume(vol_idx).want_it = True;
	  end;
         end;
      end;

end get_volumes_specified_loop;

end get_volumes_specified;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

insert_node:  proc(volx);

/* Called by the add procedures, insert_node puts a new node into the linked volume list 
   contained in volume_pool.vpe  
   volx: index to the node to be linked (input).   */

dcl volx				fixed bin;

     vpe(volx).state_date = clock();
     vpe(volx).next = volume_pool.head;
     if volume_pool.head ^= no_link then vpe(volume_pool.head).previous = volx;
     vpe(volx).previous = no_link;
     volume_pool.head = volx;
     volume_pool.volume_count = volume_pool.volume_count + 1;

end insert_node;


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

last_volume_in_set:  proc(primary_idx) returns(fixed bin);
		 
/* Determines the last volume in a volume set and returns the index of this last volume
   primary_idx:  index of the primary volume of the set (input).
*/   
dcl (primary_idx, vol_idx)		fixed bin;

     if vpe(primary_idx).vs_count = 1 then return(primary_idx);
     vol_idx = vpe(primary_idx).secondary_idx;
     do while (vpe(vol_idx).secondary_idx ^= no_link); 
        vol_idx = vpe(vol_idx).secondary_idx;
        end;
     return (vol_idx);

end last_volume_in_set;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

list_key:    proc();
	   
/* Lists volume sets in the pool. */

dcl (volx, i)			fixed bin;
dcl total_char			char(256) var;
dcl (get_area, not_in_pool)		bit(1);

    if volume_pool.volume_count = 0 then call abort_proc (0, "Volume pool is empty.");
    vs_size = -1;
    most_recent = False;
    allocate listed_flag in (based_area) set (Plisted);
    listed_flag = False;

    if narg = 1 then do;		/* No control args. Print the default. */
       i = volume_pool.head;
       do while (i ^= no_link);
          if active_fnc then do;
	   ret = ret || " " || rtrim(vpe(i).name);
	   end;
          else do;
	   dfmt_sw = True;
	   specified_states = "1"b;
	   call print (i, vs_size);
	   end;
	i = vpe(i).next;
          end;
       goto END_LIST;
       end;

     /* first process list control args */

    vol_cnt = 0;
    get_area = True;
    do ac = 2 to narg;
       call get_arg (ac, ap, al, (0), alp);
       if arg = "-match" then do;
	ac = ac + 1;
	call get_arg (ac, ap, al, code, alp);
	if code ^= 0 then call abort_proc (code, "Unable to get arg after ^a", arg);
	match_sw = True;
	match_string = arg;
	end;
       else if arg = "-free" then do;
	specified_states(free_state), free_sw = True;
	all_states = False;
	end;
       else if arg = "-alloc" | arg = "-allocate" | arg = "-allocated" then do;
	specified_states(allocated_state), alloc_sw = True;
	all_states = False;
	end;
       else if arg = "-pvexp" | arg = "-pv_expire" then do;
	specified_states(pvexp_state), pvexp_sw = True;
	all_states = False;
	end;
       else if arg = "-rsv" | arg = "-reserve" | arg = "-reserved" then do;
	specified_states(reserved_state), reserve_sw = True;
	all_states = False;
	end;
       else if arg = "-exp" | arg = "-expire" then expire_sw = True;
       else if arg = "-ft" | arg = "-first" then do;
	first_last_sw, first_sw, most_recent = True;
	vol_cnt = get_number();
	end;
       else if arg = "-lt" | arg = "-last" then do;
	first_last_sw, last_sw = True;
	most_recent = False;
	vol_cnt = get_number();
	end;
       else if arg = "-vs" | arg = "-volume_size" then do;
 	vs_sw = True;
	vs_size = get_number();
	end;
       else if arg = "-nm" | arg = "-name" then name_sw = True;
       else if arg = "-edt" | arg = "expire_date" then edt_sw = True;
       else if arg = "-pvedt" | arg = "pv_expire_date" then pvedt_sw = True;
       else if arg = "-com" | arg = "-comment" then comment_sw = True;
       else if arg = "-sdt" | arg = "state_date" | arg = "-time" then sdt_sw= True;
       else if arg = "-state" then state_sw = True;
       else if arg = "-nhe" | arg = "-no_header" then header_sw, header_to_be_printed = False;
       else if arg = "-ast" | arg = "-all_states" | arg = "-all" then all_states = True;
       else if arg = "-dfmt" | arg = "-default_format" then dfmt_sw  = True;
       else if arg = "-he" | arg = "-header" then  header_sw, header_to_be_printed = True;
       else if arg = "-tt" | arg = "-total" then do;
         totals_wanted = True;
         header_sw, header_to_be_printed = False;
         end;
       else do; /* assume a volume name */
          if get_area then do;
	   get_area = False;
	   volume_cnt = narg;
	   allocate volume in (based_area) set (Pvolume);
	   end;
          volume_sw = True;
	vol_cnt = vol_cnt + 1;
	volume(vol_cnt).name = arg;
	end;
    end;

if totals_wanted & (header_sw | state_sw | sdt_sw | name_sw | edt_sw | pvedt_sw | dfmt_sw | comment_sw | first_last_sw)
    then call abort_proc(error_table_$inconsistent, 
        "-total^[ -header^;^]^[ -state^;^]^[ -state_date^;^]^[ -name^;^]^[ -edt^;^]^[ -pvedt^;^]^[ -dfmt^;^]^[ -first^;^]^[ -last^;^]",
         header_sw, state_sw, sdt_sw, name_sw, edt_sw, pvedt_sw, dfmt_sw, first_sw, last_sw);

    if volume_sw & (match_sw | vs_sw | expire_sw | reserve_sw | pvexp_sw | free_sw | alloc_sw | first_last_sw)
    then call abort_proc(error_table_$inconsistent, 
        "volume_names ^[ -match^;^]^[ -volume_size^;^]^[ -expire^;^]^[ -rsv^;^]^[ -pvexp^;^]^[ -free^;^]^[ -alloc^;^]^[ -first^;^]^[ -last^;^]",
         match_sw, vs_sw, expire_sw, reserve_sw, pvexp_sw, free_sw, alloc_sw, first_sw, last_sw);

    if ^(name_sw | sdt_sw | state_sw | comment_sw | pvedt_sw | edt_sw) then dfmt_sw = True;
    if (name_sw & sdt_sw & state_sw & comment_sw) then dfmt_sw = True;

    if index(state_string, "1"b) = 0 then     /* set the default to consider all states			*/
              specified_states(*) = True;

    if volume_sw then do;
       not_in_pool = False;
       do i = 1 to vol_cnt;
          if volume_in_pool ((volume(i).name), volx) then call print(volx, vs_size);
	else do;
	   not_in_pool = True;
	   vol_list.name(fb_not_reg) = vol_list.name(fb_not_reg)  || " " || rtrim(volume(i).name);
	   vol_list.cnt(fb_not_reg) = vol_list.cnt(fb_not_reg) + 1;
	   end;
	end;
       if not_in_pool then call construct_msg(not_reg);
       end;

    else if (vs_sw | first_last_sw) then do;
       if vol_cnt = 0 then vol_cnt = volume_pool.n_vol;    /* -ft or -lt not specified, set default	*/
       volume_cnt = vol_cnt;
       allocate volume in (based_area) set (Pvolume);
       volume(*).want_it = False;
       call get_list_names(Pvolume, vol_cnt, vs_size, most_recent);
       if vol_cnt = 0 then call abort_proc(0, "No volumes met the list criteria specified.");
       do i = 1 to vol_cnt;
          if volume(i).want_it then call print (volume(i).indx, vs_size);
	end;
       end;

    else do;
       i = volume_pool.head;
       do while (i ^= no_link);
	call print (i, vs_size);
	i = vpe(i).next;
	end;
       end;

    if totals_wanted then do;
       if active_fnc then ret = convert(total_char, total_cnt);
       else do;
          if total_cnt = 0 then call msg_proc(0, "No volume sets met the list criteria specified.");
	else call msg_proc(0, "A total of ^d volume set^[s^].", total_cnt, total_cnt > 1);
	end;
       goto END_LIST;
       end;

    if total_cnt = 0 then call msg_proc(0, "No volume sets met the list criteria specified.");
    else if ^active_fnc then 
       if noaction_msg ^= "" then call ioa_$nnl("^/^a", noaction_msg);

END_LIST:
      return;
end list_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

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

/* lock_required determines whether the pool has to be locked or not, depending on the requested action 
   and the effective access of the caller
*/

dcl code				fixed bin(35);
dcl mode				fixed bin(5);

    code = 0;
    if arg = "l" | arg = "ls" | arg = "list" |
       arg = "p" | arg = "pr" | arg = "print" |
       arg = "t" | arg = "test" then do;
       call hcs_$get_user_effmode (vol_dir, vol_ename, "", (get_ring_()), mode, code);
       if code ^= 0 then call abort_proc(code, "^/Unable to determine access of ^a", path(vol_dir, vol_ename));
       if mode = R_ACCESS_BIN | mode = RE_ACCESS_BIN then return(False);
       end;

    return(True);

end lock_required;


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

lock_volume_pool: proc;

/* Locks the volume pool */

     lock = False;
     call set_lock_$lock (volume_pool.lock, lock_interval, code);
     if code ^= 0
     then do;
	if code = error_table_$invalid_lock_reset then code = 0;
	else if code = error_table_$locked_by_this_process then code = 0;
	else call abort_proc (code, " ^a",
	     path (vol_dir, vol_ename));
     end;
     lock = (code = 0);
end lock_volume_pool;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

msg:	proc (err);

/* msg is a semi all-purpose message reporting facility. 
   err = 0  means print the "manage_volume_pool:" header before the message.
   err = -1 says don't identify myself before the message.
*/

dcl  err fixed bin (35);
dcl  str char (256);
dcl  argp ptr;
dcl  str_len fixed bin;

     if subroutine then do;
        if err = 0 | err = -1 then a_code = error_table_$action_not_performed;
        else a_code = err;
        if lock then call unlock_volume_pool;
        end;

     call cu_$arg_list_ptr (argp);			/* convert args to message */
     call ioa_$general_rs (argp, 2, 3, str, str_len, "0"b, "0"b);
     if (err = 0 | err = -1) & ^subroutine & ^active_fnc then
        call ioa_ ("^[^a: ^;^s^]^a", err = 0, myname, substr (str, 1, str_len));
        else call error_rnt (err, myname, substr (str, 1, str_len));
     if subroutine then goto return_to_caller;

end msg;


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

move_into_state_date_order:
     proc(volx);

/* move_into_state_date_order moves the volume entry specified by volx to the appropriate
   location in the volume_pool list (based upon its state_date) by relinking the volume list.
*/

dcl volx				fixed bin;
dcl voli				fixed bin;

     if volume_pool.head = volx &			/* volume is alone in the list.*/
        volume_pool.tail = volx then return;

     if volume_pool.head = volx then do;		/* first, remove volume from the list. */
        volume_pool.head = vpe(volx).next;
        vpe(vpe(volx).next).previous = no_link;
        end;
     else if volume_pool.tail = volx then do;
        volume_pool.tail = vpe(volx).previous;
        vpe(vpe(volx).previous).next = no_link;
        end;
     else do;
        vpe(vpe(volx).previous).next = vpe(volx).next;
        vpe(vpe(volx).next).previous = vpe(volx).previous;
        end;
     
     do voli = volume_pool.head repeat vpe(voli).next	/* then skip over volumes with more */
        while (voli ^= no_link & vpe(voli).state_date > vpe(volx).state_date);
        end;					/* state date than our volume.      */

     if voli = no_link then do;			/* put volume at tail of list.      */
        voli = volume_pool.tail;
        vpe(voli).next = volx;
        vpe(volx).previous = voli;
        vpe(volx).next = no_link;
        volume_pool.tail = volx;
        end;
     else if voli = volume_pool.head then do;		/* put volume at head of list.      */
        voli = volume_pool.head;
        vpe(voli).previous = volx;
        vpe(volx).next = voli;
        vpe(volx).previous = no_link;
        volume_pool.head = volx;
        end;
     else do;					/* put volume in front of voli      */
        vpe(vpe(voli).previous).next = volx;
        vpe(volx).previous = vpe(voli).previous;
        vpe(volx).next = voli;
        vpe(voli).previous = volx;
        end;

end move_into_state_date_order;

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

move_to_head:  proc(volx);

/* move_to_head moves the volume entry specified by volx to the head of the volume_pool list by
   relinking the volume list.
*/

dcl volx				fixed bin;

     vpe(volx).state_date = clock();
     if volx = volume_pool.head then goto END_MOVE_TO_HEAD; /* Volume is already at head of pool		*/
     if vpe(volx).previous ^= no_link then do;
        vpe(vpe(volx).previous).next = vpe(volx).next;
        if volx = volume_pool.tail then volume_pool.tail = vpe(volx).previous;
        end;
     if vpe(volx).next ^= no_link then  vpe(vpe(volx).next).previous = vpe(volx).previous;
     vpe(volx).previous = no_link;
     vpe(volx).next = volume_pool.head;
     vpe(volume_pool.head).previous = volx;
     volume_pool.head = volx;

END_MOVE_TO_HEAD:
     return;
end move_to_head;


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

path:	proc (dirname, ename) returns (char (168));

/* Constructs a pathname given the directory name and the entry name. */

dcl  dirname char (*);
dcl  ename char (*);
dcl  pathname char (168);
	     call ioa_$rsnnl ("^a^[>^]^a", pathname, (0), dirname, dirname ^= ">", ename);
	     return (pathname);
	end path;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

print:	proc(vidx, vs_size);
	
/* Called by list_key, print determines whether a volume is to be printed.
   vidx: Index to volume.
   vs_size: Size of volumes to be printed.  */

dcl (vs_size, printx, vidx)		fixed bin;

    printx = vidx;
    if listed_flag(printx) then goto END_PRINT;

    if vpe(printx).secondary_vol then          /*  set printx to primary volume as he has all the info.    */
       printx = vpe(printx).primary_idx;

    if ^(specified_states(vpe (printx).state)) then goto END_PRINT;

    if vs_size = -1 then;   /* get volume_sets of any size */
    else if (vpe(printx).vs_count) ^= vs_size then goto END_PRINT;

    if expire_sw then do;
       /* print only those whose expire_date is < clock */
       if ^(vpe(printx).expire) then goto END_PRINT;
       if vpe(printx).expire_date > clock() then goto END_PRINT;
       end;

    if match_sw then do;
       compare = vpe (printx).comment;
       if ((index (compare, match_string) = 0) | (index (compare, match_string) = 64)) then goto END_PRINT;
       end;
  
       /* At this point, all initial criteria to print has been met */

       call format_print_output(printx, False);

       if verify(output, blank_NL) = 0 then;  /* don't print if no output is found */
       else do;
          if active_fnc & ^totals_wanted then do;
               requoted_output = requote_string_ (substr (output, 1, length(output)));
	     ret = ret || " ";
   	     ret = ret || requoted_output;
	     end;
          else do;
             if header_sw then do;               /* did we print the header yet?  */
	      call ioa_("^a", header_output);
	      header_sw = False;
	      end;
	   if ^totals_wanted then call ioa_("^a", output);
	   end;
          total_cnt = total_cnt + 1;
       end;
    
       if vpe(printx).vs_count > 1  then call print_secondary_volumes(printx);

END_PRINT:
    return;
end print;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

print_secondary_volumes:   proc(printx);

/* Called by print, this procedure prints secondary volumes of a set. */

dcl printx			fixed bin parameter;

          /* printx is the index to the primary volume. we want to now print the secondary volumes only */

          listed_flag(printx) = True;

          printx = vpe(printx).secondary_idx;
          do while (printx ^= no_link);
             call format_print_output(printx, True);
	   listed_flag(printx) = True;
             if output ^= "" then do;
	      if active_fnc & ^totals_wanted then do;
	           requoted_output = requote_string_ (substr (output, 1, length(output)));
		 ret = ret || " ";
		 ret = ret || requoted_output;
   	           end;
	      else if ^totals_wanted then call ioa_("^a", output);
	      end;
	   printx = vpe(printx).secondary_idx;
	   end;
        
end print_secondary_volumes;


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

process:	proc (fetch, routine);

/* Used by obselete keys change, comment and the old version of allocate. */

dcl  fetch bit (1) ;
dcl  routine entry;
	     if narg < 2 then call abort_proc (error_table_$noarg, "");
	     ac = 2;
	     do while (ac <= narg);
   	        call get_arg (ac, ap, al, (0), alp);
		if arg = "" then call abort_proc (error_table_$noarg, "");
		call search (arg);
		if fetch	then do;
		   ac = ac + 1;
		   call get_arg (ac, apa, ala, code, alp);
		   if code ^= 0 then call abort_proc (code, "No comment specified.");
		   end;
		   call routine;
		ac = ac + 1;
	     end;
	     return;
	end process;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

process_ctl_args:   proc(Pargs_allowed, begin_arg, vol_cnt);

/* Called by various keys to process their control arguments. Also fills in the volume structure when 
   volume names are specified.
   Pargs_allowed: Pointer to structure which specifies which arguments are allowed for the given 
   key procedure caller (input).
   begin_arg: Where to start argument processing (input).
   vol_cnt: The number of volumes to be acted upon (output).
*/
dcl begin_arg			fixed bin;
dcl get_area			bit(1);
dcl vol_cnt			fixed bin;
dcl Pargs_allowed			ptr;

dcl 1 args_allowed			unaligned based (Pargs_allowed),
      2  first			bit(1),
      2  last			bit(1),
      2  force			bit(1),
      2  volume_size		bit(1),
      2  comment			bit(1),
      2  expire			bit(1),
      2  brief			bit(1),
      2  fexp			bit(1),
      2  match			bit(1),
      2  all			bit(1),
      2  pvexp			bit(1),
      2  alloc			bit(1),
      2  reserve			bit(1),
      2  free			bit(1),
      2  svol			bit(1),
      2  asterisk			bit(1),
      2  exp_dt			bit(1),		/* requires a date after -exp			*/
      2  pvexp_dt			bit(1),		/* requires a date after -pvexp		*/
      2  state_dt			bit(1);

     vs_size = -1;					/* default is any size volume set if -vs isn't specified */
     vol_cnt = 0;
     asterisk_cnt = 0;
     get_area = True;
     most_recent = False;

     do ac = begin_arg to narg;
        call get_arg (ac, ap, al, (0), alp);
        if arg = "-exp" | arg = "-expire" then do;
           if ^(args_allowed.expire) then goto bad_ctl;
	 expire_sw = True;
 	 if (args_allowed.exp_dt) then			/* some keys require a date		*/
	    call get_next_arg("date", expire_ptr, expire_len);
	 end;

        else if arg = "-fc" | arg = "-force" then do;
           if ^(args_allowed.force) then goto bad_ctl;        
	 force_sw = True;
	 end;

        else if arg = "-ft" | arg = "-first" then do;
           if ^(args_allowed.first) then goto bad_ctl;
	 first_last_sw, first_sw, most_recent = True;
	 vol_cnt = get_number();
	 end;

        else if arg = "-lt" | arg = "-last" then do;
           if ^(args_allowed.last) then goto bad_ctl;
	 first_last_sw, last_sw = True;
	 most_recent = False;
	 vol_cnt = get_number();
	 end;

        else if arg = "*" then do;  /* have to support obsolete '*' use for test, delete, reserve. Same as -last 1 */
           if ^(args_allowed.asterisk) then goto bad_ctl;
	 asterisk_sw = True;
	 most_recent = False;
	 asterisk_cnt = asterisk_cnt + 1;
	 end;

        else if arg = "-vs" | arg = "-volume_size" then do;
           if ^(args_allowed.volume_size) then goto bad_ctl;
	 vs_sw = True;
	 vs_size = get_number();
	 end;

        else if arg = "-com" | arg = "-comment" then do;
           if ^(args_allowed.comment) then goto bad_ctl;
	 comment_sw = True;
	 call get_next_arg("comment", com_ptr, com_len);
	 end;

        else if arg = "-bf" | arg = "-brief" then do;
           if ^(args_allowed.brief) then goto bad_ctl;
	 brief_sw = True;
	 end;

        else if arg = "-fexp" | arg = "-force_expire" then do;
           if ^(args_allowed.fexp) then goto bad_ctl;
	 fexp_sw = True;
	 end;

        else if arg = "-a" | arg = "-all" then do;
           if ^(args_allowed.all) then goto bad_ctl;
	 all_sw = True;
	 end;

        else if arg = "-pvexp" | arg = "-pv_expire" then do;
           if ^(args_allowed.pvexp) then goto bad_ctl;
	 pvexp_sw = True;
           if (args_allowed.pvexp_dt) then		/* add and set keys require a date */
              call get_next_arg("date", pvexp_ptr, pvexp_len);
	 end;

        else if arg = "-stdt" | arg = "-state_date" then do;
	 if ^(args_allowed.state_dt) then go to bad_ctl;
           state_dt_sw = True;
	 call get_next_arg("date", state_dt_ptr, state_dt_len);
	 end;

        else if arg = "-free" then do;
           if ^(args_allowed.free) then goto bad_ctl;
	 free_sw = True;
	 end;

        else if arg = "-alloc" | arg = "-allocate" | arg = "-allocated" then do;
           if ^(args_allowed.alloc) then goto bad_ctl;
	 alloc_sw = True;
	 end;

        else if arg = "-rsv" | arg = "-reserved" | arg = "-reserve" then do;
           if ^(args_allowed.reserve) then goto bad_ctl;
 	 reserve_sw = True;
	 end;
	   
        else if arg = "-match" then do;
           if ^(args_allowed.match) then goto bad_ctl;
	 ac = ac + 1;
	 call get_arg (ac, ap, al, code, alp);
	 if code ^= 0 then call abort_proc (code, "Unable to get arg after ^a", arg);
	 match_sw = True;
	 match_string = arg;
	 end;

        else if arg = "-svol" | arg = "-secondary_volumes" then do;
           if ^(args_allowed.svol) then goto bad_ctl;
	 svol_sw = True;
	 end;

        else do; /* assume a volume name */
           if get_area then do;
	    get_area = False;
	    volume_cnt = narg;
	    allocate volume in (based_area) set (Pvolume);
	    end;
           volume_sw = True;
	 vol_cnt = vol_cnt + 1;
	 volume(vol_cnt).name = arg;
	 end;
     end;

     return;

bad_ctl:
     call abort_proc(error_table_$badopt, " ^a", arg);
     
end process_ctl_args;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

pv_expire_key:    proc();
	    
/* Procedure which handles the pv_expire key */

dcl primary_idx			fixed bin;
dcl (i, volx, vol_cnt)   		fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("0"b),
      2  last			init ("0"b),
      2  force			init ("1"b),
      2  vs			init ("0"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

    if narg < 2 then call abort_proc (error_table_$noarg, "Usage: mvp pvexp volume_names {-control_arg}");

    /* get volume_names */

    call process_ctl_args(addr(args_allowed), 2, vol_cnt);
    
    if vol_cnt = 0 then call abort_proc (error_table_$noarg, "No volume names specified.");

    call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | check_pvexp);

    call evaluate_volumes_wanted("physically expired", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
    if none_sw | abort_sw then do;
       if active_fnc then do;
	ret = "false";
	return;
	end;
       if none_sw then  call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
       else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);
      end;

    /* expire the volumes */

    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
             volx = volume(i).indx;
             if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx;
             vpe(volx).state = pvexp_state;
	   vpe(volx).pv_expire = False;
   	   if vpe(volx).vs_count > 1 then do; /* multiple volume set */
	      primary_idx = volx;
	      do while (volx ^= no_link);
	         vpe(volx).pv_expire = False;
	         volx = vpe(volx).secondary_idx;
	         end;
	      volx = primary_idx;
	      end;
             call move_to_head(volx);
	   end;
          end;
       end;

      if active_fnc then ret = "true";
      else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg);

end pv_expire_key;



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

pvexp_secondary_vol_check:   proc(a_idx) returns(bit(1));
	      
/* Called by check_for_pvexp, this procedure determines whether any secondary volumes of a set have 
   physically expired. If so, true is returned, else false. */

dcl (a_idx, vol_idx)		fixed bin;

    vol_idx = a_idx;
    if vpe(vol_idx).vs_count = 1 then return(False);	/* Not a multiple volume set			*/
    if vpe(vol_idx).state = allocated_state then return(False); /* allocated volumes cannot be expired */
     
     vol_idx = vpe(vol_idx).secondary_idx;
     do while (vol_idx ^= no_link);
        if vpe(vol_idx).pv_expire & vpe(vol_idx).pv_expire_date < clock() then return(True);
        vol_idx = vpe(vol_idx).secondary_idx;
        end;

    return(False);
    
end pvexp_secondary_vol_check;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

pvexp_volume:   proc(vol_idx);
	      
/* Called by check_for_pvexp, pvexp_volume does the actual work of physically expiring a volume as 
   specified by vol_idx. */

dcl (primary_idx, vol_idx)		fixed bin;

     vpe(vol_idx).state = pvexp_state;
     vpe(vol_idx).pv_expire = False;
     if vpe(vol_idx).vs_count > 1 then do;		/* multiple volume set, reset secondary volumes too */
        primary_idx = vol_idx;
        do while (vol_idx ^= no_link);
	 vpe(vol_idx).pv_expire = False;
	 vol_idx = vpe(vol_idx).secondary_idx;
	 end;
        vol_idx = primary_idx;
        end;
    call move_to_head(vol_idx);
    
end pvexp_volume;


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

query_to_continue:    proc(requestor, msg, force, continue);

/* Determines whether to query or not.
   requestor: The action required by the caller, used in querying (input).
   msg:  The message specified by the caller (input).
   force: Specifies whether to query the user or not (input).
   continue: Continue or abort the request? (output).
*/
dcl (continue, force)		bit(1);
dcl (requestor, msg)		char(*);

             if force then continue = True;
	   else if active_fnc then continue = False;
	   else continue = yes_to_query(requestor, msg);
	   return;

end query_to_continue;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

remove_volume_set:    proc();
	    
/* This procedure handles the rmvs key of the mvp command */

dcl (done, just_expired, found)	bit(1);
dcl i,
    volx,
    current_idx,
    remove_cnt,
    prev_idx,
    primary_idx,
    set_state			fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("0"b),
      2  last			init ("0"b),
      2  force			init ("1"b),
      2  vs			init ("0"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("1"b),
      2  fexp			init ("1"b),
      2  match			init ("0"b),
      2  all			init ("1"b),
      2  pvexp			init ("1"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

        if narg < 3 then call abort_proc (error_table_$noarg, 
                        "^/Usage: mvp rmvs primary_volume_name {secondary_volume_names} {-control_args} ");

        /* first get primary_volume_name */

        ac = 2;
        call get_arg (ac, ap, al, (0), alp);
        if ^(volume_in_pool((arg), primary_idx)) then call abort_proc(error_table_$action_not_performed,
                    "Primary volume specified is not in the pool. " || arg);
        else if vpe(primary_idx).secondary_vol then call abort_proc(error_table_$action_not_performed,
                    "^/Primary volume specified ^a is a secondary volume of set ^a.", arg, 
		vpe(vpe(primary_idx).primary_idx).name);

        /* now look at secondary volumes specified or  control args */

        call process_ctl_args(addr(args_allowed), 3, vol_cnt);
     
        if pvexp_sw then set_state = pvexp_state;
        else set_state = free_state;

       if (pvexp_sw  & all_sw) then call abort_proc(error_table_$inconsistent, "-pvexp -all");
       if (pvexp_sw | all_sw) & volume_sw then call abort_proc(error_table_$inconsistent,
                                                       "secondary_volumes and -control_args");

       if vpe(primary_idx).state = allocated_state & ^(fexp_sw) then do;
          /* check -expire date 			*/
	if  vpe(primary_idx).expire & (vpe(primary_idx).expire_date > clock()) then do; 
						/* hasn't expired, abort request 		*/
	      if brief_sw then do;
	         if active_fnc then call abort_proc(error_table_$action_not_performed,
	                 "^/Volume set ^a is not expired. ^a", vpe(primary_idx).name, 
                           time_string_(vpe(primary_idx).expire_date));
	         end;
	      else call abort_proc(error_table_$action_not_performed,
	                 "^/Volume set ^a is not expired. ^a", vpe(primary_idx).name, 
                            time_string_(vpe(primary_idx).expire_date));
             end;
	end;

       if ^(volume_sw) then do;
	vol_cnt, volume_cnt = max( 1, vpe(primary_idx).vs_count - 1);
	allocate volume in (based_area) set (Pvolume);
	volume.want_it, volume.noaction = False;

	if vpe(primary_idx).vs_count = 1 then    /* volume set is size one 		*/
             volx = primary_idx;		
          else     /* set index to first secondary volume. primary volume stays unchanged */
             volx = vpe(primary_idx).secondary_idx;  

	do i = 1 to vol_cnt while (volx >= 1);		/* fill volume array with volumes to be removed	*/
	   volume(i).name = vpe(volx).name;
	   volume(i).indx = volx;
	   volume(i).want_it = True;
	   volx = vpe(volx).secondary_idx;
	   end;

          if pvexp_sw then do;
	   volume.want_it = False;
	   do i = 1 to vol_cnt;
	      if vpe(volume(i).indx).pv_expire & (vpe(volume(i).indx).pv_expire_date < clock()) then 
                   volume(i).want_it = True;
	      end;
	   end;
          end;

       else do;  /* secondary volume names were specified, verify them.  */
          call check_for_errors(Pvolume, volume_cnt, vol_cnt, primary_idx, not_reg | sec_not_found);
          end;

       call evaluate_volumes_wanted("removed", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
       if none_sw then call abort_proc(error_table_$action_not_performed, 
	        "No physically expired volumes found in set ^a.", vpe(primary_idx).name);
       else if abort_sw then if noaction_msg ^= "" then call abort_proc(error_table_$action_not_performed, "^a", 
                                                        noaction_msg);

       /* now remove the volumes */
       
       remove_cnt = 0;
       prev_idx = primary_idx;
       if vpe(primary_idx).vs_count = 1 then current_idx = primary_idx;
       else current_idx = vpe(primary_idx).secondary_idx;  
       done = False;
       do while (^done);
          if vpe(current_idx).secondary_idx <= 0 then done = True;
          found = False;
	do i = 1 to vol_cnt while (^found);
	   if volume(i).want_it & (volume(i).name = vpe(current_idx).name) then found = True;
	   end;
	if found then call remove_volume();
 	else do;  /* update prev_idx */
	   prev_idx = current_idx;
	   current_idx = vpe(current_idx).secondary_idx;
	   end;
	end;  /* do loop */

       vpe(primary_idx).vs_count = max(1, vpe(primary_idx).vs_count - remove_cnt);
       if all_sw then do;				/* remove primary volume also			*/
          current_idx, prev_idx = primary_idx;
	call remove_volume();
	end;
       if just_expired then do;
	call construct_msg(check_pvexp);
          if ^active_fnc & noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg);
	end;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

remove_volume:  proc();

/* Internal procedure to remove_volume_set procedure, this guy does the actual removing of volumes */

dcl save_idx			fixed bin;

   /* first check pvexp date  to print message */
   call check_for_pvexp(current_idx, brief_sw, just_expired);

   remove_cnt = remove_cnt + 1;

   /* relink the volume set chain */
    vpe(prev_idx).secondary_idx = vpe(current_idx).secondary_idx;

    /* reset the vpe being removed */
    if active_fnc & ^just_expired then ret = ret || " " || rtrim(vpe(current_idx).name);
    vpe(current_idx).comment = "";
    vpe(current_idx).secondary_vol = False;
    vpe(current_idx).expire = False;
    vpe(current_idx).expire_date = 0;
    vpe(current_idx).primary_idx = no_link;
    if ^just_expired then do;
       vpe(current_idx).state = free_state;
       vpe(current_idx).state_date = clock();
       call move_to_head(current_idx);
       end;
    if vpe(current_idx).secondary_idx > 0 then do;
       save_idx = current_idx;
       current_idx = vpe(current_idx).secondary_idx;
       vpe(save_idx).secondary_idx = no_link;
       end;

end remove_volume;

end remove_volume_set;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

reserved_by_another_process:	proc(vol_idx) returns (bit(1));

/* Returns true when a volume specified by vol_idx is reserved by another process */

dcl vol_idx			fixed bin;

    if vpe(vol_idx).processid ^= get_process_id_() then do;  /* reserved by another process */
       call hcs_$validate_processid (vpe (vol_idx).processid, code);
       if code = error_table_$process_unknown then return(False);  /* other process is not active  */
       else return(True);
       end;

    return(False);

end reserved_by_another_process;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

reserve_key:    proc();

/* Procedure which handles the mvp command reserve key. */

dcl (i, vol_cnt, volx)		fixed bin;
dcl just_expired			bit(1);

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("1"b),
      2  last			init ("1"b),
      2  force			init ("1"b),
      2  vs			init ("1"b),
      2  com			init ("1"b),
      2  expire			init ("0"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("1"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

     /* first process control args */

    if narg < 2 then call abort_proc (error_table_$noarg, "Usage: reserve {volume_names} {-control_args}");

     specified_states(free_state) = True;
     just_expired = False;

    call process_ctl_args(addr(args_allowed), 2, vol_cnt);

    if asterisk_sw then 
       if (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, 
                                            "The asterisk '*' is obsolete. Use '-last'");
       else call msg_proc(-1, "The asterisk '*' is obsolete. Use '-last'");

    if volume_sw & (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, 
         "volume_names ^[-volume_size^;^]^[-first^;-last^]", vs_sw, most_recent);

    if asterisk_sw then do;
       tcnt = asterisk_cnt;
       allocate tvol in (based_area) set (Ptvol);
       tvol.want_it = False;
       call get_volumes_specified ("reserved", specified_states, Ptvol, tcnt, vs_size, most_recent);
       end;	

    else if ^(volume_sw) then do;     /* -first or -last or -vs were specified */
       if vol_cnt = 0 then vol_cnt = 1;
       volume_cnt = vol_cnt;
       allocate volume in (based_area) set (Pvolume);
       call get_volumes_specified ("reserved", specified_states, Pvolume, vol_cnt, vs_size, most_recent);
       end;

    if volume_sw then 
       call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | not_free | check_pvexp);

    if asterisk_sw then do;
       if ^(volume_sw) then do;
          vol_cnt = 0;
          volume_cnt = tcnt;
	allocate volume in (based_area) set (Pvolume);
	end;
       do i = 1 to tcnt;
          volume(vol_cnt + 1).name = tvol(i).name;
	volume(vol_cnt + 1).indx = tvol(i).indx;
	volume(vol_cnt + 1).want_it = tvol(i).want_it;
	vol_cnt = vol_cnt + 1;
          end;
       end;
    
    call evaluate_volumes_wanted("reserved", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
    if none_sw then call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
    else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);

    /* reserve volumes specified */

    vol_msg_list = "";
    vol_msg_cnt = 0;
    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
	   volx = volume(i).indx;
             if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx;
	   if active_fnc then ret = ret || " " || rtrim(vpe(volx).name);
	   vpe (volx).state = reserved_state;
	   vpe(volx).processid =  get_process_id_ ();
	   if comment_sw then vpe (volx).comment = comment_str;
	   else vpe (volx).comment = "";
	   if (first_last_sw | asterisk_sw) then  do;
                vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name);
	      vol_msg_cnt = vol_msg_cnt + 1;
	      end;
             call move_to_head(volx);
	   end;
	end;
       end;

    if ^active_fnc then do;    
       if vol_msg_list ^= "" then			
          call msg_proc (0, "Volume set^[s^] ^a ^[has^;have^] been reserved. ^[^a^;^s^]",
            (vol_msg_cnt > 1), vol_msg_list, (vol_msg_cnt = 1), (noaction_msg ^=""), noaction_msg);  
       else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg ); 
       end;

end reserve_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

reuse:    proc();

/* Procedure which handles the mvp command reuse key. */

dcl (i, vol_cnt, volx)		fixed bin;
dcl just_expired			bit(1);

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("1"b),
      2  last			init ("1"b),
      2  force			init ("1"b),
      2  vs			init ("1"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("1"b),
      2  fexp			init ("1"b),
      2  match			init ("1"b),
      2  all			init ("0"b),
      2  pvexp			init ("0"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("0"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

     /* first process list control args */

     call process_ctl_args(addr(args_allowed), 2, vol_cnt);

    if volume_sw & (vs_sw | match_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, 
         "volume_names ^[-volume_size^;^]^[-match^;^]^[-first^;-last^]", vs_sw, match_sw, most_recent);

    if first_last_sw | vs_sw then do;
       if vol_cnt = 0 then volume_cnt, vol_cnt = 1;
       else volume_cnt = vol_cnt;
       allocate volume in (based_area) set (Pvolume);
       volume.want_it, volume.noaction = False;
       specified_states(allocated_state) = True;
       call get_volumes_specified("re-allocated", specified_states, Pvolume, vol_cnt, vs_size, most_recent);
       end;

    if match_sw then do;
       if vol_cnt = 0 then do;  
          volume_cnt, vol_cnt = volume_pool.n_vol;
          allocate volume in (based_area) set (Pvolume);
	end;
       volume.want_it, volume.noaction = False;
       do i = 1 to vol_cnt;
          if (index (vpe(i).comment, match_string) > 0) & (vpe(i).state = allocated_state)  then do;
             volume(i).name = vpe(i).name;
             volume(i).indx = i; 
             volume(i).want_it = True;
             if (vpe(i).expire & vpe(i).expire_date < clock()) & ^fexp_sw then volume(i).noaction = True;
             call check_for_pvexp(i, brief_sw, just_expired);
             if just_expired then volume(i).noaction = True;
	   end; 
          end;  /* do loop */

       if index(want_str, "1"b) = 0 then if ^(brief_sw) then call abort_proc(error_table_$action_not_performed,
                                        "^/No allocated volumes found with comment string matching ^a.", match_string);
       if just_expired then call construct_msg(check_pvexp);
       end; /* if match_sw */

    /* here's the case where volume names were specified */

    else if volume_sw then do;
       call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | not_alloc | already_sec_vol | not_exp | check_pvexp);
       end;

    call evaluate_volumes_wanted("reused", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw);
    if none_sw then call abort_proc(error_table_$action_not_performed, 
                "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1));
    else if abort_sw then if noaction_msg ^= "" then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);

    /* now free and re-allocate  the volumes */

    vol_msg_list = "";
    vol_msg_cnt = 0;
    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
             volx = volume(i).indx;
	   if active_fnc then ret = ret || " " || rtrim(vpe(volx).name);
	   if (( match_sw | first_last_sw) & ^brief_sw) then  do;
	      vol_msg_cnt = vol_msg_cnt +1;
	      vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name);
	      end;
             call move_to_head(volx);
	   end;
          end;
       end;

    if ^active_fnc then do;
       if vol_msg_list ^= "" then 
          call msg_proc(-1, "^a: Volume set^[s^] ^a ^[has^;have^] been re-allocated. ^[^a^;^s^]",
            myname, (vol_msg_cnt > 1), vol_msg_list, (vol_msg_cnt = 1), (noaction_msg ^= ""), noaction_msg);  
        end;

end reuse;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

search:	proc (name);

/* Used by obselete keys and subroutine entry points. */

dcl  name char (*);

    vlx = 0;
    if name = "*"  then do;
       tvlx = volume_pool.tail;
       do while ((tvlx ^= no_link) & (vlx = 0));
          if vpe(tvlx).state = free_state & vpe(tvlx).vs_count = 1 then vlx = tvlx;
	tvlx = vpe(tvlx).previous;
          end;
       end;
    else do;
       if volume_in_pool(arg, tvlx) then do;
	if vpe(tvlx).secondary_vol then vlx = vpe(tvlx).primary_idx;
	else vlx = tvlx;
	end;
       end;

     return;
end search;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

set_key:  proc();
	    
/* Procedure which handles the mvp command set key. */

dcl (exp_clock, pv_clock)		fixed bin(71);
dcl i, vol_idx			fixed bin;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("0"b),
      2  last			init ("0"b),
      2  force			init ("0"b),
      2  vs			init ("0"b),
      2  com			init ("1"b),
      2  expire			init ("1"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("0"b),
      2  all			init ("0"b),
      2  pvexp			init ("1"b),
      2  alloc			init ("0"b),
      2  reserve			init ("0"b),
      2  free			init ("0"b),
      2  svol			init ("1"b),
      2  asterisk			init ("0"b),
      2  exp_dt			init ("1"b),
      2  pvexp_dt			init ("1"b),
      2  state_dt			init ("1"b)) bit(1);

        if narg < 3 then call abort_proc (error_table_$noarg, 
                        "^/Usage: mvp set volume_names -control_args ");

       pv_clock = 0;
       call process_ctl_args(addr(args_allowed), 2, vol_cnt);

       if vol_cnt = 0 then   call abort_proc(0, "No volume names specified.");
       if ^(comment_sw | pvexp_sw | expire_sw | state_dt_sw) then    call abort_proc(0, "No -control_args specified.");
       if (svol_sw  & ^(pvexp_sw | state_dt_sw)) then
          call abort_proc(error_table_$inconsistent,
	"-svol is used only in conjuction with -pvexp or -state_date");

       if pvexp_sw then do;
	call convert_date_to_binary_(pvexp_str, pv_clock, code);
	if code ^= 0 then call abort_proc(code, pvexp_str);
	end;

       if expire_sw then do;
	call convert_date_to_binary_(expire_str, exp_clock, code);
	if code ^= 0 then call abort_proc(code, expire_str);
	end;
 
       if state_dt_sw then do;
	call convert_date_to_binary_(state_dt_str, state_dt_clock, code);
	if code ^= 0 then call abort_proc(code, state_dt_str);
	end;

    call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | not_updated | check_pvexp);

    if vol_list.name(fb_not_updated) ^= "" then do;		/* this is the only case to abort the request	*/
       if active_fnc then do;
	ret = "false";
	return;
	end;
       else call abort_proc(error_table_$action_not_performed, "^a", noaction_msg);
       end;

    /* process volumes specified */

    do i = 1 to vol_cnt;
       if volume(i).want_it then do;
          if ^(volume(i).noaction) then do;
	   vol_idx = volume(i).indx;
	   if pvexp_sw then do;
	      if svol_sw then do;
	         if vpe(vol_idx).secondary_vol then vol_idx = vpe(vol_idx).primary_idx;
	         do while (vol_idx ^= no_link);
		  vpe(vol_idx).pv_expire_date = pv_clock;
		  vpe(vol_idx).pv_expire = True;
     	            vol_idx = vpe(vol_idx).secondary_idx;
		  end;
	         end;
	      else do;
	         vpe(vol_idx).pv_expire = pvexp_sw;
	         vpe(vol_idx).pv_expire_date = pv_clock;
	         end;
	      vol_idx = volume(i).indx;
                end;
	   if state_dt_sw then do;
	      if vpe(vol_idx).secondary_vol then vol_idx = vpe(vol_idx).primary_idx;
	      do while (vol_idx ^= no_link);
	         vpe(vol_idx).state_date = state_dt_clock;
	         vol_idx = vpe(vol_idx).secondary_idx;
	         end;
	      vol_idx = volume(i).indx;
	      call move_into_state_date_order (vol_idx);
	      end;
	   if vpe(vol_idx).secondary_vol then vol_idx = vpe(vol_idx).primary_idx;
	   if expire_sw & vpe(vol_idx).state = allocated_state then do;
	         vpe(vol_idx).expire = True;
	         vpe(vol_idx).expire_date = exp_clock;
	         end;
             if comment_sw then vpe (vol_idx).comment = comment_str;
             end;
          end;		
       end;

    if active_fnc then  ret = "true";
    else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg);

end set_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

setup:	proc ;

/* Called by just about everyone to initialize things */

	     Pvolume, Ptvol, areap, retp, vpp = null();
	     lock = False;
	     code, ecode = 0;
	     active_fnc = False;
	     abort_proc = abort;
	     msg_proc = msg;
	     if subroutine then do;
		a_code = 0;
		myname = "manage_volume_pool_";
		error_rnt = a_error_rnt;
		vpp = a_vpp;
		if vpp ^= null() then do;
		     if volume_pool.version ^= volume_pool_version_3 then call check_first_then_convert();                         
		     call lock_volume_pool;
		end;
	     end;
	     else do;
	          noaction_cnt, total_cnt = 0;
		vol_msg_list, noaction_msg  = "";
		vol_list.name = "";
		vol_list.cnt = 0;
		free_sw, match_sw, most_recent, asterisk_sw = False;
		name_sw, sdt_sw, comment_sw, state_sw, alloc_sw, reserve_sw, free_sw, 
		        force_sw, fexp_sw, brief_sw, pvedt_sw, edt_sw, first_sw, last_sw, expire_sw, first_last_sw,
		        pvexp_sw, state_dt_sw, all_sw, totals_wanted, svol_sw, volume_sw, vs_sw, dfmt_sw, specified_states(*) = False;
		all_states, header_sw, header_to_be_printed = True;
		call cu_$arg_list_ptr (alp);
		call cu_$af_return_arg (narg, retp, retl, code);
		active_fnc = (code = 0);
		if active_fnc  then error_rnt = active_fnc_err_;
		else error_rnt = com_err_;
		myname = "manage_volume_pool";
		if active_fnc then get_arg = cu_$af_arg_ptr_rel;
		else get_arg = cu_$arg_ptr_rel;

		if narg = 0 then
arg_err:		     call abort_proc (0, "USAGE: manage_volume_pool key {-control_args}");
		call get_arg (1, ap, al, (0), alp);
		if bad_arg (arg) then goto arg_err;
		if arg = "use" | arg = "u" then goto END_SETUP;
		else call setup_pool_path("0"b);
		if volume_pool.version ^= volume_pool_version_3 then call check_first_then_convert();                         
		if lock_required() then call lock_volume_pool();
		areap = get_system_free_area_();
	     end;
END_SETUP:
	return;
end setup;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

setup_pool_path:   proc(have_pool_path);

/*  Two cases:                                                                                                */
/*    1)  have_pool_path is FALSE                                                                             */
/*      Called by setup and use_key procedures. Sets the default volume pool, which is person_id.volumes in   */
/*      the user's home_dir,                      						*/
/*      creating the pool if it doesn't exist.                                                                */
/*    2)  have_pool_path is TRUE                                                                              */
/*      Called by use_key procedure and set_pool_path entry.  Initiates the volume pool specified by arg      */
/*      creating the pool if it doesn't exist.                                                                */
/*											*/
/*  Variables vol_dir and vol_ename are set.                                                                  */

dcl have_pool_path		bit(1);

if have_pool_path then do;
   call expand_pathname_ (arg, vol_dir, vol_ename, code);
   if code ^= 0 then call abort_proc (code, "Unable to expand ^a", arg);
   end;

else do;   /* Use volume pool last referenced */ 
   if vol_dir = "" then do; /* no previous volume pool was referenced; set to default pool, */
       call user_info_$homedir (vol_dir);
       call user_info_ (vol_ename, "", "");
       end;  /* if vol_dir = "" */
   end;

call suffixed_name_$make (vol_ename, "volumes", vol_ename, code);
if code ^= 0 then call abort_proc (code, "Unable to construct volume pool name ^a.volumes.", vol_ename);

call initiate_file_ (vol_dir, vol_ename, RW_ACCESS, vpp, vp_bc, code);
if vpp = null then call create_pool();

if subroutine then a_vpp = vpp;

end setup_pool_path;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

test_key:		proc();

/* Procedure which handles the mvp command test key. */

dcl (volx, list_cnt, list_no_cnt,
     vol_cnt, i)			fixed bin;
dcl (yes, no)			bit(1);
dcl (test_vol_list,
     test_no_vol_list)		char(256) var;

/* The structure below describes the control arguments allowed for a given key.
   A control arg is valid when the bit is "1"b.  */

dcl 1 args_allowed			unaligned static int options(constant),
     (2  first			init ("1"b),
      2  last			init ("1"b),
      2  force			init ("0"b),
      2  vs			init ("1"b),
      2  com			init ("0"b),
      2  expire			init ("0"b),
      2  brief			init ("0"b),
      2  fexp			init ("0"b),
      2  match			init ("1"b),
      2  all			init ("0"b),
      2  pvexp			init ("1"b),
      2  alloc			init ("1"b),
      2  reserve			init ("1"b),
      2  free			init ("1"b),
      2  svol			init ("0"b),
      2  asterisk			init ("1"b),
      2  exp_dt			init ("0"b),
      2  pvexp_dt			init ("0"b),
      2  state_dt			init ("0"b)) bit(1);

     /* process control args */

    if narg < 2 then call abort_proc (error_table_$noarg, "^/Usage: mvp test {volume_names} {-control_args}");

     call process_ctl_args(addr(args_allowed), 2, vol_cnt);

     if asterisk_sw then 
       if (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, 
                                            "The asterisk '*' is obsolete. Use '-last'");
       else call msg_proc(-1, "The asterisk '*' is obsolete. Use '-last'");

     if volume_sw & (vs_sw | first_last_sw ) then call abort_proc(error_table_$inconsistent, 
         "volumes and ^[-vs ^]^[-first^;-last ^]", vs_sw, most_recent);

     specified_states(free_state) = free_sw;
     specified_states(allocated_state) = alloc_sw;
     specified_states(reserved_state) = reserve_sw;
     specified_states(pvexp_state) = pvexp_sw;

     if state_string = truebits then call abort_proc(error_table_$inconsistent,
        "^[ -free ^]^[-alloc ^]^[-reserve ^]^[-pvexp ^]", specified_states(free_state), specified_states(allocated_state),
        specified_states(reserved_state), specified_states(pvexp_state));

     if index(state_string, "1"b) = 0 then                /* set default */
        specified_states(free_state) = True;

    force_sw = True;			/* query feature is not used with test key		*/
    if vol_cnt = 0 then vol_cnt = 1;

    if asterisk_sw then do;
       tcnt = asterisk_cnt;
       allocate tvol in (based_area) set (Ptvol);
       tvol.want_it = False;
       call get_volumes_specified ("tested", specified_states, Ptvol, tcnt, vs_size, most_recent);
       end;	

    else if ^(volume_sw) then do;
       volume_cnt = vol_cnt;
       allocate volume in (based_area) set (Pvolume);
       call get_volumes_specified("tested", specified_states, Pvolume, vol_cnt, vs_size, most_recent);
       end;

    if volume_sw then  do;   /* volume names were specified */
       call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | check_pvexp);
       end;  

    if asterisk_sw then do;
       if ^(volume_sw) then do;
          vol_cnt = 0;
          volume_cnt = tcnt;
	allocate volume in (based_area) set (Pvolume);
	end;
       do i = 1 to tcnt;
          volume(vol_cnt + 1).name = tvol(i).name;
	volume(vol_cnt + 1).indx = tvol(i).indx;
	volume(vol_cnt + 1).want_it = tvol(i).want_it;
	vol_cnt = vol_cnt + 1;
          end;
       end;
    
    yes, no = False;
    test_vol_list, test_no_vol_list = "";
    list_cnt, list_no_cnt = 0;

    do i = 1 to vol_cnt;
       if volume(i).want_it & ^(volume(i).noaction) then do;
          volx = volume(i).indx;
          if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx;
          if specified_states (vpe(volx).state) then do;
             yes = True;
	   test_vol_list = test_vol_list || " " || rtrim(volume(i).name);
	   list_cnt = list_cnt +1;
	   end;
          else do;
	   no = True;
	   test_no_vol_list = test_no_vol_list || " " || rtrim(volume(i).name);
	   list_no_cnt = list_no_cnt + 1;
	   end;
          end;
       end;

    if active_fnc then do;
       if yes & no then ret = "false";
       else if yes then ret = "true";
       else ret = "false";  /* no  */
       end;
    else do;
       if noaction_msg ^= "" then call msg_proc (0, "^a", noaction_msg);

       if yes then 
          call msg_proc
            (-1, "^[^a: ^;^s^]Volume set^[s^]^a ^[are^;is^] ^[free^;^[reserved^;^[allocated^;pv_expired^]^]^].",
            (noaction_msg = ""), myname,
	  (list_cnt > 1), test_vol_list, (list_cnt > 1),
	  specified_states(free_state), specified_states(reserved_state),
	  specified_states(allocated_state), specified_states(pvexp_state));

       if no then 
          call msg_proc
            (-1, "^[^a: ^;^s^]Volume set^[s^]^a ^[is^;are^] not ^[free^;^[reserved^;^[allocated^;pv_expired^]^]^].",
            (^yes), myname, (list_no_cnt > 1), test_no_vol_list, (list_no_cnt = 1), 
	  specified_states(free_state), specified_states(reserved_state),
	  specified_states(allocated_state), specified_states(pvexp_state));
      end;

end test_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

time_string_: proc (time) returns (char (20));

dcl  time fixed bin (71);
dcl  time_char char (24) aligned;
     
     call date_time_ (time, time_char);
     return (substr(time_char, 1, 20));

end time_string_;


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

unlock_volume_pool: proc;

/* unlocks the volume pool */

     call set_lock_$unlock (volume_pool.lock, ecode);
     if ecode ^= 0 then do;
	if ecode = error_table_$lock_not_locked then ecode = 0;
	else call abort_proc (ecode, "Error unlocking volume pool ^a.",
	     path (vol_dir, vol_ename));
     end;
     lock = ^(ecode = 0);
     return;
end unlock_volume_pool;


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

use_key:      proc();
	    
/* Procedure which handles the mvp command use key. */

     if narg > 2 then call abort_proc (0, "USAGE: manage_volume_pool use {pathname}.");
     if narg = 1 then do;
        vol_dir, vol_ename = "";
        call setup_pool_path("0"b);
     end;
     else do;
        call get_arg (2, ap, al, code, alp);
        call setup_pool_path("1"b);
        end;

    if active_fnc then ret = path(vol_dir, vol_ename);

end use_key;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

volume_in_pool:  proc(vol_name, vol_idx) returns(bit(1));

/* Determines whether the volume specified by vol_name is in the pool, and returns true.
   vol_name:  name of the volume to be looked for. (input)
   vol_idx:   index of the volume found in the pool(output)
*/

dcl vol_name			char(*),
    (i, vol_idx)			fixed bin;

     if volume_pool.volume_count = 0 then return(False); /* no volumes yet in the pool */
     vol_idx = volume_pool.head;
     do while (vol_idx ^= no_link);
        if vpe (vol_idx).name = vol_name then return(True);
        if vpe(vol_idx).vs_count > 1 then do;
	 i = vpe(vol_idx).secondary_idx;
	 do while (i ^= no_link);
	    if vpe (i).name = vol_name then do;
	       vol_idx = i;				/* return secondary volume index 		*/
	       return(True);
	       end;
	    i = vpe(i).secondary_idx;
	    end;
           end;
        vol_idx = vpe(vol_idx).next;
        end;
     return(False);

end volume_in_pool;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

volume_in_volume_set:  proc(vol_name, primary_idx, vol_idx) returns(bit(1));

/* determines whether a volume specified by vol_name is in a given volume set.
   vol_name:  name of the volume to be looked for. (input)
   primary_idx: idx of primary volume of the set to be searched (input)   
   vol_idx:   index of the secondary volume found in the pool (output)
*/

dcl vol_name			char(*),
    (primary_idx, vol_idx)		fixed bin;

     vol_idx = vpe(primary_idx).secondary_idx;
     do while (vol_idx ^= no_link);
        if vpe (vol_idx).name = vol_name then return(True);
        vol_idx = vpe(vol_idx).secondary_idx;
        end;
     return(False);

end volume_in_volume_set;


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

yes_to_query:  proc(request_type, msg) returns(bit(1));

          /* Initializes the query_info structure and querys the user about continuing  a           */
	/*  given request or not.                                                                 */

dcl (request_type, msg)			char(*);
dcl EXPLAIN_FORCE_MSG                 char(163) int static options(constant) init(
                                        "A no reply aborts the key request.  A yes will perform the request on eligible
volume sets and a message printed listing the ones upon which no action was taken.");


     if msg = "" then
     call command_query_$yes_no(yes_sw, 0, "mvp", EXPLAIN_FORCE_MSG,
         "Some volumes requested cannot be ^a. Do you wish to continue?", request_type);

     else
     call command_query_$yes_no(yes_sw, 0, "mvp", EXPLAIN_FORCE_MSG, "^a Do you wish to continue?", msg);

     return (yes_sw);

end yes_to_query;
%page;
%include access_mode_values;
end manage_volume_pool;




		    merge_ascii.pl1                 07/12/88  1440.5rew 07/12/88  1435.0      171126



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





/****^  HISTORY COMMENTS:
  1) change(88-07-06,TLNguyen), approve(88-07-06,MCR7925),
     audit(88-07-08,Parisek), install(88-07-12,MR12.2-1055):
     Fix bug which prevents printing out an error message when lacking path
     argument for -output_file (-of) control argument.
                                                   END HISTORY COMMENTS */



merge_ascii: ma: proc;
	default (fixed&^precision&^constant) precision (21); /* DEFAULT 4*256K CHARS */
	default (constant&real&^decimal) binary;

/* Coded by RE Mullen, Fall '75  */
/* Recoded by RE Mullen, Spring '77 */
/* Added code for archive :: convention THVV 1980 */
/* Jay Pattin 11/10/80 made compare_ascii take -output_file */
/* Jay Pattin 6/30/82 added -extend, -truncate to cpa, cleaned up a little */
/* Jay Pattin 11/2/82 prevent -of file from being original in cpa. see TR13883 */
%page;
%include merge_ascii_info;
%page;
dcl  merge_ascii_ entry (ptr);
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$set_bc_seg entry (ptr, fixed bin, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*),
     fixed bin, ptr, fixed bin (35));
dcl (ioa_$ioa_switch, com_err_, com_err_$suppress_name) entry options (variable);
dcl  iox_$user_output ptr external;
dcl  iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)),
     iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
     iox_$close entry (ptr, fixed bin(35)),
     iox_$detach_iocb entry (ptr, fixed bin(35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*),
     fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  get_equal_name_$component entry (char (*), char (*), char (*), char (*), char (32), char (32), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  archive_$get_component entry (ptr, fixed bin (24), char (*), ptr, fixed bin (24), fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  unique_chars_ entry (bit(*)) returns(char(15));
dcl (error_table_$noarg,
     error_table_$inconsistent,
     error_table_$segknown,
     error_table_$zero_length_seg,
     error_table_$badopt,
     error_table_$rqover,
     error_table_$noentry) ext fixed bin (35);

dcl  cleanup condition;
dcl  record_quota_overflow condition;

dcl (me, operation) char (16) aligned;

dcl (addr, baseno, divide, index, null, rtrim, substr, unspec) builtin;

dcl (i, j, k) fixed bin;
dcl  nargs fixed bin;
dcl  of_arg fixed bin;
dcl  al fixed bin;
dcl  ap ptr;
dcl  attach_desc char (256);
dcl  arg char (al) based (ap);
dcl  dn char (168);
dcl  en char (32);
dcl  ct char (32);
dcl  first_name char (32);
dcl  first_cpt char (32);

dcl  code fixed bin (35);

dcl (edit_bit, have_tc_or_ex, extend, no_header, orig_bit, out_bit) bit (1);
dcl (MA, CPA) bit (1) init (""b);
dcl (first_is_orig, old_mins_ok, saw_minlines, saw_minchars) bit (1) init (""b); /* CPA compatibility switches */
dcl  (iocb_ptr, p) ptr;
dcl (bit_count, cpt_bc) fixed bin (24);
dcl  sx fixed bin;
dcl  expected char (32);
dcl 1 mai aligned like ma_info;

dcl  ch char (999) based;
						/* ENDCL */
%page;
	me = "merge_ascii";
	MA = "1"b;
	call cu_$arg_count (nargs, code);
	if code ^= 0 | nargs = 0 then do;
	     call com_err_$suppress_name (code, me, "Usage:  merge_ascii paths {-control_args}");
	     return;
	end;
	go to common;


compare_ascii: cpa: entry;
	me = "compare_ascii";
	CPA = "1"b;

	call cu_$arg_count (nargs, code);
	if code ^= 0 | nargs = 0 then do;		/* tell usage of cpa */
	     call com_err_$suppress_name (code, me, "Usage:  compare_ascii paths {-control_args}");
	     return;
	end;
						/* for cpa nums are minchars..minlines, if -minchars..minlines not given */
						/* for cpa first path is orig unless -orig or -no_orig given somewhere */
	of_arg = 0;
	first_is_orig = "1"b;
	old_mins_ok, extend = "1"b;
	have_tc_or_ex = "0"b;

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, ap, al, code);
	     if arg = "-orig" | arg = "-original" | arg = "-no_orig" | arg = "-no_original" then do;
		if ^first_is_orig then do;
		     call com_err_ (0, me, "Either -original or -no_original can be specified once.");
		     return;
		end;
		first_is_orig = ""b;
	     end;
	     else if arg = "-minlines" | arg = "-minchars" then do;
		old_mins_ok = ""b;
	     end;
	end;
%page;
common:
	unspec (mai) = ""b;
	mai.op_ptr = null ();
	mai.op_dirname, mai.op_ename = "";
	do i = 1 to ma_max_texts;
	     mai.textid (i) = substr (MA_TEXT_IDS, i, 1);	/* print id's in uppercase */
	     mai.tptr (i), mai.cp (i) = null ();
	end;
	mai.output_iocb_ptr = iox_$user_output;
	iocb_ptr = null ();
	on cleanup call ma_cleanup_handler;
	mai.abort_label = ABORT;
	mai.minlines = 2;
	mai.minchars = 25;
	first_name = "";
	no_header = ""b;

	i = 0;
	mai.lo = 3; mai.hi = 2;			/* seg1 is output, seg2 is orig, segs3+ are updates */
	do while (i < nargs);
	     i = i + 1;
	     out_bit, orig_bit, edit_bit = ""b;		/* dont know what it is, yet */

	     call cu_$arg_ptr (i, ap, al, code);
	     if ^CPA then goto COMMON_ARGS;
	     if arg = "-totals" | arg = "-total" | arg = "-tt" then mai.totals_only = "1"b;
	     else if arg = "-no_totals" | arg = "-no_total" | arg = "-ntt" then mai.no_totals = "1"b;
	     else if arg = "-extend" then have_tc_or_ex, extend = "1"b;
	     else if arg = "-truncate" | arg = "-tc" then do;
		extend = "0"b;
		have_tc_or_ex = "1"b;
	     end;
	     else if arg = "-header" | arg = "-he" then do;
		mai.print_heading = "1"b;
		no_header = "0"b;
	     end;
	     else if arg = "-no_header" | arg = "-nhe" then no_header = "1"b;
	     else if arg = "-no_numbers" | arg = "-no_number" | arg = "-nnb" then mai.no_line_numbers = "1"b;
	     else if arg = "-print_new_lines" | arg = "-pnl" then mai.print_new_lines = "1"b;
	     else if arg = "-no_output_file" | arg = "-nof" then mai.output_iocb_ptr = iox_$user_output;
	     else if arg = "-no_orig" | arg = "-no_original" then;
						/* if CPA then we've already noticed this arg */
	     else 
COMMON_ARGS:	if arg = "-minlines" | arg = "-minchars" then do;
		expected = substr (arg, 2);		/* note what we expect */
		i = i + 1;
		call cu_$arg_ptr (i, ap, al, code);
		if code ^= 0 then do;
NOARG:		     call com_err_ (code, me, "^a", expected);	/* tell whats missing */
		     go to ABORT;
		end;
		k = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
BADNUM:		     call com_err_ (0, me, "Invalid ^a value: ""^a""", expected, arg);
		     go to ABORT;
		end;
		if k <= 0 then go to BADNUM;
		if expected = "minlines" then mai.minlines = k;
		else mai.minchars = k;
	     end;
	     else if index (arg, "-") = 1 then do;	/* -something path */
		if MA & (arg = "-old_original" | arg = "-old_orig") then do;
		     mai.convergence_ok = "1"b;
		     go to ORIG;
		end;
		else if arg = "-original" | arg = "-orig" then do;
ORIG:
		     expected = "original";
		     if mai.have_orig then go to ONLYONE;
		     mai.have_orig, orig_bit = "1"b;
		end;
		else if arg = "-output_file" | arg = "-of" then do;
		     expected = "output";
		     if mai.have_output then do;
ONLYONE:
			call com_err_ (0, me, "Only one ^a segment can be specified.", expected);
			go to ABORT;
		     end;

		     of_arg = i + 1;                    /* prepare to get the path argument for -output_file control argument */
		     if of_arg > nargs then do;
			call com_err_ (0, me, "Missing path argument for ^a control argument.", arg);
			goto ABORT;
		     end;

		     mai.have_output, out_bit = "1"b;
		end;
		else if MA & arg = "-edit" then do;
		     expected = "edit";
		     mai.have_edit, edit_bit = "1"b;
		end;
		else do;				/* -crap */
BAD_ARG:		     call com_err_ (error_table_$badopt, me, "^a", arg);
		     go to ABORT;
		end;
		i = i + 1;
		if ^(CPA & out_bit) then do;		/* Don't process cpa output path until end. */
		     call cu_$arg_ptr (i, ap, al, code);
		     if code ^= 0 then go to NOARG;	/* should have been path */
		     call PROCESS_PATH;
		end;
	     end;
	     else if ^old_mins_ok then call PROCESS_PATH; /* must be vanilla path */
	     else do;				/* a vanilla path or a vanilla number */
		k = cv_dec_check_ (arg, code);
		if code ^= 0 then call PROCESS_PATH;
		else do;				/* a number */
		     if ^saw_minchars then do;
			saw_minchars = "1"b;
			mai.minchars = k;
			expected = "minchars";
		     end;
		     else if ^saw_minlines then do;
			saw_minlines = "1"b;
			mai.minlines = k;
			expected = "minlines";
		     end;
		     else go to BAD_ARG;
		     if k <= 0 then go to BADNUM;
		end;
	     end;
	end;					/* end arg loop */
%page;
/* GLOBAL ARG CHECKS */

	if mai.lo ^< mai.hi then do;			/* (orig&no_upd) | (no_orig&one_upd) is dumb */
	     call com_err_ (0, me, "Not enough texts supplied.");
	     go to ABORT;
	end;

	if have_tc_or_ex & ^mai.have_output then do;
	     call com_err_ (error_table_$inconsistent, me, "-extend and -truncate may only be used with -output_file.");
	     return;
	end;

	if CPA & mai.have_output then do;                 /* my name is compare_ascii and -output_file (-of) is specified */
	     out_bit = "1"b;

	     call cu_$arg_ptr (of_arg, ap, al, code);     /* get path argument for -output_file (-of) control argument */
	     if code ^= 0 then do;
		call com_err_ (code, me);
		goto ABORT;
	     end;

	     if index (arg, "-") = 1 then do;              /* the first character of arg value is a hyphen. */
                                                             /* example: cpa path1 path2 -of */
		call com_err_ (error_table_$noarg, me, "^/Missing path argument for -output_file (-of) control argument.  Found ^a", arg);
		goto ABORT;
	     end;

	     call PROCESS_PATH;
	     if ^no_header then mai.print_heading = "1"b;
	     if extend then attach_desc = rtrim (attach_desc) || " -extend";
	     call iox_$attach_name (unique_chars_ ("0"b) || ".cpa", iocb_ptr, attach_desc, null (), code);
	     call iox_$open (iocb_ptr, 2, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, me, "Attaching ^a.", arg);
		goto ABORT;
	     end;
	     mai.output_iocb_ptr = iocb_ptr;
	     mai.have_output = "0"b;		/* so merge_ascii_ knows this is a compare */
	end;

	if MA & ^mai.have_output then do;
	     code = error_table_$noarg;
	     expected = "output_file";
	     go to NOARG;
	end;

	if mai.print_new_lines & ^mai.have_orig then do;
	     call com_err_ (0, me, "An original must be supplied to use print_new_lines feature");
	     go to ABORT;
	end;

	do i = mai.lo to mai.hi;
	     if mai.have_output then if mai.op_ptr ^= null () then
		if baseno (mai.op_ptr) = baseno (mai.tptr (i)) then do; /* Output must not be same as input */
		     dn = mai.op_dirname;
		     en = mai.op_ename;
		     ct = "";
		     go to SAMESEG;
		end;
	     do j = i + 1 to mai.hi;			/* No two inputs must be same */
		if mai.tptr (i) = mai.tptr (j) then do;
		     dn = mai.dirname (j);
		     en = mai.ename (j);
		     ct = mai.component (j);
SAMESEG:		     call com_err_ (0, me, "^a^[>^]^a^[::^a^;^s^] is the same segment as ^a^[>^]^a^[::^a^;^s^]",
			dn, (dn ^= ">"), en, (ct ^= ""), ct,
			mai.dirname (i), (mai.dirname (i) ^= ">"), mai.ename (i), (mai.component (i) ^= ""), mai.component (i));
		     go to ABORT;
		end;
	     end;
	end;
%page;
/* START WORK */

	if mai.print_heading then do;
	     do i = mai.lo to mai.hi;
		if mai.tptr (i) ^= null () then do;
		     call ioa_$ioa_switch (mai.output_iocb_ptr, "^a ^a^[>^]^a^[::^a^;^s^] (^[original^;new^])",
			mai.textid (i), mai.dirname (i), (mai.dirname (i) ^= ">"), mai.ename (i),
			(mai.component (i) ^= ""), mai.component (i), (i = 2));
		end;
	     end;
	end;

	call merge_ascii_ (addr (mai));

/* if merge then copy to target segment */
	if mai.have_output then do;			/* now must move output to target */
	     if mai.op_ptr = null () then do;		/* output seg not exist yet */
		call hcs_$make_seg ((mai.op_dirname), (mai.op_ename), "", 01011b, mai.op_ptr, code);
		if mai.op_ptr = null then goto OP_ERR;	/* can't create it! */
	     end;
	     else do;				/* output seg already exists */
		call hcs_$truncate_seg (mai.op_ptr, 0, code); /* check access & save paging */
		if code ^= 0 then go to OP_ERR;	/* access bad, vanished? */
	     end;
	     on record_quota_overflow begin;		/* now target exists, prepare to copy */
		code = error_table_$rqover;
		go to OP_ERR;
	     end;
	     substr (mai.op_ptr -> ch, 1, mai.tchars (1)) = substr (mai.tptr (1) -> ch, 1, mai.tchars (1));
	     call hcs_$set_bc_seg (mai.op_ptr, 9*mai.tchars (1), code); /* finally done */
	     if code ^= 0 then do;			/* unlikely .. */
OP_ERR:		call hcs_$set_bc_seg (mai.tptr (1), 9*mai.tchars (1), 0); /* come here if trouble with output seg */
		call com_err_ (code, me,
		     "^a^[>^]^a", mai.op_dirname, (mai.op_dirname ^= ">"), mai.op_ename);
		call com_err_ (0, me, "Merged output is in ^a>^a",
		     mai.dirname (1), mai.ename (1));
	     end;
	     else do;				/* successful copy, delete temp */
		call hcs_$delentry_seg (mai.tptr (1), code);
		if code ^= 0 then call com_err_ (code, me, "Could not delete ^a>^a", mai.dirname (1), mai.ename (1));
	     end;
	end;
						/* make soothing noise */
	if ^mai.no_totals then do;
	     if CPA then operation = "Comparison"; else operation = "Merge";
	     if CPA & mai.total_differences = 0 then call ioa_$ioa_switch (mai.output_iocb_ptr, "Segments are identical.");
	     else call ioa_$ioa_switch (mai.output_iocb_ptr, "^a finished: ^d difference^[s^], ^d line^[s^].",
		operation,
		mai.total_differences, (mai.total_differences ^= 1),
		mai.total_lines_differing, (mai.total_lines_differing ^= 1));
	end;
	call ma_cleanup_handler;			/* clean up address space etc */
	return;

ABORT:						/* come here for failure exit */
	if mai.tptr (1) ^= null ()
	then call hcs_$delentry_seg (mai.tptr (1), code);
	call ma_cleanup_handler;			/* failure leave address space clean */
	return;

/* ------------------------------------------------------------ */


ma_cleanup_handler: proc;				/* IP to cleanup */
	     do i = 2 to ma_max_texts;
		if mai.tptr (i) ^= null () then
		     call hcs_$terminate_noname (mai.tptr (i), code);
	     end;
	     if mai.op_ptr ^= null () then
		call hcs_$terminate_noname (mai.op_ptr, 0);

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

	end ma_cleanup_handler;
%page;
PROCESS_PATH: proc;					/* IP to deal with pathname, switches already set */

dcl cpt_ptr ptr;
dcl cpt char (32);
dcl (sname, scpt) char (32);				/* results of equal processing */

	     cpt = "";				/* can't have output in archive */
	     if out_bit then call expand_pathname_ (arg, dn, en, code);
	     else call expand_pathname_$component (arg, dn, en, cpt, code);
	     if code ^= 0 then do;
ARG_ERR:
		call com_err_ (code, me, "^a", arg);
		go to ABORT;
	     end;

	     if first_name = "" then do;
		first_name = en;			/* first_name is template for equal conv */
		first_cpt = cpt;
		if first_is_orig then do;		/* if f_i_o then first path is orig */
		     mai.have_orig, orig_bit = "1"b;	/* so simulate preceding "-orig" arg */
		     expected = "original";
		end;
	     end;
	     else do;				/* all but first ename get equal conv */
		call get_equal_name_$component (first_name, first_cpt, en, cpt, sname, scpt, code);
		if code ^= 0 then do;
		     call com_err_ (code, me, "^a^[::^a^;^s^] ^a^[::^a^;^s^]",
			first_name, (first_cpt ^= ""), first_cpt, en, (cpt ^= ""), cpt);
		     go to ABORT;
		end;
		en = sname;			/* replace by expanded name */
		cpt = scpt;
	     end;

	     if out_bit then do;
		if CPA then do;
		     attach_desc = "vfile_ " || rtrim (dn) || ">" || en;
		     return;
		end;
		
		else do				/* attempt to initiate real output segment now */
						/* if it does not exist we will create it later */
						/* if is does exist we will compare the pointer to input segments */
		     mai.op_dirname = dn;
		     mai.op_ename = en;
		     call hcs_$initiate_count ((mai.op_dirname), (mai.op_ename), "", 0, 0, mai.op_ptr, code);
		     if code ^= 0 then
			if code ^= error_table_$noentry then
			if code ^= error_table_$segknown then do;
				call com_err_ (code, me, "^a^[>^]^a", dn, (dn ^= ">"), en);
				go to ABORT;
			end;
		     sx = 1;
						/* also create temporary seg for output */
		     dn = "[pd]";
		     en = "ma_temp." || rtrim (mai.op_ename);
		     call hcs_$make_seg ("", en, "", 01011b, p, code);
		     if p = null () then do;
PATH_ERR:			call com_err_ (code, me, "^a^[>^]^a", dn, (dn ^= ">"), en);
			go to ABORT;
		     end;
		     mai.tptr (1) = p;
		end;
	     end;					/* out_bit processing done */
	     else do;				/* name of input seg */
		if orig_bit then sx, mai.lo = 2;		/* note seg_index for later */
		else do;				/* some updated version */
		     mai.hi = mai.hi + 1;
		     if mai.hi > ma_max_texts then do;
			call com_err_ (0, me, "Only six versions and one original can be merged or compared.");
			go to ABORT;
		     end;
		     sx = mai.hi;
		end;
		p = null ();
		call hcs_$initiate_count (dn, en, "", bit_count, 0, p, code);
		if p = null () then go to PATH_ERR;
		mai.tptr (sx) = p;			/* set ptr now */
		if bit_count = 0 then do;
		     code = error_table_$zero_length_seg;
		     go to PATH_ERR;
		end;
		mai.tchars (sx) = divide (bit_count+8, 9, 17, 0);
		if edit_bit then mai.edit (sx) = "1"b;
		mai.len (sx) = mai.tchars (sx);
		if cpt ^= "" then do;		/* read archive? */
		     call archive_$get_component (p, bit_count, cpt, cpt_ptr, cpt_bc, code);
		     if code ^= 0 then do;
			call com_err_ (code, me, "^a^[>^]^a::^a", dn, (dn ^= ">"), en, cpt);
			go to ABORT;
		     end;
		     p, mai.tptr (sx) = cpt_ptr;		/* set ptr to archive element */
		     mai.tchars (sx), mai.len (sx) = divide (cpt_bc+8, 9, 17, 0);
		end;
	     end;
	     mai.cp (sx) = mai.tptr (sx);			/* fill in info structure */
	     mai.line (sx) = 1;
	     mai.dirname (sx) = dn;
	     mai.ename (sx) = en;
	     mai.component (sx) = cpt;

	end PROCESS_PATH;

     end merge_ascii;




		    merge_ascii_.pl1                11/04/82  1951.6rew 11/04/82  1627.6       59526



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


merge_ascii_: proc (a_maip); default (fixed&^precision&^constant) precision (21); /* DEFAULT */
default (constant&real&^decimal) binary;

/* Subroutine implementing top level of merge/compare subsystem. */
/* It is called with a pointer to a main control structure. */
/* It may pass that pointer to procs it calls */
/* This subroutine is not externally available.  The interface can change. */

/* Re-coded Spring '77 RE Mullen */

dcl  a_maip ptr;					/* parameter */

dcl  ch char (999) based;
dcl  skipchars (0:1) char (1) unal based;
dcl (i, j, k) fixed bin;
dcl  code fixed bin (35);
dcl  NL char (1) init ("
");

dcl (ioa_, ioa_$nnl) entry options (variable);
dcl (iox_$user_input, iox_$user_output) ptr ext;
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));

dcl (ma_resynch_, ma_analyze_) entry (ptr);

dcl (addr, index, substr) builtin;

/*  */

%include merge_ascii_info;
/*  */


	ma_info_ptr = a_maip;			/* pointer at least to automatic */


	call find_same_at_start;			/* skip over matching chars at start */
	if have_output then call take_same;		/* pick up any found */
	call skip_same;				/* skip over those chars */



	do while (^ma_info.eof);
	     call ma_resynch_ (ma_info_ptr);		/* sets synchlen, difflen(*), eof, etc */

	     total_differences = total_differences + 1;	/* keep change counters */
	     do i = lo to hi;
		total_lines_differing =
		     total_lines_differing + difflines (i);
	     end;

	     if ^totals_only | have_output then
		call ma_analyze_ (ma_info_ptr);	/* print diff, auto-take, call editor */

	     call skip_diff;			/* advance past difflen(*) chars */

	     if have_output then call take_same;	/* pick up synchlen chars */

	     call skip_same;			/* advance past synchlen chars */
	end;

	return;					/* all done */

/*  */
find_same_at_start: proc;				/* IP to skip over matching lines */
dcl (ssj, ssk) fixed bin;
dcl  lo_cp ptr;
dcl  lo_len fixed bin;
dcl  same_len bit (1);


/* The objective of the following code is to determine the number of matching
   lines.  In order to avoid indexing into all segments, we index for newlines
   only in the lowest segment and then compare those characters, including the
   newline (if any), with the corresponding characters in the other segments.
   If all compares come out equal, we have found one more matching line.
   For this scheme to work we must not reference past the
   end of any segment, so we compute the min of all lengths.  If in text(lo)
   we ever fail to find a newline then the end of text(lo) cannot match the other
   texts unless they are all of the same length */

	     synchlen = 0;				/* skipped no chars yet */
	     synchlines = 0;			/* skipped no lines yet */

	     lo_cp = cp (lo);
	     lo_len = len (lo);


/* Set lo_len to the minimum remaining length in any text */
	     same_len = "1"b;
	     do ssk = lo + 1 to hi;
		if len (ssk) < lo_len then do;	/* found unequal and shorter text */
		     lo_len = len (ssk);		/* note new, lower min len */
		     same_len = ""b;		/* note all lengths not the same */
		end;
	     end;

/* Step through text(lo) line by line.  Compare each line to text in
   other texts.  Whenever any other text differs we have found what is the same */
ss_loop:
	     ssj = index (substr (lo_cp -> ch, synchlen + 1, lo_len - synchlen), NL); /* get current line length */
	     if ssj = 0 then do;			/* no new line found */
		if same_len then ssj = lo_len - synchlen; /* else get matching partial lines, not at EOF .. */
		if ssj = 0 then go to ss_done;
	     end;
	     do ssk = lo + 1 to hi;			/* see if lines all match */
		if substr (lo_cp -> ch, synchlen + 1, ssj) ^= substr (cp (ssk) -> ch, synchlen + 1, ssj)
		then go to ss_done;
	     end;
	     synchlen = synchlen + ssj;		/* count more chars */
	     synchlines = synchlines + 1;		/* count this line */
	     go to ss_loop;				/* try for another */

ss_done:						/* here when cant match one more line */

	end find_same_at_start;


/*  */
skip_diff: proc;					/* IP to skip over (processed) differences */

dcl  sdi fixed bin;

	     do sdi = lo to hi;			/* for each input seg */
		cp (sdi) = addr (cp (sdi) -> skipchars (difflen (sdi))); /* advance ptr */
		line (sdi) = line (sdi) + difflines (sdi); /* advance linno */
		len (sdi) = len (sdi) - difflen (sdi);	/* decrease remaining len */
	     end;

	end skip_diff;


skip_same: proc;					/* IP to skip over synched block */

dcl  ssx fixed bin;

	     eof = "1"b;				/* assume we are not at eof */
	     do ssx = lo to hi;			/* for each input seg */
		len (ssx) = len (ssx) - synchlen;	/* decrement remaining length */
		if len (ssx) > 0 then eof = ""b;	/* note if at eof */
		line (ssx) = line (ssx) + synchlines ;	/* increment linno */
		cp (ssx) = addr (cp (ssx) -> skipchars (synchlen)); /* advance pointer */
	     end;

	end skip_same;


take_same: proc;					/* IP to pick up unchanged text */

	     substr (cp (1) -> ch, 1, synchlen)		/* copy text */
		= substr (cp (lo) -> ch, 1, synchlen);	/* grab chars */
	     tlines (1) = tlines (1) + synchlines;	/* increment output linno */
	     tchars (1) = tchars (1) + synchlen;	/* increment output charcount */
	     cp (1) = addr (cp (1) -> skipchars (synchlen)); /* bump pointer */

	end take_same;


/*  */

/* print_diff: proc;	         /* temporary IP to print diffs, fo debugging */
/*
   /*dcl (pdi, pdj, pdk) fixed bin;
   /*
   /*     do pdi = lo to hi;
   /*        call iox_$put_chars (iox_$user_output, cp (pdi), difflen (pdi), code);
   /*     end;
   /*
   /*  end print_diff;
   /*dump: proc;	         /* IP to dump key vars */
/* dcl  di fixed bin;
   /*     call ioa_ ("^/  sx  tptp  tch  tlines     cp            len  line  dlen  dlin  same");
   /*     do di = lo to hi;
   /*
   /*        call ioa_ ("^4d: ^p ^4d ^4d      ^p	 ^4d ^4d  ^4d ^4d  ^4d",
   /*	 di, tptr (di), tchars (di), tlines (di),
   /*	 cp (di), len (di), line (di),
   /*	 difflen (di), difflines (di),
   /*	 same_as (di));
   /*     end;
   /*
   /*  end dump;
*/
     end merge_ascii_;




		    overlay.pl1                     02/02/88  1716.5r w 02/02/88  1540.0       98478



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

overlay: ov: proc;

/* OVERLAY - overlay multiple segments.

   THVV */
/* Usage message with no args; reject bad control args 08/14/80 S. Herbst */
/* Change -in to -ind, add clean_up handler, rename variables 02/18/82 L. Baldwin */
/* Change to allow the archive convention.  07/08/84 R. Roach */

%include prt_conv_info;
%include access_mode_values;

dcl  BEAD_COUNT fixed bin;
dcl  NL char (1) int static options (constant) init ("
"),
     NLVTFF char (3) int static options (constant) init ("
"),
     SP char (1) int static options (constant) init (" "),
     BS char (1) int static options (constant) init (""),
     VT char (1) int static options (constant) init (""),
     FF char (1) int static options (constant) init ("");

dcl  obuf char (BEAD_COUNT+1) based (obuf_ptr) aligned;
dcl  system_area area (1024) based (area_ptr);
dcl 1 bead (BEAD_COUNT) based (bead_ptr) aligned,
    2 loc fixed bin (26) unal,
    2 char char (1) unal;
dcl  seg char (curr_seg_len) based (curr_seg_ptr) aligned;
dcl  arg char (arg_len) based (arg_ptr) unaligned;

dcl  slew char (1);
dcl  cpt char (32);
dcl  en char (32);
dcl  dn char (168);
dcl  obuf_storage char (513);
dcl  output char (4096);

dcl  eof (10) bit (1);

dcl (area_ptr, arg_ptr, bead_ptr, obuf_ptr, curr_ptr, curr_seg_ptr) ptr;
dcl  info_ptr (10) ptr;
dcl  seg_ptr (10) ptr init ((10) null);
dcl (temp_ptr, temp1_ptr) ptr init (null);

dcl (arg_count, arg_no, arg_len) fixed bin;
dcl (i, ii, j, k, m, n) fixed bin;
dcl  nchars fixed bin;
dcl (next_line, curr_line) fixed bin;
dcl  neof fixed bin;
dcl  file_count fixed bin;
dcl  col_no fixed bin;
dcl  nxline (10) fixed bin init ((10)0);
dcl  ocount fixed bin;
dcl  offset (10) fixed bin;
dcl  page_len fixed bin init (60);
dcl  storage (512) fixed bin;

dcl  io fixed bin (21);
dcl  curr_seg_len fixed bin (21);
dcl  seg_len (10) fixed bin (21);
dcl  line_no (10) fixed bin (21);
dcl  bit_count fixed bin (24);
dcl  code fixed bin (35);

dcl  error_table_$badopt fixed bin (35) ext;
dcl  iox_$user_output ptr ext;
dcl  print_conv_$print_conv_ ext;

dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  expand_pathname_$component entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  prt_conv_ entry (ptr, fixed bin, ptr, fixed bin, ptr);

dcl (addr, divide, hbound, length, min, mod, null, search, string, substr, unspec) builtin;
dcl  cleanup condition;

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

	area_ptr = get_system_free_area_ ();

	file_count = 0;
	BEAD_COUNT = hbound (storage, 1);		/* set the initial values */
	bead_ptr = addr (storage);
	obuf_ptr = addr (obuf_storage);

	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, "overlay");
	     return;
	end;
	if arg_count = 0 then do;
	     call com_err_$suppress_name (0, "overlay", "Usage:  overlay paths {-control_args}");
	     return;
	end;

	do arg_no = 1 to arg_count;
	     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
	     if arg = "-page_length" | arg = "-pl" then do;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
		if code ^= 0 then do;
ERROR:		     call com_err_ (code, "overlay", "^a", arg);
		     return;
		end;
		page_len = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     call com_err_ (0, "overlay", "Invalid integer argument ^a for -page_length", arg);
		     return;
		end;
	     end;
	     else if arg = "-indent" | arg = "-ind" | arg = "-in" then do;
		arg_no = arg_no + 1;
		call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
		if code ^= 0 then go to ERROR;
		offset (file_count) = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     call com_err_ (0, "overlay", "Invalid integer argument ^a for -indent", arg);
		     return;
		end;
	     end;
	     else if substr (arg, 1, 1) = "-" then do;
		code = error_table_$badopt;
		go to ERROR;
	     end;
	     else do;
		file_count = file_count + 1;
		if file_count > hbound (seg_ptr, 1) then do;
		     call com_err_ (0, "overlay", "Number of files exceeds implementation maximum of ^d", hbound (seg_ptr, 1));
		     return;
		end;

		call expand_pathname_$component (arg, dn, en, cpt, code);
		if code ^= 0 then go to ERROR;

		allocate pci set (info_ptr (file_count)) in (system_area);
		call init_pci (info_ptr (file_count));

		offset (file_count) = 0;
		line_no (file_count) = 1;
		seg_ptr (file_count) = null;

		call initiate_file_$component (dn, en, cpt, R_ACCESS, seg_ptr (file_count), bit_count, code);
		if code ^= 0 then go to ERROR;
		seg_len (file_count) = divide (bit_count, 9, 17, 0);
	     end;
	end;

	if file_count = 0 then do;
	     call com_err_$suppress_name (0, "overlay", "Usage:  overlay paths {-control_args}");
	     return;
	end;

	on cleanup call clean_up;

	do i = 1 to file_count;
	     info_ptr (i) -> pci.page_length = page_len;
	     info_ptr (i) -> pci.phys_page_length = page_len;
	     info_ptr (i) -> pci.overflow_off = "0"b;
	end;

	neof = 0;					/* Initialize counters */
	curr_line = 1;
	eof (*) = "0"b;

	do while (neof < file_count);			/* Stop when end of all input */

	     nchars = 0;				/* number of chars in this line */
	     next_line = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0);

	     do i = 1 to file_count;			/* Take input from all segs */
		if eof (i) then go to SKIP;
		if curr_line < nxline (i) then go to SKIP;

		curr_seg_len = seg_len (i);		/* Get input seg length */
		curr_seg_ptr = seg_ptr (i);		/* .. ptr */
		curr_ptr = addr (substr (seg, line_no (i), 1)); /* .. ptr to current loc */
		n = search (substr (seg, line_no (i)), NLVTFF); /* .. loc of end of input line */
		if n = 0 then n = seg_len (i) - line_no (i);
		line_no (i) = line_no (i) + n;
		if line_no (i) >= seg_len (i) then do;
		     eof (i) = "1"b;		/* ignore this seg from now on */
		     neof = neof + 1;
		end;

		do while (n > 0);			/* Normalize line */
		     call prt_conv_ (curr_ptr, n, addr (obuf), ocount, info_ptr (i));
		     do j = 1 to ocount-1;
			if substr (obuf, j, 1) ^= " " then do;
			     nchars = nchars + 1;	/* Save each character */
			     if nchars > BEAD_COUNT then call MORE_ROOM;
			     bead (nchars).char = substr (obuf, j, 1);
			     bead (nchars).loc = j + offset (i);
			end;
		     end;
		end;

		slew = substr (obuf, ocount, 1);	/* Deal with slew */
		if slew = FF then do;
		     nxline (i) = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0);
		end;
		else if slew = VT then do;
		     nxline (i) = 1 + 10 * divide (curr_line+9, 10, 17, 0);
		end;
		else if slew = NL then do;		/* Can reach vertical tabstop via NL's */
		     nxline (i) = curr_line+1;
		end;
		next_line = min (next_line, nxline (i));
SKIP:	     end;					/* End loop on input files. one line assembled */
	     call sort;				/* Order chars on line */
	     io = 0;				/* output counter */
	     col_no = 1;				/* column */
	     do k = 1 to nchars;			/* put out all chars */
		m = bead (k).loc - col_no;		/* compute white space */
		if m > 0 then do ii = 1 to m;		/* if going right */
		     io = io + 1;
		     substr (output, io, 1) = SP;
		end;
		if m < 0 then do;			/* if going left (should be only one) */
		     io = io + 1;
		     substr (output, io, 1) = BS;
		end;
		io = io + 1;			/* Now put out char */
		substr (output, io, 1) = bead (k).char;
		col_no = bead (k).loc + 1;		/* remember last used column */
	     end;
	     io = io + 1;				/* output slew char */
	     if next_line = curr_line+1 then substr (output, io, 1) = NL;
	     else if mod (next_line-1, page_len) = 0 then substr (output, io, 1) = FF;
	     else substr (output, io, 1) = VT;
	     call iox_$put_chars (iox_$user_output, addr (output), io, (0));
	     curr_line = next_line;

	end;

	call clean_up;
	return;

/* ------------------------------------------------------- */

sort:	proc;

dcl  temp fixed bin;
dcl  swaps fixed bin;
dcl  d fixed bin;
dcl  i fixed bin;

dcl  vec (BEAD_COUNT) fixed bin based (bead_ptr);

	     d = nchars;
PASS:	     swaps = 0;
	     d = divide (d + 1, 2, 17, 0);
	     do i = 1 to nchars - d;
		if vec (i) > vec (i+d) then do;
		     swaps = swaps + 1;
		     temp = vec (i);
		     vec (i) = vec (i+d);
		     vec (i+d) = temp;
		end;
	     end;
	     if d > 1 then go to PASS;
	     if swaps > 0 then go to PASS;

	end sort;

init_pci:	proc (p);

dcl  p ptr;

	     unspec (p -> pci) = "0"b;		/* clear everything */
	     p -> pci.cv_proc = addr (print_conv_$print_conv_);
	     p -> pci.level = 0;
	     p -> pci.pos = 0;
	     p -> pci.lmarg = 0;
	     p -> pci.rmarg = length (obuf) - 1;
	     p -> pci.phys_line_length = length (obuf) - 1;
	     p -> pci.page_length = 60;
	     p -> pci.phys_page_length = 66;
	     p -> pci.lpi = 6;
	     p -> pci.sheets_per_page = 1;
	     p -> pci.line_count = 0;
	     p -> pci.page_count = 0;
	     string (p -> pci.modes) = ""b;
	     p -> pci.top_label_line = "";
	     p -> pci.bot_label_line = "";
	     p -> pci.top_label_length = 0;
	     p -> pci.bot_label_length = 0;
	     p -> pci.line = 1;
	     p -> pci.slew_residue = 0;
	     p -> pci.label_nelem = 0;
	     p -> pci.sav_pos = 0;
	     p -> pci.func = 0;
	     p -> pci.temp = "0"b;
	     p -> pci.overflow_off = "1"b;

	end init_pci;

MORE_ROOM: proc;

dcl  k fixed bin;

	     k = BEAD_COUNT;
	     BEAD_COUNT = 2*BEAD_COUNT;
	     allocate bead set (temp_ptr) in (system_area);
	     allocate obuf set (temp1_ptr) in (system_area);
	     BEAD_COUNT = k;
	     temp_ptr -> bead = bead;
	     temp1_ptr -> obuf = obuf;
	     if bead_ptr ^= addr (storage) then free bead;
	     if obuf_ptr ^= addr (obuf_storage) then free obuf;
	     BEAD_COUNT = 2*BEAD_COUNT;
	     bead_ptr = temp_ptr;
	     obuf_ptr = temp1_ptr;

	end MORE_ROOM;

clean_up:	proc;

	     do i = 1 to file_count;
		if seg_ptr (i) ^= null then call hcs_$terminate_noname (seg_ptr (i), code);
		free info_ptr (i) -> pci;
	     end;
	     if temp_ptr ^= null then free bead;
	     if temp1_ptr ^= null then free obuf;

	end clean_up;

     end overlay;




		    print_conv_.alm                 02/02/88  1716.5r w 02/02/88  1538.1       27522



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" PRINT_CONV_ - Conversion for for producing canonical output
"	coded 11/4/74 by Noel I. Morris
"         borrowed by thvv


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


	include	prt_conv_info




	name	print_conv_

	segdef	print_conv_

	tempd	pointer
	temp	char,line,tabstop,residue

print_conv_:
	tra	print_send_init
	tra	print_send_chars
	tra	print_send_slew_pattern
	tra	print_send_slew_count

" 
" Entry called at beginning of conversion

print_send_init:
	ldq	lb|pci.line	get current line
	sbq	1,dl		.. cause tabs are at 11 ...
	stq	line
	div	10,dl		compute starting tabstop
	stq	tabstop
	sta	residue
	tra	sb|0		return

" 

print_send_chars:
	eax2	0,2		set indicators from X2
	tmoz	nospace		if no white space, skip following

	mlr	(),(pr,rl),fill(040)  insert blanks into output
	desc9a	*,0		..
	desc9a	bb|0,x2		..

	a9bd	bb|0,2		step output pointer over blanks
	eax2	0		set white space count back to zero

nospace:	mlr	(pr,rl),(pr,rl)	copy characters into output
	desc9a	bp|0,au		..
	desc9a	bb|0,au		..

	a9bd	bp|0,au		step input and output pointers
	a9bd	bb|0,au		..

	tra	sb|0		return to caller

" 

print_send_slew_pattern:
	eax7	0		initialize for search
	rpt	nslew/2,2,tze	search for slew characters
	cmpa	slew,7		..
	lda	-1,7
	sta	char
stslew:	mlr	(pr),(pr)
	desc9a	char,1
	desc9a	bb|0,1
	ldq	1,dl
	a9bd	bb|0,ql
	tra	sb|0		return to caller


slew:
	vfd	27/,o9/0		FF
	vfd	o9/014
	vfd	27/,o9/013	top of inside page
	vfd	o9/014		treat as ff
	vfd	27/,o9/011	top of outside page
	vfd	o9/014

	equ	nslew,*-slew

nlchar:	vfd	o9/012
crchar:	vfd	o9/015
vtstring:	vfd	o9/013,o9/013,o9/013,o9/013
	vfd	o9/013,o9/013,o9/013,o9/013
	vfd	o9/013,o9/013,o9/013,o9/013
	vfd	o9/013,o9/013,o9/013,o9/013

" 

print_send_slew_count:
	spribp	pointer		see if faked slew char is beyond end of seg
	ldq	pointer+1
	qrl	18
	cmpq	=o776000
	tze	no_vt		if so, skip test for VT char
	cmpc	(pr),()		see if slew was VT
	desc9a	bp|0,1
	desc9a	vtstring,1
	tnz	no_vt
	ada	line		VT, compute new ending line
	lrs	36
	div	10,dl		convert to stop
	sba	residue		a has spaces over
	sbq	tabstop		q has vt count
	tze	no_vt
	mlr	(rl),(pr,rl)	undo work of prt_conv_
	desc9a	vtstring,ql	.. by putting out VT
	desc9a	bb|0,ql
	a9bd	bb|0,ql		step output ptr
	tra	sb|0
no_vt:	ldq	crchar
	sba	1,dl		one at a time
	tmi	2,ic
	ldq	nlchar
	stq	char
	tra	stslew

	end




		    print_error_message.pl1         11/21/84  0948.9rew 11/21/84  0944.4       33876



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


print_error_message: pem: proc;

/* Modified 84-05-28 by SGH (UNCA) for active function. */
/* Modified 840724 by Charlie Spitzer. fix for MCR changes. */

/* Automatic */

dcl  active_fnc bit(1);		
dcl  af_return_arg_len fixed bin(21);	
dcl  af_return_arg_ptr ptr;
dcl  code fixed bin (35);
dcl  error_code fixed bin (35);
dcl  esw fixed bin;
dcl  long char (100) aligned;
dcl  n_args fixed bin;
dcl  short char (8) aligned;
dcl  tc fixed bin;
dcl  tp ptr;

/* Based */ 

dcl  af_return_arg char (af_return_arg_len) varying based (af_return_arg_ptr);
dcl  targ char (tc) based (tp);

/* Builtins */

dcl  rtrim builtin;

/* Static */

dcl  ME char (32) int static options (constant) init ("print_error_message");

/* External */

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

/* Procedures */

dcl  active_fnc_err_ entry options (variable);
dcl  argument_routine entry variable options (variable);
dcl  com_err_ entry options (variable);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  error_routine entry variable options (variable);
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  requote_string_ entry (char(*)) returns(char(*));

	esw = 1;					/* indicates decimal short form */
	go to common;

peo:	entry;

	esw = 3;					/* indicates octal short form */
	go to common;

pel:	entry;

	esw = 2;					/* indicates decimal long form */
	go to common;

peol:	entry;

	esw = 4;					/* indicates octal long form */

common:
	call cu_$af_return_arg (n_args, af_return_arg_ptr, af_return_arg_len, code);
	if code = error_table_$not_act_fnc then do;
	     active_fnc = "0"b;
	     argument_routine = cu_$arg_ptr;
	     error_routine = com_err_;
	end;
	else do;
	     active_fnc = "1"b;
	     argument_routine = cu_$af_arg_ptr;
	     error_routine = active_fnc_err_;
	end;

	call argument_routine (1, tp, tc, code);
	if code ^= 0 | tc = 0 then do;
	     call error_routine (code, ME);
	     return;
	end;

	if esw < 3 then error_code = cv_dec_check_ (targ, code);
	else error_code = cv_oct_check_ (targ, code);	/* get correct code value */
	if code ^= 0 then do;
	     call error_routine (error_table_$bad_arg, ME, "^a", targ);
	     return;
	end;

	call convert_status_code_ (error_code, short, long);
	if active_fnc then
	     if esw = 1 | esw = 3 then call ioa_$rsnnl ("^a", af_return_arg, af_return_arg_len, requote_string_ (rtrim (short)));
	     else call ioa_$rsnnl ("^a", af_return_arg, af_return_arg_len, requote_string_ (rtrim (long)));
	else do;
	     if esw = 1 then call ioa_ ("^d = ^a", error_code, short);
	     else if esw = 2 then call ioa_ ("^d = ^a", error_code, long);
	     else if esw = 3 then call ioa_ ("^o = ^a", error_code, short);
	     else call ioa_ ("^o = ^a", error_code, long);
	end;

     end print_error_message;




		    rje_args.pl1                    11/04/82  1951.6rew 11/04/82  1627.7       58824



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


rje_args: proc;


/* This is the initial version of an active function to return some information about
   the submission of an RJE card input job.  It will eventually be fashoned after the
   user active function.  This version is modeled after the value command to set certain
   values which are then returned by giving the correct key to the active function.

   Only the active function entry is to be documented.  The setting entry is internal
   interfaces and will go away when the source data can be put into the PIT.
   */

/* Initial version taken from the value active function by J. C. Whitmore, Aug. 1977 */



dcl  en char (32) aligned int static,
     dn char (168) aligned int static,
     segptr ptr int static init (null),
     ap ptr, al fixed bin, bchr char (al) unal based (ap),
     answer char (168) varying,
     bvcs char (al) varying based (ap),
     ec fixed bin,
     i fixed bin,
     af_sw bit (1) init ("0"b),
     string char (168) aligned;

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

dcl  com_err_ entry options (variable),
     adjust_bit_count_ entry (char (*) aligned, char (*) aligned, bit (1), fixed bin (24), fixed bin (17)),
     get_pdir_ entry () returns (char (168) aligned),
     active_fnc_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     cu_$arg_count entry (fixed bin),
     cu_$af_arg_count entry (fixed bin, fixed bin),
     cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin),
     error_table_$wrong_no_of_args fixed bin ext,
     error_table_$bad_arg fixed bin ext,
     error_table_$not_act_fnc fixed bin ext,
     hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin),
     unique_chars_ entry (bit (*)) returns (char (15)),
     ioa_ entry options (variable);

dcl 1 valueseg based (segptr) aligned,
    2 laste fixed bin,
    2 freep fixed bin,
    2 pad (6) fixed bin,
    2 arry (1000),
      3 name char (32),
      3 valu char (168),
      3 lth fixed bin,
      3 chain fixed bin;

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

	af_sw = "1"b;				/* this should be an active function */

	call cu_$af_arg_count (i, ec);
	if ec = error_table_$not_act_fnc then af_sw = "0"b;
	else if ec ^= 0 then go to er;

	if ^af_sw then call cu_$arg_count (i);		/* not an active function so get valid count */
	if i ^= 1 then do;
	     ec = error_table_$wrong_no_of_args;
	     go to er;
	end;

	if segptr = null then do;
	     call get_segptr (ec);
	     if segptr = null then do;
er:		if af_sw then
		     call active_fnc_err_ (ec, "rje_args");
		else call com_err_ (ec, "rje_args");
		return;
	     end;
	end;

	if af_sw then
	     call cu_$af_arg_ptr (1, ap, al, ec);
	else call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then if ec ^= error_table_$not_act_fnc then go to er;

/*	check to see if the  key given is legal */

	if bchr = "prt_rqt" then;			/* the printer request type */
	else if bchr = "pun_rqt" then;		/* the punch request type */
	else if bchr = "station" then;		/* the station code of the job */
	else do;					/* all others are  invalid! */
	     ec = error_table_$bad_arg;
	     go to er;
	end;

	do i = 1 to laste;
	     if chain (i) = 0 then if name (i) ^= "" then
		     if bchr = name (i) then go to found;
	end;
	answer = "undefined!";
	go to give;

found:	answer = substr (valu (i), 1, lth (i));
	if answer = "" then answer = "undefined!";	/* always return something */
give:	if af_sw then do;
	     call cu_$af_return_arg (i, ap, al, ec);
	     if ec ^= 0 then if ec ^= error_table_$not_act_fnc then go to er;
	     bvcs = answer;
	     return;
	end;
	call ioa_ (answer);
	return;

/* ---------------------------------- */

set:	entry;

	if segptr = null then do;
	     call get_segptr (ec);
	     if segptr = null then go to er;
	end;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to er;

	if bchr = "prt_rqt" then;			/* ok to set the printer request type */
	else if bchr = "pun_rqt" then;		/* ok to set the punch request type */
	else if bchr = "station" then;		/* ok to set the station code */
	else do;					/* all other keys are invalid! */
	     ec = error_table_$bad_arg;
	     go to er;
	end;

	string = bchr;

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then do;
	     do i = 1 to laste;
		if string = name (i) then do;
		     chain (i) = freep;
		     freep = i;
		     name (i) = "";
		end;
	     end;
	     return;
	end;

	do i = 1 to laste;
	     if chain (i) = 0 then if name (i) ^= "" then
		     if name (i) = string then do;
			go to f1;
		     end;
	end;
	if freep = 0 then i, laste = laste + 1;
	else do;
	     i = freep;
	     freep = chain (i);
	end;
	name (i) = string;
f1:	valu (i) = bchr;
	chain (i) = 0;
	lth (i) = al;

	call adjust_bit_count_ (dn, en, "0"b, (0), ec);

	return;

/* ------------------------------------------ */

list:	entry;

	if segptr = null then do;
	     call get_segptr (ec);
	     if segptr = null then go to er;
	end;

	call cu_$arg_ptr (1, ap, al, ec);
	do i = 1 to laste;
	     if name (i) = "" then go to nop;
	     if chain (i) = 0 then do;
		if ec = 0 then if name (i) ^= bchr then go to nop;
		call ioa_ ("^20a^-^a", name (i), substr (valu (i), 1, lth (i)));
	     end;
nop:	end;
	call ioa_ ("");

	return;

/* ------------------------------------ */

get_segptr: proc (code);

dcl  code fixed bin;

	     dn = get_pdir_ ();
	     en = "rje_args." || unique_chars_ ((70)"0"b); /* make a unique name */

	     call hcs_$make_seg (dn, en, "", 1011b, segptr, code);

	     if code = 0 then do;			/* initialize the values to the defaults */
		laste = 3;			/* 3 entries */
		name (1) = "prt_rqt";
		valu (1) = "printer";
		lth (1) = length (rtrim (valu (1)));
		name (2) = "pun_rqt";
		valu (2) = "punch";
		lth (2) = length (rtrim (valu (2)));
		name (3) = "station";
		valu (3) = "central_site";
		lth (3) = length (rtrim (valu (3)));
	     end;

	     return;

	end get_segptr;

     end rje_args;




		    set_epilogue_command.pl1        11/04/82  1951.6rew 11/04/82  1627.5       11484



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


set_epilogue_command: sec: proc;

dcl  command char (256) int static init ("");
dcl  code fixed bin (35);
dcl  argp ptr;
dcl  arglen fixed bin;
dcl  arg char (arglen) based (argp);

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  default_error_handler_$add_finish_handler entry (entry, fixed bin (35));
dcl  cu_$cp entry (ptr, fixed bin, fixed bin (35));

	code = 0;
	call cu_$arg_ptr (1, argp, arglen, code);
	if code ^= 0 then goto ret;
	command = arg;
	call default_error_handler_$add_finish_handler (do, code);
ret:
	if code ^= 0 then call com_err_ (code, "set_epilogue_command");
	return;

do:	entry;
	call cu_$cp (addr (command), length (command), code);
	return;

     end set_epilogue_command;




		    suffixed_name_.pl1              11/04/82  1951.6rew 11/04/82  1627.7       98820



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  suffixed_name_							*/
	/*									*/
	/*      This subroutine handles suffixed names.					*/
	/*									*/
	/* E__n_t_r_y:  suffixed_name_$find						*/
	/*									*/
	/*      This entry point attempts to find an entry which is supposed to (but may not)	*/
	/* have a suffixed name.  The entry may be a directory, a segment, or a multi-segment	*/
	/* file.									*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  suffixed_name_$find entry (char(*), char(*), char(*), char(32) aligned,	*/
	/*				fixed bin(2), fixed bin(35));			*/
	/*									*/
	/*      call suffixed_name_$find (directory, entry, suffix, name, type, mode, code);	*/
	/*									*/
	/* 1) directory	name of directory in which entry is to be found.(In)		*/
	/* 2) entry	entry name supplied by user which may or may not have a suffix.(In)	*/
	/* 3) suffix	the suffix which is supposed to be on the entry. It should not	*/
	/*		contain a period (".").(In)					*/
	/* 4) name	name of the entry which was found.(Out)				*/
	/* 5) type	switch indicating the type of entry which was found.(Out)		*/
	/*		1 = segment; 2 = directory; 3 = multi-segment file.		*/
	/* 6) mode	caller's access mode to the entry which was found.(Out)		*/
	/* 7) code	an error code.(Out)						*/
	/*									*/
	/* E__n_t_r_y:  suffixed_name_$make						*/
	/*									*/
	/*      This entry point makes a properly-suffixed name out of a user-supplied name	*/
	/* which may or may not be suffixed.						*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  suffixed_name_$make entry (char(*), char(*), char(*), char(32) aligned,	*/
	/*				fixed bin(35));				*/
	/*									*/
	/*      call suffixed_name_$make (entry, suffix, name, code);			*/
	/*									*/
	/* 1) entry	is the user-supplied entry name.(In)				*/
	/* 2) suffix	is the suffix which is to be appended to the name.(In)		*/
	/* 3) name	is the properly-suffixed name.(Out)				*/
	/* 4) code	is a status code which indicates whether the properly-suffixed name	*/
	/*		will fit into the _p_r_o_p_e_r__n_a_m_e string. (Out)			*/
	/*									*/
	/* E__n_t_r_y:  suffixed_name_$new_suffix						*/
	/*									*/
	/*      This entry point creates a properly-suffixed name from a (possibly-improperly-)	*/
	/* suffixed name supplied by the user.						*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  suffixed_name_$new_suffix entry(char(*), char(*), char(*), char(32) aligned,	*/
	/*				     fixed bin(35));			*/
	/*									*/
	/*      call suffixed_name_$new_suffix (name, suffix, new_suffix, new_name, code);	*/
	/*									*/
	/* 1) name	is the suffixed name returned by suffixed_name_$find.(In)		*/
	/* 2) suffix	is the suffix which is supposed to be on name.(In)		*/
	/* 3) new_suffix	is the new suffix which is to be appended to the name to be made.(In)	*/
	/* 4) new_name	is the name which was made.(Out)				*/
	/* 5) code	is a status code which indicates whether the properly-suffixed new	*/
	/*		name will fit into the _n_e_w__n_a_m_e string. (Out)			*/
	/*									*/
	/* N__o_t_e_s									*/
	/*									*/
	/*      "code" may be any error code returned by hcs_$status_long, except		*/
	/* error_table_$no_s_permission.  "name" will contain a properly-suffixed name, even if	*/
	/* "code" is non-zero.							*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 1) Created:  Nov 1972 by Gary C. Dixon					*/
	/* 2) Modified: Jan 1973 by Gary C. Dixon; add mode argument to find entry point.	*/
	/* 3) Modified: Feb 1973 by Gary C. Dixon; add code argument to make/new_suffix entries.	*/
	/* 4) Modified: Dec 1980 by M. Broussard; fixed to work with names containing imbedded    */
	/*				  blanks.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

suffixed_name_:	procedure;			/* procedure to handle suffixed names.		*/

						/*	parameters			*/
     dcl	directory			char(*),	 	/* absolute directory path of segment to be found	*/
	entry			char(*),		/* entry name to be suffixed.			*/
	suffix			char(*),		/* suffix character string (not including ".")	*/
	new_suffix		char(*),		/* new suffix character string (not including ".")*/
	name			char(32) aligned,	/* properly-suffixed name.			*/
	Stype			fixed bin(2),	/* type of entry which was found.		*/
	mode			fixed bin(5),	/* caller's access mode to the found dir entry.	*/
	code			fixed bin(35);	/* an error code.				*/

						/*	automatic variables			*/
     dcl	Lentry			fixed bin,	/* length of non-blank part of entry.		*/
	Lname			fixed bin,	/* length of a part of non-blank part of name.	*/
	Lnew_suffix		fixed bin,	/* length of non-blank part of new suffix.	*/
	Lsuffix			fixed bin,	/* length of non-blank part of suffix.		*/
	e			fixed bin,	/* an entry point indicator.			*/
	1 stat,					/* a file system status block.		*/
	 (2 type			bit(2),		/* entry type; "01"b=seg, "10"b=dir		*/
	  2 pad1			bit(106),
	  2 mode			bit(5),		/* caller's access to the entry.		*/
	  2 pad2			bit(151),
	  2 bitcnt		bit(24),		/* multi-segment file indicator count.		*/
	  2 pad3			bit(72)) unal;

						/*	entries and builtin functions		*/
     dcl	hcs_$status_long		entry(char(*), char(*) aligned, fixed bin(1), ptr, ptr, fixed bin(35)),
	fixed			builtin,
	index			builtin,
	length			builtin,
	null			builtin,
	rtrim			builtin,
	substr			builtin;

						/*	static variables			*/
     dcl	dir			fixed bin(2) int static init (2),
	error_table_$entlong	fixed bin(35) ext static,
	error_table_$no_s_permission	fixed bin(35) ext static,
	msf			fixed bin(2) int static init (3);


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



find:	entry (directory, entry, suffix, name, Stype, mode, code);
						/* find the name of the entry which matches a	*/
						/* suffixed entry name.			*/
	e = 1;
	go to common;

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


make:	entry (entry, suffix, name, code);		/* make a suffixed name out of a user-supplied	*/
						/* entry name which may or may not be suffixed.	*/
	e = 2;
	go to common;

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



new_suffix:	entry (entry, suffix, new_suffix, name, code);
						/* change the suffix on a (possibly) suffixed	*/
						/* name to a new suffix.			*/
	e = 3;

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


common:	Lentry = length (rtrim (entry));
	Lsuffix = length (rtrim (suffix));
						/* find lengths of non-blank parts of char strings*/

	if Lsuffix = 0 then				/* if _s_u_f_f_i_x is null string, then use _e_n_t_r_y as	*/
	     go to use_entry;			/* the suffixed _n_a_m_e.			*/
	else if Lentry < Lsuffix + 1 then		/* if the _s_u_f_f_i_x won't fit in _e_n_t_r_y, then	*/
	     go to add_suffix;			/* assume its not there.			*/
	else if substr (entry, Lentry-Lsuffix, Lsuffix+1) = "." || substr (suffix, 1, Lsuffix) then
						/* otherwise, see if _s_u_f_f_i_x is already on _e_n_t_r_y.	*/
use_entry:     if Lentry <= length(name) then do;		/* if so, and if _e_n_t_r_y isn't too long, then	*/
		name = substr (entry, 1, Lentry);	/* use _e_n_t_r_y as the suffixed _n_a_m_e.		*/
		Lname = Lentry;
		end;
	     else					/* if _e_n_t_r_y won't fit into the _n_a_m_e string, then	*/
		go to long_entry_error;		/* that's an error.  Tell the caller.		*/
	else if Lentry + Lsuffix + 1 <= length(name) then do;
						/* make suffixed _n_a_m_e by appending _s_u_f_f_i_x to 	*/
						/* _e_n_t_r_y, if that will fit.			*/
add_suffix:    name = substr (entry, 1, Lentry) || "." || substr (suffix, 1, Lsuffix);
	     Lname = Lentry + Lsuffix + 1;
	     end;
	else					/* if all else fails, then report error to user.	*/
	     go to long_entry_error;
	go to do(e);				/* perform remainder of processing according to	*/
						/* entry point.				*/

do(1):	call hcs_$status_long (directory, name, 1, addr (stat), null, code);
						/* look for a directory entry with a name of	*/
	if code ^= 0 then				/* _n_a_m_e.					*/
	     if code = error_table_$no_s_permission then;	/* ignore no_s_permission error code. We got what	*/
						/* information we want.			*/
	     else					/* other errors indicate that the directory entry	*/
		return;				/* was not found.				*/
	Stype = fixed (stat.type, 2);			/* convert type to a number.			*/
	mode = fixed (stat.mode, 5);			/* same for access mode.			*/
	if Stype = dir then				/* if its a directory, then			*/
	     if stat.bitcnt then			/* maybe its really an MSF.			*/
		Stype = msf;			/* Ah ha! I was right.			*/
do(2):	code = 0;					/* make sure no error is returned.		*/
	return;

do(3):	Lnew_suffix = length (rtrim (new_suffix));
						/* compute actual length of the _n_e_w__s_u_f_f_i_x.	*/
	if Lsuffix > 0 then				/* if _s_u_f_f_i_x is non-blank, remove _s_u_f_f_i_x from	*/
	     Lname = Lname - Lsuffix;			/* length count of _n_a_m_e (do not include the dot).	*/
	else					/* if there's no suffix, add 1 to the length	*/
	     Lname = Lname + 1;			/* count to make it look like there's a dot.	*/
	if Lnew_suffix = 0 then			/* if _n_e_w__s_u_f_f_i_x is null string, then 		*/
	     substr (name, Lname) = "";		/* return just the non-suffixed part of _n_a_m_e.	*/
	else if Lname + Lnew_suffix <= length(name) then	/* if _n_e_w__s_u_f_f_i_x will fit in _n_a_m_e string, then	*/
						/* return suffixed _n_a_m_e formed by appending the	*/
						/* _n_e_w__s_u_f_f_i_x to non-suffix components of entry.	*/
	     substr (name, Lname) = "." || substr (new_suffix, 1, Lnew_suffix);
						/* (remember, dot is already included in Lname.)	*/
	else					/* if all else fails, then report error to user.	*/
	     go to long_entry_error;
	go to do(2);				/* clear error code and return.		*/
/**/
long_entry_error:					/* report to user that suffixed name won't fit in	*/
	code = error_table_$entlong;			/* _n_a_m_e.					*/
	return;


	end suffixed_name_;




		    translate_bytes_to_hex9_.alm    08/19/86  1119.2rew 08/19/86  1113.2       18504



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

"
"   Written by R.J.C. Kissel, 11/17/76, for use by dump_segment.
"   Modified by Linda Pugh, 10/4/82, to spell misspelled word correctly
"   so this program would compile.

" HISTORY COMMENTS:
"  1) change(86-07-30,Kissel), approve(86-07-30,MCR7476), audit(86-08-01,Ex),
"     install(86-08-19,MR12.0-1132):
"     Changed the name from translate_to_hex9 which was non-standard to
"     translate_bytes_to_hex9_, which is better.  This was done because this
"     entry is now retained for external use.
"                                                      END HISTORY COMMENTS

"
"   PL/I Usage:
"   dcl translate_bytes_to_hex9_ (bit(*), char(*))
"   call translate_bytes_to_hex9_ (input_bits, output_chars)
"
	name	translate_bytes_to_hex9_
	entry 	translate_bytes_to_hex9_
translate_bytes_to_hex9_:
	epp1	ap|2,*		address of source string to pr1
	epp3	ap|4,*		address of target string to pr3
	ldx3	0,du		set x3 not to skip parent pointer if none
	lxl2	ap|0		load arg list code value
	canx2	=o0000004,du	check for no parent pointer (code 4)
	tnz	*+2		transfer if no parent pointer
	ldx3	2,du		parent pointer, set x3 to skip it
	ldq	ap|6,x3*		load source string descriptor
	anq	mask		drop all but string size  bits
	qls	1		get length of string in q-reg
	div	9,dl
	lda	ap|8,x3*		load target string descriptor
	ana	mask		drop all but string size bits
	even			"EIS address must be even
	mvt	(pr,rl),(pr,rl),fill(00)	now do the bcd to ascii
	desc4a	1|0,ql
	desc9a	3|0,al
	arg	table
	short_return
mask:	oct	000077777777
	even

table:	aci	"0123456789ABCDEF"
	end




		    walk_subtree.pl1                01/26/85  1258.7r w 01/22/85  1217.0      102726



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


walk_subtree: ws: proc;

/* Initially coded in September 1969 by V. Voydock */
/* Converted to pl1  in May 1970 by V. Voydock */
/*  Modified on May 4, 1970 at 12:25 midnight by V. Voydock */
/* Modified on January 4, 1971 (to add pi handler) by V. Voydock */
/* Modified on July 8, 1971 by J. Stern
   Command name changed from "global" to "execute_in_subdirectories".
   Command format and options changed ("-bottom_up" option added).  */
/* Modified Dec 13 1973 by S. Herbst
   Converted to Version II
   Names changed to walk_subtree and ws_recursive.
   Var. length temporary command line. */
/* Bugs fixed 12/9/75 by Steve Herbst: walking through MSF's and
   cwd in command line changing walk */
/* By Greenberg 3/8/77 to allow walking MSF's (!) on -msf,
   and -priv for hphcs_$star_. */
/* By GTWilliams 5/9/78 to eliminate BRS's and RRS's from output, move pi handler functionality to a
   cleanup handler, explicitly set value of op to addr(original_dir).  */
/* Badpath error message fixed 05/12/80 S. Herbst */
/* By R. Kovalcik 9/10/82 to handle security-out-of-service error better */
/* By C Spitzer 7 Nov 83: use include star_structures, attempt to use get_shortest_path_
		      if the directory length would be > 168 */
/* By Keith Loepere, December 1984: generate good paths for dirs off root. */

dcl	cleanup condition;

dcl	original_dir char(168),		/* directory from which ws was invoked */
	command_line char(clng) based(cp),
	starting_node char(slng) based(sp),	/* starting node of subtree of subdirectories */
	starting_dir char (168),
	arg char(lng) based(ap),
	cstring char(168),			/* ioa_ control string passed to com_err_ */
	ws char(16) aligned int static init("walk_subtree"),
	nl char(1) aligned internal static initial("
");  		/* new line character */

dcl	(lng,
	 clng,
	 slng,
	 first_level init(1),   /* level of recursion at which to begin executing command line */
	 last_level init(999),
	 i,
	nargs,
	 level init(0)   /* current level of recursion */
    	 	) fixed bin(17);

dcl       (nnn, code) fixed bin(35);

dcl	(bottom_up_flag init("0"b),
	  (privf, msff) init ("0"b),
	 trace_flag init("1"b),
	 f_option_flag) bit(1) aligned;

dcl	(ap,
	 arp,
	 op,
	 sp,
           tcp,
	 cp )ptr;

dcl       tem_ area based(arp),
          tem_com_line char(clng) aligned based(tcp);     /* temporary command line to be allocated in tem_ */
dcl       error_table_$badopt ext fixed bin(35),
          error_table_$noarg ext fixed bin(35);

dcl	(addr, fixed, null, rtrim, substr) builtin,
	absolute_pathname_ entry (char(*), char(*), fixed bin(35)),
	pathname_ entry (char(*), char(*)) returns(char(168)),
	cv_dec_check_ external entry(char(*), fixed bin(35)) returns(fixed bin(35)),
	cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(35)),
	cu_$arg_count ext entry(fixed bin(17)),
          get_system_free_area_ ext entry returns(ptr),
	get_wdir_ entry() returns(char(168)),
	change_wdir_ external entry(char(168), fixed bin(35)),
          ioa_ ext entry options(variable),
          com_err_ ext entry options(variable);

/*  */

		/* Save original working directory */
	/* Establish handler for cleanup to reset user's original working_dir  */
	on condition (cleanup) call change_wdir_(original_dir,code);
	op = addr(original_dir);
	original_dir = get_wdir_();
	if original_dir="" then return;

		/* Get argument count */
	call cu_$arg_count(nargs);
	if nargs < 2 then do; code = error_table_$noarg; cstring = " "; go to ERROR_EXIT1; end;
	
		/* Get starting node name */
	call cu_$arg_ptr(1, sp, slng, code);
	if code ^= 0 then do; i = 1; go to ERROR_EXIT3; end;

		/* "-wd" => current working directory */
	if starting_node = "-wd" then do; sp = op; slng = 168; end;

	call absolute_pathname_ (starting_node, starting_dir, code);
	if code ^= 0 then do;
	     cstring = starting_node;
	     goto ERROR_EXIT1;
	     end;

		/* Get command line */
	call cu_$arg_ptr(2, cp, clng, code);
	if code ^= 0 then do; i = 2; go to ERROR_EXIT3; end;

		/* Check for options */
	do i = 3 to nargs;
	     call cu_$arg_ptr(i,ap,lng,code);
	     if code ^= 0 then go to ERROR_EXIT3;
	     if substr(arg,1,1) ^= "-" then 	     /* not an option */
	          do;
	          cstring = "Argument does not have option format as expected.  ^a";
	          go to ERROR_EXIT2;
	          end;

	     	     /* Identify options */
	     if arg="-ft" | arg="-first" then   do; f_option_flag="1"b; go to SETLEVEL; end;
	     else  
	     if arg="-lt" | arg="-last" then   do; f_option_flag="0"b; go to SETLEVEL; end;
	     else  
	     if arg="-msf" then msff = "1"b;
	     else
	     if arg = "-priv" then privf = "1"b;
	     else
	     if arg="-bf" | arg="-brief" then trace_flag="0"b;
	     else
	     if arg="-bu" | arg = "-bottom_up" then bottom_up_flag = "1"b;
	     else
	     do; code = error_table_$badopt; cstring= arg; go to ERROR_EXIT1; end;
	     go to ENDLOOP;

SETLEVEL:      i=i+1;
	     call cu_$arg_ptr(i,ap,lng,code);
	     if code ^= 0 then do; cstring = "Level number missing."; go to ERROR_EXIT2; end;
	     nnn = cv_dec_check_(arg, code);	     /* convert level number from char to binary */
	     if code ^= 0 | nnn <= 0 then
	          do;
	          cstring = "Bad level number.  ^a";
	          go to ERROR_EXIT2;
	          end;
	     if f_option_flag then first_level = nnn;
	     else last_level = nnn;
ENDLOOP:	end;


		/* Control comes here when all arguments have been processed. */
CALL_CP:	if last_level < first_level then
	     do;
	     code = 0;
	     cstring = "Last level must be >= first level.";
	     go to ERROR_EXIT1;
	     end;

		/* Get area in which star handler can allocate information */
          arp = get_system_free_area_();

                    /* Allocate temporary command line in this area */
          allocate tem_com_line in(tem_) set(tcp);

		/* Now do the real work */
	call ws_recursive(starting_dir);

                    /* Free tem_com_line */
          free tem_com_line in(tem_);


RETURN_TO_ORIGINAL_DIR:

		/* The real work has been done. Now make the user's working directory
		   be the same as when command was invoked, then return */
	call change_wdir_(original_dir,code);
	if code = 0 then return;
	cstring = original_dir;

ERROR_EXIT1: call com_err_(code, ws, cstring);
	return;

ERROR_EXIT2: call com_err_(0, ws, cstring, arg);
	return;

ERROR_EXIT3: call com_err_(code, ws, "ARG ^d", i);
	return;
	
	/*  */
	
		/* Internal procedure to execute the command line set up in the main body of
		   the program at all specified points of the file system hierarchy */
ws_recursive: proc(nodeP);
	
dcl	nodeP char(*) parameter;

dcl	(dp,
	(ep,
	 np) init(null)  ) ptr;

dcl	node char (168);
dcl	dpath char (dlng) based (dp);

dcl	type fixed bin(2);

dcl	(dlng,
 	 k,
	 ecount
		     ) fixed bin(17);
	
dcl	nind fixed bin(18);

dcl	bitcnt fixed bin(24);

dcl       code fixed bin(35);

dcl	cu_$cp ext entry(ptr,fixed bin(17),fixed bin(35)),
	get_shortest_path_ entry (char(*)) returns(char(168)),
	pathname_ entry (char(*), char(*)) returns(char(168)),
	hcs_$star_ ext entry(char(*),char(*),fixed bin(2),ptr,fixed bin(17),ptr,ptr,fixed bin(35));
dcl	hphcs_$star_ ext entry (char(*),char(*),fixed bin(2),ptr,fixed bin(17),ptr,ptr,fixed bin(35));
dcl	hcs_$status_minf entry(char(*),char(*),fixed bin(1),fixed bin(2),fixed bin(24),fixed bin(35));

dcl	error_table_$dirlong fixed bin(35) ext static;
dcl	error_table_$no_s_permission ext fixed bin(35);
dcl       error_table_$nomatch ext fixed bin(35);
dcl       error_table_$oosw ext fixed bin(35);
	
%include star_structures;

/*  */

		/* Establish cleanup handler */

	star_entry_ptr, star_names_ptr = null;

	on condition(cleanup) begin;
				if star_names_ptr ^= null then free star_names in (tem_);
				if star_entry_ptr ^= null then free star_entries in (tem_);
			  end;
	
		/* Push level of recursion */
	level=level+1;
	
	node = nodeP;
	
		/* Change working directory to this node */
	call change_wdir_(node, code);
	if code ^= 0 then go to CALL_COM;
	
		/* See if top-down trace is wanted */
	if bottom_up_flag then go to NEXT;
	
		/* See if command processor should be called at this level.
		   If so, copy the command line into temporary because the
		   the command processor destroys the input line passed to it */
EXECUTE:	if level>=first_level then
	     do;
	     if trace_flag then call ioa_("^-^a",node);    /* trace in effect */
	     tem_com_line=command_line;
	     call cu_$cp(tcp,clng,code);
	     if code^=0 then if code^=100 then do;
		level = 0;
		return;
	     end;

	     call change_wdir_(node,code);		/* restore working dir after command line */
	     if code^=0 then go to CALL_COM;

	     end;
	if bottom_up_flag then go to FREE;
	
		/* If this is last level then skip looking for subdirectories */
NEXT:	if level >= last_level then go to SKIP;
	
		/* Get list of all subdirectories */
	if privf then call hphcs_$star_(node,"**",2,arp,star_entry_count,star_entry_ptr,star_names_ptr,code);
	else call hcs_$star_(node,"**",2,arp,star_entry_count,star_entry_ptr,star_names_ptr,code);
	     if code=error_table_$nomatch then go to SKIP;    /* no subdirectories */
	
		/* Execute command in all subdirectories which are in range */
	do k=1 to star_entry_count;
	     nind = fixed(star_entries(k).nindex);
	     if ^msff then do;
		call hcs_$status_minf(node,star_names(nind),0,type,bitcnt,code);
		if code^=0
		     then if code^=error_table_$no_s_permission
		          then if code^=error_table_$oosw
		               then go to CALL_COM;
		if bitcnt ^= 0 then go to ENDLOOP;	/* Don't care if its not dir. */
	     end;
	     if star_entries(k).type ^= 2 then go to ENDLOOP;
	     if length (rtrim (node)) + length (rtrim (star_names(nind))) + 1 > 168
	     then do;				/* try to make it fit */
		node = get_shortest_path_ (node);
		if length (rtrim (node)) + length (rtrim (star_names(nind))) + 1 > 168
		then do;				/* still doesn't fit */
		     call com_err_ (error_table_$dirlong, ws, "^a", pathname_ (node, star_names (nind)));
		     goto ENDLOOP;
		     end;
		end;
	     call ws_recursive(pathname_ (node, star_names(nind)));
		     /* check for error condition occuring when starting level is greater than one.
		        e.g. "ws <test -gf 2 foo" where foo does not exist.  If this test is 
		        not made ws will print multiple error messages in above case */
	     if level=0 then return;
	     call change_wdir_(node,code);   /* pop working directory back to correct level */
	     if code ^= 0 then go to CALL_COM;
ENDLOOP:	end;

		/* See if bottom-up trace is wanted */
SKIP:	if bottom_up_flag then go to EXECUTE;

FREE:
	if star_names_ptr ^= null then free star_names in (tem_);
	if star_entry_ptr ^= null then free star_entries in (tem_);
	go to RETURN;
	
CALL_COM:
	
	call com_err_(code,ws,node);
	
RETURN:
	
	level=level-1;   /* pop recursion level count */
	return;
	
end ws_recursive;
	
	
end walk_subtree;





		    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
