



		    chase_link_.pl1                 10/25/83  1546.3r w 10/25/83  1444.2       12339



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


chase_link_:
	proc(d1, e1, d2, d2_length, e2, code);


/* This routine finds the target of a link - chasing it all the way.

   Initially coded June 1972 by Dan B. */


dcl
	code fixed bin(35),
	d1 char(*),
	d2 char(*),
	d2_length fixed bin,
	e1 char(*),
	e2 char(*),
	hcs_$fs_get_path_name entry(ptr, char(*), fixed bin, char(*), fixed bin(35)),
	hcs_$initiate entry(char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)),
	hcs_$terminate_noname entry(ptr, fixed bin(35)),
	null builtin,
	segptr ptr;


	call hcs_$initiate(d1, e1, "", 0, 0, segptr, code);	/* try to get a pointer to the entry */
	if segptr=null then return;

	call hcs_$fs_get_path_name(segptr, d2, d2_length, e2, code);/* now make the pointer into a pathname */
	if code^=0 then return;

	call hcs_$terminate_noname(segptr, code);		/* terminate the ptr */

	return;

	end;




		    check_star_.pl1                 10/25/83  1546.3r w 10/25/83  1444.2       14202



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  check_star_							*/
	/*									*/
	/*      This obsolete routine has been replaced by check_star_name_.			*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created:  Jul, 1973 by G. C. Dixon					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

check_star_:	procedure (Pstar, Lstar, code);

     dcl	Pstar			ptr,		/* ptr to star path or star entry. (In)		*/
	Lstar			fixed bin,	/* length of star path or star entry. (In)	*/
	code			fixed bin(35);	/* status code. (Out)			*/

     dcl	star			char(Lstar) based (Pstar);
						/* overlay for star path or star entry.		*/

     dcl	check_star_name_$entry	entry (char(*), fixed bin(35)),
	check_star_name_$path	entry (char(*), fixed bin(35));

	call check_star_name_$path (star, code);
	return;

check_entry_name:	entry 	(Pstar, Lstar, code);

	call check_star_name_$entry (star, code);

	end check_star_;




		    copy_switch_on.pl1              10/25/83  1546.3r w 10/25/83  1444.2       21861



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


/* Copy switch commands:
	copy_switch_on, csn 	Turn it on.
	copy_switch_off, csf	Turn it off.
   first coded by Noel I. Morris  April 1969
   last modified by M. Weaver  22 January 1970  14:35
   Names changed to copy_switch_(on off) and moved to >sss>bound_fscom1_ 05/25/79 S. Herbst
   Fixed to print proper error messages 05/31/79 W. Olin Sibert */

copy_switch_on: csn: setcopysw: proc options (variable);

dcl  np ptr;
dcl  path char (168);
dcl  entry char (32);
dcl  name char (lng) based (np);
dcl  err_name char (32) aligned;
dcl  sw fixed bin (1);
dcl  nargs fixed bin;
dcl (lng, i) fixed bin;
dcl  code fixed bin (35);

dcl  error_table_$noarg ext fixed bin (35);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$set_copysw entry (char (*), char (*), fixed bin (1), fixed bin (35));

/*  */

	sw = 1b;					/* turn on copy switch */
	err_name = "copy_switch_on";
	go to join;

copy_switch_off: csf: resetcopysw: entry options (variable);

	sw = 0b;					/* turn off copy switch */
	err_name = "copy_switch_off";

join:
	call cu_$arg_count (nargs);
	if nargs = 0 then do;
	     call com_err_ (error_table_$noarg, err_name, "^/Usage:^-^a path{s}", err_name);
	     return;
	end;

	do i = 1 to nargs;				/* process all arguments */
	     call cu_$arg_ptr (i, np, lng, code);	/* grab an argument */

	     call expand_pathname_ (name, path, entry, code); /* get directory and entry names */
	     if code ^= 0 then do;
		call com_err_ (code, err_name, "^a", name);
		return;
	     end;

	     call hcs_$set_copysw (path, entry, sw, code); /* fix the copy switch */
	     if code ^= 0 then do;
		call com_err_ (code, err_name, "^a^[>^]^a", path, (path ^= ">"), entry);
		return;
	     end;

	end;

	return;

     end copy_switch_on;




		    delete.pl1                      02/27/89  1206.7rew 02/27/89  1051.0      210591



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



/****^  HISTORY COMMENTS:
  1) change(86-07-17,Houck), approve(86-07-17,MCR7487), audit(86-08-14,Wong),
     install(86-09-04,MR12.0-1148):
     Changed the query_each_sw and -query_all_sw switches so that the
     -query_each and -query_all arguments would be processed as per Multics
     argument processing conventions.
  2) change(88-07-06,TLNguyen), approve(88-07-06,MCR7922),
     audit(88-07-08,Parisek), install(88-07-12,MR12.2-1055):
     Change the delete command to use error_table_$bad_file_name to report an
     error when a null characters string is specified in place of path
     argument.
  3) change(89-01-16,TLNguyen), approve(89-01-27,MCR8047),
     audit(89-02-06,Parisek), install(89-02-27,MR12.3-1015):
     Issue an extra query to protect directories whose safety switches are
     set and a starname is specified in place of a directory path.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */

delete:
dl:
     procedure options (variable);

/**** Implements these commands:

      delete file_paths {-control_args}

      l_delete file_paths {-control_args}

      delete_dir directory_paths {-control_args}

      unlink link_paths {-control_args}

      and the obsolete delete_force command equivalent to "delete -force".
      Rewritten 01/11/80 by S. Herbst */
/* Modified: 30 June 1980 by G. Palter to fix bug where error messages are meaningless */
/* Fixed bugs and added -absolute_pathname and -entryname 07/19/82 S. Herbst */
/* Fixed nomatch error message 11/08/82 S. Herbst */
/* Fixed "dl ** -qye -long" to print individual queries 12/13/82 S. Herbst */
/* Modified 2/20/83 Jay Pattin for object_type_ */
/* Modified 6/9/83 Jay Pattin. Added l_delete, Changed to use delete_options, added -no_force */
/* 830927 BIM for object_type_ --> fs_util_ */
/* Fixed dl -chase to delete segments 06/25/84 S. Herbst */
/* Modified 12/03/84 by Matthew Pierret: to print helpful message if the
   directory could not be deleted because it contained a protected
   data management file and a transaction is in progress (code
   returned from delete_ is error_table_$no_delete_dir_transaction).
   This means that the actual file deletion will be done when the
   transaction completes. */
/* Modified 850206 MSharpe to replace -fcnt with -inase/inaee */

/* format: off */
%page; %include delete_options;
%page; %include branch_status;
%page; %include star_structures;
%page; %include suffix_info;
%page; %include copy_flags;
%page;

/* format: on */
	dcl     1 si		        aligned like suffix_info;

	dcl     1 query_array	        (query_bound) based (query_ptr),
		2 query_dn	        char (168),
		2 query_en	        char (32);

	dcl     (old_query_ptr, query_ptr)    ptr;
	dcl     (new_query_bound, old_query_bound, query_bound, query_count)
				        fixed bin;


	dcl     1 entries		        (ecount) based (entries_ptr),
		2 type		        bit (2) unaligned,
		2 nnames		        bit (16) unaligned,
		2 nindex		        bit (18) unaligned;

	dcl     names		        (99 /* arbitrary */) char (32) aligned based (names_ptr);

	dcl     arg		        char (arg_len) based (arg_ptr);
	dcl     fs_util_type	        char (32);
	dcl     (dn, print_path, target_dn)   char (168);
	dcl     (en, myname, starname, target_en, thing, things, what)
				        char (32);

	dcl     area		        area based (area_ptr);

	dcl     (absp_sw, brief_sw, chase_sw, chased, force_sw, force_no_type_sw, long_sw, query_sw, query_all_sw,
	        query_each_sw, safety_sw, same_dir_sw, saved_force_sw, some_args, some_matches, yes_sw)
				        bit (1);

	dcl     (area_ptr, arg_ptr, entries_ptr, names_ptr)
				        ptr;
          dcl     QUERY_LIMIT fixed bin int static options (constant) init (20);

	dcl     (
	        NO_CHASE		        init (0),
	        CHASE		        init (1)
	        )			        fixed bin (1) int static options (constant);
	dcl     (
                  NO_STAR_NAME                  init (0),
	        STAR_NAME		        init (1),
	        STAR_STAR_NAME	        init (2)
	        )			        fixed bin (35) int static options (constant);

	dcl     entry_type		        fixed bin (2);
	dcl     (arg_count, arg_len, ecount, i, j)
				        fixed bin;
	dcl     bit_count		        fixed bin (24);
	dcl     (code, star_code)	        fixed bin (35);

	dcl     error_table_$action_not_performed
				        fixed bin (35) ext;
          dcl     error_table_$bad_file_name    fixed bin (35) ext;
	dcl     error_table_$badopt	        fixed bin (35) ext;
	dcl     error_table_$incorrect_access fixed bin (35) ext;
	dcl     dm_error_$no_delete_dir_transaction
				        fixed bin (35) ext;
	dcl     error_table_$no_info	        fixed bin (35) ext;
	dcl     error_table_$no_s_permission  fixed bin (35) ext;
	dcl     error_table_$noentry	        fixed bin (35) ext;
	dcl     error_table_$nomatch	        fixed bin (35) ext;
	dcl     error_table_$root	        fixed bin (35) ext;

	dcl     (
	        com_err_,
	        com_err_$suppress_name
	        )			        entry options (variable);
	dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
	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     delete_$path	        entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
	dcl     dl_handler_$dblstar	        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     dl_handler_$dirdelete	        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_system_free_area_	        entry returns (ptr);
	dcl     get_wdir_		        entry returns (char (168));
	dcl     hcs_$get_link_target	        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$get_safety_sw	        entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     hcs_$star_		        entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				        fixed bin (35));
	dcl     hcs_$status_long	        entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				        fixed bin (35));
	dcl     ioa_		        entry options (variable);
	dcl     installation_tools_$delentry_file
				        entry (char (*), char (*), fixed bin (35));
	dcl     fs_util_$get_type	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     fs_util_$suffix_info_for_type entry (character (*), pointer, fixed binary (35));
	dcl     pathname_		        entry (char (*), char (*)) returns (char (168));

	dcl     (addr, codeptr, fixed, index, null, string, substr, unspec)
				        builtin;

	dcl     (cleanup, linkage_error)      condition;	/*						*/
	myname = "delete";
	thing = "file";
	things = "files";
	string (delete_options) = ""b;
	delete_options.question, delete_options.segment = "1"b;
	force_sw = "0"b;
	go to COMMON;

l_delete:
ldl:
     entry;

	myname = "l_delete";
	thing = "file";
	things = "files";
	string (delete_options) = ""b;
	force_sw = "1"b;
	delete_options.question, delete_options.force, delete_options.segment, delete_options.library,
	     delete_options.raw = "1"b;
	go to COMMON;

delete_force:
deleteforce:
df:
     entry;					/* OBSOLETE */

	myname = "delete_force";
	thing = "file";
	things = "files";
	string (delete_options) = ""b;
	force_sw = "1"b;
	delete_options.force, delete_options.segment = "1"b;
	go to COMMON;

delete_dir:
dd:
     entry options (variable);

	myname = "delete_dir";
	thing = "directory";
	things = "directories";
	string (delete_options) = ""b;
	delete_options.force, delete_options.question, delete_options.directory = "1"b;
	force_sw = "0"b;
	go to COMMON;

unlink:
ul:
     entry options (variable);

	myname = "unlink";
	thing = "link";
	things = "links";
	string (delete_options) = ""b;
	delete_options.link = "1"b;
	force_sw = "0"b;


COMMON:
	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname);
		return;
	     end;

	si.version = SUFFIX_INFO_VERSION_1;
	entries_ptr, names_ptr, query_ptr = null;

	absp_sw, brief_sw, chase_sw, force_no_type_sw, long_sw, query_sw, query_all_sw, query_each_sw, some_args = "0"b;
	if delete_options.library
	then force_no_type_sw = "1"b;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, myname);
		return;
	     end;

	     if index (arg, "-") ^= 1
	     then some_args = "1"b;

	     else if arg = "-absolute_pathname" | arg = "-absp"
	     then absp_sw = "1"b;
	     else if arg = "-brief" | arg = "-bf"
	     then brief_sw = "1"b;
	     else if arg = "-chase" & myname = "delete"
	     then chase_sw = "1"b;
	     else if arg = "-no_chase" & myname = "delete"
	     then chase_sw = "0"b;
	     else if arg = "-entryname" | arg = "-etnm"
	     then absp_sw = "0"b;
	     else if arg = "-force" | arg = "-fc"
	     then delete_options.force, force_sw = "1"b;
	     else if arg = "-no_force" | arg = "-nfc"
	     then delete_options.force, force_sw = "0"b;
	     else if arg = "-interpret_as_standard_entry" | arg = "-inase"
	     then force_no_type_sw, delete_options.raw = "1"b;
	     else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
	     then force_no_type_sw, delete_options.raw = "0"b;
	     else if arg = "-long" | arg = "-lg"
	     then long_sw = "1"b;
	     else if arg = "-name" | arg = "-nm"
	     then do;
		     i = i + 1;
		     if i > arg_count
		     then do;
			     call com_err_ (0, myname, "No value specified for -name");
			     return;
			end;
		     some_args = "1"b;
		end;
	     else if arg = "-query_each" | arg = "-qye"
	     then do;

		     query_each_sw, query_sw = "1"b;
		     query_all_sw = "0"b;
		end;
	     else if arg = "-query_all" | arg = "-qya"
	     then do;

		     query_all_sw, query_sw = "1"b;
		     query_each_sw = "0"b;
		end;


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

	if ^some_args
	then do;
		call com_err_$suppress_name (0, myname, "Usage:  ^a ^a_paths {-control_args}", myname, thing);
		return;
	     end;

	if delete_options.library
	then do;
		on linkage_error
		     begin;			/* check for installation_tools_ access */
			call com_err_ (0, myname, "This command requires access to the installation_tools_ gate.");
			goto MAIN_RETURN;
		     end;

		arg_ptr = codeptr (installation_tools_$delentry_file);
						/* provoke linkage error */
		revert linkage_error;
	     end;

	on cleanup
	     begin;
		call star_cleanup;
		if query_ptr ^= null
		then free query_array in (area);
	     end;

	if query_all_sw
	then do;
		query_bound = QUERY_LIMIT;
		area_ptr = get_system_free_area_ ();

		allocate query_array in (area) set (query_ptr);
		query_count = 0;
	     end;
	else area_ptr = null;

	do i = 1 to arg_count;

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

	     if index (arg, "-") = 1
	     then if arg = "-name" | arg = "-nm"
		then do;
			i = i + 1;
			call cu_$arg_ptr (i, arg_ptr, arg_len, code);

			dn = get_wdir_ ();
			en, starname = arg;
			go to NO_STARS;
		     end;
		else go to NEXT_ARG;

	     if arg = ""                         /* a null string such as "", " ", "    "  is specified
		                                  in place of path argument */
	     then do;
		     call com_err_ (error_table_$bad_file_name, myname, """""");
		     go to NEXT_ARG;
		end;

	     call expand_pathname_ (arg, dn, starname, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, myname, "^a", arg);
		     go to NEXT_ARG;
		end;

	     call check_star_name_$entry (starname, star_code);
	     if star_code = NO_STAR_NAME
	     then do;

		     en = starname;

NO_STARS:
		     chased = "0"b;

STATUS:
		     call hcs_$status_minf (dn, en, NO_CHASE, entry_type, bit_count, code);
		     if code ^= 0
		     then do;
PATH_ERROR:
			     if ^brief_sw | (code ^= error_table_$noentry & code ^= error_table_$nomatch)
			     then call com_err_ (code, myname, "^a", pathname_ (dn, en));
			     go to NEXT_ARG;
			end;

		     if ^force_no_type_sw & entry_type ^= star_LINK
		     then do;
			     call fs_util_$get_type (dn, en, fs_util_type, code);
			     if code = 0 & fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
			     then do;
				     entry_type = star_SEGMENT;
				     if ^delete_options.segment
				     then do;
					     call fs_util_$suffix_info_for_type (fs_util_type, addr (si), (0));
					     call com_err_ (code, myname, "^a is a ^a. Use delete.",
						pathname_ (dn, en), si.type_name);
					     goto NEXT_ARG;
					end;
				end;
			end;

		     if entry_type = star_LINK
		     then do;
			     if ^delete_options.link
			     then do;
				     if chase_sw & ^chased
				     then do;
					     call hcs_$get_link_target (dn, en, target_dn, target_en, code);
					     if code ^= 0
					     then do;
						     call com_err_ (code, myname, "Unable to chase link ^a",
							pathname_ (dn, en));
						     go to NEXT_ARG;
						end;
					     dn = target_dn;
					     en = target_en;
					     chased = "1"b;
					     go to STATUS;
					end;
				     call com_err_ (0, myname, "^a is a link. Use unlink.", pathname_ (dn, en));
				     go to NEXT_ARG;
				end;
			end;

		     else if entry_type = star_DIRECTORY & bit_count = 0
		     then do;
			     if ^delete_options.directory
			     then do;
				     call com_err_ (0, myname, "^a is a directory. Use delete_dir.",
					pathname_ (dn, en));
				     go to NEXT_ARG;
				end;
			     if ^force_sw
			     then do;
				     if ^modify (dn, en)
				     then go to NEXT_ARG;
						/* ^modify prints err msg */
				     if ^query_sw
				     then do;
					     call dl_handler_$dirdelete (myname, dn, en, code);
						/* Do you want to delete the directory dn>en? */
					     if code ^= 0
					     then go to NEXT_ARG;
					end;
				end;
			end;

		     else do;			/* segment or MSF */
			     if ^delete_options.segment
			     then do;
				     call com_err_ (0, myname,
					"^a is a ^[multisegment file^;segment^]. Use delete.",
					pathname_ (dn, en), entry_type = star_DIRECTORY);
				     go to NEXT_ARG;
				end;
			end;

		     if absp_sw
		     then print_path = pathname_ (dn, en);
		     else print_path = en;

		     call delete_one;

		end;

	     else if star_code = STAR_NAME | star_code = STAR_STAR_NAME
	     then do;				/* star convention */

		     if area_ptr = null
		     then area_ptr = get_system_free_area_ ();
		     entries_ptr, names_ptr = null;

		     if delete_options.link | chase_sw
		     then entry_type = star_ALL_ENTRIES;
		     else entry_type = star_BRANCHES_ONLY;

		     call hcs_$star_ (dn, starname, entry_type, area_ptr, ecount, entries_ptr, names_ptr, code);
		     if code ^= 0
		     then do;
			     if ^brief_sw | code ^= error_table_$nomatch
			     then call com_err_ (code, myname, "^a", pathname_ (dn, starname));
			     go to NEXT_ARG;
			end;

		     if (delete_options.directory | star_code = STAR_STAR_NAME) & ^force_sw
		     then do;			/* dd, dl **, or ul **  */
			     if ^modify (dn, starname)
			     then go to NEXT_ARG;
			     if long_sw & ^query_each_sw
			     then do;		/* combine the ** or dd query with -long query */
				     long_sw = "0"b;
				     query_all_sw, query_sw = "1"b;
				     if query_ptr = null
				     then do;
					     query_bound = QUERY_LIMIT;
					     area_ptr = get_system_free_area_ ();

					     allocate query_array in (area) set (query_ptr);
					     query_count = 0;
					end;
				end;
			     if ^query_sw
			     then do;
				     call dl_handler_$dblstar (myname, dn, starname, code);
						/* Do you want to delete/unlink 'starname' in dn? */
				     if code ^= 0
				     then go to NEXT_ARG;
				end;

						/* query again for protected dirs because a starname is specified. */
			     if delete_options.directory & (star_code = STAR_NAME | star_code = STAR_STAR_NAME)
			     then delete_options.force = "0"b;

			end;

		     some_matches = "0"b;

		     do j = 1 to ecount;

			en = names (fixed (entries.nindex (j), 17));

			if ^force_no_type_sw & entries.type (j) ^= link_type
			then do;
				call fs_util_$get_type (dn, en, fs_util_type, code);
				if code = 0 & fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
				then entries.type (j) = segment_type;
			     end;

			if entries.type (j) = link_type
			then do;
				if chase_sw
				then do;
					some_matches = "1"b;
					call hcs_$get_link_target (dn, en, target_dn, target_en, code);
					if code ^= 0
					then do;
						call com_err_ (code, myname, "Unable to chase link ^a",
						     pathname_ (dn, en));
						go to NEXT_MATCH;
					     end;
					dn = target_dn;
					en = target_en;
					call hcs_$status_minf (dn, en, NO_CHASE, entry_type, bit_count, code);
					if entry_type = star_LINK
					     | (entry_type = star_DIRECTORY & bit_count = 0)
					then go to NEXT_MATCH;
				     end;
				else if ^delete_options.link
				then go to NEXT_MATCH;
			     end;
			else if entries.type (j) = segment_type
			then do;
FILE:
				if ^delete_options.segment
				then go to NEXT_MATCH;
			     end;
			else do;			/* directory or MSF */
				call hcs_$status_minf (dn, en, NO_CHASE, entry_type, bit_count, code);
				if bit_count ^= 0
				then go to FILE;
				if ^delete_options.directory
				then go to NEXT_MATCH;
			     end;

			some_matches = "1"b;

			if absp_sw
			then print_path = pathname_ (dn, en);
			else print_path = en;

			call delete_one;

			if code = error_table_$incorrect_access | code = error_table_$no_info
			then do;
				call star_cleanup;
				go to NEXT_ARG;
			     end;
NEXT_MATCH:
		     end;

		     call star_cleanup;

		     if ^some_matches
		     then do;
			     if ^brief_sw
			     then call com_err_ (0, myname, "No ^a selected by starname.  ^a", things,
				     pathname_ (dn, starname));
			     go to NEXT_ARG;
			end;
		end;
	     else call com_err_ (star_code, myname, "^a", pathname_ (dn, starname));

NEXT_ARG:
	end;

	if query_all_sw & query_count > 0
	then do;

		if myname = "delete" | myname = "delete_force"
		then what = "Files";
		else if myname = "delete_dir"
		then what = "Directories";
		else what = "Links";

		same_dir_sw = "1"b;
		do i = 2 to query_count;
		     if query_dn (i) ^= query_dn (1)
		     then same_dir_sw = "0"b;
		end;

		call ioa_ ("^a to be deleted^[ in ^a^]:", what, same_dir_sw, query_dn (1));

		do i = 1 to query_count;
		     if same_dir_sw
		     then call ioa_ ("^3x^a", query_en (i));
		     else call ioa_ ("^3x^a", pathname_ (query_dn (i), query_en (i)));
		end;

		call command_query_$yes_no (yes_sw, 0, myname, "", "Delete?");

		if yes_sw
		then do i = 1 to query_count;
			call delete_$path (query_dn (i), query_en (i), string (delete_options), myname, code);
			if code = 0 | code = error_table_$action_not_performed
			then do;
				if long_sw
				then if absp_sw
				     then call ioa_ ("Deleted ^a", pathname_ (query_dn (i), query_en (i)));
				     else call ioa_ ("Deleted ^a", query_en (i));
			     end;
			else if code = dm_error_$no_delete_dir_transaction
			then call com_err_ (code, myname, "^/The contents of ^a ^a^/^a^/^a",
				pathname_ (query_dn (i), query_en (i)), "which do not need to wait until the",
				"transaction commits have been deleted.  The directory itself can be",
				"deleted after the transaction ends.");

			else call com_err_ (code, myname, "^a", pathname_ (query_dn (i), query_en (i)));

		     end;
	     end;

	if query_all_sw
	then do;
		free query_array in (area);
		query_ptr = null;
	     end;

MAIN_RETURN:
	return;					/*						*/
delete_one:
     proc;

/* This internal procedure remembers the pathname dn>en if -query_all,
   else implements -query_each and -long and deletes the single entry dn>en. */

	code = 0;

	if query_all_sw
	then do;
		query_count = query_count + 1;
		if query_count > query_bound
		then call grow_query_array;
		query_dn (query_count) = dn;
		query_en (query_count) = en;
		return;
	     end;

	saved_force_sw = delete_options.force;

	if query_each_sw
	then do;
		safety_sw = "0"b;
		if ^delete_options.link
		then do;
			call hcs_$get_safety_sw (dn, en, safety_sw, 0);
			call hcs_$status_long (dn, en, NO_CHASE, addr (branch_status), null, 0);
		     end;

		call command_query_$yes_no (yes_sw, 0, myname, "",
		     "^[Unlink^;Delete^] ^a ?^[^[ (safety switch is on)^]^[ (copy switch is on)^]^]",
		     delete_options.link, print_path, ^delete_options.link, safety_sw, branch_status.copy_switch);

		if ^yes_sw
		then return;

		if safety_sw | branch_status.copy_switch
		then delete_options.force = "1"b;
	     end;

	call delete_$path (dn, en, string (delete_options), myname, code);
	if code ^= 0
	then do;
		if code = dm_error_$no_delete_dir_transaction
		then call com_err_ (code, myname, "^/The contents of ^a ^a^/^a^/^a", pathname_ (dn, en),
			"which do not need to wait until the",
			"transaction commits have been deleted.  The directory itself can be",
			"deleted after the transaction ends.");
		else if code ^= error_table_$action_not_performed
		then call com_err_ (code, myname, "^a", pathname_ (dn, en));
	     end;

	else if long_sw & ^query_each_sw
	then call ioa_ ("Deleted ^a ^a", thing, print_path);

	delete_options.force = saved_force_sw;

     end delete_one;				/*						*/
modify:
     proc (a_dn, a_en) returns (bit (1));

/* This internal procedure returns "1"b if the user has modify on the directory a_dn */

	dcl     (a_dn, a_en)	        char (*);

	call hcs_$status_long (a_dn, "", CHASE, addr (branch_status), null, code);
	if code = error_table_$root
	then return ("1"b);				/* ignore and let hardcore catch moderr */
	if code ^= 0 & code ^= error_table_$no_s_permission
	then do;
		call com_err_ (code, myname, "Unable to check access to ^a", a_dn);
		return ("0"b);
	     end;
	if substr (branch_status.mode, 4, 1)
	then return ("1"b);
	call com_err_ (error_table_$incorrect_access, myname, "^a", pathname_ (a_dn, a_en));
	return ("0"b);

     end modify;



grow_query_array:
     proc;

/* This internal procedure doubles the size of query_array */

	old_query_ptr = query_ptr;
	old_query_bound = query_bound;
	query_bound, new_query_bound = query_bound * 2;
	allocate query_array in (area) set (query_ptr);
	query_bound = old_query_bound;
	unspec (query_ptr -> query_array) = unspec (old_query_ptr -> query_array);
	free old_query_ptr -> query_array in (area);
	query_bound = new_query_bound;

     end grow_query_array;



star_cleanup:
     proc;

	if entries_ptr ^= null
	then free entries in (area);
	if names_ptr ^= null
	then free names in (area);
	entries_ptr, names_ptr = null;

     end star_cleanup;


     end delete;




		    delete_.pl1                     10/06/92  0059.4r w 10/06/92  0057.4      170685



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



/****^  HISTORY COMMENTS:
  1) change(90-07-30,Bubric), approve(90-07-30,MCR8185), audit(90-09-12,Vu),
     install(90-09-20,MR12.4-1026):
     Fix delete_$path to handle extended objects which are directories.
  2) change(92-09-24,Vu), approve(92-09-24,MCR8266), audit(92-09-24,Zimmerman),
     install(92-10-06,MR12.5-1025):
     Fixed dl command for deleting forum.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */

delete_$path:
     procedure (dirname, entryname, a_switches, caller, code);

/* The delete_ subroutine takes care of deleting branches and unlinking links.  It
   can ask questions if access is incorrect to the segment, and attempt to force delete access.

   The path entry is called with the pathname of the thing to be deleted or unlinked.
   The switches argument tells delete_ what it is to do:

   1. force_sw      If ON, delete_ attempts to delete protected
   .                as well as unprotected entries.
   2. question_sw   If ON and force_sw is OFF, delete_ queries the user
   .                about deleting protected entries. If force_sw is ON
   .                and ename refers to a directory, delete_ prints a
   .                message for each entry under that directory that
   .                cannot be deleted.
   3. directory_sw  A directory can be deleted only if ON.
   4. segment_sw    A segment can be deleted only if ON.
   5. link_sw       A link can be unlinked only if ON.
   6. chase_sw      If ON, delete_ deletes through links.
   7. lib_sw        If ON, calls through installation_tools_.
   8. raw_sw        If ON, delete_$path calls hcs_ and not object_type_.

   Initially coded April 1972 by Dan Bricklin.
   Modified on November 1972 by E. Stone for new directory control
   Modified on Jan 1974 by E. Stone to reflect that error_table_$moderr not returned from delentry
   Modified on May 15, 1974 by Kobziar to delete initiate acl if seg not deleted.
   Modified on Oct 1, 1974 by J. Whitmore to attempt to delete a directory before calling del_dir_tree also
   to correct a bad error code if the ptr entry is called with a null pointer.
   Modified on 8/27/75 to prevent infinite delete_again, etc. loops.
   Modified April 1976 by Larry Johnson for master directories.
   Modified Oct 4, 1979 by M. Pierret to skip unnecessary calls to term_$nomakeunknown.
   Modified to work on mailboxes and queues 03/28/80 S. Herbst
   Modified 30 June 1980 by G. Palter to make delete_$path not loop on inner ring segments and make delete_$ptr work again
   Modified 21 October 1980 by G. Palter to not loop on inner ring segments with names shorter than 4 characters
   Modified 01/17/83 by S. Herbst to recognize et_$action_not_performed fom dl_handler_
   Modified 1/26/83 Jay Pattin for object_type_, added raw_sw
   Modified 3/15/83 Jay Pattin to terminate segments when user answers no to "delete?" query
   Modified 830927 BIM for object_type_ --> fs_util_.
   Modified 831022 BIM to fix bug in descriptor checking for bit (6).
   Modified 831027 BIM to never terminate until after checking safety switch.
   Modified 840626 to suppress ssw/copysw query when force-deleting dir.
   Modified 841119 MAP to generate all abs pathnames by using pathname_.
   Modified 841203 Matthew Pierret: to not delete a directory which contains
   a protected data management file if a transaction is in
   progress.  This is because deletion of dm files is delayed
   until the transaction commits.
   Modified 850124 Steve Herbst to call hcs_$get_segment_ptr_path rather
	than initiate a segment.
   Modified 850206 Keith Loepere for correct error code $moderr instead of
	$incorrect_access from hcs_$star_.
*/

	dcl     a_switches		        bit (36) aligned;
	dcl     all		        fixed bin (2) init (3);
	dcl     bitcount		        fixed bin (24);
	dcl     caller		        char (*);
	dcl     code		        fixed bin (35);
	dcl     com_err_		        entry options (variable);
	dcl     delete_$path	        entry (char (*), char (*), bit (36) aligned, char (*), fixed bin (35));
	dcl     directory_contents_code       fixed bin (35);
	dcl     dirname		        char (*);
	dcl     dl_handler_$switches	        entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
	dcl     dname		        char (168);
	dcl     ecount		        fixed bin;
	dcl     ename		        char (32);
	dcl     entryname		        char (*);
	dcl     eptr		        pointer;
	dcl     etype		        bit (2);
	dcl     fs_util_type	        char (32);
	dcl     get_group_id_$tag_star        entry returns (char (32) aligned);
	dcl     get_system_free_area_	        entry returns (ptr);
	dcl     path_entry		        bit (1);
	dcl     fs_util_$get_type	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     fs_util_$delentry_file        entry (character (*), character (*), fixed binary (35));

	dcl     hcs_$add_dir_acl_entries      entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delentry_file	        entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$fs_get_path_name	        entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$get_link_target	        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$get_safety_sw_seg        entry (pointer, bit (1) aligned, fixed bin (35));
	dcl     hcs_$get_segment_ptr_path     entry (char (*), char (*), ptr, bit (36) aligned, fixed bin (35));
	dcl     hcs_$lv_attached	        entry (bit (36) aligned, 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_$status_long	        entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     installation_tools_$delentry_file
				        entry (char (*), char (*), fixed bin (35));
	dcl     i			        fixed bin;
	dcl     init_acl_sw		        bit (1) aligned init ("0"b);
	dcl     mdc_$delete_dir	        entry (char (*), char (*), fixed bin (35));
	dcl     name		        char (32);
	dcl     nptr		        pointer;
	dcl     operation		        char (6);
	dcl     pathname_		        entry (char (*), char (*)) returns (char (168));
	dcl     pname		        char (168);
	dcl     safety_switch	        bit (1) aligned;
	dcl     segp		        ptr;
	dcl     segptr		        ptr;
	dcl     term_$seg_ptr	        entry (pointer, fixed binary (35));
	dcl     type		        fixed bin (2);

	dcl     error_table_$action_not_performed
				        ext fixed bin (35);
	dcl     error_table_$copy_sw_on       ext fixed bin (35);
	dcl     dm_error_$delete_pending_transaction
				        ext fixed bin (35);
	dcl     error_table_$dirseg	        ext fixed bin (35);
	dcl     error_table_$fulldir	        ext fixed bin (35);
	dcl     error_table_$incorrect_access ext fixed bin (35);
	dcl     error_table_$invalidsegno     ext fixed bin (35);
	dcl     error_table_$master_dir       ext fixed bin (35);
	dcl     error_table_$moderr	        ext fixed bin (35);
	dcl     dm_error_$no_delete_dir_transaction
				        ext fixed bin (35);
	dcl     error_table_$nondirseg        ext fixed bin (35);
	dcl     error_table_$not_a_branch     ext fixed bin (35);
	dcl     error_table_$safety_sw_on     ext fixed bin (35);


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


	dcl     1 dir_acl		        aligned,
		2 userid		        char (32),
		2 mode		        bit (36),
		2 status		        fixed bin (35);

	dcl     1 entries		        (ecount) aligned based (eptr),
		2 type		        bit (2) unaligned,
		2 nnames		        bit (16) unaligned,
		2 nindex		        bit (18) unaligned;

	dcl     names		        (1000) char (32) aligned based (nptr);


	dcl     1 lbranch		        aligned,	/* structure returned by status_long */
		2 type		        bit (2) unaligned,
		2 nnames		        fixed bin (15) unaligned,
		2 nrp		        bit (18) unaligned,
		2 dtm		        bit (36),
		2 dtu		        bit (36),
		2 mode		        bit (5) unaligned,
		2 raw_mode	        bit (5) unaligned,
						/* raw mode from acl entry */
		2 pad1		        bit (8) unaligned,
		2 records		        fixed bin (17) unaligned,
		2 dtd		        bit (36),	/* date time segment and branch dumped */
		2 dtem		        bit (36),	/* date time branch modified */
		2 lvid		        bit (36),	/* logical volume id (sons_lvid for dirs) */
		2 curlen		        fixed bin (11) unaligned,
						/* highest 1024-word block used */
		2 bitcnt		        bit (24) unaligned,
						/* bit count */
		2 did		        bit (4) unaligned,
		2 mdid		        bit (4) unaligned,
		2 copysw		        bit (1) unaligned,
		2 tpd		        bit (1) unaligned,
		2 pad3		        bit (8) unaligned,
		2 rbs		        (0:2) fixed bin (5) unaligned,
		2 uid		        bit (36);
%page;
%include delete_options;
%include std_descriptor_types;

%include dl_handler_options;

%include suffix_info;
%include copy_flags;

/* Initialize variables.  Set code to zero, and remember that we have the pathname
   of the thing to be deleted (the ptr entry does not provide it). */

	code = 0;
	dname = dirname;
	ename = entryname;
	path_entry = "1"b;
	segp = null;
	call check_switches (3);

/* Find out what type of branch this is.  Then dispatch to the appropriate action routine,
   or error message.  Note that a directory with a non-zero bitcount
   is considered to be a segment - an MSF */

check_type:
	call hcs_$status_minf (dname, ename, 0, type, bitcount, code);
	if code ^= 0
	then return;

	if ^delete_options.raw & type ^= 0
	then do;
		call fs_util_$get_type (dname, ename, fs_util_type, code);
						/* Is this Xobj (not link to Xobj)? */
		if code = 0 & (substr (fs_util_type, 1, 1) ^= "-" | fs_util_type = FS_OBJECT_TYPE_DM_FILE)
		then do;				/* - at beginning implies standard object, but */
						/* this program treats DM files as extended */
						/* rather than standard objects */
            		/* if extended object, don't try to initiate */
		          if type = 1 & ^delete_options.segment
                              then goto is_segment;
                              goto call_delete;
		     end;
	     end;

	if type = 0
	then /* link */
	     if ^delete_options.link
	     then go to is_link;
	     else if delete_options.chase
	     then do;
		     call hcs_$get_link_target (dname, ename, dname, ename, code);
		     if code ^= 0
		     then return;			/* chase the link and start again */
		     go to check_type;
		end;
	     else go to unlink_link;

	else if type = 1
	then /* segment */
	     if ^delete_options.segment
	     then go to is_segment;
	     else go to delete_segment;

	else if type = 2
	then /* directory */
	     if bitcount ^= 0
	     then do;
		     if ^delete_options.segment
		     then go to is_segment;
		     type = 3;			/* msf */
		     go to delete_msf;
		end;

	     else if ^delete_options.directory
	     then go to is_directory;
	     else go to delete_directory;


/* Call term_ on the segment to be deleted. */
/* Initiate it here, so we can take advantage of segptr if we have it */

delete_segment:
	if segp = null ()
	then do;
		call hcs_$get_segment_ptr_path (dirname, ename, segp, "0"b, code);
		if segp ^= null ()			/* segment was previously initiated */
		then do;
			call hcs_$get_safety_sw_seg (segp, safety_switch, (0));
			if safety_switch
			then go to protected_by_switch;
			/*** * We don't check the copy switch, it is too much pain. */
			call term_$seg_ptr (segp, (0));
						/* begone! */
		     end;
		segp = null ();
	     end;
	else do;
		call hcs_$fs_get_path_name (segp, dname, (0), ename, code);
		if code ^= 0
		then return;
	     end;


unlink_link:
call_delete:
	if delete_options.library
	then call installation_tools_$delentry_file (dname, ename, code);
	else if delete_options.raw | type = 0		/* flush links with hcs_ */
	then call hcs_$delentry_file (dname, ename, code);
	else call fs_util_$delentry_file (dname, ename, code);

	if code ^= 0
	then if code = error_table_$copy_sw_on | code = error_table_$safety_sw_on
	     then
protected_by_switch:				/* come here to avoid terminating before asking question */
		do;				/* entry is protected - see whether to force */
		     if (^delete_options.force & ^delete_options.question)
		     then return;

		     string (dl_handler_options) = ""b;
		     dl_handler_options.no_question = delete_options.force;
		     dl_handler_options.raw = delete_options.raw;
		     dl_handler_options.library = delete_options.library;

		     call dl_handler_$switches (caller, dname, ename, string (dl_handler_options), code);

		     if code = 0
		     then go to call_delete;
		     else return;
		end;
	return;


/* Delete a directory.  MSF's (directories with non-zero bitcounts) are treated the same way */

delete_msf:
delete_directory:
	call hcs_$delentry_file (dname, ename, code);	/* try to delete it first */
	if code = error_table_$fulldir
	then do;					/* have to delete its contents */
delete_contents:
		call hcs_$status_long (dname, ename, 0, addr (lbranch), null, code);
						/* must find out if mounted before deleting */
		if code ^= 0
		then return;
		call hcs_$lv_attached (lbranch.lvid, code);
		if code ^= 0
		then return;
		pname = pathname_ (rtrim (dname), ename);
list_again:
		call hcs_$star_ (pname, "**", all, get_system_free_area_ (), ecount, eptr, nptr, code);
		if code ^= 0
		then do;
			if code = error_table_$moderr
			then do;			/* force dir access */
				if init_acl_sw
				then return;
				dir_acl.userid = get_group_id_$tag_star ();
				dir_acl.mode = "111"b;
				dir_acl.status = 0;
				call hcs_$add_dir_acl_entries (dname, ename, addr (dir_acl), 1, code);
				init_acl_sw = "1"b;
				if code = 0 & dir_acl.status = 0
				then go to list_again;
			     end;
			if delete_options.question
			then call com_err_ (code, caller, "Unable to delete ^a", pname);
			return;
		     end;
		directory_contents_code = 0;
		do i = 1 to ecount;
		     name = names (fixed (entries (i).nindex));
		     etype = entries (i).type;
		     delete_options.link, delete_options.segment = "1"b;
		     init_acl_sw = "0"b;
delete_again:
		     call delete_$path (pname, name, (string (delete_options)), caller, code);
						/* recurse */
		     if code ^= 0
		     then do;
			     if code = error_table_$incorrect_access
			     then do;		/* force dir access */
				     if init_acl_sw
				     then return;
				     dir_acl.userid = get_group_id_$tag_star ();
				     dir_acl.mode = "111"b;
				     dir_acl.status = 0;
				     call hcs_$add_dir_acl_entries (dname, ename, addr (dir_acl), 1, code);
				     init_acl_sw = "1"b;
				     if code = 0 & dir_acl.status = 0
				     then go to delete_again;
				end;
			     if code = error_table_$action_not_performed
			     then do;
				     directory_contents_code = code;
				     go to endloop;
				end;
			     if directory_contents_code ^= error_table_$action_not_performed
				& (code = dm_error_$delete_pending_transaction
				| code = dm_error_$no_delete_dir_transaction)
			     then directory_contents_code = dm_error_$no_delete_dir_transaction;
			     else directory_contents_code = error_table_$action_not_performed;
			     if delete_options.question
			     then if code = dm_error_$delete_pending_transaction
				then call com_err_ (code, caller, " ^a>^a", pname, name);
				else do;
					if etype = "00"b
					then operation = "unlink";
					else operation = "delete";
					call com_err_ (code, caller, "Unable to ^a ^a>^a", operation, pname,
					     name);
				     end;
			end;
endloop:
		end;
		code = directory_contents_code;
		if code = 0
		then go to delete_directory;		/* try again now that contents are deleted */
	     end;
	else if code = error_table_$copy_sw_on | code = error_table_$safety_sw_on
	then do;
		string (dl_handler_options) = ""b;
		dl_handler_options.no_question = ^delete_options.question | delete_options.force;
		dl_handler_options.raw = delete_options.raw;
		dl_handler_options.library = delete_options.library;

		if delete_options.question | delete_options.force
						/* either dl handler will ask, or it is licensed to fix things without asking */
		then call dl_handler_$switches (caller, dname, ename, string (dl_handler_options), code);
		else return;
		if code = 0
		then go to delete_directory;
	     end;

	else if code = error_table_$master_dir
	then do;					/* must call mdc to delete this */
		call mdc_$delete_dir (dname, ename, code);
		if code ^= 0
		then if code = error_table_$fulldir
		     then go to delete_contents;
	     end;

	return;






ptr:
     entry (segptr, a_switches, caller, code);


/* The ptr entry is similar to the path entry, except that the caller already has a ptr to the
   segment, so we might as well save the initiate call.  You can only have a ptr to a segment (not
   a link, directory, or MSF). */




	if segptr = null
	then do;
		code = error_table_$invalidsegno;
		return;
	     end;

	code = 0;
	segp = segptr;
	path_entry = "0"b;
	type = 1;

	call check_switches (2);
	if ^delete_options.segment
	then go to is_segment;
	go to delete_segment;






is_link:
	code = error_table_$not_a_branch;
	return;

is_segment:
	code = error_table_$nondirseg;
	return;

is_directory:
	code = error_table_$dirseg;
	return;
%page;
check_switches:					/* Need to check whether old style call where switches were */
     proc (switch_arg);				/* declared bit (6) */

	dcl     switch_arg		        fixed bin;
	dcl     (size, type)	        fixed bin;
	dcl     arg_ptr		        ptr,
	        arg		        bit (6) based (arg_ptr);
	dcl     cu_$arg_list_ptr	        entry returns (ptr);
	dcl     cu_$arg_ptr		        entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     decode_descriptor_	        entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin,
				        fixed bin);

	call decode_descriptor_ (cu_$arg_list_ptr (), switch_arg, type, ("0"b), (0), size, (0));

/**** * THIS DEPENDS ON THE FACT THE A CHAR (*) IN THE ARG LIST
      CAUSES ALL ARGUMENTS TO HAVE DESCRIPTORS! */
	if type = bit_dtype & size = 36
	then /* bit (36) */
	     string (delete_options) = a_switches;
	else do;
		call cu_$arg_ptr (switch_arg, arg_ptr, (0), (0));
		substr (string (delete_options), 1, 6) = arg;
		substr (string (delete_options), 6) = ""b;
	     end;

	return;
     end check_switches;


     end;




		    directory_commands_.pl1         09/04/90  1204.4rew 09/04/90  1202.2      801747



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * 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-04-28,TLNguyen), approve(88-04-28,MCR7839),
     audit(88-06-02,Lippard), install(88-07-05,MR12.2-1054):
     SCP6361 requested to add new functions to change_wdir (cwd), print_dir
     (pwd) and working_dir (wd).  For details, see the MTB 775.
  2) change(90-01-25,Vu), approve(90-01-25,MCR8153), audit(90-06-21,Huen),
     install(90-09-04,MR12.4-1032):
     The active function for working_dir will now return quoted string.
  3) change(90-01-25,Vu), approve(90-01-25,MCR8154), audit(90-06-21,Huen),
     install(90-09-04,MR12.4-1032):
     The wd command with an argument of 0 should return the current directory.
                                                   END HISTORY COMMENTS */

directory_commands_:
	proc options (variable);

/* *	Commands and subroutines for manipulating the working directory and default working directory. */
/* *	Completely rewritten, 05/24/79 W. Olin Sibert */
/* Fix bugs, remove checks before calling hcs_$fs_search_set_wdir */

/* constants */
dcl ALLOWED_DIGITS char (10) internal static options (constant) init ("0123456789");
dcl MAX_LENGTH_LABEL_NAME fixed bin (17) internal static options (constant) init (32);     

/*  automatic variables */
dcl  (LOCATION_after_colon, LOCATION_before_colon) char (32) varying;
dcl  active_function bit (1) aligned;
dcl  ap ptr;
dcl  al fixed bin;
dcl  arg_index fixed bin;
dcl  array_index fixed bin;
dcl  clear_entire_stack_flag bit (1) aligned;
dcl  clear_wdir_flag bit (1) aligned;
dcl  code fixed bin (35);
dcl  current_wdir char (168);
dcl  current_wdir_length fixed bin;
dcl  given_label_name char (32);
dcl  error_count fixed bin;
dcl  label_current_wdir_for_rotation bit (1) aligned;
dcl  labels_the_current_wdir char (32);
dcl  location_array (0:9999) fixed bin (35);
dcl  match bit (1) aligned;
dcl  max_array_index fixed bin;
dcl  nargs fixed bin;
dcl  pathname char (168);
dcl  pathname_count fixed bin;
dcl  pop_wdir_flag bit (1) aligned;
dcl  push_wdir_flag bit (1) aligned;
dcl  rotate_wdir_flag bit (1) aligned;
dcl  stack_location fixed bin (35);
dcl  temp_ptr ptr;
dcl  whoami char (32);

/*  static variables */
dcl  area_ptr ptr internal static init (null);
dcl  total_number_of_pushes fixed bin (35) internal static init (0);  /* total number of prior wdirs */
dcl  default_wdir_set bit (1) aligned internal static initial ("0"b); /* turned on after we've been called once */
dcl  default_wdir_pathname char (168) aligned internal static init (""); /* the static default wdir pathname */
dcl  first_node_ptr ptr internal static init (null);
dcl  last_node_ptr ptr internal static init (null);
dcl  label_name_of_current_wdir char (32) varying internal static init ("");
dcl  current_wdir_pathname char (168) varying internal static init ("");
     
/* based */
dcl  arg char (al) based (ap);

dcl 1 stack_linked_list aligned based,
      2 back_ptr ptr,
      2 label_name char (32) varying,
      2 wdir_name char (168) varying;

dcl system_area area based (area_ptr);
	

/* external entries */
dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$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 (35));
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$fs_search_get_wdir entry (ptr, fixed bin);
dcl  hcs_$fs_search_set_wdir entry (char (*), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  sub_err_ entry options (variable);
dcl  user_info_$homedir entry (char (*) aligned);

dcl  (error_table_$argerr,
      error_table_$bad_arg,
      error_table_$badopt,
      error_table_$bigarg,
      error_table_$no_wdir,
      error_table_$not_act_fnc) fixed bin (35) ext static;
/* builtin */
dcl (abs, after, addr, before, char, index, ltrim, length, null, rtrim, substr, verify) builtin;

/*--------------------------------------------------------------------------*/
%page;
change_wdir:
cwd: entry options (variable);

/* The following internal procedures are belonged to change_wdir entry.     */
/* They are listed first before you can reach the main program of           */
/* change_wdir entry.  There are other internal procedures which belong to  */
/* this entry are listed at the end of directory_commands_.pl1 since they   */
/* are also called by working_dir entry.                                    */
/*                                                                          */
/* This entry is documented in the MTB 775 and approved in MCR7839.         */
/* It syntax: cwd {path} {-control_args}                                    */
/* control arguments: -push {LABEL}; -pop {LOCATION}  default is stack      */
/* location 1; -rotate {LOCATION {LABEL}}  default is the top stack at      */
/* stack location 1; -clear {LOCATIONs}  default is the entire stack.       */
/* LOCATION can be either stack location N or a text string LABEL.          */
/*                                                                          */
/* The design of data structure: singlely linked circular list to implement */
/* a stack of prior working directory that you have been visited.           */
/*                                                                          */
/* first_node_ptr : points to the node containing the least recent wdir.    */
/* last_node_ptr  : points to the node containing the most recent_wdir.     */
/* total_number_of_pushes: indicates the number of nodes currently on the   */
/* stack of prior working directories.                                      */
/*                                                                          */
/* for an empty linked list:                                                */
/*   first_node_ptr = null                                                  */
/*   last_node_ptr  = null                                                  */
/*   total_number_of_pushes = 0                                             */
/*                                                                          */
/* for a linked list of one node:                                           */
/*      total_number_of_pushes = 1                                          */
/*                                                                          */
/*      first_node_ptr  last_node_ptr                                       */
/*            |           |                                                 */
/*      ______|___________|_________                                        */
/*      |  |       |                |                                       */
/*   <____ | LABEL |  PRIOR WDIR    |                                       */
/*   |  |__|_______|________________|                                       */
/*   |                  |                                                   */
/*   |________>_________|
/*                                                                          */
/*                                                                          */
/* for a linked list of n nodes:                                            */
/*      total_number_of_pushes = n  (where n is a numeric digit)            */
/*                                                                          */
/*      first_node_ptr                                      last_node_ptr   */
/*         |                                                   |            */
/*     ____|______   ___________    ___________            ____|______      */
/*     |  |  |   |   |  |  |   |    |  |  |   |            |  |  |   |      */
/*   <___ |  |   |<____ |  |   |<_____ |  |   |<___ ... <____ |  |   |      */
/*   | |__|__|___|   |__|__|___|    |__|__|___|            |__|__|___|      */
/*   |                                                             |        */
/*   |______________>______________________________>_______________|        */
/*                                                                          */
            /*----------------------------------------------*/
%page;
LOCATION_validation: proc (P_arg, P_stack_position, P_label_name, P_label_current_wdir_for_rotation, P_labels_the_cur_wdir,
		        P_clear_flag, P_push_flag);

/* verify that LOCATION specified is valid, where LOCATION can be a stack   */
/* position N or a text string LABEL.                                       */
/* N must be within a stack of prior wdirs.  LABEL's max. lenghth is 32     */
/* characters and it cannot begin with a minus sign or a numeric digit.     */
/* LABEL cannot include a colon since a colon indicates a range.            */
/* LABEL cannot be a reserved word such as first (f), last (l), all (a).    */

                                                               /* parameters */
     dcl P_arg char (*);
     dcl P_clear_flag bit (1) aligned;
     dcl P_labels_the_cur_wdir char (*);
     dcl P_label_current_wdir_for_rotation bit (1) aligned;
     dcl P_label_name char (*);
     dcl P_push_flag bit (1) aligned;
     dcl P_stack_position fixed bin (35);
                                                               /* local */
     dcl err_count fixed bin;
		   
/* begin coding */
     code = 0;
     LOCATION_before_colon = "";
     LOCATION_after_colon  = "";
     err_count = 0;

     if index (P_arg, "-") = 1 then do;
	code = error_table_$badopt;
	return;
     end;

     if index (P_arg, ":") ^= 0 then do;                      /* a range is specified */
	if ^P_clear_flag then do;                           /* only -clear allowed a range */
ERR_RET:
	     code = error_table_$bad_arg;
	     return;
	end;

          else do;                                            /* prepare for parsing a range */
	     LOCATION_before_colon = before (P_arg, ":");
	     LOCATION_after_colon  = after (P_arg, ":");

	     if (LOCATION_before_colon = "") | (LOCATION_after_colon = "") then
		goto ERR_RET;
	end;
     end;

     if verify (substr (P_arg, 1, 1), ALLOWED_DIGITS) = 0 then do;
                                                               /* LOCATION is a stack position N. */
	if ^P_clear_flag then do;
	     if P_push_flag then                             /* -push allowed only LABEL */
		goto ERR_RET;

                                                               /* -pop, -rotate allow both LABEL and stack location N */
	     P_stack_position = cv_dec_check_ (P_arg, code);
	     if code ^= 0 then goto ERR_RET;

	     if (P_stack_position < 1) | (P_stack_position > total_number_of_pushes) then
		goto ERR_RET;                           /* the specified stack position N is without the stack of prior wdirs */

	     P_stack_position = abs (P_stack_position);
	end;
          else do;                                             /* -clear */
	     if index (P_arg, ":") > 1 then do;              /* LOCATION is a range (e.g. 10:l  15:LABEL  8:12) */
		P_stack_position = cv_dec_check_ ((LOCATION_before_colon), code);
		if code ^= 0 then goto ERR_RET;

		if P_stack_position = 0 then               /* stack position N must begin at 1 and end at total_number_of_pushes */
		     goto ERR_RET;

		P_stack_position = abs (P_stack_position);
                                                               /* save it */
		call save_a_valid_LOCATION (max_array_index, P_stack_position);

		call LOCATION_continue_validation ((LOCATION_after_colon), max_array_index, P_stack_position, code);
               end;
	     else do;                                        /* LOCATION is a stack location N */
		P_stack_position = cv_dec_check_ (P_arg, code);
		if code ^= 0 then goto ERR_RET;

                                                               /* make sure a specified stack position N is within the stack of prior wdirs */
		if P_stack_position = 0 | P_stack_position > total_number_of_pushes then
		     goto ERR_RET;
		
		P_stack_position = abs (P_stack_position);
		call save_a_valid_LOCATION (max_array_index, P_stack_position);
	     end;
          end;
     end;

     else if P_clear_flag then do;
	     if P_arg = "first" | P_arg = "f" then do;
		P_stack_position = 1;
		call save_a_valid_LOCATION (max_array_index, P_stack_position);
	     end;

	     else if P_arg = "last" | P_arg = "l"  then do;
		     P_stack_position = total_number_of_pushes;
		     call save_a_valid_LOCATION (max_array_index, P_stack_position);
	     end;

	     else if P_arg = "all" | P_arg = "a" then do;
		     P_stack_position = 1;
		     call save_a_valid_LOCATION (max_array_index, P_stack_position);
		     P_stack_position = total_number_of_pushes;
		     call CONTINUE_save_good_data (max_array_index, P_stack_position, code);
	     end;

	     else if index (P_arg, ":") = 0 then
		call LABEL_validation (P_arg, max_array_index, P_stack_position, code);

               else do;
		if LOCATION_before_colon = "first" | LOCATION_before_colon = "f" then do;
		     P_stack_position = 1;
		     call save_a_valid_LOCATION (max_array_index, P_stack_position);
	          end;

	          else if LOCATION_before_colon = "last" | LOCATION_before_colon = "l" then
		     goto ERR_RET;

		else if LOCATION_before_colon = "all" | LOCATION_before_colon = "a" then
		     goto ERR_RET;

		else call LABEL_validation ((LOCATION_before_colon), max_array_index, P_stack_position, code);
	         
		call LOCATION_continue_validation ((LOCATION_after_colon), max_array_index, P_stack_position, code);
	     end;
     end;

     else do;
	if P_arg = "all" | P_arg = "a" then err_count = err_count + 1;
	if P_arg = "first" | P_arg = "f" then err_count = err_count + 1;
	if P_arg = "last" | P_arg = "l"  then err_count = err_count + 1;

	if err_count > 0 then do;
	     error_count = -1;                           /* mark that an error encountered */
	     goto ERR_RET;
	end;

          if length (P_arg) > MAX_LENGTH_LABEL_NAME then do;
	     code = error_table_$bigarg;
	     return;
	end;

          if P_label_current_wdir_for_rotation then        /* want to label the current wdir before rotation begins */
	     P_labels_the_cur_wdir = P_arg;
	else P_label_name = P_arg;
     end;

     return;                                               /* return to change_wdir entry */

     end LOCATION_validation;

            /*---------------------------------------------*/
%page;
array_selection_sort: proc;
			    
/* sort the contents of location_array from array index 1 through            */
/* max_array_index in an ascending order (increasing value).   All duplicate */
/* stack locations containing in an array are eliminated so that the array   */
/* only contains unique stack location values.                               */
/*                                                                           */
/* Currently, all LOCATIONs containing in an array are not in order and      */
/* may be duplicated.   For example:                                         */
/*                                                                           */
/*    Before sorting: max_array_index = 6, location_array contains stack     */
/* locations 1, 6, 7, 3, 5, and 3.                                           */
/*                                                                           */
/*    After sorting, max_arry_index = 5, the contents of location_array are  */
/* 1, 3, 5, 6, and 7.                                                        */
/*                                                                           */
/*              before sorting               after sorting                   */
/*                                                                           */
/*              ________                     ________                        */
/*          1   |  1   |                1    |  1   |                        */
/*              |______|                     |______|                        */
/*          2   |  6   |                2    |  3   |                        */
/*              |______|                     |______|                        */
/*          3   |  7   |   =====>       3    |  5   |                        */
/*              |______|                     |______|                        */
/*          4   |  3   |                4    |  6   |                        */
/*              |______|                     |______|                        */
/*          5   |  5   |                5    |  7   |                        */
/*              |______|                     |______|                        */
/*          6   |  3   |                6    | -1   |                        */
/*              |______|                     |______|                        */
/*                                                                           */
                                                          /* local */
     dcl (i_index, j_index, k_index) fixed bin;
     dcl smallest_index_for_unsorted_array fixed bin;
     dcl  temp_data fixed bin (35);
			    
			    
/* begin coding */
     i_index = 1;
     temp_data = 0;
     
     do while (i_index < max_array_index);
                                                         /* prepare for the inner loop */
	smallest_index_for_unsorted_array = i_index;
	j_index = i_index + 1;

	do while (j_index <= max_array_index);         /* find the minimum location (which stored early) so far */
	     if location_array (j_index) < location_array (smallest_index_for_unsorted_array) then
		smallest_index_for_unsorted_array = j_index;

               else if location_array (j_index) = location_array (smallest_index_for_unsorted_array) then do;
                                                         /* duplicate stack location value is found, so get rid of it */
                                                         /* by move the contents of an array underneath of the duplicate value up to 1 level */
		     do k_index = j_index to (max_array_index - 1);
			location_array (k_index) = location_array (k_index + 1);
		     end;
                                                         /* re-initialize the contents of location_array at subcript max_array_index */
		     location_array (max_array_index) = - 1;
                                                         /* update the actual maximum array index value after overwritten the duplicate */
		     max_array_index = max_array_index - 1;
                                                         /* forget about the duplicate, assume that no duplication found at subcript j_index */
		     j_index = j_index - 1;
	     end;

	     j_index = j_index + 1;
          end;
                                                         /* swapping: move the smaller location found into a temp. place */
          temp_data = location_array (smallest_index_for_unsorted_array);
                                                         /* move the larger location into the place where the smaller location used to live */
	location_array (smallest_index_for_unsorted_array) = location_array (i_index);

	location_array (i_index) = temp_data;
	
	i_index = i_index + 1;
     end;

     return;                                              /* return to do_clear internal procedure of change_wdir entry */
     
     end array_selection_sort;

             /*--------------------------------------------*/
%page;
move_to_top_stack_dir: proc (p_travel_ptr, p_temp_ptr, p_dir_pathname);

/* set the most recent prior wdir at the top stack to become the current     */
/* wdir.  Since all prior wdirs are stored in a singlely circular linked     */
/* list, links such as first_node_ptr which points to the least recent wdir  */
/* at the bottom stack and temp_ptr which points to the current wdir must be */
/* updated after appended the current wdir to the bottom stack.              */
                                                       /* parameters */
     dcl p_dir_pathname char (*);
     dcl p_temp_ptr ptr;
     dcl p_travel_ptr ptr;
			
/* begin coding */
                                                        /* update pointers */
     p_temp_ptr -> stack_linked_list.back_ptr = p_travel_ptr -> stack_linked_list.back_ptr;
     first_node_ptr -> stack_linked_list.back_ptr = p_temp_ptr;

     first_node_ptr = p_temp_ptr;
     last_node_ptr = p_travel_ptr -> stack_linked_list.back_ptr;

                                                        /* get the most recent wdir and its associated label name */
     p_dir_pathname = p_travel_ptr -> stack_linked_list.wdir_name;
     label_name_of_current_wdir = p_travel_ptr -> stack_linked_list.label_name;

                                                        /* remove the node containing most recent wdir and label from the list */
     free p_travel_ptr -> stack_linked_list in (system_area);
     p_temp_ptr = null;
     p_travel_ptr = null;

     return;                                            /* return to do_rotate internal procedure of change_wdir entry */
     end move_to_top_stack_dir;

          /*--------------------------------------------*/
%page;
move_to_a_specified_dir: proc (para_travel_ptr, para_previous_ptr, para_temp_ptr, para_pathname);
			    
/* set the prior wdir at a specified LOCATION to become the current wdir.    */
/* Since all prior wdirs are stored in a singlely circular linked list,      */
/* links (pointers) must be updated depending on which LOCATION you want     */
/* to move to (e.g. middle, end, or any LOCATION on the stack).              */

     dcl para_travel_ptr ptr;
     dcl para_pathname char (*);
     dcl para_previous_ptr ptr;
     dcl para_temp_ptr ptr;
			    
/* begin coding */
                                                        /* update links */
     para_temp_ptr -> stack_linked_list.back_ptr = last_node_ptr;
     first_node_ptr -> stack_linked_list.back_ptr = para_temp_ptr;

     para_previous_ptr -> stack_linked_list.back_ptr = para_travel_ptr -> stack_linked_list.back_ptr;
     
     first_node_ptr = para_previous_ptr;
     last_node_ptr = para_travel_ptr -> stack_linked_list.back_ptr;

                                                        /* get a prior wdir and its associated label name at that specified LOCATION */
     para_pathname = para_travel_ptr -> stack_linked_list.wdir_name;
     label_name_of_current_wdir = para_travel_ptr -> stack_linked_list.label_name;
     
                                                        /* remove the node at that specified LOCATION from the linked list */
     free para_travel_ptr -> stack_linked_list in (system_area);

     para_previous_ptr = null;
     para_temp_ptr = null;
     para_travel_ptr = null;
     
     return;                                            /* return to do_rotate internal procedure of change_wdir entry */
     end move_to_a_specified_dir;     

               /*------------------------------------------*/
%page;
do_clear: proc (p_total_numb_of_pushes, p_err_cnt);

/* remove working directories from the stack without changing the current    */
/* wdir.  Assume that specified LOCATIONs or reserved words are valid at     */
/* at this point.  All stack locations where prior wdirs will be cleared out */
/* are stored earlier in an array.                                           */
/* The array containing stack locations must be sorted in increasing order   */
/* before removing prior wdirs from the stack.                               */
/* Start the linked list from the node containing the most recent wdir and   */
/* stop at the node containing the prior wdir to be cleared out.  Remove it  */
/* from the linked list after taken care of links (pointers).                */
/* If there are more prior wdirs to be cleared out then continue walk on the */
/* linked list from previous stop, since stack locations where prior wdirs   */
/* to be deleted are already sorted, until specified prior wdirs are removed */
/* from the stack.                                                           */

                                                               /* parameters */
     dcl p_err_cnt fixed bin;
     dcl p_total_numb_of_pushes fixed bin (35);
                                                               /* local */
     dcl clear_index fixed bin (35);
     dcl previous_pointer pointer;
     dcl skip_node_index fixed bin (35);

/* begin coding */	
     array_index = 0;
     p_err_cnt = 0;
     clear_index = 0;
     previous_pointer = null;
     skip_node_index = 0;

     if last_node_ptr = null & p_total_numb_of_pushes = 0 then do;
	if rtrim (pathname) ^= "" then                        /* allows to change to the NEW current wdir instead of return as an error */
	     call ioa_ ("Warning: the stack of prior wdirs is empty.");
	else do;
	     p_err_cnt = p_err_cnt + 1;                       /* the stack is empty */
	     call com_err_ (0, whoami, "Empty stack.");
	end;
	return;
     end;

     if clear_entire_stack_flag then do;                        /* wanted to clear the entire stack of prior wdirs */
	do clear_index = 1 to p_total_numb_of_pushes;
	     temp_ptr = last_node_ptr;
	     last_node_ptr = temp_ptr -> stack_linked_list.back_ptr;
	     first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;

	     free temp_ptr -> stack_linked_list in (system_area);
	end;
        
          p_total_numb_of_pushes = 0;
          last_node_ptr = null;
          first_node_ptr = null;
	return;
     end;

     if max_array_index > 1 then
	call array_selection_sort;                       /* sort given stack locations in ascending order */
	
     temp_ptr = last_node_ptr;                             /* prepare for looking a target */

     if max_array_index = 1 then do;                       /* want to clear out only a single prior wdir from the stack */

	if location_array (max_array_index) = 1 then do; /* want to clear out the most recent wdir from the stack */
	     last_node_ptr = temp_ptr -> stack_linked_list.back_ptr;
	     first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;

	     if p_total_numb_of_pushes = 1 then do;      /* the linked list contains only one node to be cleared out */
		last_node_ptr = null;
		first_node_ptr = null;
	     end;
	end;
	else do;
                                                           /* walk on the linked list from the node containing the most recent wdir */
                                                           /* and stop at the node located at (n-1)th before reaching the */
                                                           /* node containing the prior wdir to be deleted at stack position n */
	     do skip_node_index = 1 to (location_array (max_array_index) - 1);
		previous_pointer = temp_ptr;
		temp_ptr = temp_ptr -> stack_linked_list.back_ptr;
	     end;
                                                           /* prepare to clear out the least recent wdir at bottom stack */
               if location_array (max_array_index) = p_total_numb_of_pushes then do;
		first_node_ptr = previous_pointer;
		first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;
	     end;
                                                           /* prepare to clear out a prior wdir at a specified stack location */
	     else previous_pointer -> stack_linked_list.back_ptr = temp_ptr -> stack_linked_list.back_ptr;
	end;
                                                           /* remove a prior wdir from the stack */
          free temp_ptr -> stack_linked_list in (system_area);
                                                           /* update the total number of nodes currently in the linked list */
	p_total_numb_of_pushes = p_total_numb_of_pushes - 1;
     end;                                                  /* remove only a single prior wdir from the stack */
     else do;                                              /* remove at least two prior wdirs from the stack of prior wdirs */
	do array_index = 1 to max_array_index;
                                                           /* prepare to clear out the most recent wdir from the stack */
	     if location_array (array_index) = 1 then do;
		last_node_ptr = temp_ptr -> stack_linked_list.back_ptr;
		first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;
	     end;
                                                           /* prepare to remove several consective prior wdirs (e.g. 1 2 3; 7 8 9) */
	     if (location_array (array_index)) = (location_array (array_index - 1) + 1) then do;

		if previous_pointer ^= null then do;
		     temp_ptr = previous_pointer -> stack_linked_list.back_ptr;
		     previous_pointer -> stack_linked_list.back_ptr = temp_ptr -> stack_linked_list.back_ptr;

                                                          /* prepare to clear out the least recent wdir */
		     if location_array (array_index) = p_total_numb_of_pushes then
			first_node_ptr = previous_pointer;
		end;
		else do;                              /* update pointer pointing to the node containing the most recent wdir and */
                                                          /* back pointer of the bottom stack node which contains the least recent wdir */
		     last_node_ptr = temp_ptr -> stack_linked_list.back_ptr;
		     first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;
		end;
	     end;
	     else do;                                   /* clear out several prior wdirs at NON consective stack locations */
		if array_index = 1 then do;           /* prepare to clear a prior wdir FOR THE FIRST TIME looping */
                                                          /* skip the node containing the most recent wdir at stack location 1 to */
                                                          /* the node at stack location (n -1) before reaching the node containing */
                                                          /* the prior wdir to be deleted at stack location n */
		     do skip_node_index = 1 to (location_array (array_index) - 1);
			previous_pointer = temp_ptr;
			temp_ptr = temp_ptr -> stack_linked_list.back_ptr;
		     end;
		end;                                  /* prepare to clear out a prior wdir FOR THE FIRST TIME looping */
		else do;                              /* prepare to clear out ANOTHER prior wdir from the stack */
		     if previous_pointer ^= null then /* continue to walk on the linked list from the previous stop */
			temp_ptr = previous_pointer -> stack_linked_list.back_ptr;

                                                          /* continue to skip nodes before reaching the node to be cleared out */
		     do skip_node_index = (location_array (array_index - 1) + 1) to (location_array (array_index) - 1);
			previous_pointer = temp_ptr;
			temp_ptr = temp_ptr -> stack_linked_list.back_ptr;
		     end;
	          end;                                  /* prepare to clear out ANOTHER prior wdir from the stack */
                                                          /* prepare to clear out the least recent prior wdir at the bottom linked list */
	          if location_array (array_index) = p_total_numb_of_pushes then do;
		     first_node_ptr = previous_pointer;
		     first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;
		end;
                                                           /* prepare to clear out another prior wdir at a specified stack location */
		else if previous_pointer ^= null then
		     previous_pointer -> stack_linked_list.back_ptr =  temp_ptr -> stack_linked_list.back_ptr;
	     end;                                        /* clear out several prior wdirs at NON-consective stack locations */
                                                           /* finally, remove a prior wdir at a specified stack location from the stack */
	     free temp_ptr -> stack_linked_list in (system_area);

	     temp_ptr = last_node_ptr;                  /* prepare to walk on the linked list again */
	end;                                            /* do loop */
                                                          /* update the total number of nodes left over on the linked list */
          p_total_numb_of_pushes = p_total_numb_of_pushes - max_array_index;
     end;                                                 /* complete the request of removing prior wdirs from the stack */

     if p_total_numb_of_pushes = 0 then do;               /* become empty after complete the request of removing prior wdir(s) from the stack */
	last_node_ptr = null;
	first_node_ptr = null;
     end;     

     return;                                              /* return to change_wdir entry */

     end do_clear;

           /*--------------------------------------------*/
%page;
do_pop: proc (para_npushes, para_pathname, para_error_count);
        
/* pop to the wdir identified by LOCATION, where LOCATION can be a stack   */
/* location N or a LABEL associated with a prior wdir.  The prior wdir     */
/* popped to becomes the NEW current wdir.  Prior directories ABOVE the    */
/* the selected directory are REMOVED from the stack.  However,            */
/* directories BELOW the selected prior wdir REMAIN on the stack.          */

                                                             /* parameters */
     dcl para_error_count fixed bin;                         /*   input    */
     dcl para_npushes fixed bin (35);                        /*   in/out   */
     dcl para_pathname char (*);                             /*   output   */
        
     dcl pop_index fixed bin;                           /* local */
     dcl remove_index fixed bin;
     dcl dispose_node_ptr ptr;
        

/* begin coding */
     dispose_node_ptr = null;                                /* initialized local variables */
     pop_index = 0;
     remove_index = 0;

     match = "0"b;                                           /* for double check */
     temp_ptr = null;
        
     if last_node_ptr = null & para_npushes = 0 then do;     /* case of an EMPTY stack */
	para_error_count = para_error_count + 1;
	call com_err_ (0, whoami, "An empty stack of prior wdirs.");
	return;
     end;

     temp_ptr = last_node_ptr;

     if stack_location ^= - 1 then do;                       /* LOCATION is N */
	do pop_index = 1 to (stack_location - 1);          /* remove all directories ABOVE the selected directory at stack location N */
	     last_node_ptr = temp_ptr -> stack_linked_list.back_ptr;
	     first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;

	     free temp_ptr -> stack_linked_list in (system_area);

	     temp_ptr = last_node_ptr;
	end;
     
          para_npushes = para_npushes - stack_location;
     end;

     if given_label_name ^= " " then do;                    /* LOCATION is LABEL */
	do pop_index = 1 to para_npushes while (^match);  /* scan the entire singely circular linked list to find a match of label name */
	     if temp_ptr -> stack_linked_list.label_name = given_label_name then
		match = "1"b;
	     else temp_ptr = temp_ptr -> stack_linked_list.back_ptr;
	end;
     
          if (pop_index > para_npushes) & (^match) then do; /* for the case of no matched label name, cwd treats as an error */
	     para_error_count = para_error_count + 1;
	     call com_err_ (0, whoami, "No match ^a.  Directory not popped.", given_label_name);
	     return;
	end;

          pop_index = pop_index - 1;                        /* correct the pop_index value after left the above do loop. */

	do remove_index = 1 to (pop_index - 1);           /* remove all directories ABOVE the matched labelled directory. */
	     dispose_node_ptr = last_node_ptr;
	     last_node_ptr = dispose_node_ptr -> stack_linked_list.back_ptr;
	     first_node_ptr -> stack_linked_list.back_ptr = last_node_ptr;
	     
	     free dispose_node_ptr -> stack_linked_list in (system_area);
	end;
     
          para_npushes = para_npushes - pop_index;
     end;

	                                                       /* get the selected prior wdir and its associated label name */
     para_pathname = temp_ptr -> stack_linked_list.wdir_name;
     label_name_of_current_wdir = temp_ptr -> stack_linked_list.label_name;

                                                                 /* finally, remove this selected directory from the stack of prior wdirs. */
     if para_npushes = 0 then do;
	last_node_ptr = null;
	first_node_ptr = null;
     end;
     else do;
	first_node_ptr -> stack_linked_list.back_ptr = temp_ptr -> stack_linked_list.back_ptr;
	last_node_ptr = temp_ptr -> stack_linked_list.back_ptr;
     end;
     
     free temp_ptr -> stack_linked_list in (system_area);
	
     return;                                         /* return to change_wdir entry */
	
     end do_pop;

             /*-------------------------------------------*/
%page;
do_push: proc (parameter_npushes);
         
/* push the current wdir into a stack of prior wdirs.  If LABEL is         */
/* specified, it is attached to the current wdir.  Note that the stack is  */
/* a singely circular linked  list.  No finite limit to the total number   */
/* of wdirs to be pushed on the stack.  The only limit will be the amount  */
/* of available spae in the system free area.                              */

     dcl parameter_npushes fixed bin (35);
         
/* begin coding */
                                                            /* create a new node in system_area and set temp_ptr points to it */
     allocate stack_linked_list in (system_area) set (temp_ptr);

     if last_node_ptr = null then do;                       /* empty singlely linked CIRCULAR list */
                                                            /* statics pointers point to the newly created node since it is */
                                                            /* only node in the list */
	first_node_ptr = temp_ptr;
	last_node_ptr = temp_ptr;
                                                            /* back pointer of the newly created node points to itself because of circular */
	temp_ptr -> stack_linked_list.back_ptr = temp_ptr;
     end;
     else do;                                               /* at least one node in the singely circular linked list */
	temp_ptr -> stack_linked_list.back_ptr = last_node_ptr;
	first_node_ptr -> stack_linked_list.back_ptr = temp_ptr;
	last_node_ptr = temp_ptr;
     end;

                                                            /* fill in the current wdir and the value of label_name_of_current_wdir */
/* example: ! print_wdir all
              LOC LABEL PATHNAME

                0 x     >udd>m>TLNguyen>cwd_dev
                1       >udd>m>TLNguyen>canon_dev
                2 y     >udd>m>TLNguyen>meetings
 
            ! cwd subcwd_dev -push

                               temp_ptr
                                  |
                   _______________|___________________________
                   | |   |                                   |
                <--- | x | >udd>m>TLNguyen>cwd_dev>subcwd_dev|
                   |_|___|___________________________________|
*/

     temp_ptr -> stack_linked_list.wdir_name = rtrim (current_wdir);
     temp_ptr -> stack_linked_list.label_name = label_name_of_current_wdir;


                                                            /* this is time to RE-label the label name of the current wdir */
     if given_label_name ^= "" then                         /* wanted to label the current wdir */
	temp_ptr -> stack_linked_list.label_name = rtrim (given_label_name);

     label_name_of_current_wdir = "";                       /* must reinitialize this static variable after pushed the current wdir */
                                                            /* and either its existing associated label or the newly given label onto the stack */

     parameter_npushes = parameter_npushes + 1;             /* update the total number of nodes currently in the linked list */

     return;                                                /* return to change_wdir entry */
     
     end do_push;
         
              /*---------------------------------------------*/
%page;
do_rotate: proc (p_pathname, p_error_count);
	 
/* move to the prior wdir indentified by LOCATION, where LOCATION can be   */
/* either stack location N or a LABEL.  Rotation occurs by placing the     */
/* current wdir at the BOTTOM of the stack and set the NEW current wdir    */
/* from the top stack identified by a given LOCATION.  For a specified N,  */
/* rotate Nth times, the wdir at the Nth location becomes the NEW current  */
/* wdir.  For a specified LABEL, rotate until a matched label name is      */
/* is found, the wdir associated with a matched LABEL becomes the NEW      */
/* current wdir.                                                           */
                                                       /* output parameters */
     dcl p_error_count fixed bin;
     dcl p_pathname char (*);                          /* prior wdir at a specified LOCCATION */
                                                       /* local */
     dcl rotate_index fixed bin;
     dcl travel_ptr ptr;
     dcl prev_travel_ptr ptr;
	 
/* begin coding */
     rotate_index = 0;
     travel_ptr = null;
     prev_travel_ptr = null;

     match = "0"b;                                     /* for double check */

     if last_node_ptr = null & total_number_of_pushes = 0 then do;  /* an empty stack */
	p_error_count = p_error_count + 1;
	call com_err_ (0, whoami, "Empty stack.");
	return;
     end;
		                                   /* APPEND the current wdir to the stack.  Labels it if requested. */
     allocate stack_linked_list in (system_area) set (temp_ptr);

     temp_ptr -> stack_linked_list.wdir_name = current_wdir;
     temp_ptr -> stack_linked_list.label_name = label_name_of_current_wdir;

     if labels_the_current_wdir ^= "" then             /* either -rotate N LABEL or -rotate LABEL LABEL;  The second LABEL */
	temp_ptr -> stack_linked_list.label_name = rtrim (labels_the_current_wdir);

                                                       /* prepare for moving to a prior wdir at a specified LOCATION */
     travel_ptr = last_node_ptr;
     
     if stack_location ^= - 1 then do;                 /* LOCATION is a stack location N */
	if stack_location = 1 then
	     call move_to_top_stack_dir (travel_ptr, temp_ptr, p_pathname);
	else do;
	     do rotate_index = 1 to (stack_location - 1);
		prev_travel_ptr = travel_ptr;
		travel_ptr = travel_ptr -> stack_linked_list.back_ptr;
	     end;
	
	     call move_to_a_specified_dir (travel_ptr, prev_travel_ptr, temp_ptr, p_pathname);
	end;
     end;

     if given_label_name ^= " " then do;                    /* -rotate LABEL */
	if travel_ptr -> stack_linked_list.label_name = rtrim (given_label_name) then
	     call move_to_top_stack_dir (travel_ptr, temp_ptr, p_pathname);
	else do;
	     do rotate_index = 2 to total_number_of_pushes while (^match);
		prev_travel_ptr = travel_ptr;
		travel_ptr = travel_ptr -> stack_linked_list.back_ptr;
		
		if travel_ptr -> stack_linked_list.label_name = rtrim (given_label_name) then
		     match = "1"b;
	     end;
	
               if (rotate_index > total_number_of_pushes) & (^match) then do;
		p_error_count = p_error_count + 1;

		free temp_ptr -> stack_linked_list in (system_area);
		
		call com_err_ (0, whoami, "No matched ^a.  Directory not rotated.", given_label_name);
		return;
	     end;
	
               call move_to_a_specified_dir (travel_ptr, prev_travel_ptr, temp_ptr, p_pathname);
	end;
     end;

     return;                                                    /* return to change_wdir entry */
     
     end do_rotate;

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

     max_array_index = 0;
     location_array (*) = - 1;
     current_wdir = "";
     labels_the_current_wdir = "";
     label_current_wdir_for_rotation = "0"b;
     clear_entire_stack_flag = "0"b;
     clear_wdir_flag = "0"b;
     code = 0;
     given_label_name = "";
     error_count = 0;
     match = "0"b;
     rotate_wdir_flag = "0"b;
     pathname = "";
     pathname_count = 0;
     pop_wdir_flag = "0"b;
     push_wdir_flag = "0"b;
     stack_location = - 1;
     temp_ptr = null;
	
     return;                                                  /* return to change_wdir entry */
     
     end initialization;

           /*-------------------------------------------------*/
%page;
/* main program of change_wdir entry */

     whoami = "change_wdir";                                  /* my name is change_wdir */

     call initialization;                                     /* initialize automatic variables */

     if area_ptr = null then                                  /* get system free area */
	area_ptr = get_system_free_area_ ();

     call cu_$arg_count (nargs, code);                        /* get the total number of input arguments specified on the command line. */
     if code ^= 0 then do;
	call com_err_ (code, whoami);
	return;
     end;

     if nargs = 0 then do;
	label_name_of_current_wdir = "";                    /* must re-initialized */
	pathname = get_default_wdir_ ();                    /* set pathname to default wdir */
     end;
     else do;
	do arg_index = 1 to nargs;                          /* validate input arguments */
	     call cu_$arg_ptr (arg_index, ap, al, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami);
		return;
	     end;
	
	     if index (arg, "-") = 1 then do;
		if arg = "-clear" | arg = "-cl" then do; 
		     clear_wdir_flag = "1"b;

		     if arg_index = nargs then            /* clear out the entire stack */
			clear_entire_stack_flag = "1"b;
		     else do;                             /* LOCATION specifier for -clear */
			do arg_index = (arg_index + 1) to nargs while (code = 0);
			     call cu_$arg_ptr (arg_index, ap, al, code);
			     if code ^= 0 then do;
				call com_err_ (code, whoami);
				return;
			     end;

			     if arg = "0" then do;
				call com_err_ (0, whoami, "^a is not in the stack of prior wdirs.", arg);
				return;
			     end;

			     call LOCATION_validation (arg, stack_location, given_label_name, label_current_wdir_for_rotation,
			     labels_the_current_wdir, clear_wdir_flag, push_wdir_flag);
			     if code ^= 0 then do;
				if arg = "-pop" | arg = "-push" | arg = "-rotate" then
				     call com_err_ (0, whoami, "-clear is mutually exclusive with ^a.", arg);
				else call com_err_ (code, whoami, "^a", arg);
				return;
			     end;
			end;
		     end;
		end;

	          else if arg = "-pop" then do;
			pop_wdir_flag = "1"b;

			if arg_index = nargs then
			     stack_location = 1;        /* by default */
			else do;
			     arg_index = arg_index + 1;
			     call cu_$arg_ptr (arg_index, ap, al, code);
			     if code ^= 0 then do;
				call com_err_ (code, whoami);
				return;
			     end;

			     if arg = "0" then do;
				call com_err_ (0, whoami, "^a is not in the stack of prior wdirs.", arg);
				return;
			     end;

			     call LOCATION_validation (arg, stack_location, given_label_name, label_current_wdir_for_rotation,
				labels_the_current_wdir, clear_wdir_flag, push_wdir_flag);
			     if code ^= 0 then do;
				if arg = "-clear" | arg = "-push" | arg = "-rotate" then
				     call com_err_ (0, whoami, "-pop is mutually exclusive with ^a.", arg);
				else do;
				     call com_err_ (code, whoami, "^a", arg);
				     if error_count ^= 0 then
					call ioa_ ("A label cannot be a reserved word (all, a, first, f, last, l).");

				     return;
				end;
			     end;
			end;
		end;

	          else if arg = "-push" then do;
			push_wdir_flag = "1"b;

			if arg_index = nargs then;      /* -push */
			else do;                        /* -push LABEL */
			     arg_index = arg_index + 1;
			     call cu_$arg_ptr (arg_index, ap, al, code);
			     if code ^= 0 then do;
				call com_err_ (code, whoami);
				return;
			     end;

			     call LOCATION_validation (arg, stack_location, given_label_name, label_current_wdir_for_rotation,
				labels_the_current_wdir, clear_wdir_flag, push_wdir_flag);
			     if code ^= 0 then do;
				if arg = "-clear" | arg = "-pop" | arg = "-rotate" then
				     call com_err_ (0, whoami, "-push is mutually exclusive with ^a", arg);
				else do;
				     call com_err_ (code, whoami, "^a", arg);
				     if error_count ^= 0 then
					call ioa_ ("A label cannot be a reserved word (all, a, first, f, last, l).");

				     return;
				end;
			     end;				
			end;
		end;

	          else if arg = "-rotate" then do;
			rotate_wdir_flag = "1"b;

			if arg_index = nargs then
			     stack_location = 1;        /* by default */
			else do;                        /* LOCATION is specified for -rotate */
			     arg_index = arg_index + 1;
			     call cu_$arg_ptr (arg_index, ap, al, code);
			     if code ^= 0 then do;
				call com_err_ (code, whoami);
				return;
			     end;

			     call LOCATION_validation (arg, stack_location, given_label_name, label_current_wdir_for_rotation,
				labels_the_current_wdir, clear_wdir_flag, push_wdir_flag);
			     if code ^= 0 then do;
				if arg = "-clear" | arg = "-pop" | arg = "-push" then
				     call com_err_ (0, whoami, "-rotate is mutually exclusive with ^a.", arg);
				else do;
				     call com_err_ (code, whoami, "^a", arg);
				     if error_count ^= 0 then
					call ioa_ ("A label cannot be a reserved word (all, a, first, f, last, l).");

				     return;
				end;
			     end;

			     if (arg_index + 1) <= nargs then do;
                                                              /* want to label the current wdir (e.g. cwd -rotate 2 label_the_current_wdir) */
				label_current_wdir_for_rotation = "1"b;

				arg_index = arg_index + 1;
				call cu_$arg_ptr (arg_index, ap, al, code);
				if code ^= 0 then do;
				     call com_err_ (code, whoami);
				     return;
				end;

				call LOCATION_validation (arg, stack_location, given_label_name, label_current_wdir_for_rotation,
				     labels_the_current_wdir, clear_wdir_flag, push_wdir_flag);
				if code ^= 0 then do;
				     call com_err_ (code, whoami, "^a", arg);
				     if error_count ^= 0 then
					call ioa_ ("A label cannot be a reserved word (all, a, first, f, last, l).");

				     return;
				end;
			     end;
			end;
	          end;

	          else do;
		     call com_err_ (error_table_$bad_arg, whoami, "^a", arg);
		     return;
		end;
	     end;
	     else do;                                       /* PATH is specified */
		if (rotate_wdir_flag | pop_wdir_flag) then do;
                                                              /* examples: cwd -rotate 2 lable_current_wdir error; cwd -pop 2 error */
		     call com_err_ (error_table_$bad_arg, whoami, "^a", arg);
		     return;
		end;

		pathname_count = pathname_count + 1;      /* trying to protect cwd when more than one PATH is specified */
		if pathname_count > 1 then do;            /* for example: cwd change_wdir_directory canonicalize_directory */
		     call com_err_ (0, whoami, "Only one PATH is allowed.   ^a  ^a", rtrim (pathname), arg);
		     return;
		end;

		call expand_path_ (ap, al, addr (pathname), null, code);
		if code ^= 0 then do;
		     call com_err_ (code, whoami, "^a", arg);
		     return;
		end;
	     end;
	end;
     end;                                                     /* complete validating all input arguments specified on the command level. */

     error_count = 0;                                         /* for double check */

     if nargs > 2 then do;                                    /* for violating syntax, display an usage message */
	if pop_wdir_flag then
	     error_count = error_count + 1;
	
	if (rotate_wdir_flag | push_wdir_flag) & (nargs > 3) then
	     error_count = error_count + 1;
	     
	if error_count > 0 then do;
	     call com_err_ (0, whoami, "Usage:  cwd {PATH} {-control_args}");
	     call ioa_ (" ");
	     call ioa_ ("Optional control arguments:^/-clear {N;LABEL}  Default: the entire stack^/-pop {N;LABEL}  Default: 1^/-push {LABEL}^/-rotate {LABEL; N {LABEL}}  Default: 1");
               call ioa_ (" ");
	     call ioa_ ("Note that -push, -pop, -rotate, and -clear are exclusive to each other.  PATH is exclusive to -pop or -rotate");
	     return;
	end;
     end;
                                                              /* for inconsistent combination of optional arguments, cwd treats as an error */
     if (pathname ^= "") & (pop_wdir_flag | rotate_wdir_flag) then do;
	call com_err_ (error_table_$argerr, whoami);
	return;
     end;

/* do cwd */
                                                              /* The following three lines of coding is needed instead of calling the */
                                                              /* existing get_wdir internal procedure because don't want the current */
                                                              /* pathname value which contains user's specified PATH to be altered */

     call hcs_$fs_search_get_wdir (addr (current_wdir), current_wdir_length);
     if current_wdir_length = 0 then
	current_wdir = "";                                  /* to indicate there is no current wdir */
     else substr (current_wdir, current_wdir_length + 1) = "";/* fill out the rest with white spaces */
     
     if current_wdir ^= "" then                               /* save it for displaying purpose only when it will be deleted later */
	current_wdir_pathname = current_wdir;               /* the current wdir is stored in a static variable */

     if pathname ^= "" then do;                               /* PATH is specified */
	if push_wdir_flag then do;
	     if current_wdir ^= "" then                     /* push the current wdir onto the stack */
		call do_push (total_number_of_pushes);
	                                                    /* allow to change wdir to PATH even if could not find the current wdir */
	     else call ioa_ ("Warning: current wdir not pushed.  It has been deleted.  ^a", rtrim (current_wdir_pathname));
	end;

	if clear_wdir_flag then do;
	     call do_clear (total_number_of_pushes, error_count);
	     if error_count > 0 then return;
	end;
     end;
     else do;                                                 /* PATH is omitted */
	if push_wdir_flag then do;
	     call get_default_wdir ();                   /* for -push, if PATH is omitted, then sets pathname to the default wdir */

	     if current_wdir ^= "" then                  /* push the current wdir onto the stack */
		call do_push (total_number_of_pushes);

	     else if pathname = "" then do;                     /* no current wdir and no default wdir */
		     call com_err_ (0, whoami, "No default wdir set for this process.");
		     return;
	     end;
                                                                   /* allow to change to the default wdir even if there is no current wdir */
	     else call ioa_ ("Warning: current wdir not pushed.  It has been deleted.  ^a", rtrim (current_wdir_pathname));
	end;

	if pop_wdir_flag then                                    /* pop the prior wdir at a specified LOCATION out the stack */
	     call do_pop (total_number_of_pushes, pathname, error_count);

	if rotate_wdir_flag then do;
	     if current_wdir ^= "" then
		call do_rotate (pathname, error_count);        /* get the prior wdir at a specified LOCATION */
	     else do;
		call com_err_ (error_table_$no_wdir, whoami);
		return;
	     end;
	end;
          
          if clear_wdir_flag then
	     call do_clear (total_number_of_pushes, error_count);

	if error_count > 0 then 
	     return;
     end;

     if pathname ^= "" then do;  
	call hcs_$fs_search_set_wdir (pathname, code);         /* set pathname value to be the NEW current wdir. */
	if code ^= 0 then do;
	     if push_wdir_flag then do;
		if current_wdir ^= "" then
		     call com_err_ (code, whoami, "^a.  Directory ^a already pushed for you.", rtrim (pathname), rtrim (current_wdir));
		else call com_err_ (code, whoami, "^a.  Directory not pushed.", rtrim (pathname));
	     end;
	     else call com_err_ (code, whoami, "^a", rtrim (pathname));
	end;
     end;

     return;                                                /* finish cwd */

/*------------------------------------------------------------------------*/
%page;
change_default_wdir:
cdwd: entry options (variable);

/* Get the number of arguments by calling the cu_$arg_count entrypoint.   */
/* Since this entry only allows one optional argument, if more than one   */
/* argument is given, treats as an error.  If no optional argument, the   */
/* get_wdir internal procedure is called to get the pathname of the       */
/* current working directory.  Othewise it calls the expand_path_ to get  */
/* the address of the pathname of the PATH specified.                     */
/* Stores the pathname value into the default_wdir_pathname and sets      */
/* the default_wdir_set flag before terminating normality.                */

/* begin coding */
	whoami = "change_default_wdir";

	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami);
	     return;
	end;
          if nargs > 1 then do;
	     call com_err_ (0, whoami,
		"More than one optional argument supplied.^/Usage:  ^a {PATH}", whoami);
	     return;
	end;
          else if nargs = 0 then do;                        /* get the default wdir */
		call get_wdir ();
		if pathname = "" then do;
		     call com_err_ (error_table_$no_wdir, whoami);
		     return;
		end;
	end;
	else do;
	     call cu_$arg_ptr (1, ap, al, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami);
		return;
	     end;
	
               call expand_path_ (ap, al, addr (pathname), null, code);
	     if code ^= 0 then do;
		call com_err_ (code, whoami, "^a", arg);
		return;
	     end;
	end;
     
          default_wdir_pathname = pathname;
	default_wdir_set = "1"b;

	return;
	
/*-------------------------------------------------------------------------*/
%page;
working_dir:
wd:
print_wdir:
pwd: entry options (variable);

/* This entry is documented in the MTB 775 and approved in MCR7839.        */
/*                                                                         */
/* Its syntax either "wd {LOCATIONs} {-he; -nhe}" or "[wd {LOCATIONs}]".   */
/*                                                                         */
/* LOCATION can be either stack location N within a stack of prior wdirs   */
/* or a text string LABEL associated with a stack entry or can be one of   */
/* the following reserved words:                                           */
/*   first (f) indicates the current wdir at location 0.                   */
/*   last  (l) indicates the least recent wdir at stack location N.        */
/*   all   (a) indicates the current wdir at location 0 and all prior      */
/*             wdirs begin at stack location 1 and end at location N.      */
/*                                                                         */
/*   Note that the most recent wdir is located at stack location 1 and in  */
/*   the stack of prior wdirs.  The current wdir is NOT in the stack.      */

/* automatic variables */
     dcl control_string char (45) varying;
     dcl header_control_string char (25) varying;
     dcl comments char (31);
     dcl longest_label_length fixed bin (35);
     dcl no_header bit (1) aligned;
     dcl print_index fixed bin;
     dcl ret_ptr pointer;
     dcl ret_len fixed bin (21);
     dcl want_header bit (1) aligned;

/* based */
     dcl  ret_arg char (ret_len) varying based (ret_ptr);

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

/* This internal procedure called by working_dir entry is self documented.  */
/* Several lines of documentation are followed by primary lines of coding.  */
			
/* begin coding */
   code = 0;
   LOCATION_before_colon = "";
   LOCATION_after_colon = "";

   do arg_index = 1 to nargs;                               /* scan through all input arguments specified on the command level */

        call cu_$arg_ptr (arg_index, ap, al, code);         /* get an input argument specified on the command level */
        if code ^= 0 then do;
	   if active_function then
	        call active_fnc_err_ (code, whoami);
	   else call com_err_ (code, whoami);
             return;
        end;

        if index (arg, "-") = 1 then do;                    /* the first character of a specified input argument is a minus sign */
	   
	   if arg = "-header" | arg = "-he" then do;
	        want_header = "1"b;

	        error_count = error_count + 1;            /* prepare for the case of -he and -nhe are both specified */
	   end;
             else if arg = "-no_header" | arg = "-nhe" then do;
		   no_header = "1"b;

		   error_count = error_count + 1;       /* prepare for the case of both -he and -nhe are specified */
	   end;
             else do;                                        /* neither -header (-he) nor -no_header (-nhe) specified, wd reports an error */
	        code = error_table_$badopt;
RETURN:
	        if active_function then
		   call active_fnc_err_ (code, whoami, "^a", arg);
	        else call com_err_ (code, whoami, "^a", arg);
	        return;
	   end;
        end;                                                /* the first character of a specified input argument is a minus sign */

        else do;                                             /* the specified input argument is a LOCATION */
	   if index (arg, ":") > 0 then do;
                                                             /* LOCATION is a stack range identified by a given colon in it */
	        LOCATION_before_colon = before (arg, ":");
	        LOCATION_after_colon  = after (arg, ":");
	        
	        if LOCATION_before_colon = "" | LOCATION_after_colon = "" then do;
		   code = error_table_$bad_arg;
		   goto RETURN;
	        end;
	   end;
        
             if arg = "first" | arg = "f" then do;           /* LOCATION is a reserved word named first (f) */
	        stack_location = 0;
	        call save_a_valid_LOCATION (max_array_index, stack_location);
	   end;
        
             else if arg = "last" | arg = "l" then do;       /* LOCATION is a reerved word named last (l) */
		   if total_number_of_pushes > 0 then do;
		        stack_location = total_number_of_pushes;
		        call save_a_valid_LOCATION (max_array_index, stack_location);
		   end;
	             else do;
		        if active_function then
			   call active_fnc_err_ (0, whoami, "Empty stack of prior wdir.");
		        else call com_err_ (0, whoami, "Empty stack of prior wdir.");
		        return;
		   end;
	   end;
        
             else if arg = "all" | arg = "a" then do;        /* LOCATION is a reserved word named last (l) */
		   stack_location = 0;
		   call save_a_valid_LOCATION (max_array_index, stack_location);
		   
		   if total_number_of_pushes > 0 then do;
		        stack_location = total_number_of_pushes;
		        call CONTINUE_save_good_data (max_array_index, stack_location, code);
		   end;
	             else;                                 /* do not treat as an error.  Let print or return the current wdir */
	   end;
        
             else if verify (substr (arg, 1, 1), ALLOWED_DIGITS) = 0 then do;
                                                             /* the first character of LOCATION is specified as a decimal digit */

		   if index (arg, ":") = 0 then do;
                                                             /* it is considered as a stack position N */
		        stack_location = cv_dec_check_ (arg, code);
		        if code ^= 0 then
			   goto RETURN;

		        if stack_location > total_number_of_pushes then do;
			   code = error_table_$bad_arg;
			   goto RETURN;
		        end;

		        stack_location = abs (stack_location);
		        call save_a_valid_LOCATION (max_array_index, stack_location);
		   end;
	             else do;                               /* it is a mix range of N and one of the following: N, LABEL, or a reserved word */
		        stack_location = cv_dec_check_ ((LOCATION_before_colon), code);
		        if code ^= 0 then
			   goto RETURN;
                                                              /* save the first part of a range which is a stack position N into an array */
		        if stack_location > total_number_of_pushes then do;
			   code = error_table_$bad_arg;
			   goto RETURN;
		        end;

		        stack_location = abs (stack_location);
		        call save_a_valid_LOCATION (max_array_index, stack_location);
		                                          /* continue to validate the second part of the range */
		        call LOCATION_continue_validation ((LOCATION_after_colon), max_array_index, stack_location, code);
		   end;
             end;                                             /* the first character of LOCATION is a decimal digit */

             else do;                                         /* LOCATION is specified a text string */
	        if index (arg, ":") = 0 then
		   call LABEL_validation (arg, max_array_index, stack_location, code);
	        else do;                                    /* the text string specified is a stack range */
		   if LOCATION_before_colon = "first" | LOCATION_before_colon = "f" then do;
		        stack_location = 0;
		        call save_a_valid_LOCATION (max_array_index, stack_location);
		   end;
	        
	             else if LOCATION_before_colon = "last" | LOCATION_before_colon = "l" then do;
			   code = error_table_$bad_arg;
			   goto RETURN;
		   end;
	        
	             else if LOCATION_before_colon = "all" | LOCATION_before_colon = "a" then do;
			   code = error_table_$bad_arg;
			   goto RETURN;
		   end;
	        
	             else do;
		        call LABEL_validation ((LOCATION_before_colon), max_array_index, stack_location, code);
		        if code ^= 0 then goto RETURN;
		   end;
		   
		   call LOCATION_continue_validation ((LOCATION_after_colon), max_array_index, stack_location, code);
		   if code ^= 0 then do;
		        if (LOCATION_after_colon = "last" | LOCATION_after_colon = "l") & total_number_of_pushes = 0 then
			   code = 0;                      /* let pwd print the first portion of the range (e.g. pwd f:l) */
		   end;
	        end;                                   /* the text string specified is a range */
	   end;                                        /* LOCATION is specified as a text string */

             if code ^= 0 then goto RETURN;              /* an error found during parsing a specified LOCATION */             
        end;                                             /* the specified input argument is a LOCATION */
   end;                                                  /* validate each input argument given on the command level */

   return;                                               /* return to working_dir entry */
   
   end wd_input_argument_validation;

               /*---------------------------------------------*/
%page;
/* main program of working_dir */
     temp_ptr = null;
     max_array_index = 0;
     stack_location = - 1;
     location_array (*) = - 1;
     longest_label_length = 0;
     want_header = "0"b;
     no_header = "0"b;
     error_count = 0;

     call get_wdir ();                                    /* sets pathname to current working dir */

     whoami = "working_dir";                               /* my primary name is working_dir */

     call cu_$af_return_arg (nargs, ret_ptr, ret_len, code);
     if code ^= 0 then do;
	if code = error_table_$not_act_fnc then          /* i was specified as a command */
	     active_function = "0"b;
	else do;
	     call active_fnc_err_ (code, whoami);
	     return;
	end;
     end;
     else do;                                              /* i was specified as an active function */
	active_function = "1"b;
	ret_arg = "";
     end;

     if nargs = 0 then do;                                 /* users interest on the current wdir only */
	if pathname = " " then do;                       /* the current wdir has been deleted */
	     code = error_table_$no_wdir;
	     if active_function then
		call active_fnc_err_ (code, whoami);
	     else call com_err_ (code, whoami);
	     return;
	end;
     
	if active_function then                           /* return the current wdir */
	     ret_arg = requote_string_ (rtrim(pathname));
	else call ioa_ ("^a", rtrim (pathname));          /* print out the current wdir */
     end;


     call wd_input_argument_validation;                     /* validate each input argument given on the command level */
     if code ^= 0 then return;

     if error_count > 1 then do;
	call com_err_ (0, whoami, "Both -header (-he) and -no_header (-nhe) are specified.");
	return;
     end;
     else error_count = 0;

     if (want_header | no_header) & active_function then do;
	call active_fnc_err_ (0, whoami, "Usage: [wd {LOCATIONs}]");
	return;
     end;


                                                            /* case only a valid control argument is specified on the command level */
     if nargs = 1 then do;
	if arg = "-header" | arg = "-he" | arg = "-no_header" | arg = "-nhe"  then do;
	     if pathname = " " then do;
		call com_err_ (error_table_$no_wdir, whoami);
		return;
	     end;
	
	     if arg = "-header" | arg = "-he" then do;
		call ioa_ ("LOC LABEL PATHNAME");
		call ioa_ (" ");
	     end;

	     call ioa_ ("^10x^a", rtrim (pathname));
	end;
     end;


                                                            /* for indentation, find the longest length of label name, given LOCATIONS */
     do array_index = 1 to max_array_index;                 /* loop through the entire array which contains one or more LOCATIONs to be printed */

	if location_array (array_index) = 0 then do;      /* indicate the current wdir */
	     if length (label_name_of_current_wdir) > longest_label_length then
		longest_label_length = length (label_name_of_current_wdir);
	end;

	temp_ptr = last_node_ptr;
	                                                  /* scan the linked list of prior wdirs from index 1 to a specified LOCATION */
	do print_index = 1 to location_array (array_index);

                                                            /* have i reached a specified LOCATION yet? */
	     if print_index = location_array (array_index) then do;
                                                            /* is the label length at that specified LOCATION longest length? */
		if length (temp_ptr -> stack_linked_list.label_name) > longest_label_length then
		     longest_label_length = length (temp_ptr -> stack_linked_list.label_name);
	     end;
	     else temp_ptr = temp_ptr -> stack_linked_list.back_ptr;
	end;
     end;

                                                            /* then build control string for ioa_ calls later.  Indentation purpose only */
     if want_header | ^no_header then do;                   /* either users want header when only a single LOCATION is printed or */
                                                            /* pwd only prints a header when more than one LOCATIONs are printed (by default) */
	if longest_label_length < 5 then
	     longest_label_length = 5;                    /* 5 indicates the total number of characters of "LABEL" */
     end;
                                                            /* for stack entry, adjust the distance between associated label and a wdir */
     control_string = "^4d ^" || ltrim (char (longest_label_length));
     control_string = control_string || "a ^a";
                                                            /* for the header, adjust the distance between "LABEL" and "PATHNAME" */
     header_control_string = " LOC LABEL^" || ltrim (char (longest_label_length - 5));
     header_control_string = header_control_string || "x PATHNAME";

     if pathname ^= "" then
	current_wdir_pathname = pathname;                 /* save the current wdir for printting only if it is deleted and want to print it */

                                                            /* print or return wdir(s) at specified LOCATION(s) */
     do array_index = 1 to max_array_index;

	temp_ptr = last_node_ptr;

	if (array_index = 1) & (max_array_index > 1) & (^active_function) then do;
                                                            /* as a command, print out the header once when more than one LOCATION is asked */
	     if ^no_header then do;                       /* by default */
		call ioa_ (header_control_string);
		call ioa_ (" ");
	     end;
	end;

	if location_array (array_index) = 0 then do;      /* is it the current wdir? */
	     print_index = 0;                             /* to indicate the current wdir */

	     if max_array_index = 1 then do;              /* case of only the current wdir is printed or returned */
		if pathname = " " then do;              /* the current wdir has been deleted */
		     if active_function then
			call active_fnc_err_ (error_table_$no_wdir, whoami);
		     else call com_err_ (error_table_$no_wdir, whoami);
		     return;
		end;
	          else do;                                /* the current wdir still exists */
		     if active_function then
			ret_arg = rtrim (pathname);   /* return the current wdir */
		     else do;                           /* print out the current wdir on the terminal */
			if want_header then do;       /* users also want the header to be printed */
			     call ioa_ (header_control_string);
			     call ioa_ (" ");
			end;

		          call ioa_ (control_string, print_index, label_name_of_current_wdir, rtrim (pathname));
		     end;
		end;
	     end;                                         /* case of printing or returning only the current wdir */
               else do;                                     /* print or return the current wdir and AT LEAST one prior wdir */
		if active_function then do;            /* as an active function, needs to find out whether the current wdir exists or not */
		     if array_index ^= 1 then          /* not the first time go into the do loop */
			ret_arg = ret_arg || " ";    /* prepare to return the next prior wdir pathname */
		     
		     if pathname ^= "" then            /* the current wdir exists.  Return it to an user */
			ret_arg = ret_arg || rtrim (pathname);
                                                            /* the current wdir has been deleted, returns it, its value was saved earlier */
		     else ret_arg = ret_arg || rtrim (current_wdir_pathname);
		end;                                    /* as an active function */
		else do;                                /* as a command, must find out whether the current wdir exist or not */
		     if pathname ^= " " then            /* if the current wdir still exists, print it out */
			call ioa_ (control_string, print_index, rtrim (label_name_of_current_wdir), rtrim (pathname));
		     else do;                           /* the current wdir has been deleted */
			comments = "[current wdir has been deleted]";

			call ioa_ (control_string, print_index, rtrim (label_name_of_current_wdir),
			     rtrim (current_wdir_pathname) || " " || comments);
		     end;                               /* the current wdir has been deleted */
		end;                                    /* as a command, must find out whether the current wdir exists or not */
               end;                                         /* case of the current wdir and AT LEAST ONE MORE stack entry are printed or returned */
	end;                                              /* finish to print or return the current wdir */

                                                            /* scan the linked list of prior wdirs from index 1 to a specified LOCATION */
          do print_index = 1 to location_array (array_index);

	     if (print_index = 1) & (max_array_index = 1) & (^active_function) then do;
		if want_header then do;                 /* users want to print the header when only one LOCATION is printed out */
		     call ioa_ (header_control_string);
		     call ioa_ (" ");
		end;
	     end;

	     if print_index = location_array (array_index) then do;

		if active_function then do;            /* return a prior wdir at a specified LOCATION */
		     if print_index ^= 1 | ret_arg ^= " " then
			ret_arg = ret_arg || " ";    /* for returning several stack entries, separated by a white space */
		     ret_arg = ret_arg || temp_ptr -> stack_linked_list.wdir_name;
		end;
                                                           /* print out a prior wdir at a specified LOCATION */
		else call ioa_ (control_string, print_index, temp_ptr -> stack_linked_list.label_name, temp_ptr -> stack_linked_list.wdir_name);
	     end;
                                                          /* have not reached a specified LOCATION yet */
	     else temp_ptr = temp_ptr -> stack_linked_list.back_ptr;
	end;                                            /* complete printed or returned a single wdir at a specified LOCATION */
     end;                                                 /* complete printed or returned wdir(s) at specified LOCATION(s) */
     
     return;                                              /* complete working_dir */

/*---------------------------------------------------------------------------*/
%page;
print_default_wdir:
pdwd: entry options (variable);

/* begin coding */
     whoami = "print_default_wdir";

     call cu_$arg_count (nargs, code);
     if code ^= 0 then do;
	call com_err_ (code, whoami);
	return;
     end;

     if nargs > 0 then do;                                  /* no arguments allowed at all ... */
	call com_err_ (0, whoami, "This command takes no arguments.^/Usage:^_^a", whoami);
	return;
     end;

     call get_default_wdir ();                              /* get the default wdir */

     if pathname = "" then                                  /* no default wdir */
	call com_err_ (error_table_$no_wdir, whoami);
     else call ioa_ ("^a", rtrim (pathname));               /* prints it out */
     
     return;                                                /* all done with print_default_wdir */

/*-------------------------------------------------------------------------- */
%page;
get_wdir_: entry () returns (char (168));

     call get_wdir ();				/* sets pathname */

     if pathname = "" then do;			/* no wdir, warn the user */
	call sub_err_ (error_table_$no_wdir, "get_wdir_", "h", null (), (0), "");
	return ("");				/* return nothing */
     end;

     return (pathname);                                     /* all done with get_wdir_ */

/*---------------------------------------------------------------------------*/
%page;
get_default_wdir_: entry () returns (char (168));

/* begin coding */
     call get_default_wdir ();                              /* sets pathname to the default wdir */

     return (pathname);                                     /* all done with get_default_wdir_ */

/*--------------------------------------------------------------------------*/
%page;
change_wdir_: entry (P_pathname, P_code);

     dcl (P_pathname char (168),
          P_code fixed bin (35)) parameter;

     call hcs_$fs_search_set_wdir (P_pathname, P_code);     /* set it, and just return the code */

     return;                                                /* all done with change_wdir_ */

/*---------------------------------------------------------------------------*/
%page;
change_default_wdir_: entry (P_pathname, P_code);

     default_wdir_pathname = P_pathname;
     default_wdir_set = "1"b;

     P_code = 0;

     return;                                               /* all done with change_default_wdir_ */

/*--------------------------------------------------------------------------*/
%page;
get_wdir: proc ();

/* sets pathname to the current wdir pathname.  If there is no current wdir */
/* pathname is set to a null string.                                        */

     call hcs_$fs_search_get_wdir (addr (pathname), current_wdir_length);

     if current_wdir_length = 0 then
	pathname = "";	                              /* set it to the null string to indicate no wdir */

     else substr (pathname, current_wdir_length + 1) = "";  /* otherwise, fill the rest with spaces */

     return;

     end get_wdir;

/*-------------------------------------------------------------------------*/
%page;
get_default_wdir: proc ();

     if ^default_wdir_set then do; 		/* first call, sets the default wdir to home_dir */
	call user_info_$homedir (default_wdir_pathname);

	default_wdir_set = "1"b;                /* indicate this has been done */
     end;

     pathname = default_wdir_pathname;            /* sets pathname */

     return;

     end get_default_wdir;
/*-------------------------------------------------------------------------*/
%page;
CONTINUE_save_good_data: proc (p_max_array_index, p_stack_pos, p_ec);

/* Several consective stack locations are saved in an array.               */
/* Note that a specified LOCATION was identified as a range of either a    */
/* stack location range (e.g. 3:7), a label range (e.g. x:y), or a mixed   */
/* range (e.g. x:5; 3:z; first:z; first:3, ect.).  This range of a certain */
/* kind will be stored in an array as numeric digits.                      */

                                                            /* parameter   */
     dcl p_max_array_index fixed bin;
     dcl p_ec fixed bin (35);
     dcl p_stack_pos fixed bin (35);
                                                            /* local */
     dcl next_stack_position fixed bin (35);
     dcl next_stack_pos fixed bin (35);

/* begin coding */
     if p_stack_pos <= location_array (p_max_array_index) then do;
	p_ec = error_table_$bad_arg;                      /* for examples: 10:10 10:4 */
	return;
     end;
     else do;
	next_stack_pos = location_array (p_max_array_index) + 1;

	do next_stack_position = next_stack_pos to p_stack_pos;
	     p_max_array_index = p_max_array_index + 1;
	     location_array (p_max_array_index) = next_stack_position;
	end;
     end;

     return;
     
     end CONTINUE_save_good_data;

/*---------------------------------------------------------------------------*/
%page;
LOCATION_continue_validation: proc (p_LOCATION_after_colon, p_max_arr_indx, p_stack_loctn, p_ecode);

/* continue to validate the remaining character string after a colon         */
/* character was found. (e.g. 3:7, 5:label_x, first:y, z:w, ect) when        */
/* LOCATION was specified as a range which known by a colon character.       */

                                                        /* parameters */
     dcl p_LOCATION_after_colon char (*);
     dcl p_ecode fixed bin (35);
     dcl p_max_arr_indx fixed bin;
     dcl p_stack_loctn fixed bin (35);
                                                        /* local */
     dcl found bit (1) aligned;
     dcl search_index fixed bin (35);
     dcl search_ptr ptr;
     dcl skip_index fixed bin (35);

/* begin coding */
     found = "0"b;
     skip_index = 0;
     search_index = 0;
     search_ptr = null;

     if verify (substr (p_LOCATION_after_colon, 1, 1), ALLOWED_DIGITS) = 0 then do;
		                                            /* LOCATION is a range of stack positions (e.g. 10:16) */
	p_stack_loctn = cv_dec_check_ (p_LOCATION_after_colon, p_ecode);
	if p_ecode ^= 0 then return;

	if p_stack_loctn > total_number_of_pushes then do;
	     p_ecode = error_table_$bad_arg;
	     return;
	end;

	p_stack_loctn = abs (p_stack_loctn);
                                                                /* save them */
	call CONTINUE_save_good_data (p_max_arr_indx, p_stack_loctn, p_ecode);
     end;

     else if p_LOCATION_after_colon = "first" | p_LOCATION_after_colon = "f" then 
	p_ecode = error_table_$bad_arg;                  /* e.g. 10:first */

     else if p_LOCATION_after_colon = "all" | p_LOCATION_after_colon = "a" then
	p_ecode = error_table_$bad_arg;
		
     else if p_LOCATION_after_colon = "last" | p_LOCATION_after_colon = "l" then do;
	     p_stack_loctn = total_number_of_pushes;     /* e.g. 10:last */

	     call CONTINUE_save_good_data (p_max_arr_indx, p_stack_loctn, p_ecode);
      end;

      else do;
	 if index (p_LOCATION_after_colon, "-") = 1 then do;
	      p_ecode = error_table_$badopt;
	      return;
	 end;
		     
           if index (p_LOCATION_after_colon, ":") > 0 then do;
	      p_ecode = error_table_$bad_arg;
	      return;
	 end;

	 if length (p_LOCATION_after_colon) > MAX_LENGTH_LABEL_NAME then do;
	      p_ecode = error_table_$bigarg;
	      return;
	 end;
                                                           /* search for a matched label name */
           search_ptr = last_node_ptr;
	 do skip_index = 1 to p_stack_loctn;
	      search_ptr = search_ptr -> stack_linked_list.back_ptr;
	 end;

	 do search_index = (p_stack_loctn + 1) to total_number_of_pushes while (^found);
	      if p_LOCATION_after_colon = search_ptr -> stack_linked_list.label_name then
		 found = "1"b;
	      else search_ptr = search_ptr -> stack_linked_list.back_ptr;
	 end;
		
	 if (search_index > total_number_of_pushes) & (^found) then do;
	      p_ecode = error_table_$bad_arg;
	      return;
	 end;
		     
	 search_index = search_index - 1;                     /* calculate the correct value of search_index after leaving do loop */
	 p_stack_loctn = abs (search_index);

	 call CONTINUE_save_good_data (p_max_arr_indx, p_stack_loctn, p_ecode);
      end;

      return;
      
      end LOCATION_continue_validation;

/*---------------------------------------------------------------------------*/
%page;
save_a_valid_LOCATION: proc (p_max_arr_index, p_stack_loc);

/* save a valid stack location into an array.                                */
		                                           /* parameter  */
     dcl p_max_arr_index fixed bin;
     dcl p_stack_loc fixed bin (35);
		 
/* begin coding */
     p_max_arr_index = p_max_arr_index + 1;
     location_array (p_max_arr_index) = p_stack_loc;

     return;
      
     end save_a_valid_LOCATION;

/*---------------------------------------------------------------------------*/
%page;
LABEL_validation: proc (para_arg, para_max_array_index, para_stack_pos, para_ec);

/* validate that a given LABEL length is less or equal the maximum length    */
/* allowed, 32 characters.  Also it must be defined that means it must be    */
/* attached to a prior wdir in some earlier time.                            */

                                                             /* parameter    */
     dcl para_arg char (*);
     dcl para_ec fixed bin (35);
     dcl para_max_array_index fixed bin;
     dcl para_stack_pos fixed bin (35);
	                                                   /* local */
     dcl match_label_name bit (1) aligned;
     dcl searching_index fixed bin (35);
     dcl searching_ptr ptr;

/* begin coding */
     match_label_name = "0"b;
     searching_ptr = null;
     
     if length (para_arg) > MAX_LENGTH_LABEL_NAME then do;
	para_ec = error_table_$bigarg;
	return;
     end;

     searching_ptr = last_node_ptr;
     do searching_index = 1 to total_number_of_pushes while (^match_label_name);
	if searching_ptr -> stack_linked_list.label_name = para_arg then
	     match_label_name = "1"b;
	else searching_ptr = searching_ptr -> stack_linked_list.back_ptr;
     end;

     if searching_index > total_number_of_pushes & ^match_label_name then do;
	para_ec = error_table_$bad_arg;
	return;
     end;

     searching_index = searching_index - 1;                         /* calculate the correct value of search_index after leaving the do loop */
     para_stack_pos = abs (searching_index);

     call save_a_valid_LOCATION (para_max_array_index, para_stack_pos);
     
     return;
     
     end LABEL_validation;

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

     end directory_commands_;




		    dl_handler_.pl1                 12/09/86  1226.8rew 12/09/86  1226.4       88803



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




/****^  HISTORY COMMENTS:
  1) change(86-08-05,Houck), approve(86-08-11,MCR7501), audit(86-08-15,Wong),
     install(86-08-29,MR12.0-1140):
     Fixed so that an error code is now checked which was previously ignored.
  2) change(86-11-17,Dickson), approve(86-11-18,MECR0001),
     audit(86-11-17,GDixon), install(86-11-18,MR12.0-1221):
     Fix bug in which mailboxes/message_segments couldn't be deleted because
     the "safety" switch was on, but the "copy" switch was unimplemented.
  3) change(86-12-04,Dickson), approve(86-12-04,MCR7582),
     audit(86-12-08,GDixon), install(86-12-09,MR12.0-1236):
     Fixed the bug in which mailboxes/message_segments couldn't be delete
     because the "safety" switch was on, but the "copy" switch was
     unimplemented.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */

dl_handler_:
     procedure (id, dname, ename, code);

/* Initially coded 6/69 by V. Voydock */
/* Modified 03/08/70 P. Karger */
/* Modified 12/03/70 E. Donner */
/* Modified 11/02/71 Dennis Capps */
/* Modified 01/74 by E. Donner to reflect that the safety switch protects a branch. */
/* Rewritten to work on mailboxes and queues 03/28/80 S. Herbst */
/* Changed $dirdelete to say "empty" or "nonempty" if possible 12/15/82 S. Herbst */
/* changed for object_type_, added switches entry 7/2/83 Jay Pattin */
/* 830927 BIM object_type_ --> fs_util_ */
/* Fixed to return et_$vtoc_io_error & try to ignore et_$vtoce_connection_fail 06/25/84 S. Herbst */


%include query_info;
%include dl_handler_options;

%include suffix_info;
%include copy_flags;

	dcl     1 dir_acl		        aligned,	/* for hcs_$add_dir_acl_entries */
		2 user_id		        char (32) aligned,
		2 mode		        bit (36) aligned,
		2 status		        fixed bin (35);


	dcl     (id, dname, ename)	        char (*);
	dcl     switches		        bit (36) aligned parameter;
	dcl     (code, star_code)	        fixed bin (35);

	dcl     fs_util_type	        char (32);
	dcl     answer		        char (150) varying;
	dcl     (empty_str, switch_type)      char (32);

	dcl     fb_copy_switch	        fixed bin (1);
	dcl     copy_switch		        bit (1) aligned;
	dcl     safety_switch	        bit (1) aligned;

	dcl     bit_count		        fixed bin (24);
	dcl     entry_count		        fixed bin;
	dcl     type		        fixed bin (2);

	dcl     error_table_$action_not_performed
				        fixed bin (35) ext;
	dcl     error_table_$nomatch	        fixed bin (35) ext;
	dcl     error_table_$safety_sw_on     fixed bin (35) ext;
	dcl     error_table_$vtoce_connection_fail
				        fixed bin (35) ext;

	dcl     command_query_	        entry options (variable);
	dcl     fs_util_$list_switches        entry (char (*), char (*), char (*), ptr, ptr, fixed bin (35));
	dcl     get_group_id_	        entry returns (char (32));
	dcl     get_system_free_area_	        entry returns (ptr);
	dcl     hcs_$add_dir_acl_entries      entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$get_safety_sw	        entry (char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     hcs_$get_copysw	        entry (char (*), char (*), fixed bin (1), fixed bin (35));
	dcl     hcs_$set_copysw	        entry (char (*), char (*), fixed bin (1), fixed bin (35));
	dcl     hcs_$set_safety_sw	        entry (char (*), char (*), bit (1) aligned, 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     installation_tools_$set_safety_sw
				        entry (char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     fs_util_$get_switch	        entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     fs_util_$set_switch	        entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     fs_util_$get_type	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     pathname_		        entry (char (*), char (*)) returns (char (168));

	dcl     cleanup		        condition;

	dcl     (addr, hbound, lbound, null, string, unspec)
				        builtin;

/* dl_handler_$dl_handler_ */

	string (dl_handler_options) = ""b;
	goto JOIN;

dl_handler_$switches:
     entry (id, dname, ename, switches, code);

	string (dl_handler_options) = switches;
	if dl_handler_options.no_question
	then goto RESET;

JOIN:
	call query_init;
	query_info.status_code = error_table_$safety_sw_on;

	if dl_handler_options.raw
	then call hcs_$get_safety_sw (dname, ename, safety_switch, code);
	else call fs_util_$get_switch (dname, ename, "safety", safety_switch, code);
	if code ^= 0
	then if code = error_table_$vtoce_connection_fail
	     then go to GET_STATUS;			/* OK to delete anyway */
	     else return;

	if safety_switch
	then switch_type = "safety switch";
	else do;
		if dl_handler_options.raw
		then do;
			call hcs_$get_copysw (dname, ename, fb_copy_switch, code);
			copy_switch = (fb_copy_switch ^= 0);
		     end;
		else call fs_util_$get_switch (dname, ename, "copy", copy_switch, code);
		if code ^= 0
		then if code = error_table_$vtoce_connection_fail
		     then go to GET_STATUS;		/* unlikely 2nd time */
		     else return;

		if copy_switch
		then switch_type = "copy switch";
		else go to GET_STATUS;		/* neither switch is on */
	     end;

	code = 0;

	call command_query_ (addr (query_info), answer, id, "^a is protected by ^a. Do you want to delete it?  ",
	     pathname_ (dname, ename), switch_type);

	if answer = "no"
	then do;
NO:
		code = error_table_$action_not_performed;
		return;
	     end;
	goto RESET;

noquestion:
     entry (id, dname, ename, code);			/* dl_handler_$noquestion: no need to query */

	string (dl_handler_options) = ""b;		/* no need to set no_question */

RESET:
	if dl_handler_options.library
	then call installation_tools_$set_safety_sw (dname, ename, "0"b, code);
	else if dl_handler_options.raw
	then do;
		call hcs_$set_copysw (dname, ename, 0, code);
		call hcs_$set_safety_sw (dname, ename, "0"b, code);
	     end;
	else do;
		call fs_util_$set_switch (dname, ename, "copy", "0"b, code);
		if code ^= 0
		then if ^switch_implemented (dname, ename, "copy")
		     then code = 0;
		if code = 0
		then do;
			call fs_util_$set_switch (dname, ename, "safety", "0"b, code);
			if code ^= 0
			then if ^switch_implemented (dname, ename, "safety")
			     then code = 0;
		     end;
	     end;
	if code ^= 0
	then return;

/* Obtain storage system type */

GET_STATUS:
	call hcs_$status_minf (dname, ename, 0, type, bit_count, code);
	if code ^= 0
	then return;

/* If entry is a directory, add current user onto ACL with sma access */

	if type = 2 & bit_count = 0
	then do;
		if ^dl_handler_options.raw
		then do;				/* is it really a dir? */
			call fs_util_$get_type (dname, ename, fs_util_type, code);
			if code = 0 & fs_util_type ^= FS_OBJECT_TYPE_DIRECTORY
			then return;		/* its some sort of extended something */
		     end;

		dir_acl.user_id = get_group_id_ ();
		dir_acl.mode = "111"b;
		call hcs_$add_dir_acl_entries (dname, ename, addr (dir_acl), 1, code);
	     end;

	return;					/*						*/
dblstar:
     entry (id, dname, ename, code);			/* "Do you want to delete '**'? */

	call query_init;
	query_info.suppress_name_sw = "1"b;

	call command_query_ (addr (query_info), answer, id, "Do you want to '^a ^a' in ^a ?  ", id, ename, dname);

	if answer = "no"
	then go to NO;
	else code = 0;

	return;



dirdelete:
     entry (id, dname, ename, code);			/* "Do you want to delete the directory...?" */

	call query_init;

	call hcs_$star_ (pathname_ (dname, ename), "**", 3 /* ALL ENTRIES */, null, entry_count, null, null, star_code);
	if star_code = 0
	then if entry_count = 0
	     then empty_str = " empty";
	     else empty_str = " nonempty";
	else if star_code = error_table_$nomatch
	then empty_str = " empty";
	else empty_str = "";
	call command_query_ (addr (query_info), answer, id, "Do you want to delete the^a directory ^a ? ", empty_str,
	     pathname_ (dname, ename));
	if answer = "no"
	then go to NO;
	else code = 0;

	return;					/*						*/
query_init:
     proc;

	unspec (query_info) = "0"b;
	query_info.version = query_info_version_4;
	query_info.yes_or_no_sw = "1"b;
	query_info.question_iocbp, query_info.answer_iocbp = null;

     end query_init;


switch_implemented:
     procedure (dname, ename, switch) returns (bit (1) aligned);

	dcl     switch		        char (32);
	dcl     dname		        char (*);
	dcl     ename		        char (*);

	dcl     found		        bit(1);
	dcl     indx		        fixed bin;
	dcl     system_area_ptr	        ptr;
	dcl     system_area		        area based(system_area_ptr);

	switch_list_ptr = null ();
	on cleanup call cleanup_switch_list;
	system_area_ptr = get_system_free_area_();

	call fs_util_$list_switches (dname, ename, SWITCH_LIST_VERSION_1,
	     addr(system_area), switch_list_ptr, code);
	if code ^= 0 then return ("0"b);

	do indx = lbound (switch_list.names, 1)
	       to hbound (switch_list.names, 1)
	    while (switch_list.names(indx) ^= switch);
	end;
	found = indx > hbound(switch_list.names, 1);
	free switch_list in (system_area);

	return (found);

cleanup_switch_list:
     procedure;

	if switch_list_ptr ^= null ()
	then free switch_list in (system_area);

     end cleanup_switch_list;

     end switch_implemented;

     end dl_handler_;




		    initiate_file_.pl1              10/25/83  1546.3r w 10/25/83  1444.2       61506



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


/* Initiate a segment or an archive component.

   Written 8 April 1981 by M. N. Davidoff.
   Modified: 19 February by G. Palter to not return error_table_$zero_length_seg
   Modified 3/82 BIM for creation.
*/

/* format: style2 */

initiate_file_:
     procedure (P_dirname, P_entryname, P_mode, P_seg_ptr, P_bit_count, P_code);

	create_requested = "0"b;
	component_name = "";
	go to join;


create:
     entry (P_dirname, P_entryname, P_mode, P_seg_ptr, P_created, P_bit_count, P_code);

	P_created = "0"b;
	create_requested = "1"b;
	component_name = "";
	go to join;


component:
     entry (P_dirname, P_entryname, P_component_name, P_mode, P_seg_ptr, P_bit_count, P_code);

	component_name = P_component_name;
	create_requested = "0"b;
	go to join;
%page;
/* parameters */

	declare P_bit_count		 fixed binary (24);
	declare P_code		 fixed binary (35);
	declare P_component_name	 char (*);
	declare P_created		 bit (1) aligned;
	declare P_dirname		 char (*);
	declare P_entryname		 char (*);
	declare P_mode		 bit (*);
	declare P_seg_ptr		 pointer;

/* automatic */

	declare bit_count		 fixed binary (24);
	declare create_code		 fixed binary (35);
	declare code		 fixed binary (35);
	declare component_name	 char (32);
	declare create_requested	 bit (1);
	declare created		 bit (1);
	declare 1 effective_mode,
		2 pad1		 bit (1),
		2 read		 bit (1),
		2 execute		 bit (1),
		2 write		 bit (1),
		2 pad2		 bit (1);
	declare effective_mode_bin	 fixed binary (5);
	declare 1 required_mode,
		2 read		 bit (1),
		2 execute		 bit (1),
		2 write		 bit (1);
	declare seg_ptr		 pointer;

/* builtin */

	declare (bit, index, null, reverse, rtrim, string)
				 builtin;

/* condition */

	declare cleanup		 condition;

/* external static */

	declare error_table_$archive_component_modification
				 fixed binary (35) external static;
	declare error_table_$namedup	 fixed binary (35) external static;
	declare error_table_$no_e_permission
				 fixed binary (35) external static;
	declare error_table_$no_m_permission
				 fixed binary (35) external static;
	declare error_table_$no_r_permission
				 fixed binary (35) external static;
	declare error_table_$no_w_permission
				 fixed binary (35) external static;
	declare error_table_$not_archive
				 fixed binary (35) external static;

/* entry */

	declare archive_$get_component entry (pointer, fixed binary (24), char (*), pointer, fixed binary (24),
				 fixed binary (35));
	declare hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35));
	declare hcs_$append_branch	 entry (character (*), character (*), fixed binary (5), fixed binary (35));
	declare hcs_$fs_get_mode	 entry (pointer, fixed binary (5), fixed binary (35));
	declare hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));
	declare hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2),
				 pointer, fixed binary (35));
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

%include terminate_file;

join:
	string (required_mode) = P_mode;
	P_seg_ptr = null;
	P_bit_count = 0;
	P_code = 0;

	seg_ptr = null;
	created = "0"b;

	if component_name ^= "" & before (reverse (rtrim (P_entryname)), ".") ^= "evihcra"
	then call finish_error (error_table_$not_archive);

	on cleanup call finish_error (0);

	call hcs_$initiate_count (P_dirname, P_entryname, "", bit_count, 0, seg_ptr, code);
	if seg_ptr = null
	then do;
		if ^create_requested
		then call finish_error (code);

		string (effective_mode) = ""b;
		effective_mode = required_mode, by name;

		call hcs_$append_branch (P_dirname, P_entryname, bin (string (effective_mode), 5), create_code);
		string (effective_mode) = ""b;	/* leave for next use */
		if create_code ^= error_table_$namedup
		then code = create_code;		/* report original error if it was a lack of status access */
		else if create_code = 0
		then code = 0;

		if code ^= 0
		then call finish_error (code);

		call hcs_$initiate (P_dirname, P_entryname, "", 0, 0, seg_ptr, code);
		if seg_ptr = null
		then do;
			call hcs_$delentry_file (P_dirname, P_entryname, (0));
			call finish_error (code);
		     end;
		created = "1"b;
	     end;

	call hcs_$fs_get_mode (seg_ptr, effective_mode_bin, code);
	if code ^= 0
	then call finish_error (code);

	string (effective_mode) = bit (effective_mode_bin);

	if component_name = ""
	then if required_mode.read & ^effective_mode.read
	     then call finish_error (error_table_$no_r_permission);

	     else if required_mode.write & ^effective_mode.write
	     then call finish_error (error_table_$no_w_permission);

	     else if required_mode.execute & ^effective_mode.execute
	     then call finish_error (error_table_$no_e_permission);

	     else ;

	else begin;
		declare component_bit_count	 fixed binary (24);
		declare component_ptr	 pointer;

		if ^effective_mode.read
		then call finish_error (error_table_$no_r_permission);

		call archive_$get_component (seg_ptr, bit_count, component_name, component_ptr, component_bit_count,
		     code);
		if code ^= 0
		then call finish_error (code);

		if required_mode.write
		then call finish_error (error_table_$archive_component_modification);

		else if required_mode.execute
		then call finish_error (error_table_$no_e_permission);

		seg_ptr = component_ptr;
		bit_count = component_bit_count;
	     end;

	P_seg_ptr = seg_ptr;
	P_bit_count = bit_count;

	if created
	then P_created = "1"b;			/* only set for created entrypoint */

return:
	return;

finish_error:
     procedure (final_code);

	declare final_code		 fixed binary (35); /* (Input) */

	if ((final_code = error_table_$no_r_permission) | (final_code = error_table_$no_w_permission)
	     | (final_code = error_table_$no_e_permission)) & created
	then final_code = error_table_$no_m_permission;	/* not enough access to create it with proper access */

	P_seg_ptr = null;
	P_bit_count = 0;
	P_code = final_code;

	if seg_ptr ^= null
	then if created
	     then call terminate_file_ (seg_ptr, 0, TERM_FILE_DELETE, 0);
	     else call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, 0);
	else if created
	then call hcs_$delentry_file (P_dirname, P_entryname, 0);

	if final_code ^= 0				/* Zero ONLY in cleanup case */
	then goto return;
     end finish_error;

     end initiate_file_;




		    list.pl1                        03/01/89  1409.2rew 03/01/89  1357.4      922248



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




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-09-04,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to extract the mode on a multisegment file from the mode on
     component 0.
  2) change(89-01-31,TLNguyen), approve(89-01-31,MCR8045),
     audit(89-02-23,RBarstad), install(89-03-01,MR12.3-1018):
     1. Remove trailing white spaces in the pathname that gets printed in the
        error message "Directory empty.".
     2. The returned error message now includes specified invalid control
        argument that a user typed in on the command line.
     3. For the case of no entries matching a starname, list prints out
        "Use of star convention resulted in no match.  STARNAME."
     4. Modify the existing internal procedure "check_for_msf" to return
        correct information of a specified multisegment-file (MSF).
                                                   END HISTORY COMMENTS */


/* list (ls) ... Standard Service System directory-listing command */

/* Completely rewritten by T. Casey, March 1975, replacing the 1969 version by R.C.Daley
   Modified for NSS by T. Casey, January 1976. (Rev 33)
   Modified by T. Casey April 1976 to fix bugs. (Rev 36)
   Modified by T. Casey November 1976 to fix bugs and add ability to give pathnames without -pn. (Rev 37)
   Modified by T. Casey August 1977 to fix bugs in msf access, listing the root, and allow 4 cols for records. (Rev 38)
   Modified by C. Hornig June 1981 to pay attention to link pathname length.
   Modified by M. Pandolf August 1984 to support DM files by special casing MSFs.
   Modified by M. Pandolf September 1984 to support DM file control args.
   Modified by JAFalksen 1984-09-18 to use date_time_$format("^<date> ^<time>",...
   Modified by M. Pandolf October 1984 to let inner ring MSFs be...
   Modified by M. Pandolf November 1984 to die when invoked as an AF.
   Modified by Steve Herbst 11/20/84 to assume -all if no other type args and all nonstarnames.
   Modified by M. Sharpe 2/21/85 to indent addnames by 2 if only names are listed-- bug introduced by the date_time changes
*/

ls:
list:
     procedure options (variable);

/* system_free_area - used by directory listing primitives to return information,
   and by list to allocate the starnames and sort_ix arrays */

dcl  system_free_area area based (system_free_ptr);
dcl  system_free_ptr ptr;

dcl  aloc_ptr (6) ptr;				/* pointers to storage allocated in system_free_area,
						   which must be freed by the cleanup handler */
dcl  ep ptr defined (aloc_ptr (1));
dcl  np ptr defined (aloc_ptr (2));
dcl  msf_ep ptr defined (aloc_ptr (3));
dcl  msf_np ptr defined (aloc_ptr (4));
dcl  starptr ptr defined (aloc_ptr (5));
dcl  sort_index_ptr ptr defined (aloc_ptr (6));

/* Misc. pointers, init (null) */

dcl  lp ptr init (null);				/* link pathname pointer */

/* Misc. fixed bin init (0) */

dcl  (bc, ec, err_opt, first, from_to_date_ix, lc, ni, n_listed, nn, nnames, not_found_count, pathl, records, tpix, tx, dmf_count, dmf_rec_count)
	fixed bin init (0);

/* Misc. fixed bin not initialized */

dcl  (dir_bc, dir_ec, dir_lc, first_br, first_et, first_lk, hdng_index, i, ia, ib, ix, last_br, last_et, last_lk, msf_count, msf_rec_count)
	fixed bin;

dcl msf_bc fixed bin;

/* Variables related to the four entry types: segs, dirs, msfs, and links */

dcl  (
     tcount (0:3),
     trecs (0:3)
     ) fixed bin;					/* tcount holds no. of links,segs,dirs,msfs while
						   trecs contains page totals */
						/* trecs(0) is unused, and is declared only to make
						   tcount(i),trecs(i) legal for i = 0,1,2,3 */
dcl  tsws (0:3) bit (1) aligned;			/* switches saying which types are to be listed */
dcl  (
     linksw defined tsws (0),				/* give a name to each element in the array of switches */
     segsw defined tsws (1),
     dirsw defined tsws (2),
     multisegsw defined tsws (3)
     ) bit (1) aligned;

dcl  type_ix (5) fixed bin static options (constant) init (1, 3, 3, 2, 0);
						/* since the order of entry types in the listing is: */
dcl  LINK fixed bin static options (constant) init (0);	/* segs, msfs, dirs, links */
dcl  SEG fixed bin static options (constant) init (1);	/* the do loop would read do i = 1,3,2,0 */
dcl  DIR fixed bin static options (constant) init (2);	/* which generates messy code */
dcl  MSF fixed bin static options (constant) init (3);	/* so we use this array of entry types instead */

/* switches, init ("1"b) */

dcl  (default_col, default_type, lnsw) bit (1) aligned init ("1"b);

/* switches init ("0"b) - see also the two arrays of switches: tsws(0:3) and colsw(7) */

dcl  (allsw, bfsw, branchsort, branchsw, dtem_arg_sw, excludesw, filesw, fromsw, got_all_branch_info, got_branch_info,
     includesw, length_arg_sw, link_path_arg, matchsw, error_flag, noheadsw, pathsw, pbranchsw, 
     pdmfilesw, pmultisegsw, prisw, read_vtoc_sw,
     real_dtm_sw, real_record_sw, revsw, shortsw, sort_vtoc_sw, sortsw, tosw, totalsw) bit (1) aligned init ("0"b);

dcl  colsw (7) bit (1) aligned;
dcl  dtmsw bit (1) aligned defined (colsw (1));
dcl  dtusw bit (1) aligned defined (colsw (2));
dcl  modesw bit (1) aligned defined (colsw (3));
dcl  recordsw bit (1) aligned defined (colsw (4));
dcl  namesw bit (1) aligned defined (colsw (5));
dcl  countsw bit (1) aligned defined (colsw (6));
dcl  lkpathsw bit (1) aligned defined (colsw (7));

dcl  msf_pass2 bit (1) aligned;

/* Variables used in argument processing */

dcl  argptr ptr;
dcl  (argno, arglen, nargs) fixed bin;
dcl  targ char (arglen) based (argptr);

dcl  ch8 char (8) aligned;				/* place to put short control args, for best
						   comparison code generation (ldaq, cmpaq) */
dcl  ch4 char (4) aligned based (addr (ch8));		/* overlay to get lda, cmpa for
						   arguments of 4 chars or less */

dcl  ch20 char (20) aligned;				/* for args > 8 chars, at least put it in the stack and
						   avoid page faults during comparisons */
dcl  (
     ch12 char (12),
     ch16 char (16)
     ) aligned based (addr (ch20));

dcl  (path, dirname) char (168);

/* Control arguments.  Look them up in arrays, instead of having a separate
   CMPC instruction for each one (there are 74) */

dcl  c4arg (40) char (4) aligned static options (constant) init ("-a",
						/* 1 */
	"-all",					/* 2 */
	"-b",					/* 3 */
	"-bf",					/* 4 */
	"-br",					/* 5 */
	"-d",					/* 6 */
	"-dr",					/* 7 */
	"-dtm",					/* 8 */
	"-dtu",					/* 9 */
	"-f",					/* 10 */
	"-fi",					/* 11 */
	"-l",					/* 12 */
	"-lk",					/* 13 */
	"-lks",					/* 14 */
	"-msf",					/* 15 */
	"-nm",					/* 16 */
	"-p",					/* 17 */
	"-pn",					/* 18 */
	"-pri",					/* 19 */
	"-prn",					/* 20 */
	"-rec",					/* 21 */
	"-rev",					/* 22 */
	"-rv",					/* 23 */
	"-s",					/* 24 */
	"-sh",					/* 25 */
	"-sm",					/* 26 */
						/* new ones - out of order */
	"-ct",					/* 27 */
	"-ex",					/* 28 */
	"-fm",					/* 29 */
	"-md",					/* 30 */
	"-nhe",					/* 31 */
	"-nh",					/* 32 */
	"-sr",					/* 33 */
	"-to",					/* 34 */
	"-tt",					/* 35 */
	"-ft",					/* 36 */
	"-lp",					/* 37 */
	"-dir",					/* 38 */
	"-ln",					/* 39 */
          "-dmf");					/* 40 */

dcl  c8arg (26) char (8) aligned static options (constant) init ("-branch",
						/* 1 */
	"-brief",					/* 2 */
	"-file",					/* 3 */
	"-files",					/* 4 */
	"-link",					/* 5 */
	"-name",					/* 6 */
	"-names",					/* 7 */
	"-primary",				/* 8 */
	"-record",				/* 9 */
	"-records",				/* 10 */
	"-reverse",				/* 11 */
	"-segment",				/* 12 */
	"-short",					/* 13 */
						/* new ones - out of order */
	"-count",					/* 14 */
	"-exclude",				/* 15 */
	"-from",					/* 16 */
	"-match",					/* 17 */
	"-mode",					/* 18 */
	"-sort",					/* 19 */
	"-total",					/* 20 */
	"-totals",				/* 21 */
	"-links",					/* 22 */
	"-first",					/* 23 */
	"-dtcm",					/* 24 */
	"-dtem",					/* 25 */
	"-length");				/* 26 */

dcl  c12arg (5) char (12) aligned static options (constant) init ("-directory",
						/* 1 */
	"-pathname",				/* 2 */
	"-no_header",				/* 3 */
	"-link_path",				/* 4 */
	"-link_paths");				/* 5 */

dcl  c16arg (1) char (16) aligned static options (constant) init ("-date_time_used");
						/* 1 */

dcl  c20arg (2) char (20) aligned static options (constant) init ("-date_time_modified",
						/* 1 */
	"-multisegment_file");			/* 2 */

dcl  c28arg (3) char (28) aligned static options (constant) init ("-date_time_contents_modified",
						/* 1 */
	"-date_time_entry_modified",			/* 2 */
          "-data_management_file");			/* 3 */

/* Variables connected with sort argument processing, and sorting */

dcl  c4key (11) char (4) aligned static options (constant) init (
						/* sort keys */
	"ct",					/* 6 */
	"md",					/* 3 */
	"mode",					/* 3 */
	"name",					/* 5 */
	"nm",					/* 5 */
						/* first 5 are not involved in VTOC-or-directory question */
	"dtm",					/* 1 */
	"dtem",					/* 1 */
	"ln",					/* 4 */
						/* numbers 6, 7, and 8 are directory items */
	"dtu",					/* 2 */
	"dtcm",					/* 1 */
	"rec");					/* 4 */
						/* numbers 9, 10, and 11 are VTOC items */

dcl  c4key_value (11) fixed bin static options (constant) init (6, 3, 3, 5, 5, 1, 1, 4, 2, 1, 4);
dcl  sort_key fixed bin init (0);			/* remember the given sort key as a code number */

dcl  DEFAULT fixed bin static options (constant) init (0);

/* The following named values are used for two purposes:
   1) values of sort_key, to determine which column to sort on;
   2) references to the colsw array, to determine which columns to print (and to set up format strings for).
*/

dcl  DTM fixed bin static options (constant) init (1);
dcl  DTU fixed bin static options (constant) init (2);
dcl  REC fixed bin static options (constant) init (4);
dcl  NAME fixed bin static options (constant) init (5);
dcl  CT fixed bin static options (constant) init (6);

/* This array holds indices of entries. It is allocated large enough to hold indices of all entries in the directory,
   but only the indices of entries selected (by star matching, etc.) for listing are actually placed in it.
   Sorting, if specified by the user, is accomplished by reordering the indices, rather than the entries themselves. */

dcl  sort_ix (dir_ec) fixed bin aligned based (sort_index_ptr);

/* Variables connected with starname argument processing and star matching */

dcl  1 starnames (alloc_len) aligned based (starptr),	/* this structure has one entry per starname */
       2 type fixed bin,				/* see below */
       2 action fixed bin,				/* for possible values of these two variables */
       2 length fixed bin,				/* length in characters of the starname */
       2 matched bit (1) aligned,			/* = "1"b after star matching, if any entries matched this name */
       2 name char (32) unaligned;			/* the starname itself */

dcl  1 stack_starnames (4) like starnames aligned automatic;/* the starnames structure usually overlays this */
dcl  alloc_len fixed bin;				/* but if there are > 4, we allocate enough room for them */
dcl  starname_idx fixed bin;
dcl  all_nonstarred_sw bit (1);

/* Here are the values that starnames.type can have */

dcl  ENTRY_NAME fixed bin static options (constant) init (0);
dcl  DOUBLE_STAR fixed bin static options (constant) init (2);

/* Here are the values that starnames.action can have */

dcl  INCLUDE fixed bin static options (constant) init (10);
dcl  EXCLUDE fixed bin static options (constant) init (11);

dcl  starname_count fixed bin init (0);			/* number of starnames given on command line */

/* Variables used in accessing information returned by the directory listing primitives */

dcl  type bit (2);

dcl  lkpath char (168) based (lp);

dcl  mode char (4);					/* for printing "sma" or "rew" */
dcl  mode_array (3) char (1) unaligned based (addr (mode)); /* for storing mode letters in mode */
dcl  file_mode char (4) static options (constant) init ("rew ");
						/* mode letters for files */
dcl  dir_mode char (4) static options (constant) init ("s ma");
						/* mode letters for directories */
dcl  mode_ptr ptr;					/* points to one of the mode letter strings */
dcl  et_mode (4) char (1) unaligned based (mode_ptr);	/* for picking up mode letters from one of the strings */
dcl  mode_bits (4) bit (1) unaligned;			/* copy of the "rewa" mode bits, from the branch */

/* This should use star_structures.incl.pl1 */

dcl  name (16384) char (32) based (np);			/* name array as returned from star_list */
						/* 16384 is the longest array that could be allocated
						   in system_free_area */

dcl  1 br (dir_ec) based (ep) aligned,			/* branch array */
       2 type bit (2) unaligned,
       2 nname fixed bin (15) unaligned,
       2 nindex fixed bin (17) unaligned,
       2 (dtm, dtu) bit (36) aligned,			/* really bit (36) - all 36 bits are data - no sign bit */
       2 mode unaligned,				/* see explanation in the get_date internal procedure */
         3 (t, r, e, w, a) bit (1) unaligned,
       2 pad bit (6) unaligned,
       2 records fixed bin (24) unaligned;

dcl  1 branch automatic aligned,
       2 type bit (2) unaligned,
       2 nname fixed bin (15) unaligned,
       2 nindex fixed bin (17) unaligned,
       2 (dtm, dtu) bit (36) aligned,			/* really bit (36) - all 36 bits are data - no sign bit */
       2 mode unaligned,				/* see explanation in the get_date internal procedure */
         3 (t, r, e, w, a) bit (1) unaligned,
       2 pad bit (13) unaligned,
       2 records fixed bin (17) unaligned;

dcl  1 et (dir_ec) based (ep) aligned,			/* overlay for br and lk structures, to pick up date and mode */
       2 et_pad1 fixed bin,				/* pick up the dates out of an array, in a do loop */
       2 date (2) bit (36) aligned,			/* really bit 36 ... */
       2 et_pad2 bit (1) unaligned,			/* ignore "t" mode */
       2 mode bit (4) unaligned,			/* "rewa" */
       2 et_pad3 bit (31) unaligned;

dcl  1 lk (dir_ec) based (ep) aligned,			/* link entry array */
       2 type bit (2) unaligned,
       2 nname fixed bin (15) unaligned,
       2 nindex fixed bin (17) unaligned,
       2 (dtm, dtd) bit (36) aligned,			/* really bit 36 ... */
       2 (pln, pnindex) fixed bin (17) unaligned;

/* Variables used in accessing and formatting date information */

dcl  (from_date, to_date) bit (36) aligned;
dcl  fb71 fixed bin (71);
dcl  cdate (2) char (64)var;                               /* hold dtm value (either dtcm or dtem) and dtu value */
dcl  cdtm char (64)var defined (cdate (1));                /* either dtcm value (for -dtcm) or dtem value (for -dtem).
                                                              But not both values because of inconsitency */
dcl  cdtu char (64)var defined (cdate (2));                /* dtu value for -dtu */
     

/* Variables used for formatting and printing output */

dcl  ioa_control_string char (256) varying;		/* used for all ioa_ calls */

/* ioa_ control string values for printing headings */

dcl  1 hdng aligned int static options (constant),	/* pack headings into unaligned strings: 423 chars (106 words) */
       (
       2 lkbfze char (8) init ("Links=0."),		/* The length and offset arrays occupy a total of 44 words. */
       2 smbfze char (7) init ("Segs=0;"),		/* The (single) statement that copies the right heading into */
	  2 drbfze char (7) init ("Dirs=0;"),		/* ioa_control_string generates 10 words of code. */
       2 msbfze char (7) init ("Msfs=0;"),		/* Total: 160 words used by this method. */
						/* An array of char(44) strings would use 242 words (no good). */
	  2 lkbfnz char (9) init ("Links=^d."),		/* Stored as aligned strings (generated for literal constants) */
	  2 smbfnz char (16) init ("Segs=^d,recs=^d;"),	/* the headings would use 111 words. */
       2 drbfnz char (16) init ("Dirs=^d,recs=^d;"),	/* The code to assign the strings as constants would be */
       2 msbfnz char (16) init ("Msfs=^d,recs=^d;"),	/* 7 words per string: 3-word mlr, ldq-stq to set the length */
	  2 lklgze char (12) init ("^/Links = 0."),	/* of the varying string, tra around the other assignments, */
       2 smlgze char (15) init ("^/Segments = 0."),	/* and one word in a transfer vector to get to */
       2 drlgze char (18) init ("^/Directories = 0."),	/* the right assignment. Total: 7*22=154, */
       2 mslgze char (25) init ("^/Multisegment-files = 0."),
						/* plus the 111 words to store the strings, totaling 265 words. */
	  2 lklgnz char (16) init ("^/Links = ^d.^2/"),	/* Saving: 265-160=105 words. */
       2 smlgnz char (33) init ("^/Segments = ^d, Records = ^d.^2/"),
       2 drlgnz char (36) init ("^/Directories = ^d, Records = ^d.^2/"),
       2 mslgnz char (43) init ("^/Multisegment-files = ^d, Records = ^d.^2/"),
       2 smbfxx char (16) init ("Segs=^d,lths=^d;"),
       2 drbfxx char (8) init ("Dirs=^d;"),
       2 msbfxx char (16) init ("Msfs=^d,lths=^d;"),
       2 smlgxx char (33) init ("^/Segments = ^d, Lengths = ^d.^2/"),
       2 drlgxx char (22) init ("^/Directories = ^d.^2/"),
       2 mslgxx char (43) init ("^/Multisegment-files = ^d, Lengths = ^d.^2/")
       ) unaligned;

dcl  hdng_len (0:21) fixed bin unaligned static options (constant)
	init (8, 7, 7, 7, 9, 16, 16, 16, 12, 15, 18, 25, 16, 33, 36, 43, 16, 8, 16, 33, 22, 43);
dcl  hdng_offset (0:21) fixed bin unaligned static options (constant)
	init (1, 9, 16, 23, 30, 39, 55, 71, 87, 99, 114, 132, 157, 173, 206, 242, 285, 301, 309, 325, 358, 380);
						/* 380+43=423 */

dcl  dmf_control_string dim (0:21) char (64) internal static options (constant)
     init ("", "", "", "Dmfs=0;", "", "", "", "Dmfs=^d,recs=^d;",
           "", "", "", "^/Data Management files = 0.", "", "", "", "^/Data Management files = ^d, Records = ^d.^2/",
           "", "", "Dmfs=^d,cis=^d;", "", "", "^/Data Management files = ^d, Control Intervals = ^d.^2/");

/* Variables used in constructing ioa_ format strings */

/* max_day is "1999-12-31  23:59:59.999999 gmt Fri"		       */
/* None of the component values have leading or trailing zeroes, so no       */
/*  matter what kind of space or zero suppression has been called for in a   */
/*  user's default formats, this value will cause a max-length result from   */
/*  date_time_$format.					       */
dcl max_day fixed bin (71) int static options (constant) init (3124137599999999);
dcl date_format char (15) int static options (constant) init ("^<date> ^<time>");
dcl  dt_len fixed bin;
dcl  dt_len_pic pic"99";


dcl  col_fmt (6) char (8) int static options (constant) init (
     	"^2x^__a",				/* dtm */
	"^2x^__a",				/* dtu */
	"^2x^3a",					/* mode */
	"^1x^4d",					/* records */
	"^2x^a",					/* name */
	"^2x(^d)");				/* count */

dcl  col_fmt_ln (6) fixed bin static options (constant) init (7, 7, 6, 6, 5, 7);
dcl  branch_fmt (2) char (35);			/* for files and directories, respectively */
dcl  branch_fmt_ln (2) fixed bin init ((2) 0);
dcl  branch_fmt_ix fixed bin;


dcl  name_indent fixed bin init (0);			/* how far to indent addnames */

dcl  name_fmt (0:2) char (8);				/* name formats for links, files, and dirs, respectively */
dcl  name_fmt_ln (0:2) fixed bin;			/* their lengths */

dcl  link_fmt (2) char (24);				/* two link formats, for singly- and multiply-named links */
dcl  link_fmt_ln (2) fixed bin;			/* their lengths */

/* Variables used in error message printing */

dcl  (
     code,
     (
     error_table_$nomatch,				/* no match error for star name (or entry name) */
     error_table_$bigarg,				/* arg too long */
     error_table_$logical_volume_not_connected,		/* tried to read VTOC but the volume is not available */
     error_table_$logical_volume_not_defined,		/* unavailable for a different reason */
     error_table_$null_dir,				/* Directory is empty */
     error_table_$root,				/* can't list the root as a dir itself */
     error_table_$inconsistent,			/* inconsistent combination of args */
     error_table_$badopt
     ) ext
     ) fixed bin (35);				/* unrecognized option error */

dcl  message char (68) varying;			/* ioa_ control string for com_err_ calls */
dcl  errname char (168) aligned init ("");		/* path name variable for com_err_ calls */

/* External Entries */

dcl  iox_$error_output ext ptr;

dcl  absolute_pathname_ entry (char (*), char(*), fixed bin (35));
dcl  (
     com_err_,
     ioa_,
     ioa_$nnl,
     ioa_$ioa_switch
     ) entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin(35));
dcl  cu_$arg_ptr entry (fixed bin (17), ptr, fixed bin (17), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl  cv_fstime_ entry (bit (36) aligned) returns (fixed bin (71));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
dcl  file_manager_$validate entry (char(*), char(*), fixed bin(35));
dcl  fs_util_$get_user_access_modes entry (char(*), char(*), char(*), fixed bin, bit(36) aligned,
	bit(36) aligned, fixed bin(35));
dcl hcs_$get_user_access_modes entry (char(*), char(*), char(*), fixed bin, bit(36) aligned,
	bit(36) aligned, fixed bin(35));
dcl  hcs_$star_dir_list_
	entry (char (*), char (*) aligned, fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  check_star_name_$entry ext entry (char (*), fixed bin (35));
dcl  match_star_name_ ext entry (char (*), char (*), fixed bin (35));
dcl  convert_date_to_binary_ ext entry (char (*), fixed bin (71), fixed bin (35));

/* Conditions and builtins */

dcl  cleanup condition;

dcl  (addr, bin, bit, convert, divide, fixed, hbound, index, length, mod, null, rtrim, search, string, substr) builtin;

/**/
                                                            /* set variables to initial values to avoid unexpected values */
          msf_bc = 0;
          dirname = "";

	system_free_ptr = get_system_free_area_ ();	/* get pointer to free storage area */

	tcount (1), tcount (2), tcount (3), tcount (0) = 0;
						/* inits of automatic arrays compile inefficiently */
	trecs (1), trecs (2), trecs (3), trecs (0) = 0;
	tsws (1), tsws (2), tsws (3), tsws (0) = "0"b;
	name_fmt_ln (0), name_fmt_ln (1) = 0;
	link_fmt_ln (1), link_fmt_ln (2) = 0;

	colsw (1), colsw (2), colsw (3), colsw (4), colsw (6) = "0"b;
	namesw = "1"b;				/* turn on colsw (5) - the names column is always printed */
	lkpathsw = "1"b;				/* turn on colsw (7) - link paths are printed, by default */

	aloc_ptr (1), aloc_ptr (2), aloc_ptr (3), aloc_ptr (4), aloc_ptr (6) = null;
	starptr = addr (stack_starnames);		/* aloc_ptr (5) starts out pointing at a small stack array */

/* All allocation pointers must be initialized or nulled before we establish the cleanup handler */

	on condition (cleanup) call cleanup_proc;

	call cu_$arg_count (nargs, code);		/* pick up command argument count */
	if code ^= 0 then do;
	     call com_err_ (code, "list");
	     return;                                      /* quit */
	     end;
	do argno = 1 to nargs;			/* begin option processing loop */
	     call get_arg_ptr;			/* call cu_$arg_ptr to pick up next argument */
	     if arglen = 0 then go to endopt;		/* ignore null strings */
	     if substr (targ, 1, 1) = "-" then do;	/* check for control argument */
ctl_arg:
		if arglen > 8 then goto arglong;	/* arg <= 8 chars gets special treatment */
		ch8 = targ;			/* copy into double-word-aligned string */
		if arglen > 4 then goto argl8;	/* go compare using ldaq, cmpaq */
						/* else fall thru and compare using lda, cmpa */
		do i = 1 to hbound (c4arg, 1);
		     if ch4 = c4arg (i) then goto c4lab (i);
		end;
		goto badopt;			/* if no match */

argl8:
		do i = 1 to hbound (c8arg, 1);
		     if ch8 = c8arg (i) then goto c8lab (i);
		end;
		goto badopt;

arglong:
		if arglen > 20 then goto arglong2;
		ch20 = targ;			/* at least avoid page faults during comparisons */

		if arglen <= 12 then do;
		     do i = 1 to hbound (c12lab, 1);
			if ch12 = c12arg (i) then goto c12lab (i);
		     end;
		     goto badopt;
		     end;

/* for the 5 arguments longer than 12 characters, individual cmpb's occupy less space than do loops would */

		if ch20 = c20arg (1) then goto c20lab1;
		if ch20 = c20arg (2) then goto c20lab2;
		if ch16 = c16arg (1) then goto c16lab1;
		goto badopt;

arglong2:
		if targ = c28arg (1) then goto c28lab1;
		if targ = c28arg (2) then goto c28lab2;
		goto badopt;


/* Set switches as specified by control arguments */


c4lab (1):					/* -a */
c4lab (2):					/* -all */
		pbranchsw, allsw, segsw, dirsw, multisegsw, pmultisegsw, pdmfilesw, linksw = "1"b;
reset_default_type:
		default_type = "0"b;
		goto endopt;

c4lab (3):					/* -b */
c4lab (5):					/* -br */
c8lab (1):					/* -branch */
		branchsw, pbranchsw, segsw, dirsw, multisegsw, pmultisegsw, pdmfilesw = "1"b;
		goto reset_default_type;

c4lab (4):					/* -bf */
c8lab (2):					/* -brief */
		bfsw = "1"b;
		lkpathsw = "0"b;			/* -brief suppresses link pathnames */
reset_default_col:
		default_col = "0"b;
		goto endopt;

c4lab (27):					/* -ct */
c8lab (14):					/* -count */
		countsw = "1"b;
		goto endopt;

c4lab (6):					/* -d */
c4lab (7):					/* -dr */
c4lab (38):					/* -dir */
c12lab (1):					/* -directory */
		dirsw, pbranchsw = "1"b;
		goto reset_default_type;

c4lab (40):					/* -dmf */
c28lab3:						/* -data_management_file */
		pdmfilesw, multisegsw, pbranchsw = "1"b;
		goto reset_default_type;

c8lab (24):					/* -dtcm */
c28lab1:						/* -date_time_contents_modified */
		if dtem_arg_sw then goto vtoc_conflict;
		real_dtm_sw, read_vtoc_sw = "1"b;
		goto set_dtm_sw;

c8lab (25):					/* -dtem */
c28lab2:						/* -date_time_entry_modified */
c4lab (8):					/* -dtm */
c20lab1:						/* -date_time_modified */
		if real_dtm_sw then goto vtoc_conflict;
		dtem_arg_sw = "1"b;
set_dtm_sw:
		dtmsw = "1"b;
		lnsw = "0"b;
		goto endopt;

c4lab (9):					/* -dtu */
c16lab1:						/* -date_time_used */
		dtusw = "1"b;
		read_vtoc_sw = "1"b;
		lnsw = "0"b;
		goto endopt;

c4lab (28):					/* -ex */
c8lab (15):					/* -exclude */
		argno = argno + 1;
		call get_arg_ptr;
		call get_starname;
		starnames (starname_count).action = EXCLUDE;
						/* remember to exclude entries that match this one */
		excludesw = "1"b;
		goto endopt;

c4lab (10):					/* -f */
c4lab (11):					/* -fi */
c8lab (3):					/* -file */
c8lab (4):					/* -files */
		filesw, segsw, multisegsw, pmultisegsw, pdmfilesw, pbranchsw = "1"b;
		goto reset_default_type;

c4lab (36):					/* -ft */
c8lab (23):					/* -first */
		argno = argno + 1;			/* get next arg, which must be decimal number */
		call get_arg_ptr;			/* if none there, get_arg_ptr calls com_err_ */
		first = cv_dec_check_ (targ, code);
		if code ^= 0 then do;		/* bad char in decimal arg */
		     code = 0;			/* not error_table_ code - com_err_ dislikes it */
		     call com_err_ (code, "list", "Illegal character in decimal argument: ^a.", targ);

		     err_opt = err_opt + 1;             /* indicate that errors in options */
		     end;
		goto endopt;

c4lab (15):					/* -msf */
c20lab2:						/* -multisegment_file */
		multisegsw, pmultisegsw, pbranchsw = "1"b;
		goto reset_default_type;

c4lab (29):					/* -fm */
c8lab (16):					/* -from */
		fromsw = "1"b;
		call get_date (from_date, "from");	/* internal procedure used by -from and -to */
		goto endopt;

c4lab (39):					/* -ln */
c8lab (26):					/* -length */
		if real_record_sw then goto vtoc_conflict;
		length_arg_sw, recordsw = "1"b;
		lnsw = "0"b;
		goto reset_default_col;

c4lab (14):					/* -lks */
		shortsw = "1"b;			/* fall thru to set link switch */

c4lab (12):					/* -l */
c4lab (13):					/* -lk */
c8lab (5):					/* -link */
c8lab (22):					/* -links */
		linksw = "1"b;
		goto reset_default_type;

c4lab (37):					/* -lp */
c12lab (4):					/* -link_path */
c12lab (5):					/* -link_paths */
		link_path_arg = "1"b;
		goto endopt;

c8lab (17):					/* -match */
		matchsw = "1"b;
		goto endopt;

c4lab (30):					/* -md */
c8lab (18):					/* -mode */
		modesw = "1"b;
		lnsw = "0"b;
		goto reset_default_col;

c4lab (16):					/* -nm */
c8lab (6):					/* -name */
c8lab (7):					/* -names */
		namesw = "1"b;
		goto reset_default_col;

c4lab (31):					/* -nh */
c4lab (32):					/* -nhe */
c12lab (3):					/* -no_header */
		noheadsw = "1"b;
		goto endopt;

c4lab (17):					/* -p */
c4lab (18):					/* -pn */
c12lab (2):					/* -pathname */
		argno = argno + 1;			/* next arg is the directory pathname */
		call get_arg_ptr;			/* get ptr to it */
		dirname = targ;			/* copy it into temp */
		if pathsw
		then				/* if a directory path already given */
		     if path ^= dirname then do;	/* and this one is different */
two_pn_error:
			code = 0;			/* complain */
			call com_err_ (code, "list", "More than one directory specified: ^a and ^a.",
			     rtrim (path), rtrim (dirname));		/* print the earlier pathname too */

			err_opt = err_opt + 1;        /* indicate that errors in options */
			goto endopt;
			end;
		path = dirname;			/* save directory path */
		path = targ;			/* copy it into char (168) */
		pathl = arglen;			/* remember its actual length */
		pathsw = "1"b;			/* remember to print it if not found or null dir errors occur */
		goto endopt;

c4lab (20):					/* -prn */
		countsw = "1"b;			/* fall thru to set primary switch */

c4lab (19):					/* -pri */
c8lab (8):					/* -primary */
		prisw = "1"b;
		goto endopt;

c4lab (21):					/* -rec */
c8lab (9):					/* -record */
c8lab (10):					/* -records */
		if length_arg_sw then goto vtoc_conflict;
		recordsw = "1"b;
		real_record_sw, read_vtoc_sw = "1"b;
		lnsw = "0"b;
		goto reset_default_col;

c4lab (22):					/* -rev */
c4lab (23):					/* -rv */
c8lab (11):					/* -reverse */
		revsw = "1"b;
		goto endopt;

c4lab (24):					/* -s */
c4lab (26):					/* -sm */
c8lab (12):					/* -segment */
		segsw, pbranchsw = "1"b;
		goto reset_default_type;

c4lab (25):					/* -sh */
c8lab (13):					/* -short */
		shortsw = "1"b;
		goto endopt;

c4lab (33):					/* -sr */
c8lab (19):					/* -sort */
		sortsw = "1"b;
		argno = argno + 1;			/* look at next arg, which MIGHT be a sort key */
		if argno > nargs then goto endopt;	/* but only if there is a next arg */
		call get_arg_ptr;
		if substr (targ, 1, 1) = "-" then goto ctl_arg;
						/* not sort key */
		if arglen <= 4 then do;		/* look up short keys in array, for efficiency */
		     ch4 = targ;			/* copy it into stack var */
		     do i = 1 to hbound (c4key, 1) while (ch4 ^= c4key (i));
		     end;
		     if i = 1 + hbound (c4key, 1) then goto star_arg;
						/* not sort key - must be starname */
		     sort_key = c4key_value (i);	/* remember the sort key number corresponding to this key */

		     if i > 5
		     then				/* this is a VTOC-or-directory item */
			goto sort_lab (i - 5);	/* check consistency and set switches */
		     goto endopt;

sort_lab (1):					/* dtm */
sort_lab (2):					/* dtem */
		     if real_dtm_sw then goto vtoc_conflict;
		     dtem_arg_sw = "1"b;
		     goto endopt;

sort_lab (3):					/* ln */
		     if real_record_sw then goto vtoc_conflict;
		     length_arg_sw = "1"b;
		     goto endopt;

sort_lab (4):					/* dtu */
		     read_vtoc_sw, sort_vtoc_sw = "1"b;
		     goto endopt;

sort_lab (5):					/* dtcm */
		     if dtem_arg_sw then goto vtoc_conflict;
		     real_dtm_sw = "1"b;
		     goto sort_lab (4);

sort_lab (6):					/* rec */
		     if length_arg_sw then goto vtoc_conflict;
		     real_record_sw = "1"b;
		     goto sort_lab (4);

		     end;

		else if arglen <= 20 then do;		/* arg longer than 4 chars */
			ch20 = targ;		/* copy into 20-char stack variable */
			if ch20 = "date_time_modified" then do;
			     sort_key = DTM;
			     goto sort_lab (1);
			     end;
			else if ch20 = "date_time_used" then do;
				sort_key = DTU;
				goto sort_lab (4);
				end;
			     else if substr (ch20, 1, 6) = "record" then do;
						/* match "record" or "records" */
				     sort_key = REC;
				     goto sort_lab (6);
				     end;
				else if ch20 = "length" then do;
					sort_key = REC;
					goto sort_lab (3);
					end;
				     else if ch20 = "count"
					then sort_key = CT;
					else if ch20 = "names"
					     then sort_key = NAME;
					     else goto star_arg;
						/* not sort key - must be starname */
			end;			/* end of <= 20 char do group */

		     else if arglen <= 28 then do;
			     if targ = "date_time_contents_modified" then do;
				sort_key = DTM;
				goto sort_lab (5);
				end;
			     else if targ = "date_time_entry_modified" then do;
				     sort_key = DTM;
				     goto sort_lab (1);
				     end;
				else goto star_arg;
			     end;

			else goto star_arg;		/* too long to be sort key - must be starname */

		goto endopt;			/* exit after picking up sort key and falling thru to here */

c4lab (34):					/* -to */
		tosw = "1"b;
		call get_date (to_date, "to");	/* share code with -from */
		goto endopt;

c4lab (35):					/* -tt */
c8lab (20):					/* -total */
c8lab (21):					/* -totals */
		totalsw = "1"b;
		goto endopt;

/* Come here for inconsistent arguments: VTOC and directory */

vtoc_conflict:
		code = error_table_$inconsistent;
		call com_err_ (code, "list", "^a and a previous sort or column argument.", targ);

		err_opt = err_opt + 1;                  /* indicate errors in options. */
		goto endopt;

/* Come here for unrecognized control args */

badopt:
		code = error_table_$badopt;		/* unrecognized control argument */
badarg:
		call com_err_ (code, "list", "^a", targ);

		err_opt = err_opt + 1;		/* indicate errors in options */
		end;

	     else do;				/* arg does not begin with "-" so it must be a starname */
star_arg:
		call get_starname;			/* internal procedure */
		if starnames (starname_count).action = 0 then do;
						/* unless it was set by get_starname */
		     starnames (starname_count).action = INCLUDE;
						/* starname not preceeded by one of the special */
		     includesw = "1"b;		/* control args gets matching entries included in the listing */
		     end;
		end;

endopt:
	end;					/* end of option handling section */

	if err_opt ^= 0				/* If errors in options, leave now */
	then go to error_return;

/* If no errors, set up for processing: examine results of argument processing, set some defaults,
   go get information out of directory, and then set up ioa_ control strings needed to print it */

	if default_type then do;			/* if no entry type arguments were given */

	     if starname_count > 0 then do;		/* check if all specified names are non-starnames */
		all_nonstarred_sw = "1"b;
		do starname_idx = 1 to starname_count while (all_nonstarred_sw);
		     call check_star_name_$entry (starnames.name (starname_idx), code);
		     if code ^= 0 then all_nonstarred_sw = "0"b;
		end;
	     end;
	     else all_nonstarred_sw = "0"b;

	     if all_nonstarred_sw then		/* enforce -all in this case */
		pbranchsw, allsw, segsw, dirsw, multisegsw, pmultisegsw, pdmfilesw, linksw = "1"b;
	     else filesw, segsw, multisegsw, pmultisegsw, pdmfilesw, pbranchsw = "1"b; /* the default is -file */
	end;

	if default_col then do;			/* if no arguments were given to override the default columns */
	     namesw, modesw, recordsw = "1"b;		/* default is names, mode, and records */
	     lnsw = "0"b;
	     end;

	if sortsw then do;				/* if -sort was given */
	     if sort_key = DEFAULT then do;		/* but not followed by a keyword */
		if dtmsw then do;			/* if dtm being printed */
		     sort_key = DTM;		/* then sort on it */
		     if real_dtm_sw then sort_vtoc_sw = "1"b;
						/* remember to read VTOCs before sorting */
		     end;
		else if dtusw then do;		/* otherwise if dtu is being printed */
			sort_key = DTU;		/* then sort on it */
			sort_vtoc_sw = "1"b;
			end;
		     else sort_key = NAME;		/* otherwise sort on primary names */
		end;

	     if linksw
	     then					/* if printing links */
		if sort_key < NAME
		then				/* and sorting on something that only a branch has */
		     if sort_key > DTM
		     then				/* we don't want to sort links on garbage */
			branchsort = "1"b;		/* so remember to sort only branches */
	     end;

	if fromsw | tosw then do;			/* figure out which date to use for from-to comparisons */
	     if dtmsw | sort_key = DTM
	     then					/* if dtm being printed or sorted on */
		from_to_date_ix = DTM;		/* use it for from-to comparison */
	     else if dtusw | sort_key = DTU
		then				/* otherwise, if dtu being printed or sorted on */
		     from_to_date_ix = DTU;		/* use that for from-to comparison */
		else				/* but if neither date being printed or sorted on */
		     from_to_date_ix = DTM;		/* use dtm for from-to comparison */
	     end;

	if fromsw
	then if tosw
	     then					/* if both given */
		if from_date >= to_date then do;	/* from must be before to */
		     call com_err_ (error_table_$inconsistent, "list", "from-date must be BEFORE to-date.");
		     goto error_return;                 /* call cleanup_proc internal procedure and quit */
		     end;

	if lnsw
	then					/* if printing only names (like old ln command) */
	     lkpathsw = "0"b;			/* then don't print link pathnames */
						/* (-brief also suppresses linkpaths; that is checked above) */

	if link_path_arg
	then					/* but if -link_path given */
	     lkpathsw = "1"b;			/* print link paths no matter what else */

/* All the information related to selection of entries to be printed has now been analyzed.
   Go get the information out of the directory now, so that, knowing what we do and
   do not have to print, we can omit construction of unneeded format strings. */

	call get_list;				/* internal procedure, for historical reasons;
						   also to make the main procedure shorter and more readable */

	if error_flag
	then					/* if get_list returned nothing, and told user why */
	     goto error_return;			/* don't rub it in with lots of "<thing>s = 0" messages */

/* Set up ioa_ format strings for printing branch information, link information, and secondary names.
   All of these formats are a function of which columns the user wants printed, and what was found in the directory. */

	if ^totalsw then do;			/* don't waste time if only totals being printed */
	     if dtmsw | dtusw
	     then dt_len = length (date_time_$format (date_format, max_day, "", ""));
	     else dt_len = 1;


/* Set up branch format */

	     if pbranchsw & bc > 0 then do;		/* only if at least one branch type is to be printed */

		call set_branch_fmt (1);		/* set up format string for files */

		if dirsw
		then				/* if listing directories */
		     if recordsw
		     then				/* and printing the records column */
			if ^real_record_sw then do;	/* but not real records */
			     recordsw = ""b;	/* turn off the records column switch */
			     call set_branch_fmt (2); /* and build a format string without the records column */
			     recordsw = "1"b;	/* and turn it back on again */
			     end;			/* but don't bother if the file format will be ok for dirs */

		end;

/* Set up link format. The possible items to be printed are:
   dtm, name, count, and linkpath. In addition, the presence or absence
   of the -short argument determines how linkpath is lined up. We must build
   two format strings (only when both linkpaths and counts are being printed),
   to be used for singly- and multiply-named links, since count is not printed
   when it is = 1. We did not have to do this for branches, because count is the
   last column, for branches, and we just chop the format item for count off
   the end of (a copy of) the format string, when count = 1. */

	     if linksw & lc > 0 then do;		/* only if links are to be printed */

		if dtmsw then do;			/* if dtm to be printed for links */
		     link_fmt (1) = "^__a^2x";
		     substr (link_fmt (1), 2, 2) = convert (dt_len_pic, dt_len);
		     link_fmt_ln (1) = 7;
		     end;
		else do;
		     link_fmt (1) = "^s";
		     link_fmt_ln (1) = 2;
		     end;

		if ^lkpathsw
		then				/* if not printing linkpaths */
		     goto lkshort1;			/* then don't bother with the long format */
		if shortsw then do;
lkshort1:
		     substr (link_fmt (1), link_fmt_ln (1) + 1) = "^a";
						/* save printing time by not padding names to 32 char */
		     link_fmt_ln (1) = link_fmt_ln (1) + 2;
		     end;
		else do;
		     substr (link_fmt (1), link_fmt_ln (1) + 1) = "^32a";
						/* pad names, to line up link paths */
		     link_fmt_ln (1) = link_fmt_ln (1) + 4;
		     end;

		if countsw then do;			/* if printing counts, we have to have two format strings */
		     link_fmt (2) = link_fmt (1);	/* the second one is for when there are no secondary names */
		     link_fmt_ln (2) = link_fmt_ln (1); /* its left half is just like the first one */

		     if ^lkpathsw
		     then				/* if linkpaths not to be printed */
			goto lkshort2;		/* don't pad count to constant length */
		     if shortsw then do;		/* if -short given */
lkshort2:						/* also don't pad count to constant length */
			substr (link_fmt (1), link_fmt_ln (1) + 1) = "^2x(^d)";
			link_fmt_ln (1) = link_fmt_ln (1) + 7;
			end;
		     else do;			/* pad count to constant length, to keep linkpaths lined up */
			substr (link_fmt (1), link_fmt_ln (1) + 1) = "^2x(^3d)";
			link_fmt_ln (1) = link_fmt_ln (1) + 8;
			end;

		     if lkpathsw then do;		/* if lkpaths to be printed, put a ^s in the second format,
						   preceeding the ^a for the linkpath */
			if shortsw
			then			/* if -short, don't bother lining things up */
			     substr (link_fmt (2), link_fmt_ln (2) + 1) = "^2x^s";
			else			/* otherwise, line up linkpaths */
			     substr (link_fmt (2), link_fmt_ln (2) + 1) = "^9x^s";
			link_fmt_ln (2) = link_fmt_ln (2) + 5;
						/* in either case, 5 chars were added to the format string */
			end;
		     end;				/* end of if countsw do group */

		if lkpathsw then do;		/* if linkpaths to be printed, set up their formats */
		     if countsw then do;		/* if counts being printed, there is a second format string */
			substr (link_fmt (2), link_fmt_ln (2) + 1) = "^a";
						/* so put format for linkpaths into it */
			link_fmt_ln (2) = link_fmt_ln (2) + 2;
			end;
		     else do;			/* but if counts not being printed */
			substr (link_fmt (1), link_fmt_ln (1) + 1) = "^s";
						/* skip over the count argument */
			link_fmt_ln (1) = link_fmt_ln (1) + 2;
						/* in the first (and only) string */
			end;

		     substr (link_fmt (1), link_fmt_ln (1) + 1) = "^2x^a";
						/* in either case, */
		     link_fmt_ln (1) = link_fmt_ln (1) + 5;
						/* put the link path format into the first string */
		     end;				/* end of if lkpathsw do group */

/* Set up format for secondary names of links */

		if ^prisw then do;			/* only if they will be printed */
		     if dtmsw then do;		/* if dtm being printed */
			name_fmt (0) = "^18x^a";	/* indent secondary names 18 spaces */
			name_fmt_ln (0) = 6;
			end;
		     else do;
			name_fmt (0) = "^2x^a";	/* otherwise, indent 2 spaces, just for readability */
			name_fmt_ln (0) = 5;
			end;
		     end;				/* end of if ^prisw do group */
		end;				/* end of if linksw do group */
	     end;					/* end of if ^totalsw do group */

/* End of setting up of formats */

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


/* Make adjustments for MSF/DMF ambiguity */

	msf_count = tcount (MSF) - dmf_count;
	tcount (MSF) = msf_count;
	msf_rec_count = trecs (MSF) + dmf_rec_count;
	trecs (MSF) = msf_rec_count;

/* Finished setting up. Now start printing the stuff */

	if totalsw then do;				/* if only totals being printed */
	     if noheadsw
	     then goto brief_totals;			/* inconsistent - but why quibble? */
	     else if bfsw
		then				/* this is the correct way to say it */
brief_totals:
		     do;				/* ls -tt -bf gets a very brief (one line) answer */
			do tx = 1 to 5;

			     msf_pass2 = (tx=3);
			     if msf_pass2 then do;
				tcount (MSF) = dmf_count;
				trecs (MSF) = dmf_rec_count;
				end;

			     tpix = type_ix (tx);	/* segs, dirs, msfs, links */
			     if tsws (tpix) then do;	/* if user wants info on this entry type */
				if tcount (tpix) = 0
				then hdng_index = tpix;
						/* "<entry type>=0;" */
				else do;
				     hdng_index = tpix + 4;
						/* "<entry type>=^d,recs=^d;" */
				     if ^real_record_sw
				     then		/* if printing lengths rather than records */
					if hdng_index >= 5
					then	/* and this is a branch (5, 6, or 7) */
					     hdng_index = hdng_index + 11;
						/* use one of the "lths=" headings (16, 17, or 18) */
						/* but note that 17 is just "Dirs=^d;" */
				     end;
				call print_heading;
				end;		/* end this type wanted do group */
			end;			/* end do loop on tpix */
			ioa_control_string = "";
			call print_message;		/* put newline onto end of brief total line */
			goto return;		/* all done */
		     end brief_totals;
		else goto start_list;		/* go print normal totals */
	     end;

	else if (noheadsw				/* if headers are not to be printed */
		| default_type) then do;		/* or if user did not specify type */
						/* make sure we are going to print some entries,
						   rather than nothing, or "<thing>s = 0" */
		do i = 0 to 3;
		     if tsws (i)
		     then				/* if user wants info on this type */
			if tcount (i) > 0
			then			/* and there are entries of this type */
			     goto start_list;	/* then something will be printed */
		end;
		if dmf_count > 0			/* special case DMFs here */
		then goto start_list;

		if default_type
		then				/* if user did not say "ls -<entry type>" */
		     tsws (0), tsws (1), tsws (2), tsws (3) = "1"b;
						/* simulate "ls -tt -a -bf" */
		goto brief_totals;			/* we were about to print nothing, or "<thing>s = 0" */
		end;

start_list:
	if branchsw then do;
	     if bc = 0 then do;
		ioa_control_string = "^/Branches = 0.";
		call print_message;
		end;
	     end;
	else if filesw then do;
		if tcount (SEG) + tcount (MSF) + dmf_count = 0 then do;
		     ioa_control_string = "^/Files = 0.";
		     call print_message;
		     end;
		end;

/* Readjust MSF count for next loop */

	tcount (MSF) = msf_count;
	trecs (MSF) = msf_rec_count;

/* Start outer loop on entry types */

type_loop:
	do tx = 1 to 5;
	     msf_pass2 = (tx=3);			/* second msf pass is for DMFs */
	     tpix = type_ix (tx);			/* list segs, msfs, dirs, and links, in that order */
	     if ^tsws (tpix) then goto end_type_loop;	/* if user does not want this entry type listed */
	     if tpix = MSF
	     then if msf_pass2
		then if ^pdmfilesw
		     then goto end_type_loop;
		     else;
		else if ^pmultisegsw
		     then goto end_type_loop;
		     else;
	     else;

	     type = bit (fixed (tpix, 2));

	     if msf_pass2 then do;
		tcount (MSF) = dmf_count;
		trecs (MSF) = dmf_rec_count;
		end;

	     if noheadsw then goto no_heading;
	     if tcount (tpix) = 0 then do;
		if allsw then goto no_heading;	/* don't print ...=0 when -all given */
		if tpix > 0 then do;		/* branches */
		     if branchsw then goto no_heading;	/* don't print ...=0 when -branch given */
		     if tpix ^= DIR
		     then				/* if not directories */
			if filesw then goto no_heading;
						/* don't print ...=0 when -files given */
		     end;				/* end branches */
		hdng_index = tpix + 8;		/* "^/<entry type> = 0." */
		call print_heading;
		end;				/* end count = 0 do group */

	     else do;				/* count ^= 0 */
		hdng_index = tpix + 12;		/* "^/<entry type> = ^d, Records = ^d.^2/" */
		if ^real_record_sw |		/* if printing lengths rather than records, or */
		     first > 0
		then				/* if just reading VTOCs of first N entries */
		     if hdng_index >= 13
		     then				/* and this is a branch (13, 14, or 15) */
			hdng_index = hdng_index + 6;	/* use the "Lengths =" headings (19, 20, or 21) */
						/* but note that 20 is just "Directories = ^d." */
		call print_heading;
		end;				/* end count ^= 0 */

no_heading:					/* come here to skip printing of heading */
						/* Decide whether we have to go through the entries, on this pass. */
	     if totalsw then goto end_type_loop;	/* if -totals given, don't print entries */

	     if tcount (tpix) = 0 then goto end_type_loop;/* if no entries of this type,
						   skip the inner loop to save time */

/* We will go through all the entries. Initialize for it. */

	     if branchsort then do;			/* if we sorted only on branches */
		if tpix = LINK then do;		/* links got put at the other end of the array */
		     first_et = first_lk;		/* so pick up indices of where they are */
		     last_et = last_lk;
		     end;
		else do;				/* this is a branch */
		     first_et = first_br;		/* pick up branch indices */
		     last_et = last_br;
		     end;
		end;				/* first_et and last_et are already set,
						   unless we sorted by branch only */

	     n_listed = 0;				/* this makes "-first N" list first N of each type */

/* Start inner loop on entries. Only those of the type specified in the outer loop will be listed. */

list_entries:
	     do i = first_et to last_et;
		ix = sort_ix (i);			/* pick up index of entry to be listed in position "i" */

		if br (ix).type ^= type
		then				/* if this entry is not the type we are listing now */
		     goto end_list_entries;		/* skip it */

		if tpix = MSF
		then if msf_pass2
		     then				/* we are reporting DMFs */
			if br (ix).records >= 0	/* so skip MSFs */
			then
			     goto  end_list_entries;
			else br (ix).records = -br (ix).records;
		     else				/* we are reporting MSFs */
			if br (ix).records < 0	/* so skip DMFs */
			then
			     goto end_list_entries;
			else;
		else;

		if first > 0
		then				/* if -first given */
		     if n_listed >= first
		     then				/* and we have already printed the first N of this type */
			goto end_type_loop;		/* get out of inner loop and start on next type */
		     else n_listed = n_listed + 1;

		ni = br (ix).nindex;		/* get index to start of name array for this entry */
		nnames = br (ix).nname;		/* pick up count of names for this entry */
		nn = ni + nnames - 1;		/* compute index of last name for this entry */

		if lnsw then do;			/* if listing nothing but names, special-case it */
		     if countsw
		     then				/* but if printing counts */
			if nnames > 1
			then			/* and count is nonzero */
			     goto not_just_names;	/* we can't special-case it */
		     ioa_control_string = "^a";
		     call print_name;
		     branch_fmt_ix = 1;		/* to select format for additional names */
		     goto additional_names;
		     end;

not_just_names:					/* Format date(s) for both branches and links, if they are to be printed */
		ia = 1;				/* dtm is valid for branches and links */
		if tpix ^= LINK then do;
		     ia = 2;			/* dtu is valid only for branches */
		     if read_vtoc_sw
		     then				/* if we have to read the VTOC */
			if ^got_all_branch_info
			then			/* and we did not do it in get_list */
			     if tpix ^= MSF
			     then			/* (which we definitely did for an MSF) */
				call get_branch_info (ix);
						/* do it now */
		     end;

		do ib = 1 to ia;
		     if colsw (ib)
		     then                               /* if this date is to be printed */
			cdate (ib) = date_time_$format (date_format, cv_fstime_ (et (ix).date (ib)), "", "");
		end;

/* If this is a branch, print branch info */

		if tpix ^= LINK then do;

		     if modesw then do;		/* if printing modes, format them */
			if (type = "10"b) & (msf_bc = 0)
			then			/* if directory */
			     mode_ptr = addr (dir_mode);
						/* use "sma" */
			else mode_ptr = addr (file_mode);
						/* else use "rew" */
			mode = "";		/* blank out the mode string */
			ia, ib = 1;		/* input, output indices start at 1 */
			string (mode_bits) = et (ix).mode;
						/* copy mode bits into word in stack */

mode_loop:
			if mode_bits (ia)
			then			/* if entry has this mode */
			     mode_array (ib) = et_mode (ia);
						/* put its character into the string */
next_col:
			ib = ib + 1;		/* move output column index */
			if ib = 4 then goto end_mode_loop;
						/* done, if we filled in 3 cols */
next_bit:
			ia = ia + 1;		/* move input bit index */
			if ia = 2 then do;		/* if bit 2 (e) */
			     if type = "10"b
			     then			/* if directory, e mode is not used */
				goto next_bit;	/* skip bit but not column */
			     end;
			goto mode_loop;		/* go back for next one */
end_mode_loop:
			end;

		     if recordsw
		     then				/* if records to be printed */
			records = br (ix).records;	/* pick up record count */

/* Pick up the format string for branches, built above. If printing counts,
   but this branch has only one name, chop the trailing "^2x(^d)" off the format,
   to avoid printing "(1)" after the primary name */

		     branch_fmt_ix = 1;		/* use the format string for files */
		     if tpix = DIR
		     then				/* unless this is a directory */
			if recordsw
			then			/* and the records column is in the file format string */
			     if ^real_record_sw
			     then			/* but real records are not being printed */
				branch_fmt_ix = 2;	/* then use format string that omits records column for dirs */

		     ia = branch_fmt_ln (branch_fmt_ix);/* don't chop off anything, by default */
		     if countsw
		     then				/* if printing counts */
			if nnames = 1
			then			/* but count = 1 */
			     ia = ia - 7;		/* chop off last 7 chars of format */

		     ioa_control_string = substr (branch_fmt (branch_fmt_ix), 1, ia);

		     call print_branch;		/* now go print the selected branch information */
		     end;				/* end of list branch information */

/* Otherwise it is a link, so print link info */

		else do;
		     if lkpathsw
		     then				/* if printing linkpaths */
			lp = addr (name (lk (ix).pnindex));
						/* get pointer to link pathname */

/* Pick up the format string for links. Choose one of the two that were built above,
   depending on whether name count is being printed, and how many names the link has */

		     ia = 1;			/* use the first format string */
		     if countsw
		     then				/* except when printing counts */
			if nnames = 1
			then			/* and the count = 1 */
			     ia = 2;		/* when the second format string must be used */
		     ioa_control_string = substr (link_fmt (ia), 1, link_fmt_ln (ia));

		     call ioa_ (ioa_control_string, cdtm, name (ni), nnames, substr (lkpath, 1, lk (ix).pln));
		     end;				/* end list link info */

additional_names:					/* do we want to print additional names ? */
		if ^prisw
		then				/* if user wants to see them */
		     if nnames > 1 then do;		/* and there are some, print them */

/* Pick up the name format constructed above */

			if tpix = LINK
			then			/* if this is a link */
			     ia = 0;		/* then use format (0) */
			else ia = branch_fmt_ix;	/* else use format (1) or format (2) */
			ioa_control_string = substr (name_fmt (ia), 1, name_fmt_ln (ia));
			do ni = (ni + 1) to nn;	/* ni is index of primary name, set above */
			     call print_name;
			end;
			end;

end_list_entries:
	     end list_entries;			/* end inner loop (on i) over all entries */

end_type_loop:
	end type_loop;				/* end outer loop (on tx) over the 4 entry types */

return:
	if ^totalsw
	then					/* if we printed some entries (not just totals) */
	     if ^noheadsw then do;			/* and user did not say -no_header */
		ioa_control_string = "";		/* print an extra blank line at the end */
		call print_message;
		end;

error_return:
	call cleanup_proc;				/* go free any allocated storage */

	return;					/* return to caller */

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


/* INTERNAL PROCEDURES, IN ALPHABETIC ORDER */
%page;

cleanup_proc:
     proc;					/* Cleanup handler */
dcl  dummy based;
dcl  i fixed bin;

	do i = 1 to hbound (aloc_ptr, 1);
	     if aloc_ptr (i) ^= null
	     then if aloc_ptr (i) ^= addr (stack_starnames) then free aloc_ptr (i) -> dummy in (system_free_area);
	end;

     end cleanup_proc;

/* ****************************************************************************************************************** */
%page;

get_arg_ptr:
     proc;					/* replaces 7 cu_$arg_ptr calls (105 words) */

	if argno > 1
	then					/* if there was a previous argument */
	     errname = targ;			/* save it for possible error message */

	call cu_$arg_ptr (argno, argptr, arglen, code);
	if code ^= 0 then do;			/* it can only be "expected argument missing" */
	     if argno > 1
	     then call com_err_ (code, "list", "after ""^a""", rtrim (errname));
	     else call com_err_ (code, "list");

	     goto error_return;                          /* call cleanup_proc internal procedure and quit. */
	     end;

	return;

     end get_arg_ptr;

/* ****************************************************************************************************************** */
%page;

get_branch_info:
     proc (ix);

dcl  ix fixed bin;
dcl  (temp_ep, temp_np) ptr;

	if ep -> br (ix).type = "00"b
	then					/* some times we get called for a link, by accident */
	     goto say_we_got_it;			/* when that happens, just return, to avoid clobbering anything */
	temp_ep = ep;				/* get pointer to array of directory entries */
	temp_np = np;				/* and their entry names */

get_info_common:
	call hcs_$status_ (dirname, temp_np -> name (temp_ep -> br (ix).nindex), (0), addr (branch), null (), code);
	if code ^= 0 then do;

	     if code = error_table_$logical_volume_not_connected | code = error_table_$logical_volume_not_defined
	     then	do;			          /* give up if pack not mounted */
		call com_err_ (code, "list", "^a", rtrim (dirname));
		goto error_return;                      /* call cleanup_proc internal procedure and quit */
		end;

	     errname = temp_np -> name (temp_ep -> br (ix).nindex);
	     call com_err_ (code, "list", "^a in ^a", rtrim (errname), rtrim (dirname));

	     code = 0;
	     goto say_we_got_it;			/* to avoid trying again later */
	     end;

	if real_record_sw then temp_ep -> br (ix).records = branch.records;

	if real_dtm_sw then temp_ep -> br (ix).dtm = branch.dtm;
						/* dtu is always the real thing */
	temp_ep -> br (ix).dtu = branch.dtu;

say_we_got_it:
	got_branch_info = "1"b;

	return;                                           /* return from get_branch_info */

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

get_msf_records:
     entry (ix);

	temp_ep = msf_ep;				/* get pointer to array of msf components */
	temp_np = msf_np;				/* and their entry names */

	goto get_info_common;

     end get_branch_info;

/* ****************************************************************************************************************** */
%page;

get_date:
     proc (date, from_to);				/* procedure to pick up and convert -from and -to dates */
dcl  date bit (36) aligned;
dcl  from_to char (*);

dcl  1 clock aligned based,				/* the calendar clock is a 52-bit unsigned integer */
       2 pad bit (20) unaligned,			/* only the high-order 36 bits are kept in the file system */
       2 fstime bit (36) unaligned,			/* the truncation is 2**16 (=64K) microseconds (0.064 sec) */
       2 pad2 bit (16) unaligned;			/* leaving a value that is accurate within about 0.1 second */


	argno = argno + 1;
	call get_arg_ptr;
	call convert_date_to_binary_ (targ, fb71, code);
	if code ^= 0 then goto badarg;

/* The following code adjusts the from or to date as necessary, to make the
   date matching appear to be exact, to within the 0.1 minute accuracy with which
   file system date-times are printed. The problem is that every date-time value typed
   by the user will, if not adjusted somehow, be rounded down to the next lower
   tenth of a minute, by the truncation of its low order 16 bits during conversion
   to an fstime.

   The from date is adjusted upward to produce the smallest fstime that will convert
   to its corresponding date-time string (e.g. a date-time ending in 1800.0 might
   be adjusted upward to 1800.0271828, so that it still converts to 1800.0 after
   being truncated, instead of converting to 1759.9).

   The to date is adjusted upward to produce the largest fstime that will convert
   to its corresponding date-time string (e.g. 1800.0 might be adjusted upward
   to 1800.0999999, so that all date_times less than 1800.1 will compare <= to it,
   and be included in the listing). */

	fb71 = fb71 - mod (fb71, 6000000);		/* first, round down to an exact 0.1 minute */

	if from_to = "to" then do;			/* adjust to-date upward to next tenth of a minute */
	     fb71 = fb71 + 6000000;			/* in the unlikely event that this leaves 16 trailing zero bits */
	     fb71 = fb71 - 10000000000000000b;		/* truncation will not decrease its value  */
	     end;					/* so subtract 1 from fstime, and fall thru, to add it */
						/* back again, except when value ends in 16 zero bits. */
						/* ... */
						/* For both from and to dates, */
	if string (addr (fb71) -> clock.pad2) ^= ""b
	then					/* if there are any nonzero bits that will be truncated, */
	     fb71 = fb71 + 10000000000000000b;		/* add 1 to fstime. */

	date = addr (fb71) -> clock.fstime;		/* convert 52-bit date to 36-bit date */

	return;
     end get_date;

/* ****************************************************************************************************************** */
%page;
get_list:
     procedure;					/* procedure to list directory, do star matching, and sorting */

dcl  type fixed bin;
dcl  pbl fixed bin (3);

dcl  bitcnt fixed bin (24);
dcl  dirname_len fixed bin;
dcl  msename char (32);

dcl  dir_ix fixed bin;
dcl  name_ix fixed bin;
dcl  star_ix fixed bin;

dcl  br_ix fixed bin;
dcl  lk_ix fixed bin based (lk_ix_ptr);
dcl  lk_ix_ptr ptr;
dcl  lk_ix_automatic fixed bin;
dcl  ix_inc fixed bin;
dcl  f_t_ix fixed bin;
dcl  match_ix fixed bin;
dcl  action fixed bin;
dcl  (first_name, last_name) fixed bin;

dcl  include_match bit (1) aligned;
dcl  matched bit (1) aligned;
dcl  count_other_types bit (1) aligned;
dcl  check_msf_sw bit (1) aligned;
dcl  skip_it bit (1) aligned;
dcl  all_starnames_matched bit (1) aligned;
dcl  from_to_found bit (1) aligned;

/* Get full pathname of directory to be listed */

	call absolute_pathname_ (substr (path, 1, pathl), dirname, code);
						/* if -pn not given, pathl=0, which implies working_dir */
						/* arg4 = null means put full path in dirname */
	if code ^= 0 then do;
	     error_flag = "1"b;                           /* set error flag before return to the caller */

	     call com_err_ (code, "list", "^a", rtrim (path));
	     return;
	     end;

	dirname_len = index (dirname, " ");		/* find first vacant char */

/* Set up for, and call, hcs_$star_list */
	pbl = 3;					/* request branches and links no matter what user wants, so we
						   can handle "not found" and "directory empty" consistently. */
	if linksw
	then					/* check for link option */
	     if lkpathsw
	     then					/* if linkpaths wanted */
		if ^totalsw
		then				/* and they really will be printed */
		     pbl = pbl + 4;			/* ask star_list to return them */
	call star_list (dir_bc, dir_lc, ep, np);	/* go call hcs_$star_list */

	if code ^= 0 then do;
	     error_flag = "1"b;			/* set error flag before return to the caller */

	     if code = error_table_$nomatch then do;	/* since we said "**" this is an empty directory */
		ioa_control_string = "Directory empty: " || rtrim (dirname);

		call print_message;			/* write on user_output, not error_output */
		end;
	     else call com_err_ (code, "list", "^a", rtrim (dirname));

	     return;
	     end;					/* end code ^= 0 */

	dir_ec = dir_bc + dir_lc;			/* compute total entries (branches + links) */

/* Allocate array in which to put indices that select entries. It can hold all the entries (it is dir_ec elements long) */
	allocate sort_ix in (system_free_area) set (sort_index_ptr);

/* Initialize for pass through all entries in directory, selecting those to be listed */

	if branchsort then do;			/* if we will sort by a branch-only item */
	     lk_ix_ptr = addr (lk_ix_automatic);	/* put links out of the way, at the other end of the array */
	     first_br, first_et = 1;			/* first_et and last_et specify the entries to be sorted */
	     last_br, last_et = dir_bc;		/* later, they will be set to specify the entries to be printed */
	     first_lk = last_br + 1;
	     last_lk = dir_ec;
	     end;

	else do;					/* otherwise intermix branches and links */
	     lk_ix_ptr = addr (br_ix);		/* by having br_ix and lk_ix actually be the same word */
	     first_br, first_lk, first_et = 1;
	     last_br, last_lk, last_et = dir_ec;
	     end;

/* hcs_$star_list returns entries in the order created, oldest first.
   By default, we want to list them in the reverse of that order, newest first.
   Therefore we fill in the sort_ix array from right to left (reverse order),
   unless the user said -reverse, in which case we fill it in from left to right. */

	if revsw then do;				/* if reverse, fill it in left to right */
	     br_ix = first_br - 1;			/* set indices to left of first entry */
	     lk_ix = first_lk - 1;
	     ix_inc = 1;				/* and increment to the right */
	     end;

	else do;					/* fill it in from right to left */
	     br_ix = last_br + 1;			/* set indices to right of last entry */
	     lk_ix = last_lk + 1;
	     ix_inc = -1;				/* and increment to the left */
	     end;

/* Set some switches */
	if default_type
	then					/* if user did not give any entry type arguments */
	     count_other_types = "1"b;		/* we want to be able to say "Files = 0. Links = N" */
	else count_other_types = "0"b;		/* if that happens. (Suggested by Jerry Saltzer) */

	check_msf_sw = "1"b;			/* usually have to check all dirs to see if really msfs */
	if ^tsws (DIR)
	then					/* but if not listing dirs */
	     if ^tsws (MSF)
	     then					/* or msfs */
		check_msf_sw = "0"b;		/* we don't care, so skip it and save time */

	if from_to_date_ix > 0
	then from_to_found = "0"b;			/* this is analogous to the matched switch for each starname */
	else from_to_found = "1"b;			/* it lets us say why nothing is being listed, if that happens */

	if starname_count > 0
	then					/* if any starnames were given, we will check later */
	     all_starnames_matched = ""b;		/* to be sure they were all matched */
	else all_starnames_matched = "1"b;		/* if none given, skip over those checks */

/* Go thru all entries in directory, doing star matching and other testing, to determine which ones will be listed */

	do dir_ix = 1 to dir_ec;
	     type = bin (br (dir_ix).type);		/* pick up entry type */

/* Note that we have not yet separated msfs from directories. We put that off as long as possible */

/* Try to eliminate each entry as early as possible. Start with cheapest tests. */

	     skip_it = "0"b;			/* assume entry will be listed, until we find a reason not to */
	     got_branch_info = ""b;			/* we have not read the VTOC for this branch yet */

/* First, try to eliminate on basis of type */

	     if ^check_msf_sw
	     then					/* if not listing dirs or msfs */
		if ^count_other_types
		then				/* and not counting them either */
		     goto check_type;		/* we could eliminate dirs without making msf check */
	     if type ^= DIR
	     then					/* otherwise we can't eliminate dirs, 'cause they might be msfs */
check_type:
		if ^tsws (type)
		then				/* if we are not listing this type */
		     if ^count_other_types
		     then				/* and not counting unlisted types */
			skip_it = "1"b;		/* we can probably skip the rest of the tests */

/* Next, try from-to dates, if given */

	     if skip_it
	     then					/* but get out of it if we can */
		if from_to_found
		then				/* if entries within given dates found (or none were given) */
		     goto skip_date_check;		/* then we can get out of it */
						/* otherwise we must check, to be able to print right err. msg. */

	     if from_to_date_ix > 0 then do;		/* if either from or to was given */
		if type = LINK
		then				/* links have only DTM */
		     f_t_ix = DTM;
		else				/* branches have both */
		     f_t_ix = from_to_date_ix;	/* and which one to use was decided earlier */

		if type ^= LINK
		then				/* if a branch */
		     if f_t_ix = 2 | real_dtm_sw then do;
						/* if using a date from the VTOC */
			call get_branch_info (dir_ix);
			got_all_branch_info = "1"b;	/* we will have, by the time we're through */
			end;

		if fromsw
		then if et (dir_ix).date (f_t_ix) < from_date then do;
			skip_it = "1"b;
			goto skip_date_check;
			end;
		if tosw
		then if et (dir_ix).date (f_t_ix) > to_date then do;
			skip_it = "1"b;
			goto skip_date_check;
			end;
		from_to_found = "1"b;		/* at least one entry fell within the from-to dates */
		end;
skip_date_check:					/* Finally, try star matching */
	     if starname_count = 0
	     then					/* get out of it if we can */
		if skip_it
		then goto skip_entry;
		else goto keep_entry;

	     if skip_it
	     then					/* if we already know we are skipping this entry */
		if all_starnames_matched
		then				/* and  we don't need to check for starnames not found */
		     goto skip_entry;		/* skip over star matching to save time */

	     all_starnames_matched = "1"b;		/* gets turned off if we fail to match an unmatched starname */

/* We will start comparing all the names of the entry with all the given starnames,
   but stop as soon as we know whether or not to list this entry. */

	     if includesw
	     then					/* if any INCLUDE starnames were given */
		include_match = "0"b;		/* we have to turn this on by matching one of them */
	     else include_match = "1"b;		/* else pretend we matched one */

/* Make starnames the outer loop for efficiency, in case the plan to optimize
   match_star_name_ for repeated calls using the same starname is ever implemented. */

	     do star_ix = 1 to starname_count;		/* go thru all starnames */
		action = starnames (star_ix).action;	/* code might not be that much better */
		matched = starnames (star_ix).matched;	/* but "action" and "matched" are easier to type */

		if action = EXCLUDE
		then				/* if this is an exclude starname */
		     if skip_it
		     then				/* and we already know we are skipping this entry */
			goto next_starname;		/* save time by skipping inner loop */

/* Inner loop on names of entry */

		first_name = br (dir_ix).nindex;
		last_name = first_name + br (dir_ix).nname - 1;

		do name_ix = first_name to last_name;
		     if action = EXCLUDE then do;
			if names_match ()
			then			/* internal procedure to match the various types of starname */
			     skip_it = "1"b;	/* if they match, exclude this entry */
			end;

		     else do;			/* action must = INCLUDE */
			if ^matched then goto try_include_match;
						/* if starname never been matched, keep trying */
			if ^skip_it
			then			/* if we have not already decided to skip this entry */
			     if ^include_match
			     then			/* but it hasn't matched any INCLUDE starname yet */
try_include_match:
				if names_match () then do;
						/* go see if this one matches */
				     include_match = "1"b;
						/* and remember it, if it matches */
				     starnames (star_ix).matched = "1"b;
						/* some entry matched this starname */
				     goto next_starname;
						/* no need to look at rest of entrynames */
				     end;
			end;
		end;				/* end inner loop on names of entry */

		if ^starnames (star_ix).matched
		then				/* if this starname has never been matched */
		     all_starnames_matched = "0"b;	/* remember to keep trying to find a match for it */

next_starname:
	     end;					/* end outer loop on starnames */

	     if skip_it then goto skip_entry;		/* if we found a positive reason for skipping it */
	     if ^include_match then goto skip_entry;	/* or if it just did not match any of the INCLUDE starnames */

/* come here if we THINK we want to keep the entry (still not completely sure) */

keep_entry:
	     if type = DIR
	     then				          /* if a directory made it through all the above */
		call check_for_msf (type);		/* we can't get out of checking to see if it's an msf */

	     if ^tsws (type)
	     then					/* if not listing this type */
		if ^count_other_types
		then				/* and not counting other types */
		     goto skip_entry;		/* skip the following to save time */

/* This entry will be listed (or maybe just counted). Increment counts, and put its index into sort_ix array */

	     tcount (type) = tcount (type) + 1;		/* count entries of this type */

	     if tsws (type) then do;			/* if we are really going to list it */
		count_other_types = "0"b;		/* we no longer have to count other types (if we were doing so) */
		ec = ec + 1;			/* count number of entries really being listed */

/* This do group implements -match */

		if matchsw
		then				/* if only matching names are to be printed */
		     if br (dir_ix).nname > 1 then do;	/* and this entry has multiple names */
			match_ix = br (dir_ix).nindex;/* get index of its first name */
			do name_ix = match_ix to match_ix + br (dir_ix).nname - 1;
						/* go thru entry names */
			     do star_ix = 1 to starname_count;
						/* go thru starnames */
				if starnames (star_ix).action ^= EXCLUDE
				then		/* except for EXCLUDE names */
				     if names_match () then do;
						/* if name matches, keep it */
					if match_ix < name_ix
					then	/* if we removed any previous names */
					     name (match_ix) = name (name_ix);
						/* move this one up */
					match_ix = match_ix + 1;
						/* move index to next vacant position */
					goto kept_name;
						/* get out of loop on starnames */
					end;	/* end of "keep this name" do group */
			     end;			/* end loop on starnames */
kept_name:
			end;			/* end loop on entry names */
			br (dir_ix).nname = match_ix - br (dir_ix).nindex;
						/* save new name count */
			end;			/* end implementation of -match */
		end;				/* end of "really going to list it" do group */

/* Increment counters, and store index, for branch or link, whichever this is */

	     if type = LINK then do;
		if tsws (LINK) then do;		/* if we are really listing links and not just counting them */
		     lk_ix = lk_ix + ix_inc;
		     sort_ix (lk_ix) = dir_ix;	/* then store the index of this one */
		     lc = lc + 1;			/* and increment the really-being-listed counter for links */
		     end;
		end;

	     else do;				/* branch */

/* We want to avoid unnecessary VTOC reading. If a VTOC item is to be printed but -first N was given,
   we can sometimes get away with reading the VTOCEs of only the first N entries. If real records are to
   be printed, we can compute the total lengths from the bitcounts, for printing in the header, to avoid
   reading all the VTOCEs. Although this makes the figure printed in the header inconsistent, in a sense, with
   the figures printed for each entry, the saving is worth it - and the total length figure printed when
   -first N is given is not very useful anyway - only the total entries figure is interesting in that case.

   However, if we have to sort by a VTOC item before we can determine which are the first N entries
   to be listed, we might as well read the VTOCEs now, and print a correct total records figure in the heading.

*/

		if first = 0 | sort_vtoc_sw
		then				/* if -first not given, or sorting by VTOC item */
		     if real_record_sw
		     then				/* and real records are to be printed */
			if ^got_branch_info then do;	/* if we haven't already read the vtoc, do it now */
			     call get_branch_info (dir_ix);
						/* before updating total records */
			     got_all_branch_info = "1"b;
						/* we will have, before we're through */
			     end;

		trecs (type) = trecs (type) + br (dir_ix).records;
						/* count records even if just counting */
		if tsws (type) then do;		/* but if really listing this type */
		     br_ix = br_ix + ix_inc;
		     sort_ix (br_ix) = dir_ix;	/* then store the index of this one */
		     bc = bc + 1;			/* and increment the really-being-listed counter for branches */
		     end;
		end;
skip_entry:
	end;					/* end loop on all entries */

/* Tell user if anything was not found. */

	if ^from_to_found then do;
	     error_flag = "1"b;                           /* set error flag before return to the caller */

	     errname = "Entries within given dates";	/* "Entries within given dates not found" */
	     call print_not_found;
	     return;
	     end;


	if ^all_starnames_matched then do;		/* if there were any unmatched starnames */
						/* tell user, and check for nothing to list */

	     if includesw
	     then					/* if any include starnames were given */
		include_match = "0"b;		/* assume none matched, until we find one that did */
	     else include_match = "1"b;		/* else pretend "**" was given, which always matches */

	     do star_ix = 1 to starname_count;		/* look at all starnames */
		if starnames (star_ix).action ^= EXCLUDE then do;
						/* except EXCLUDE names */
		     if ^starnames (star_ix).matched then do;
						/* if it was never matched */
			errname = starnames (star_ix).name;

			if starnames (star_ix).type = 0
			     then starname_count = 0; /* because no starname is specified */

			call print_not_found;	/* "<starname> not found" */
			end;
		     else				/* if an INCLUDE name was matched */
			include_match = "1"b;	/* remember that we found one that was */
		     end;
	     end;

	     if ^include_match then do;		/* if no INCLUDE names were matched */
		error_flag = "1"b;			/* nothing will be printed */
		return;
		end;
	     end;

	if error_flag then return;			/* quit now if nothing to list */
	if ec = 0 then return;			/* or if only "<thing>s = 0" messages to print */

/* Compute and store positions of the sets: branches, and links, in the sort_ix array,
   for use by sort, and by main printing loop */

	if branchsort then do;			/* if we put links at the other end of the array */
	     if revsw then do;			/* if array was filled in left to right */
		last_et, last_br = br_ix;
		last_lk = lk_ix;
		end;
	     else do;				/* it was filled in right to left */
		first_et, first_br = br_ix;
		first_lk = lk_ix;
		end;
	     end;

	else do;					/* links and branches mixed */
	     if revsw
	     then last_et, last_br, last_lk = br_ix;	/* left to right */
	     else first_et, first_br, first_lk = br_ix;	/* right to left */
	     end;

	if sort_vtoc_sw
	then					/* if sorting by a vtoc item */
	     if ^got_all_branch_info then do;		/* and we have not read the VTOCs yet */
		do dir_ix = first_br to last_br;	/* do so now */
		     call get_branch_info (sort_ix (dir_ix));
		end;
		got_all_branch_info = "1"b;		/* remember not to do it again */
		end;
	if sortsw then call shell_sort;		/* default */

	return;					/* normal return from get_list */

/* ********** */
%page;

/* Note that these internal procedures are internal to get_list */

check_for_msf: proc (para_type);

/* procedure to see if a dir is really an msf, and if it is, count up     */
/* records used by its components, msf_ep and msf_np are declared in      */
/* the main procedure, so the cleanup handler can access them.            */

dcl para_type fixed bin parameter;

dcl MSF_COMPONENT_ZERO fixed bin static options (constant) init (0);

dcl  msf_lc fixed bin;
dcl  xcode fixed bin (35);				/* for local status processing */
dcl  msf_dir_count fixed bin init (0);
dcl  msf_rec_count fixed bin;				/* no need to init this - it starts out = rec count of dir */
dcl  k fixed bin;
dcl (raw_mode, ex_mode) bit (36) aligned;
dcl temp_dir_ec fixed bin;                                  /* for MSF, this variable temporarily holds the dir_ec value to avoid */
                                                            /* subcriptrange in et array after updating dir_ec in star_list */

dcl component_name char (32) varying;
dcl msf_last_component fixed bin;
dcl msf_index fixed bin;

dcl 1 msf_info aligned,				/* status for MSF components */
     2 type bit (2) unaligned,
     2 nnames bit (16) unaligned,
     2 names_offset bit (18) unaligned,
     2 dtcm bit (36) unaligned,
     2 dtu bit (36) unaligned,
     2 mode bit (5) unaligned,
     2 pad bit (13) unaligned,
     2 records fixed bin (17) unaligned,
     2 dtd bit (36) unaligned,
     2 dtem bit (36) unaligned,
     2 pad3 bit (36) unaligned,
     2 current_length fixed bin (11) unaligned,
     2 bit_count bit (24) unaligned,
     2 pad2 bit (18) unaligned,
     2 rbs (0:2) fixed bin (5) unaligned,
     2 pad4 bit (36) unaligned;

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

dcl (convert, ltrim) builtin;
	
                                                            /* set variables to initial values to avoid unexpected values */
	     temp_dir_ec = 0;
	     msf_bc = 0;

	     msename = name (br (dir_ix).nindex);	/* pick up its name, for status_minf call */

	     call hcs_$status_minf (dirname, msename, 0, (0), bitcnt, xcode);
	     if xcode = 0
	     then					/* Could have disappeared, if so say it's a dir */
		if bitcnt ^= 0 then do;		/* non-zero bit-count indicates multi-segment-file */

		     if ^tsws (MSF) then goto set_msftype;
						/* if not listing msfs, don't count recs, just set type */

		     if read_vtoc_sw
		     then				/* if using anything from vtoc, possibly including records */
			if ^got_branch_info
			then			/* and we have not already read the VTOC */
			     call get_branch_info (dir_ix);
						/* do it, before computing msf size */
		     msf_rec_count = br (dir_ix).records;
						/* get size of msf directory */

						/* build pathname of msf dir for star_list call */
		     substr (dirname, dirname_len, 1) = ">";
		     substr (dirname, dirname_len + 1, 32) = msename;
		     pbl = 2;			/* branches only */
		     temp_dir_ec = dir_ec;
		     
		     call star_list (msf_bc, msf_lc, msf_ep, msf_np);
		     if code ^= 0 then do;		/* Check for errors */
			if code ^= error_table_$nomatch
			then if code ^= error_table_$null_dir then do;
				call file_manager_$validate (substr (dirname, 1, dirname_len-1), msename, xcode);
				if xcode ^= 0
				then do;
				     msf_rec_count = 0;
				     code = 0;
				     end;
				else do;
				     dmf_count = dmf_count + 1;
				     dmf_rec_count = dmf_rec_count + br (dir_ix).records;
				     msf_rec_count = -br (dir_ix).records;
				     call fs_util_$get_user_access_modes (substr (dirname, 1, dirname_len-1), msename, "",
					- 1, raw_mode, ex_mode, xcode);
				     if xcode = 0 then et (dir_ix).mode = substr (raw_mode, 1, 3);
				     end;
				end;
			goto msfempty;
			end;
		     else do;
			                              /* extract the mode of a MSF from the mode of MSF component 0 */
		          call hcs_$get_user_access_modes (dirname, "0", "", -1,
			     raw_mode, ex_mode, xcode);
			if xcode = 0 then do;
			     dir_ec = temp_dir_ec;    /* restore the limit index of et array which was saved earlier */

			     et (dir_ix).mode = substr (raw_mode, 1, 3);
			     end;

			if msf_bc > 0 then do;
                                                            /* currently, got MSF directory's dtm and dtu values. */
                                                            /* But we want MSF component's dtm and dtu information. */
                                                            /* So, must reset these flags before loading MSF component's dtm and dtu */
			     br (dir_ix).dtm = "0"b;
			     br (dir_ix).dtu = "0"b;

			     msf_last_component = msf_bc - 1;
			     do msf_index = MSF_COMPONENT_ZERO to msf_last_component;

                                                           /* call hcs_$status_long to get most user_accessible informattion */
                                                           /* about a specified MSF component */
			                             /* if the returned code is not zero in value then go get */
                                                           /* the next msf component.  Do not return to the caller. */
				component_name = convert (component_name, msf_index);
				component_name = ltrim (component_name);

				call hcs_$status_long (dirname, (component_name), 1, addr (msf_info), null, code);
				if code = 0
				then do;
				     if real_dtm_sw
				     then do;
					if fixed (msf_info.dtcm) > fixed (br (dir_ix).dtm)
					then br (dir_ix).dtm = msf_info.dtcm;
					end;

				     if dtem_arg_sw
				     then do;
					if fixed (msf_info.dtem) > fixed (br (dir_ix).dtm)
					then br (dir_ix).dtm = msf_info.dtem;
					end;

				     if fixed (msf_info.dtu) > fixed (br (dir_ix).dtm)
				     then br (dir_ix).dtu = msf_info.dtu;
				     end;
				end;               /* go get the next MSF component */
			     end;                    /* specified entryname is a MSF */
			end;                         /* else do */

		     do k = 1 to msf_bc;
                                                           /* if msf contains director(y ies) then count how many */
			if msf_ep -> br (k).type = "10"b
			then msf_dir_count = msf_dir_count + 1;

				                   /* if using real records then go read vtoc of msf component */
			if real_record_sw
			then call get_msf_records (k);

					        /* add up length of this msf component */
			msf_rec_count = msf_rec_count + msf_ep -> br (k).records;
	               end;

		     if msf_dir_count > 0 then do;	/* if msf contained director(y ies) */
			code = 0;
			call com_err_ (code, "list", "Multisegment-file: ^a contains director^[y^;ies^].", rtrim (msename), msf_dir_count = 1);
			end;

		     free msf_ep -> br in (system_free_area);
		     free msf_np -> name in (system_free_area);

msfempty:
		     substr (dirname, dirname_len, 33) = "";
						/* blank out msf name */
		     br (dir_ix).records = msf_rec_count;
						/* store total msf length */

set_msftype:
                                                            /* set type to msf in the branch array entry for this branch */
		     br (dir_ix).type = bit (fixed (MSF, 2));
		     para_type = 3;			/* also set the variable used by the caller (get_list) */
		     end;				/* end it-was-an-msf do group */

	     return;
	end check_for_msf;

/* ********** */
%page;

in_order:
	proc (ix1, ix2) returns (bit (1) aligned);

dcl  (ix1, ix2) fixed bin;

	     goto comparison (sort_key);		/* go compare the thing to be sorted on */

comparison (1):					/* dtm */
						/* normal order for dates is high to low (newest to oldest) */
	     if br (ix2).dtm > br (ix1).dtm
	     then					/* if they are reversed */
		goto items_reversed;
	     else goto items_in_order;

comparison (2):					/* dtu */
						/* normal order for dates is high to low (newest to oldest) */
	     if br (ix2).dtu > br (ix1).dtu
	     then goto items_reversed;
	     else goto items_in_order;

comparison (3):					/* mode */
						/* it is not clear what the right order for modes is */
	     if string (br (ix1).mode) > string (br (ix2).mode)
	     then					/* but this puts null (blank) first */
		goto items_reversed;		/* rew or sma last */
	     else if string (br (ix2).mode) = string (br (ix1).mode)
		then				/* and rw before re */
		     goto return_in_order;		/* if equal, do not reorder */
		else goto items_in_order;

comparison (4):					/* records */
						/* normal order for records is high to low (large to small) */
	     if br (ix2).records > br (ix1).records
	     then					/* if they are out of order */
		goto items_reversed;		/* go see if we want them that way */
	     else if br (ix2).records = br (ix1).records
		then				/* check for equality (which is likely with records) */
		     goto return_in_order;		/* if equal, do not reorder */
		else goto items_in_order;

comparison (5):					/* name */
						/* normal order for names is low to high (a to z) */
	     if name (br (ix1).nindex) > name (br (ix2).nindex)
	     then					/* if they are reversed */
		goto items_reversed;		/* go see if we want them that way */
	     else goto items_in_order;		/* names will never be equal */

comparison (6):					/* count */
						/* normal order for count is high to low (most names to fewest) */
	     if br (ix2).nname > br (ix1).nname
	     then					/* if they are reversed */
		goto items_reversed;
	     else if br (ix2).nname = br (ix1).nname
		then				/* if they are equal */
		     goto return_in_order;		/* if equal, do not reorder */
		else goto items_in_order;


items_reversed:
	     if revsw
	     then goto return_in_order;
	     else goto return_out_of_order;

items_in_order:
	     if revsw
	     then
return_out_of_order:
		return ("0"b);
	     else
return_in_order:
		return ("1"b);

	end in_order;

/* ********** */
%page;

/* The code in this internal procedure could be written more compactly as something like
   the following, which more closely resembles the Knuth algorithm (see comments in shell_sort).
   However, the generated code would waste a lot of time doing bookkeeping, as
   noted in the comments, and that overhead has been avoided by the hand-coded
   logic that has been used.
*/

/*     do j = first_et+h to last_et;			/* add h to first_et to get j */
/*	ix2 = sort_ix (j);				/* */
/*	do i = j-h repeat i-h			/* subtract h each time around the loop */
/*	   while (i >= first_et			/* if i<first_et, sort_ix(i) is garbage, but pl1 keeps */
/*						/* evaluating "and" expressions after finding a false term */
/*	   & ^in_order (sort_ix (i), ix2));		/* if in order on first try, all the do loop bookkeeping */
/*						/* was a waste of time */
/*	   sort_ix (i+h) = sort_ix (i);		/* add h back again */
/*	end;					/* */
/*	sort_ix (i+h) = ix2;			/* add h back again */
/*     end;					/* */

%page;
insertion_sort:
	proc (h);

dcl  h fixed bin;					/* >1 for early shell sort passes */

dcl  (i, j, k) fixed bin;
dcl  (ix1, ix2) fixed bin;

	     i = first_et;				/* position of first entry in sort_ix */
	     ix1 = sort_ix (i);			/* index of first entry */

	     do j = first_et + h to last_et;		/* look at each entry to right of first */
		k = j;				/* remember its (soon to be vacant) position */
		ix2 = sort_ix (j);			/* pick up its index */

compare:
		if ^in_order (ix1, ix2) then do;	/* if it's not in order with the one on its left */
		     sort_ix (k) = ix1;		/* move the latter to the right, into the vacant position */
		     k = i;			/* the vacant position is now where we moved it from */
		     i = i - h;			/* look further to the left */
		     if i >= first_et then do;	/* if not past left end of array, keep going */
			ix1 = sort_ix (i);		/* pick up index of new entry */
			goto compare;		/* and go compare it with one we're trying to find a place for */
			end;			/* fall thru if at left end of array */
		     end;				/* fall thru if it's in order with the one on the left */

		if j ^= k then do;			/* save time by doing this only if we moved something */
		     sort_ix (k) = ix2;		/* store it in the vacant spot */
		     ix1 = sort_ix (j);		/* index of entry to left of next sort_ix(j) */
						/* (if at top of loop, would be "ix1=sort_ix(j-h)") */
		     end;
		else ix1 = ix2;			/* if we did not move anything */
		i = j;				/* index of entry to left of next sort_ix(j) */
						/* (if at top of loop, would be "i=j-1") */
	     end;					/* end loop on j. go back for next one to the right */

	     return;
	end insertion_sort;

/* ********** */
%page;
names_match:
	proc returns (bit (1) aligned);		/* procedure to see if one starname matches one entry name */
						/* implicit arguments are star_ix and name_ix */
dcl  star_code fixed bin (35);

	     if starnames (star_ix).type = DOUBLE_STAR
	     then goto match;

	     else if starnames (star_ix).type = ENTRY_NAME then do;
		     if starnames (star_ix).name = name (name_ix) then goto match;
		     end;


		else do;				/* must be regular starname */
		     call match_star_name_ (name (name_ix), starnames (star_ix).name, star_code);
		     if star_code = 0 then goto match;
		     end;

nomatch:
	     return ("0"b);				/* no match */
match:
	     return ("1"b);
	end names_match;

/* ********** */
%page;
shell_sort:
	proc;

dcl  (n, incr, next_incr) fixed bin;

/* This sorting algorithm is taken from Knuth, The Art of Computer Programming,
   Volume 3, "Sorting and Searching", pp. 80-95 and p. 379.
   The Shell sort is Algorithm 5.2.1D (Diminishing increment sort) on p. 85.
   The internal procedure, insertion_sort (see above) is the inner loop of 5.2.1D,
   which also happens to be Algorithm 5.2.1S (Straight insertion sort),
   generalized for use as the inner loop of the Shell sort.

   The increment computation is taken from equation (8) on p 95:

   "Let h(1)=1, h(s+1) = 3*h(s)+1, and stop with h(t) when h(t+2) >= N. (8)"

   we use incr for h(s),
   next_incr for h(s+1),
   and we stop with next_incr=h(t+2) and incr=h(t+1),
   but then we decrement from h(t+1) to h(t) before the first call to insertion_sort.

*/

	     n = last_et - first_et + 1;		/* compute number of entries to be sorted */
	     incr = 4;				/* compute initial increment */
	     next_incr = 13;			/* the first few are: 1,4,13,40,121,364,1092,3820,9841 */
	     do while (next_incr < n);		/* Knuth recommends the Shell sort for up to 1000 items (p.379) */
		incr = next_incr;			/* directories with more than 1000 items are very rare */
		next_incr = 3 * next_incr + 1;	/* (if not completely non-existent) */
	     end;					/* so 121 will be the largest increment used */

	     do while (incr > 1);			/* the last insertion sort is done with incr = 1 */
		incr = divide (incr - 1, 3, 17, 0);	/* decrease incr from h(s) to h(s-1) */
		call insertion_sort (incr);		/* do an insertion sort using that increment */
	     end;					/* if we just sorted with incr = 1, the array is in order */
	     return;
	end shell_sort;

/* ********** */
%page;
star_list:
	proc (star_bc, star_lc, star_ep, star_np);	/* replaces 2 hcs_$star_list calls (80 words) */

dcl  (star_bc, star_lc) fixed bin;
dcl  (star_ep, star_np) ptr;
dcl  i fixed bin;

	     call hcs_$star_dir_list_ (dirname, "**", pbl, system_free_ptr, star_bc, star_lc, star_ep, star_np, code);
	     if code = 0
	     then do;				/* caller checks code so just avoid referencing bad ptrs here */
	          dir_ec = star_bc + star_lc;
		do i = 1 to star_bc + star_lc;
		     if star_ep -> br (i).type ^= "00"b
		     then				/* if not link */
			star_ep -> br (i).records = divide (star_ep -> br (i).records + 36863, 36864, 24, 0);
		     end;
		end;
	     return;
	end star_list;

     end get_list;

/* ****************************************************************************************************************** */
%page;

get_starname:
     proc;					/* procedure to pick up, interpret, and store, a starname */


	if starptr = addr (stack_starnames)
	then					/* if we are still using the stack starnames array */
	     if starname_count = hbound (stack_starnames, 1) then do;
						/* but we have run out of room in it */
		alloc_len = nargs - argno + 5;	/* allocate a bigger one - with enough room for this arg, the
						   first 4, and all the rest, in case they are all starnames */

		allocate starnames in (system_free_area) set (starptr);
		do i = 1 to hbound (stack_starnames, 1);
		     starnames (i) = addr (stack_starnames) -> starnames (i);
		end;
		end;

	starname_count = starname_count + 1;
	starnames (starname_count).type = 0;
	starnames (starname_count).action = 0;
	starnames (starname_count).matched = "0"b;

	if search (targ, "<>") > 0 then do;		/* see if it is a pathname */
	     call expand_pathname_ (targ, dirname, starnames (starname_count).name, code);
	     if code ^= 0 then goto badarg;
	     if pathsw
	     then					/* if a directory path already given */
		if path ^= dirname
		then				/* and this one is different */
		     goto two_pn_error;		/* go complain */
	     path = dirname;			/* save directory path */
	     pathsw = "1"b;				/* remember that we got one */
	     pathl = length (rtrim (path, " "));
	     starnames (starname_count).length = length (rtrim (starnames (starname_count).name, " "));
	     if path = ">" & starnames (starname_count).length = 0 then do;
		code = error_table_$root;
		goto badarg;
		end;
	     end;

	else do;
	     starnames (starname_count).name = targ;
	     starnames (starname_count).length = arglen;
	     end;

	if starnames (starname_count).length > 32 then do;
	     code = error_table_$bigarg;
	     goto badarg;
	     end;

	call check_star_name_$entry (starnames (starname_count).name, code);
	if code > DOUBLE_STAR then goto badarg;		/* bad starname - code will produce message */
	starnames (starname_count).type = code;

	return;
     end get_starname;

/* ****************************************************************************************************************** */
%page;

print_branch:
     proc;					/* replaces 4 ioa_ calls (122 words) */
	call ioa_ (ioa_control_string, cdtm, cdtu, mode, records, np -> name (ni), nnames);

	return;
     end print_branch;

/* ****************************************************************************************************************** */
%page;

print_heading:
     proc;					/* replaces 12 ioa_ calls (200 words) */
	if msf_pass2
	then
	     ioa_control_string = rtrim (dmf_control_string (hdng_index));
	else
	     ioa_control_string = substr (string (hdng), hdng_offset (hdng_index), hdng_len (hdng_index));
	if hdng_index >= 8 & hdng_index < 12
	then					/* if heading is ... = 0. */
	     call print_message;			/* don't bother passing count and recs args */
	else call ioa_$nnl (ioa_control_string, tcount (tpix), trecs (tpix));

	return;
     end print_heading;

/* ****************************************************************************************************************** */
%page;

print_message:
     proc;					/* replaces 11 ioa_ calls (140 words) */
	call ioa_ (ioa_control_string);

	return;
     end print_message;

/* ****************************************************************************************************************** */
%page;

print_name:
     proc;					/* replaces 5 ioa_ calls (85 words) */
	call ioa_ (ioa_control_string, name (ni));

	return;
     end print_name;

/* ****************************************************************************************************************** */
%page;

print_not_found:
     proc;					/* procedure to print "<starname> not found [in <dirname>]" */

	not_found_count = not_found_count + 1;

	if starname_count > 0
	then message = "Use of star convention resulted in no match.  ^a";
	else message = """^a"" not found";

	if not_found_count = 1 then do;		/* only call com_err_ and print dir for first one */
	     if pathsw
	     then do;				/* if user gave -pn arg */
		message = message || " in ^a";	/* put dir in message (user might have typed wrong dir) */
		call com_err_ (code, "list", message, rtrim (errname), rtrim (dirname));
		end;
	     else do;
		if message ="""^a"" not found"
		then message = message || ".";          /* for readable purpose, this error message is terminated by a period. */

		call com_err_ (code, "list", message, rtrim (errname));
		end;
	     end;

	else do;
	     if message = """^a"" not found"
	     then message = message || ".";               /* for readable purpose, this error message is terminated by a period. */

	     call ioa_$ioa_switch (iox_$error_output, message, rtrim (errname));
						/* put all "not found" messages on same stream - error_output */
	     end;

	return;
     end print_not_found;

/* ****************************************************************************************************************** */
%page;

set_branch_fmt:
     proc (ix);

dcl  ix fixed bin;
dcl  fmtx fixed bin;

	fmtx = 4;					/* skip leading ^Nx of 1st col fmt to not indent whole thing */
	name_indent = 0;				/* initialize */
	do i = 1 to CT;				/* check switch for each column, up to count column */
	     if colsw (i) then do;			/* if we will print it, put its format into the string */
		substr (branch_fmt (ix), branch_fmt_ln (ix) + 1) = substr (col_fmt (i), fmtx);
		branch_fmt_ln (ix) = branch_fmt_ln (ix) + col_fmt_ln (i) + 1 - fmtx;
		if i < 3				/* plug in the current date/time width */
		then do;
		     substr (branch_fmt (ix), branch_fmt_ln (ix) -2, 2) = convert (dt_len_pic, dt_len);
		     name_indent = name_indent + dt_len + 2;
	          end;
		else if i=3
		then name_indent = name_indent + 5;
		else if i=4
		then name_indent = name_indent + 5;
		fmtx = 1;				/* pick up leading ^Nx of subsequent col fmts to separate cols */
		end;
	     else do;				/* if we will not print it, use "^s" to skip it */
		substr (branch_fmt (ix), branch_fmt_ln (ix) + 1) = "^s";
		branch_fmt_ln (ix) = branch_fmt_ln (ix) + 2;
		end;
	end;

/* Set up format for printing secondary names of branches, lined up under
   the primary name, or indented 2 spaces if only names are being printed */

	if ^prisw then do;				/* skip it if only primary names are to be printed */
	     if name_indent=5
	     then if modesw				/* if it is just mode, indent by 2 so user can distinguish */
	        then name_indent = 7;			/* secondary names from segments with null access */
	        else name_indent = 6;			/* for just records, adjust slightly */

	else if name_indent = 0 then name_indent = 2;	/* when only names are printed, indent addnames */

	     substr (name_fmt (ix), 1) = "^__x";
	     substr (name_fmt (ix), 2, 2) = convert (dt_len_pic, name_indent);
						/* how many spaces to indent */
	     name_fmt_ln (ix) = 4;			/* all of the format strings are 4 chars */
	     substr (name_fmt (ix), name_fmt_ln (ix) + 1) = "^a";
						/* to print the name */
	     name_fmt_ln (ix) = name_fmt_ln (ix) + 2;
	     end;

	return;

     end set_branch_fmt;

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

     end list;




		    list_sub_tree.pl1               10/10/88  1528.1rew 10/10/88  1526.1      568917



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-09-20,GDixon), approve(88-09-20,MCR8008),
     audit(88-10-07,Beattie), install(88-10-10,MR12.2-1159):
      A) Rewritten to use fs_star_ for searching/selecting of entries to be
         listed.
      B) Added many new control arguments.
                                                   END HISTORY COMMENTS */


list_sub_tree:
lst:
    procedure;

dcl  1 auto_hd			aligned auto,	/* AUTOMATIC			 */
       2 args,
         3 archive			bit(1) aligned,
         3 debug			bit(1) aligned,
         3 depth			fixed bin,
         3 inaee			bit(1) aligned,
         3 length			bit(1) aligned,
         3 names			bit(1) aligned,
         3 selection		bit(1) aligned,
         3 total			bit(1) aligned,
         3 total_only		bit(1) aligned,
         3 type			bit(1) aligned,
       2 subtree,
         3 error			bit(1) aligned,
         3 lengths			fixed bin(35),
       2 last_ent,
         3 depth			fixed bin,
         3 path			char(168),
         3 type			char(32),
         3 uids			(15) bit(36) aligned,
       2 ext_ent,
         3 type			(19) char(32) unal,
         3 count			(19) fixed bin,
         3 lengths			(19) fixed bin(35);

dcl  code				fixed bin(35) auto;
dcl  hdP				ptr auto;
dcl  max_lineL			fixed bin auto;
dcl  pathX			fixed bin auto;
dcl  typeX			fixed bin auto;

						/* BASED				 */
dcl  1 hd				aligned like auto_hd based (hdP);

						/* BUILTINS			 */
dcl (addr, after, before, bin, char, copy, divide, hbound, index, lbound, length, ltrim, max, min, 
     null, rtrim, search, substr, sum)
				builtin;

dcl  cleanup			condition;	/* CONDITIONS			 */

						/* CONSTANTS			 */
dcl  ALT_ENTRY_TYPES		(9) char(12) int static options(constant) init(
				"lk", "seg", "dir", "ms_file", "ms_comp", "dm_file",
				"arch", "arch_comp", "unkn");
dcl (TYPE_LINK			init(1),
     TYPE_SEGMENT			init(2),
     TYPE_DIRECTORY			init(3),
     TYPE_MSF			init(4),
     TYPE_MSF_COMP			init(5),
     TYPE_DM_FILE			init(6),
     TYPE_ARCHIVE			init(7),
     TYPE_ARCHIVE_COMP		init(8)) fixed bin int static options(constant);
dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant);
dcl  LST_ENTRY_TYPES		(9) char(8) int static options(constant) init(
				"lk", "sm", "dr", "msf", "msf_comp", "dmf",
				"ac", "ac_comp", "unkn");
dcl  ME				init("list_sub_tree") char(13) int static options(constant);
dcl  PRINT_ENTRY_TYPES		(9) char(9) int static options(constant) init(
				"      lk", "      sm", "      dr", "     msf", "msf_comp", 
				"     dmf", "      ac", " ac_comp", "    unkn");
dcl  SPACES			char(100) int static options(constant) init("");

						/* ENTRIES			 */
dcl  convert_status_code_		entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl  fs_star_$adjust_structure_size	entry (ptr, char(*), char(8), fixed bin, fixed bin(35));
dcl  fs_star_$init			entry (ptr, char(*), char(*), char(8), ptr, fixed bin(35));
dcl  fs_star_$select		entry (ptr, ptr, fixed bin(35));
dcl  fs_star_$term			entry (ptr);
dcl  expand_pathname_		entry (char(*), char(*), char(*), fixed bin(35));
dcl  get_line_length_$switch		entry (ptr, fixed bin(35)) returns(fixed bin);
dcl  get_wdir_			entry() returns(char(168));
dcl  hcs_$get_uid_file		entry (char(*), char(*), bit(36) aligned, fixed bin(35));
dcl  hcs_$quota_read		entry (char(*), fixed bin(18), fixed bin(71), bit(36) aligned,
				     bit(36), fixed bin(1), fixed bin(18), fixed bin(35));
dcl  hcs_$status_			entry (char(*), char(*), fixed bin(1), ptr, ptr,
				     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(194));

						/* EXTERNAL STATIC			 */
dcl (error_table_$bad_opt,
     error_table_$no_s_permission,
     error_table_$root
     )				fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* OVERVIEW of OPERATION:								 */
/* 1) Establish cleanup handler.							 */
/* 2) Initialize command interface and argument processing.					 */
/* 3) Process input arguments.  Call fs_star_$init to obtain place to store input arguments.	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

    call CLEANUP_init();
    on cleanup call CLEANUP();

    call ARG_initialization (ME, "1.0", ALLOW_COMMAND, exit_proc);
    call ARGS_init();

    call ARGS_process();
    star_options.path_allow = PATH_ALLOW_NONDIR_STAR_NAMES;
    if hd.args.depth ^= 1 then
       star_options.entry_type.dirs, star_options.entry_type.msfs =
	ENTRY_RETURN | ENTRY_LIST_SUBENTRIES;
    if hd.args.archive then do;
       do pathX = lbound(star_paths.value,1) to star_paths.count
	while  (index (star_paths.value(pathX), "::") > 0);
	end;
       if EXTENDED_TYPE_archive_given() then		/* -slet ac given; return archives.	 */
	star_options.entry_type.archives = ENTRY_RETURN | ENTRY_LIST_SUBENTRIES;
       else if pathX > star_paths.count then do;		/* all paths are archive pathnames	 */
						/*  so only return the components.	 */
	star_options.entry_type.archives = ENTRY_DONT_RETURN | ENTRY_LIST_SUBENTRIES;
	hd.args.selection = TRUE;
	end;
       else					/* otherwise return both archives & comps*/
	star_options.entry_type.archives = ENTRY_RETURN | ENTRY_LIST_SUBENTRIES;
       end;
    if hd.args.inaee then do;
       star_options.entry_type.dirs = star_options.entry_type.dirs | ENTRY_INAEE;
       star_options.entry_type.segs = star_options.entry_type.segs | ENTRY_INAEE;
       end;
    star_options.handler = HANDLER;
    star_options.error = ERROR_ROUTINE;
    star_options.handler_dataP = addr(hd);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* OVERVIEW of OPERATION (continued):							 */
/* 4) Call fs_star_$select to perform processing of subtrees.				 */
/* 5) If processing was successful, summarize its results briefly or in detail.			 */
/* 6) Cleanup and exit.								 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

    call fs_star_$select (star_optionsP, star_dataP, code);

    if code = 0 then do;
       if (hd.last_ent.type = ENTRY_TYPE_DIRECTORY |	/* If prior entry was a dir, and it is	 */
						/*  empty, say that.  Same for archives	 */
						/*  if we are searching them.		 */
         ((hd.last_ent.type = ENTRY_TYPE_ARCHIVE) & hd.args.archive)) & 
         (hd.args.depth>hd.last_ent.depth) & ^hd.args.selection then
	call ioa_ ("^[^vt^;^s^]^[^vt^;^s^]^v(   ^)<EMPTY>", hd.args.type, length(typ)+1,
	   hd.args.length, length(len)+1+bin(hd.args.type,1)*length(typ), hd.last_ent.depth);

       if (star_data.matched.total > 0) & (hd.args.total | hd.args.total_only) then do;
	call ioa_("");
	call TOTAL_print_init ("      ", "count:", "pages:");
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "TOTAL",      star_data.matched.total,      hd.subtree.lengths);
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "SEGMENTS",   star_data.matched.segs,       hd.ext_ent.lengths(TYPE_SEGMENT));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "ARCHIVES",   star_data.matched.archives,   hd.ext_ent.lengths(TYPE_ARCHIVE));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "ARCH_COMPS", star_data.matched.arch_comps, hd.ext_ent.lengths(TYPE_ARCHIVE_COMP));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "LINKS",      star_data.matched.links,      hd.ext_ent.lengths(TYPE_LINK));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "DIRS",       star_data.matched.dirs,       hd.ext_ent.lengths(TYPE_DIRECTORY));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "MSFS",       star_data.matched.msfs,       hd.ext_ent.lengths(TYPE_MSF));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "MSF_COMPS",  star_data.matched.msf_comps,  hd.ext_ent.lengths(TYPE_MSF_COMP));
	call TOTAL_print	  ("      ", "count:", "pages:",
	   "DM_FILES", star_data.matched.dm_files,     hd.ext_ent.lengths(TYPE_DM_FILE));
	if hd.ext_ent.type(hbound(STANDARD_ENTRY_TYPES,1)+1) ^= "" then do;
	   do typeX = hbound(STANDARD_ENTRY_TYPES,1)+1 to hbound(hd.ext_ent.type,1)
	      while (hd.ext_ent.type(typeX) ^= "");
	      call TOTAL_print  ("EXTENDED", "ENTRIES ", " pages: ",
	         hd.ext_ent.type(typeX), hd.ext_ent.count(typeX), hd.ext_ent.lengths(typeX));
	      end;
	   call TOTAL_print_end ("EXTENDED", "ENTRIES ", " pages: ");
	   end;
	else
	   call TOTAL_print_end ("      ", "count:", "pages:");
	end;
       else
	call ioa_ ("^[^/^]^d ^[entries^;entry^] found^[, ^d total pages^;^s^].",
	   star_data.matched.total > 0, star_data.matched.total, star_data.matched.total ^= 1,
	   (star_data.matched.total > 0) & hd.args.length, hd.subtree.lengths);
       end;

EXIT:
    call CLEANUP();
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* EXIT PROCEDURE:									 */
/* 1) This procedure is called by ssu_$abort_subsystem when ERR_fatal is called to report a fatal	 */
/*    error.									 */
/* 2) It does a non-local goto to the EXIT label to stop execution of the command.		 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

exit_proc:
    proc;
    go to EXIT;
    end exit_proc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARGUMENT PROCESSING:								 */
/*   Declare variables and subroutines needed for argument processing.  This is a general argument	 */
/*   processing package that can be shared among many programs.				 */
/*										 */
/* SEE ARGUMENT PROCESSING PROGRAMS:							 */
/*   ARG_initialization, ARG_get, ARG_get_numeric_operand, ARG_get_extra_operand, ARG_get_operand,	 */
/*   ARG_remaining_arg_count								 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

dcl (afS				bit(1) aligned,	/* on: called as an active function	 */
     argL				fixed bin(21),	/* current argument length		 */
     argN				fixed bin,	/* arg count			 */
     argP				ptr,
     argX				fixed bin,	/* arg index			 */
     opL				fixed bin(21),	/* control argument operand		 */
     opP				ptr,
     retL				fixed bin(21),	/* af return value			 */
     retP				ptr,
     sciP				ptr) auto;	/* ssu_ info ptr			 */

dcl  arg				char(argL) based(argP),
     op				char(opL) based(opP),
     ret				char(retL) varying based(retP);

dcl  ssu_$abort_subsystem		entry() options(variable),
     ssu_$arg_ptr			entry (ptr, fixed bin, ptr,
				     fixed bin(21)),
     ssu_$destroy_invocation		entry (ptr),
     ssu_$print_message		entry() options(variable),
     ssu_$return_arg		entry (ptr, fixed bin, bit(1) aligned,
				     ptr, fixed bin(21)),
     ssu_$standalone_invocation	entry (ptr, char(*), char(*), ptr,
				     entry, fixed bin(35));

dcl (ALLOW_COMMAND			init(1),
     ALLOW_AF			init(2),
     ALLOW_COMMAND_AF		init(3)) fixed bin int static
				     options(constant);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_initialization:								 */
/* 1) Initialize error handling subroutines.						 */
/* 2) Determine whether invoked as command or af.						 */
/* 3) Is this type of invocation allowed?						 */
/* 4) Initialize af return argument, and index of current argument.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARG_initialization:
    proc (caller, version, allowed, exit_procedure);

dcl  caller			char(*) parm,
     version			char(*) parm,
     allowed			fixed bin parm,
     exit_procedure			entry parm;

dcl  code				fixed bin(35) auto;

dcl  com_err_			entry() options(variable),
     cu_$arg_list_ptr		entry returns(ptr);

dcl (error_table_$active_function,
     error_table_$not_act_fnc)	fixed bin(35) ext static;

    call ssu_$standalone_invocation (sciP, caller, version,
       cu_$arg_list_ptr(), exit_procedure, code);
    if code ^= 0 then do;
       call com_err_ (code, caller,
	"Error creating standalone ssu_ invocation.");
       call exit_procedure();
       end;

    call ERR_init();
    call ssu_$return_arg (sciP, argN, afS, retP, retL);
    if allowed = ALLOW_COMMAND & afS then
       call ERR_fatal (sciP, error_table_$active_function);
    else if allowed = ALLOW_AF & ^afS then
       call ERR_fatal (sciP, error_table_$not_act_fnc);
    else if allowed = ALLOW_COMMAND_AF then;
    if afS then
       ret = "";
    argX = 0;
    end ARG_initialization;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_get:									 */
/*   Gets the next argument from arg list.  Returns TRUE if an argument is available, FALSE if the	 */
/*   argument list is exhausted.							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARG_get:
    proc returns (bit(1));

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

    if argX < argN then do;
       argX = argX + 1;
       call ssu_$arg_ptr (sciP, argX, argP, argL);
       return (TRUE);
       end;
    else
       return (FALSE);
    end ARG_get;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_get_extra_operand:								 */
/* 1) Get an optional control arg operand.  An argument beginning with a minus (-) or contains       */
/*    < or > chars is assumed to be a subsequent control argument or a positional pathname, rather	 */
/*    than an operand.								 */
/* 2) Returns TRUE if an extra operand is found.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

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

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

    if argX < argN then do;
       argX = argX + 1;
       call ssu_$arg_ptr (sciP, argX, opP, opL);
       if (index(op, "-") = 1) | (search(op,"<>") > 0) then do;
	argX = argX - 1;				/* Exclude control args and pathnames	 */
	return (FALSE);				/*  from being treated as extra operands.*/
	end;
       else
	return (TRUE);
       end;
    else
       return (FALSE);

    end ARG_get_extra_operand;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_get_numeric_operand:								 */
/* 1) Parg is name of control argument whose operand is to be obtained.			 */
/* 2) If operand is optional, Pdescription is a null string.				 */
/*    If operand is required, Pdescription is used in an error message to describe missing operand.	 */
/* 3) If operand is optional, default_value is the default value that will be returned.  The	 */
/*    constant NO_DEFAULT_VALUE can be used to specify that there is no default value.		 */
/* 4) allowed_values is an array of accepted values.  It can be NO_ALLOWED_VALUES to specify that	 */
/*    there is no restriction on the acceptable value; POSITIVE_VALUES to specify values > 0; or	 */
/*    NONNEGATIVE_VALUES to specify values >= 0.						 */
/* 5) Returns TRUE if a numeric operand was found, with operand value in num_op integer.		 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

dcl  num_op			fixed bin(35);
dcl  NO_DEFAULT_VALUE		fixed bin(35) int static options(constant) init(-34359738368);
dcl  NO_ALLOWED_VALUES		(1) fixed bin(35) int static options(constant) init(
				-34359738368);	/* -34359738368 is -2**35, the largest 	 */
						/*  negative integer.		 */
dcl  POSITIVE_VALUES		(2) fixed bin(35) int static options(constant) init(
				1, 34359738367);	/*  34359738367 is 2**35-1, the largest	 */
						/*  positive integer.		 */
dcl  NONNEGATIVE_VALUES		(2) fixed bin(35) int static options(constant) init(
				0, 34359738367);

ARG_get_numeric_operand:
    proc (Parg, Pdescription, Pdefault_value, Pallowed_values) returns (bit(1));

dcl  Parg				char(*) parm,
     Pdescription			char(*) parm,
     Pdefault_value			fixed bin(35) parm,
     Pallowed_values		(*) fixed bin(35) parm;

dcl  valX				fixed bin auto;

dcl (convert, dim, hbound, lbound)	builtin;

dcl (conversion, size)		condition;

dcl (FALSE			init("0"b),
     TRUE				init("1"b)) bit(1) int static options(constant),
    (error_table_$bad_arg,
     error_table_$noarg)		fixed bin(35) ext static;

    if Pdefault_value ^= NO_DEFAULT_VALUE & Pdescription = "" then
       num_op = Pdefault_value;

    if argX < argN then do;
       argX = argX + 1;
       call ssu_$arg_ptr (sciP, argX, opP, opL);
       on conversion, size begin;
	if index(op,"-") = 1 & Pdescription = "" then do;	/* If operand optional and it begins	 */
	   argX = argX - 1;				/*  with -, assume it is ctl arg.  Save	 */
	   num_op = Pdefault_value;			/*  it for later, and return the default */
	   go to USE_DEFAULT_VALUE;			/*  value.			 */
	   end;
	else if dim(Pallowed_values,1) = dim(POSITIVE_VALUES,1) then 
	   if Pallowed_values(hbound(Pallowed_values,1)) = NONNEGATIVE_VALUES(2) then
	      go to BAD_RANGE;
	   else
	      go to BAD_OPT;
	else
	   go to BAD_OPT;
	end;
       num_op = convert (num_op, op);
       revert conversion, size;

       if dim(Pallowed_values,1) = 1 & Pallowed_values(1) = NO_ALLOWED_VALUES(1) then;
       else if dim(Pallowed_values,1) = dim(POSITIVE_VALUES,1) then do;
	if Pallowed_values(hbound(Pallowed_values,1)) = POSITIVE_VALUES(2) then do;
	   if Pallowed_values(1) <= num_op & num_op <= Pallowed_values(2) then;
	   else do;
BAD_RANGE:      call ERR (sciP, error_table_$bad_arg, "^a ^a
^a must be followed by a ^[positive^;nonnegative^] ^a.^[
Default value is:^- ^d^;^s^]",
	         Parg, op, Parg, Pallowed_values(1)=1, Pdescription, 
	         Pdefault_value ^= NO_DEFAULT_VALUE, Pdefault_value);
	      return (FALSE);
	      end;
	   end;
	else go to TEST_ARRAY;
	end;
       else do;					/* Compare with allowed values, if any.	 */
TEST_ARRAY:
	do valX = lbound(Pallowed_values,1)
	       to hbound(Pallowed_values,1)
	   while (num_op ^= Pallowed_values(valX));
	   end;
	if valX > hbound(Pallowed_values,1) then do;
BAD_OPT:	   call ERR (sciP, error_table_$bad_arg,
	      "^a ^a
^a must be followed by a^[n^] ^a.^[
Default value is:^- ^d^;^s^]^[
Allowed ^[value is^;values are^]:^-^( ^d^)^]",
	      Parg, op, Parg, ARG_vowel(Pdescription), Pdescription, 
	      Pdefault_value ^= NO_DEFAULT_VALUE, Pdefault_value,
	      ^(dim(Pallowed_values,1)=1 & Pallowed_values(1)=NO_ALLOWED_VALUES(1)),
	      dim(Pallowed_values,1)=1, Pallowed_values);
	   return (FALSE);
	   end;
	end;
       end;

    else if Pdescription ^= "" then do;
       call ERR (sciP, error_table_$noarg,
	"^/^a must be followed by a^[n^] ^a.^[
Default value is:^- ^d^;^s^]^[
Allowed ^[value is^;values are^]:^-^( ^d^)^]", Parg,
	ARG_vowel(Pdescription), Pdescription,
	Pdefault_value ^= -1, Pdefault_value,
	^(dim(Pallowed_values,1)=1 & Pdefault_value=Pallowed_values(1)),
	dim(Pallowed_values,1)=1, Pallowed_values);
       return (FALSE);
       end;

USE_DEFAULT_VALUE:
    return (TRUE);
    end ARG_get_numeric_operand;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_get_operand:									 */
/* 1) ctl_arg is name of control argument whose operand is to be obtained.			 */
/* 2) If operand is optional, description is a null string.					 */
/*    If operand is required, description is used in error message to describe the missing operand.	 */
/* 3) Returns TRUE if an operand is found, with the value in op.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARG_get_operand:
    proc (ctl_arg, description) returns (bit(1));

dcl  ctl_arg			char(*) parm,
     description			char(*) parm;

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

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

    if argX < argN then do;
       argX = argX + 1;
       call ssu_$arg_ptr (sciP, argX, opP, opL);
       return (TRUE);
       end;
    else do;
       if description ^= "" then
	call ERR (sciP, error_table_$noarg,
	"^a requires a^[n^] ^a operand.", ctl_arg, ARG_vowel(description),
	description);
       return (FALSE);
       end;

    end ARG_get_operand;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_remaining_arg_count:								 */
/*   Returns the number of unprocessed arguments.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARG_remaining_arg_count:
    procedure returns (fixed bin);
    return (max(0, argN - argX));
    end ARG_remaining_arg_count;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARG_vowel:									 */
/* 1) returns true if str begins with a vowel, false otherwise.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARG_vowel:
    proc (str) returns (bit(1));

dcl  str				char(*) parm;

dcl (search, substr)		builtin;

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

    if search ("aeiouAEIOU", substr(str,1,1)) > 0 then
       return (TRUE);
    else
       return (FALSE);

    end ARG_vowel;

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










/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARGUMENT PROCESSING FOR list_sub_tree:						 */
/*   Routines with the ARGS_ prefix process the particular arguments accepted by the lst command.	 */
/*   Routines involved include:							 */
/*										 */
/*     ARGS_init, ARGS_process							 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARGS_init:									 */
/* 1) Call fs_star_$init to initialize fs_star_.						 */
/* 2) Initialize argument-holding handler data structure, hd.				 */
/* 3) Get terminal line length for use in formatting output.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARGS_init:
    proc;

dcl  code				fixed bin(35) auto;
dcl  typeX			fixed bin auto;

    call fs_star_$init (sciP, "", "", STAR_OPTIONS_VERSION_1, star_optionsP, code);
    call ERR_fatal (sciP, code, "Calling fs_star_$init.");

    hdP = addr(auto_hd);
    hd.args.archive = FALSE;
    hd.args.debug = FALSE;
    hd.args.depth = 99;
    hd.args.inaee = FALSE;
    hd.args.length = TRUE;
    hd.args.names = FALSE;
    hd.args.selection = FALSE;
    hd.args.total = TRUE;
    hd.args.total_only = FALSE;
    hd.args.type = TRUE;

    hd.subtree.error = FALSE;
    hd.subtree.lengths = 0;

    hd.last_ent.depth = 0;
    hd.last_ent.path = "";
    hd.last_ent.type = ENTRY_TYPE_UNSET;
    hd.last_ent.uids(*) = "0"b;

    hd.ext_ent.type(*) = "";
    hd.ext_ent.count(*) = 0;
    hd.ext_ent.lengths(*) = 0;
    do typeX = lbound(STANDARD_ENTRY_TYPES,1) to hbound(STANDARD_ENTRY_TYPES,1);
       hd.ext_ent.type(typeX) = STANDARD_ENTRY_TYPES(typeX);
       end;

    max_lineL = get_line_length_$switch (null, code);
    call EXTENDED_TYPE_init();
    end ARGS_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
										 
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ARGS_process:									 */
/* 1) Loop through all input arguments, storing them in the handler data structure (hd),		 */
/*    star_options and star_paths structures, etc.					 */
/* 2) Apply argument defaults.							 */
/* 3) If errors occur, diagnose them and exit lst.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ARGS_process:
    proc;

dcl  archive_set			bit(1) aligned auto;
dcl  inaee_set			bit(1) aligned auto;
dcl  pathX			fixed bin auto;

    archive_set = FALSE;
    inaee_set = FALSE;
    do while (ARG_get());
       if index(arg, "-") = 1 then do;
	if arg = "-archives" | arg = "-archive" | arg = "-ac" then do;
	   hd.args.archive = TRUE;
	   archive_set = TRUE;
	   end;
	else if arg = "-no_archives" | arg = "-no_archive" | arg = "-nac" then do;
	   hd.args.archive = FALSE;
	   archive_set = TRUE;
	   end;

	else if arg = "-debug" | arg = "-db" then
	   hd.args.debug = TRUE;
	else if arg = "-no_debug" | arg = "-ndb" then
	   hd.args.debug = FALSE;

	else if arg = "-depth" | arg = "-dh" then do;
	   if ARG_get_numeric_operand (arg, "maximum subtree depth to scan",
	      NO_DEFAULT_VALUE, POSITIVE_VALUES) then
	      hd.args.depth = num_op + 1;
	   end;

	else if arg = "-exclude" | arg = "-ex" then do;
	   if ARG_get_operand (arg, "star name") then do;
	      if star_options.exclude_namesP = null then do;
	         exclude_names_size = ARG_remaining_arg_count() + 1;
	         call fs_star_$adjust_structure_size (star_optionsP, "exclude_names",
		  STAR_EXCLUDE_NAMES_VERSION_1, exclude_names_size, code);
	         call ERR_fatal (sciP, code, "^/Allocating exclude_names structure with ^d elements.",
		  exclude_names_size);
	         end;
	      exclude_names.count = exclude_names.count + 1;
	      exclude_names.value (exclude_names.count) = op;
	      do while (ARG_get_extra_operand());
	         exclude_names.count = exclude_names.count + 1;
	         exclude_names.value (exclude_names.count) = op;
	         end;
	      end;
	   end;
	else if arg = "-no_exclude" | arg = "-nex" then do;
	   if star_options.exclude_namesP ^= null then
	      exclude_names.count = 0;
	   end;

	else if arg = "-interpret_as_extended_entry" | arg = "-inaee" then do;
	   hd.args.inaee = TRUE;
	   inaee_set = TRUE;
	   end;
	else if arg = "-interpret_as_standard_entry" | arg = "-inase" then do;
	   hd.args.inaee = FALSE;
	   inaee_set = TRUE;
	   end;

	else if arg = "-length" | arg = "-ln" then 
	   hd.args.length = TRUE;
	else if arg = "-no_length" | arg = "-nln" then 
	   hd.args.length = FALSE;

	else if arg = "-match" then do;
	   if ARG_get_operand (arg, "star name") then do;
	      if star_options.match_namesP = null then do;
	         match_names_size = ARG_remaining_arg_count() + 1;
	         call fs_star_$adjust_structure_size (star_optionsP, "match_names",
		  STAR_MATCH_NAMES_VERSION_1, match_names_size, code);
	         call ERR_fatal (sciP, code, "^/Allocating match_names structure with ^d elements.",
		  match_names_size);
	         end;
	      match_names.count = match_names.count + 1;
	      match_names.value (match_names.count) = op;
	      do while (ARG_get_extra_operand());
	         match_names.count = match_names.count + 1;
	         match_names.value (match_names.count) = op;
	         end;
	      end;
	   end;
	else if arg = "-no_match" | arg = "-nmatch" then do;
	   if star_options.match_namesP ^= null then
	      match_names.count = 0;
	   end;

	else if arg = "-names" | arg = "-name" | arg = "-nm" | arg = "-all" | arg = "-a" then
	   hd.args.names = TRUE;
	else if arg = "-no_names" | arg = "-no_name" | arg = "-nnm" then
	   hd.args.names = FALSE;

	else if arg = "-select_entry_type" | arg = "-slet" then do;
	   if ARG_get_operand (arg, "entry type selector") then do;
	      if star_options.extended_entry_typesP = null then do;
	         extended_entry_types_size = ARG_remaining_arg_count() + 1;
	         call fs_star_$adjust_structure_size (star_optionsP, "extended_entry_types",
		  STAR_EXTENDED_ENTRY_VERSION_1, extended_entry_types_size, code);
	         call ERR_fatal (sciP, code,
		  "^/Allocating extended_entry_types structure with ^d elements.",
		  extended_entry_types_size);
	         end;
	      call EXTENDED_TYPE(op);
	      do while (ARG_get_extra_operand());
	         call EXTENDED_TYPE(op);
	         end;
	      end;
	   end;
	else if arg = "-no_select_entry_type" | arg = "-nslet" then do;
	   if star_options.extended_entry_typesP ^= null then
	      extended_entry_types.count = 0;
	   call EXTENDED_TYPE_init();
	   end;

	else if arg = "-totals" | arg = "-total" | arg = "-tt" then
	   hd.args.total = TRUE;
	else if arg = "-no_totals" | arg = "-no_total" | arg = "-ntt" then
	   hd.args.total = FALSE;

	else if arg = "-totals_only" | arg = "-total_only" | arg = "-tto" then
	   hd.args.total_only = TRUE;
	else if arg = "-no_totals_only" | arg = "-no_total_only" | arg = "-ntto" then
	   hd.args.total_only = FALSE;

	else if arg = "-types" | arg = "-type" | arg = "-tp" then 
	   hd.args.type = TRUE;
	else if arg = "-no_types" | arg = "-no_type" | arg = "-ntp" then 
	   hd.args.type = FALSE;

	else
	   call ERR (sciP, error_table_$bad_opt, arg);
	end;

       else do;
	if star_paths.count >= hbound(star_paths.value,1) then do;
	   call fs_star_$adjust_structure_size (star_optionsP, "star_paths", STAR_PATHS_VERSION_1,
	      hbound(star_paths.value,1) + 10, code);
	   call ERR (sciP, code,
	      "Calling fs_star_$adjust_structure_size to increase star_paths array size to ^d.",
	      hbound(star_paths.value,1) + 10);
	   end;
	star_paths.count = star_paths.count + 1;
	star_paths.value (star_paths.count) = arg;
	end;
       end;

    if star_paths.count = 0 then do;
       star_paths.count = 1;
       star_paths.value(1) = get_wdir_();
       end;

    if ^archive_set then do;
       do pathX = lbound(star_paths.value,1) to star_paths.count;
	if index (star_paths.value(pathX), "::") > 0 then
	   hd.args.archive = TRUE;
	end;
       if EXTENDED_TYPE_archive_comp_given() then
	hd.args.archive = TRUE;
       end;
    if ^inaee_set then
       hd.args.inaee = EXTENDED_TYPE_given();

    if star_options.exclude_namesP ^= null then
       if exclude_names.count > 0 then
          hd.args.selection = TRUE;
    if star_options.match_namesP ^= null then
       if match_names.count > 0 then
          hd.args.selection = TRUE;
    if star_options.extended_entry_typesP ^= null then
       if extended_entry_types.count > 0 then
          hd.args.selection = TRUE;

    if ERR_occurred() then
       go to EXIT;
    end ARGS_process;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* CLEANUP:									 */
/* 1) Terminate fs_star_ processing.							 */
/* 2) Destroy ssu_ invocation created to process arguments.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

CLEANUP:
    proc;

    call fs_star_$term (star_optionsP);
    call ssu_$destroy_invocation (sciP);

    end CLEANUP;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* CLEANUP_init:									 */
/* 1) Initialize variables referenced by CLEANUP handler above.				 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

CLEANUP_init:
    proc;

    star_optionsP = null;
    sciP = null;

    end CLEANUP_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* EXTENDED_TYPE:									 */
/*   This procedure converts traditional entry types (eg, directory or dr) to fs_star_		 */
/*   STANDARD_ENTRY_TYPES and stores them in the extended_entry_types structure.		 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

EXTENDED_TYPE:
    procedure (Ptypes);
    
dcl  Ptypes			char(*) parm;

dcl  standard_type			bit(1) aligned auto;
dcl  type				char(32) auto;
dcl  types			char(1000) varying auto;

    types = ltrim(rtrim(Ptypes));
    do while (types ^= "");
       standard_type = FALSE;
       type = before(types, ",");
       types = after(types, ",");

       do typeX = lbound(STANDARD_ENTRY_TYPES,1) to hbound(STANDARD_ENTRY_TYPES,1);
	if substr(STANDARD_ENTRY_TYPES(typeX),2) = type &
	   substr(STANDARD_ENTRY_TYPES(typeX),1,length("-")) = "-" then do;
	   type = STANDARD_ENTRY_TYPES(typeX);
	   standard_type = TRUE;
	   if typeX = TYPE_ARCHIVE then
	      archive_type_found = TRUE;
	   else if typeX = TYPE_ARCHIVE_COMP then
	      archive_comp_type_found = TRUE;
	   end;
	end;

       do typeX = lbound(LST_ENTRY_TYPES,1) to hbound(LST_ENTRY_TYPES,1);
	if LST_ENTRY_TYPES(typeX) = type then do;
	   type = STANDARD_ENTRY_TYPES(typeX);
	   standard_type = TRUE;
	   if typeX = TYPE_ARCHIVE then
	      archive_type_found = TRUE;
	   else if typeX = TYPE_ARCHIVE_COMP then
	      archive_comp_type_found = TRUE;
	   end;
	end;

       do typeX = lbound(ALT_ENTRY_TYPES,1) to hbound(ALT_ENTRY_TYPES,1);
	if ALT_ENTRY_TYPES(typeX) = type then do;
	   type = STANDARD_ENTRY_TYPES(typeX);
	   standard_type = TRUE;
	   if typeX = TYPE_ARCHIVE then
	      archive_type_found = TRUE;
	   else if typeX = TYPE_ARCHIVE_COMP then
	      archive_comp_type_found = TRUE;
	   end;
	end;

       if ^standard_type then
	extended_types_found = TRUE;

       if extended_entry_types.count >= extended_entry_types.max_count then do;
	extended_entry_types_size = extended_entry_types.max_count + 10;
	call fs_star_$adjust_structure_size (star_optionsP, "extended_entry_types",
	   STAR_EXTENDED_ENTRY_VERSION_1, extended_entry_types_size, code);
	call ERR_fatal (sciP, code, "^/Allocating extended_entry_types structure with ^d elements.",
	   extended_entry_types_size);
	end;
       extended_entry_types.count = extended_entry_types.count + 1;
       extended_entry_types.value (extended_entry_types.count) = type;
       end;
    end EXTENDED_TYPE;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* EXTENDED_TYPE_init:								 */
/*    This procedure initializes the flags which record whether any of the types given to -slet are	 */
/* not standard entry types.								 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

dcl  archive_comp_type_found		bit(1) aligned auto;
dcl  archive_type_found		bit(1) aligned auto;
dcl  extended_types_found		bit(1) aligned auto;

EXTENDED_TYPE_init:
    procedure();

    archive_comp_type_found = FALSE;
    archive_type_found = FALSE;
    extended_types_found = FALSE;

    return;
    


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* EXTENDED_TYPE_archive_comp_given:							 */
/*    This functions returns TRUE is any of the types given to -slet are not standard entry types..	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

EXTENDED_TYPE_archive_comp_given:
    entry() returns (bit(1) aligned);

    return (archive_comp_type_found);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* EXTENDED_TYPE_archive_given:							 */
/*    This functions returns TRUE is any of the types given to -slet are not standard entry types..	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

EXTENDED_TYPE_archive_given:
    entry() returns (bit(1) aligned);

    return (archive_type_found);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* EXTENDED_TYPE_given:								 */
/*    This functions returns TRUE is any of the types given to -slet are not standard entry types..	 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

EXTENDED_TYPE_given:
    entry() returns (bit(1) aligned);

    return (extended_types_found);

    end EXTENDED_TYPE_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ERROR REPORTING ROUTINES:								 */
/* 1) Nonfatal errors set a switch, which can be tested via error_occurred function.		 */
/* 2) Fatal errors abort the subsystem by calling ssu_$abort_subsystem, which calls the main	 */
/*    procedure's exit procedure, which branches to the EXIT label to exit the command.		 */
/*										 */
/* Syntax:  call ERR (sciP, code, ioa_ctl, args);						 */
/*	  call ERR_fatal (sciP, code, ioa_ctl, args);					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

dcl  error_occurred_sw		bit(1) auto;

ERR:
    proc options (variable);

dcl  code				fixed bin(35) based (codeP),
     codeP			ptr auto;

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),
     ioa_				entry() options(variable);

dcl  CODE_ARG			fixed bin
				int static options(constant) init(2),
     TRUE				init("1"b) bit(1)
				int static options(constant);

    call cu_$arg_ptr (CODE_ARG, codeP, 0, 0);
    if code = 0 then return;
    if code = -1 then code = 0;
    error_occurred_sw = TRUE;
    call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr());
    return;

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

ERR_fatal:
    entry options(variable);

    call cu_$arg_ptr (CODE_ARG, codeP, 0, 0);
    if code = 0 then return;
    if code = -1 then code = 0;
    error_occurred_sw = TRUE;
    call ioa_ ("");
    call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr());

    end ERR;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ERR_init:									 */
/*   Initialize nonfatal error processing routine flag, which records whether such an error has	 */
/*   occurred.									 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ERR_init:
    proc;

    error_occurred_sw = FALSE;
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ERR_occurred:									 */
/*   Returns TRUE if a nonfatal error has occurred.					 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ERR_occurred:
    entry returns (bit(1));

    return (error_occurred_sw);
    end ERR_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ERROR_ROUTINE:									 */
/*   This is the fs_star_ error handler, which is called whenever an error occurs while processing	 */
/*   entries in the subtree being listed.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ERROR_ROUTINE:
    procedure (Pstar_dataP, Pdir, Pent, Pcomp, Pcode, Pmessage, Paction);
    
dcl  Pstar_dataP			ptr parm;		/* ptr to star_data. (In)		 */
dcl  Pdir				char(*) parm;	/* dir part of entry's pathname. (In)	 */
dcl  Pent				(*) char(32) parm;	/* entry names on entry. (In)		 */
dcl  Pcomp			char(*) parm;	/* archive component name. (In)	 */
dcl  Pcode			fixed bin(35) parm; /* status code. (In)		 */
dcl  Pmessage			char(*) parm;	/* error message. (In)		 */
dcl  Paction			fixed bin parm;	/* entry action code. (Out)		 */

dcl  action			fixed bin auto;
dcl  code				fixed bin(35) auto;
dcl  dir				char(168) auto;
dcl  ent				(1) char(32) auto;
dcl  long				char(100) aligned auto;
dcl  short			char(8) aligned auto;

    Paction = ERROR_REJECT;				/* Errant entries are rejected.	 */

    star_dataP = Pstar_dataP;				/* Access data structures, including our */
    star_optionsP = star_data.star_optionsP;		/*  handler data structure.		 */
    sciP = star_options.ssu_sciP;
    hdP = star_options.handler_dataP;

    if (hd.args.depth < star_data.entry_data.depth) then	/* -depth control arg limits error msgs	 */
       return;					/*  which get printed.		 */

    if star_data.entry_data.depth <= 1 then do;		/* error occurred prior to calling 	 */
       if star_data.matched.current > 1 then		/*  hcs_$star_ to list subtree entries.	 */
	call ioa_ ("");
       call ssu_$print_message (sciP, Pcode, "^[^a^s^;^s^a^]^[^/(^a)^]",
	  Pent(1)="", Pdir, pathname_$component (Pdir, Pent(1), Pcomp), Pmessage^="", Pmessage);
       end;

    else do;					/* error occurred on a subtree entry.	 */
       if hd.args.total_only then return;		/*  Don't report if -total_only given.	 */
       hd.subtree.error = TRUE;			/*  Let HANDLER report where we are in	 */
       if Pent(1) = "" then do;			/*   the subtree before reporting the 	 */
	if hd.last_ent.path ^= Pdir then do;		/*   error.  The .error flag tells the	 */
	   call expand_pathname_ (Pdir, dir, ent(1),code);/*   HANDLER not to put lengths in the	 */
	   star_data.depth = star_data.depth - 1;	/*   subtree location.		 */
	   call HANDLER (Pstar_dataP, dir, ent, "", action);
	   star_data.depth = star_data.depth + 1;
	   end;
	end;
       else if hd.last_ent.path ^= pathname_(Pdir, Pent(1)) then
	call HANDLER (Pstar_dataP, Pdir, Pent, Pcomp, action);
       hd.subtree.error = FALSE;

       call convert_status_code_ (Pcode, short, long);	/*  Report error against subtree entry.	 */
       call ioa_ ("^[^vt^;^s^]^[^vt^;^s^]^v(   ^)^a^[^/^[^vt^;^s^]^[^vt^;^s^]^v(   ^)(^a)^]",
	hd.args.type, length(typ)+1, hd.args.length, length(len)+1+bin(hd.args.type,1)*length(typ),
	star_data.depth-1, long, Pmessage^="", hd.args.type, length(typ)+1,
	hd.args.length, length(len)+1+bin(hd.args.type,1)*length(typ), star_data.depth-1,
	Pmessage);
       end;

    hd.last_ent.depth = star_data.entry_data.depth;	/* Avoid marking errant entries as 	 */
    hd.last_ent.type = ENTRY_TYPE_UNSET;		/* <EMPTY>.			 */

    end ERROR_ROUTINE;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* HANDLER:									 */
/*    This is the fs_star_ handler routine.  It is called to process each selected entry.		 */
/* 1) Access fs_star_ and handler data structures.					 */
/* 2) Don't print location info for entries below max hierarchy level given in -depth control arg.	 */
/* 3) Figure out entry pathname, type (as lst will report it), its entry length (in pages).	 */
/* 4) If -total_only was given, return without printing information about the entry.  Only entry	 */
/*    length has been accumulated in handler data structure.				 */
/* 5) If -match, -exclude or -slet was given, then HANDLER won't be called for every subtree level,	 */
/*    but only entries which match these selection criteria.  hd.args.selection will be TRUE in such */
/*    cases.  We must call HANDLER_depth to report missing levels before printing info about the	 */
/*    selected entry.								 */
/* 6) Then call HANDLER_depth to report information about the selected entry.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

dcl  len				char(5) auto;	/* length of these vars is referenced	 */
dcl  typ				char(9) auto;	/*  in one place outside HANDLER>	 */

HANDLER:
    procedure (Pstar_dataP, Pdir, Pent, Pcomp, Paction);
    
dcl  Pstar_dataP			ptr parm;		/* ptr to star_data. (In)		 */
dcl  Pdir				char(*) parm;	/* dir part of entry's pathname. (In)	 */
dcl  Pent				(*) char(32) parm;	/* entry names on entry. (In)		 */
dcl  Pcomp			char(*) parm;	/* archive component name. (In)	 */
dcl  Paction			fixed bin parm;	/* entry action code. (Out)		 */

dcl  code				fixed bin(35) auto;
dcl (common_depthI, depthI, depthN)	fixed bin auto;
dcl  dir				char(168) auto;
dcl  ent				(1) char(32) auto;
dcl  1 last_ent			aligned like auto_hd.last_ent auto;
dcl  typeX			fixed bin auto;

    Paction = HANDLER_OK;

    star_optionsP = star_data.star_optionsP;
    hdP = star_options.handler_dataP;
    if (hd.args.depth < star_data.entry_data.depth) then do;
       Paction = HANDLER_REJECT;
       return;
       end;

    do typeX = lbound(STANDARD_ENTRY_TYPES,1) to hbound(STANDARD_ENTRY_TYPES,1)
       while (star_data.entry_data.type ^= STANDARD_ENTRY_TYPES(typeX));
       end;
    if typeX > hbound(STANDARD_ENTRY_TYPES,1) then do;
       if star_data.entry_data.type = ENTRY_TYPE_UNSET then
          typ = "    ^set";
       else if length(rtrim(star_data.entry_data.type)) <= length(typ)-1 then
	typ = copy(" ",max(length(typ)-1-length(rtrim(star_data.entry_data.type)),0)) ||
	   rtrim(star_data.entry_data.type);
       else
	typ = "     ext";
       end;
    else
       typ = PRINT_ENTRY_TYPES(typeX);

    do typeX = lbound(hd.ext_ent.type,1) to hbound(hd.ext_ent.type,1)
       while (hd.ext_ent.type(typeX) ^= "" & hd.ext_ent.type(typeX) ^= star_data.entry_data.type);
       end;					/* count occurrences of each type of	 */
    if typeX <= hbound(hd.ext_ent.type,1) then do;	/*  extended entry.			 */
       hd.ext_ent.type (typeX) = star_data.entry_data.type;
       hd.ext_ent.count(typeX) = hd.ext_ent.count(typeX) + 1;
       end;

    last_ent = hd.last_ent;

    hd.last_ent.depth = star_data.entry_data.depth;
    hd.last_ent.path = pathname_ (Pdir, Pent(1));
    hd.last_ent.type = star_data.entry_data.type;
    hd.last_ent.uids(*) = ""b; 

    if hd.last_ent.type = ENTRY_TYPE_ARCHIVE_COMP then do;
       depthN = hd.last_ent.depth-1;
       dir = Pdir;
       ent = Pent(1);
       end;
    else if (hd.last_ent.type = ENTRY_TYPE_DIRECTORY) |
            (hd.last_ent.type = ENTRY_TYPE_MSF) |
            (hd.last_ent.type = ENTRY_TYPE_ARCHIVE) then do;
       depthN = hd.last_ent.depth;
       dir = Pdir;
       ent = Pent(1);
       end;
    else do;
       depthN = hd.last_ent.depth-1;
       call expand_pathname_ (Pdir, dir, ent(1), code);
       end;

    common_depthI = 0;
    do depthI = depthN to 1 by -1;
       call hcs_$get_uid_file (dir, ent(1), hd.last_ent.uids(depthI), code);
       if code = error_table_$root then
	hd.last_ent.uids(depthI) = "777777777777"b3;
       if hd.last_ent.uids(depthI) = last_ent.uids(depthI) then do;
	common_depthI = depthI;
	do depthI = depthI-1 to 1 by -1;
	   hd.last_ent.uids(depthI) = last_ent.uids(depthI);
	   end;
	end;
       else 
	call expand_pathname_ (dir, dir, ent(1), code);
       end;

    if hd.args.length then				/* If -length given, replace type with	 */
       if hd.subtree.error then			/*  an entry length (in pages).	 */
	len = "";					/* Don't report length if processing	 */
       else					/*  subtree location for an error msg.	 */
	len = ENTRY_length(typeX);
    else len = "";
    if hd.args.total_only then return;			/* For -total_only, don't print info 	 */
						/*  about specific entries.		 */

    if ^hd.args.selection then			/* We're called for EVERY subtree entry	 */
						/*  so don't have to worry about missing */
						/*  locations in the subtree.		 */
       call HANDLER_depth (hd.last_ent.depth, typ, len, Pdir, Pent, Pcomp, last_ent);
    else if hd.last_ent.depth = 1 then			/* This entry is at TOP of a subtree, 	 */
       call HANDLER_depth (1, typ, len, Pdir, Pent, Pcomp,	/*  so don't have to worry about missing */
	last_ent);				/*  locations in the subtree.		 */

    else do;					/* Call HANDLER_depth to report missing	 */
       depthN = hd.last_ent.depth;			/*  (nonselected) subtree levels prior	 */
       if Pcomp ^= "" then depthN = depthN - 1;		/*  to reporting selected entry HANDLER	 */
       do depthI = common_depthI+1 to depthN-1;		/*  was called with.		 */
	dir = pathname_ (dir, ent(1));
	ent(1) = before (after (hd.last_ent.path, rtrim(dir)||">"), ">");
	call HANDLER_depth (depthI, PRINT_ENTRY_TYPES(TYPE_DIRECTORY), "", dir, ent, "", last_ent);
	last_ent.depth = depthI;
	last_ent.type = ENTRY_TYPE_DIRECTORY;
	end;
       if (Pcomp ^= "") & (depthI < hd.last_ent.depth) then do;
	call HANDLER_depth (depthI, PRINT_ENTRY_TYPES(TYPE_ARCHIVE), "", Pdir, Pent, "", last_ent);
	last_ent.depth = depthI;
	last_ent.type = ENTRY_TYPE_ARCHIVE;
	end;
       call HANDLER_depth (star_data.entry_data.depth, typ, len, Pdir, Pent, Pcomp, last_ent);
       end;					/* Report the selected entry.		 */
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* HANDLER_depth:									 */
/*    Report information about a single entry in the subtree.  Before reporting about the current	 */
/*    entry, it figures out whether the prior (directory/archive) entry was empty and reports if it	 */
/*    was.  Most of the complexity comes from this Emptiness reporting.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

HANDLER_depth:
    procedure (Pdepth, Ptyp, Plen, Pdir, Pent, Pcomp, Plast_ent);
    
dcl  Pdepth			fixed bin parm;	/* depth below star_paths dir. (In)	 */
dcl  Ptyp				char(9) parm;	/* printable type of entry. (In)	 */
dcl  Plen				char(5) parm;	/* printable length of entry. (In)	 */
dcl  Pdir				char(*) parm;	/* dir part of entry's pathname. (In)	 */
dcl  Pent				(*) char(32) parm;	/* entry names on entry. (In)		 */
dcl  Pcomp			char(*) parm;	/* archive component name. (In)	 */
dcl  1 Plast_ent			aligned like last_ent;
						/* info about prior entry. (In)	 */

dcl (STARTING			init(1),
     NEW_SUBTREE			init(2),
     DOWN_DIR			init(3),
     ANOTHER_ENTRY			init(4),
     UP_DIR			init(5),
     NEW_ARCHIVE			init(6),
     ANOTHER_COMP			init(7)
     )				fixed bin int static options(constant);

    if Pdepth <= 1 then
       if star_data.matched.current <= 1 then
	go to PROCESS (STARTING);			/* Begin the first subtree.		 */
       else
	go to PROCESS (NEW_SUBTREE);			/* Begin another subtree.		 */

    else if Pdepth < Plast_ent.depth then
       go to PROCESS (UP_DIR);			/* End reporting on a subdir.		 */

    else if (Pdepth > Plast_ent.depth) then
       if (Pcomp = "") then
	go to PROCESS (DOWN_DIR);			/* Begin reporting on a subdir.	 */
       else
	go to PROCESS (NEW_ARCHIVE);			/* Begin reporting on archive components.*/

    else if Pcomp = "" then
       go to PROCESS (ANOTHER_ENTRY);			/* Process another subdir entry.	 */
    else
       go to PROCESS (ANOTHER_COMP);


PROCESS (NEW_SUBTREE):				/* If prior entry was a dir, and it is	 */
    if (Plast_ent.type = ENTRY_TYPE_DIRECTORY |		/*  empty, say that.  Same for archives	 */
      ((Plast_ent.type = ENTRY_TYPE_ARCHIVE) & hd.args.archive)) & (hd.args.depth>Pdepth) & 
     ^hd.args.selection then				/*  if we are searching them.		 */
       call ioa_ ("^[^vt^;^s^]^[^vt^;^s^]^v(   ^)<EMPTY>^[ NEW_SUBTREE^]",
          hd.args.type, length(typ)+1, hd.args.length, length(len)+1+bin(hd.args.type,1)*length(typ),
          Plast_ent.depth, hd.args.debug);
    call ioa_ ("");

PROCESS (STARTING):
    call ioa_ ("^[^a^vt^;^2s^]^[^a^vt^;^2s^]^a", hd.args.type, Ptyp, length(typ)+1,
       hd.args.length, Plen, length(len)+1+bin(hd.args.type,1)*length(typ),
       NAMES_output (Pdepth, pathname_ (Pdir,Pent(1))));
    return;

PROCESS (UP_DIR):
PROCESS (ANOTHER_ENTRY):				/* If prior entry was a dir, and it is	 */
    if (Plast_ent.type = ENTRY_TYPE_DIRECTORY |		/*  empty, say that.  Same for archives	 */
						/*  if we are searching them.		 */
      ((Plast_ent.type = ENTRY_TYPE_ARCHIVE) & hd.args.archive)) & (hd.args.depth>Pdepth) & 
     ^hd.args.selection then
       call ioa_ ("^[^vt^;^s^]^[^vt^;^s^]^v(   ^)<EMPTY>^[ ANOTHER_ENTRY^]",
	hd.args.type, length(typ)+1, hd.args.length, length(len)+1+bin(hd.args.type,1)*length(typ),
          Pdepth, hd.args.debug);

PROCESS (DOWN_DIR):
    call ioa_ ("^[^a^vt^;^2s^]^[^a^vt^;^2s^]^v(   ^)^a", hd.args.type, Ptyp, length(typ)+1,
       hd.args.length, Plen, length(len)+1+bin(hd.args.type,1)*length(typ), Pdepth-1, 
       NAMES_output(Pdepth, Pent(1)));
    return;

PROCESS (NEW_ARCHIVE):
PROCESS (ANOTHER_COMP):
    call ioa_ ("^[^a^vt^;^2s^]^[^a^vt^;^2s^]^v(   ^)^a", hd.args.type, Ptyp, length(typ)+1,
       hd.args.length, Plen, length(len)+1+bin(hd.args.type,1)*length(typ), Pdepth-1, Pcomp);
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* NAMES_output:									 */
/* 1) When -names was given, return a string containing the first name on an entry (or starting path */
/*    of a subtree), followed by comma-separated list of the other names.			 */
/* 2) When -no_names was given, just return the first name (subtree path).			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

NAMES_output:
    procedure (Pdepth, first_name) returns (char(1000) varying);
    
dcl  Pdepth			fixed bin parm;	/* depth below star_paths dir. (In)	 */
dcl  first_name			char(*) parm;

dcl  indentL			fixed bin auto;
dcl  lineL			fixed bin auto;
dcl  name				char(32) varying auto;
dcl  names			char(1000) varying auto;
dcl  nameX			fixed bin auto;

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

    names = rtrim(first_name);
    if ^hd.args.names then return(names);

    indentL = min(100, (length(Ptyp) * bin(hd.args.type,1)) + (length(Plen) * bin(hd.args.length,1))
       +  (3 * (Pdepth-1)) + length(" "));		/* multiple names are put as many as 	 */
    lineL = indentL + length(names);			/*  will fit on a terminal line.  	 */
    do nameX = 2 to hbound(Pent,1);			/* Subsequent lines are indented at 	 */
       name = rtrim(Pent(nameX));			/*  subtree level + 1.		 */
       if length(name) + length(", ") + lineL > max_lineL then do;
	names = names || ",";
	names = names || NL;
	names = names || substr(SPACES,1,indentL);
	lineL = indentL;
	end;
       else
	names = names || ", ";
       names = names || name;
       lineL = lineL + length(name) + length(", ");
       end;
    return (names);

    end NAMES_output;

    end HANDLER_depth;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* ENTRY_length:									 */
/* 1) Call hcs_$status_ to get length (in pages) of a particular entry.  This cannot get the length	 */
/*    of inner ring entries (eg, .mbx or .ms segments), so 0 is returned for such entries.	 */
/* 2) Also accumulate length of all entries in handler data structure.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

ENTRY_length:
    procedure (PtypeX) returns(char(4));
    
dcl  PtypeX			fixed bin parm;

dcl  code				fixed bin(35) auto;
dcl  digits			pic"zzz9" auto;
dcl  pages			fixed bin(35) auto;
dcl (quota, quota_used)		fixed bin(18) auto;
dcl  NO_CHASE			fixed bin(1) int static options(constant) init(0);

    if star_data.entry_data.type = ENTRY_TYPE_LINK |
       star_data.entry_data.type = ENTRY_TYPE_ARCHIVE_COMP |
       star_data.entry_data.type = ENTRY_TYPE_UNKNOWN |
       star_data.entry_data.type = ENTRY_TYPE_UNSET then
       return ("");
    call hcs_$status_ (Pdir, Pent(1), NO_CHASE, addr(status), null, code);
    if (code ^= 0) & (code ^= error_table_$no_s_permission) then
       return("");
    pages = status.records_used;
    if star_data.entry_data.type = "forum" then do;
       call hcs_$quota_read (pathname_ (Pdir, Pent(1)), quota, 0, ""b, ""b, 0, quota_used, code);
       if code = 0 then
	pages = pages + quota_used;
       end;
    hd.subtree.lengths = hd.subtree.lengths + pages;
    hd.ext_ent.lengths(PtypeX) = hd.ext_ent.lengths(PtypeX) + pages;
    digits = pages;
    return (digits);

    end ENTRY_length;

    end HANDLER;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* TOTAL_print:									 */
/*   Adds totals information about particular entry types to the pending output lines.  If the lines */
/*   overflow terminal line length, they are printed and new lines are started.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

dcl (line1, line2, line3)		char(160) varying auto;

TOTAL_print:
    procedure (Pprefix1, Pprefix2, Pprefix3, Ptype, Pcount, Plength);
    
dcl (Pprefix1, Pprefix2, Pprefix3)	char(*) parm;
dcl  Ptype			char(*) parm;
dcl  Pcount			fixed bin parm;
dcl  Plength			fixed bin(35) parm;

dcl  1 field			aligned auto,
       2 (type,  count, length)	char(32) varying,
       2 L			fixed bin,
       2 (typeI, countI, lengthI)	fixed bin;

dcl  length			builtin;

    if Pcount <= 0 then return;

    field.type  = rtrim (Ptype);			/* get length of field label and value.	 */
    field.count = ltrim (char(Pcount));			/* center label/value with entire field. */
    field.length = ltrim (char(Plength), " 0");
    if length(field.count) < length(field.length) then
       field.count = substr(SPACES, 1, length(field.length)-length(field.count)) || field.count;
    else if length(field.count) > length(field.length) then
       field.length = substr(SPACES, 1, length(field.count)-length(field.length)) || field.length;
    if hd.args.length then
       field.L = max (length(field.type), length(field.count), length(field.length));
    else
       field.L = max (length(field.type), length(field.count));
    field.typeI  = divide (field.L-length(field.type)+1, 2, 17, 0);
    field.countI = divide (field.L-length(field.count)+1, 2, 17, 0);
    field.lengthI = divide (field.L-length(field.length)+1, 2, 17, 0);

    if (index(line2, Pprefix2) = 0) & (length(Pprefix2) > 0) then do;
       if length(line2) + field.L + length((4)" ") + length(Pprefix2) > max_lineL then
	call TOTAL_print_end (Pprefix1, Pprefix2, Pprefix3);
       else do;					/* Put EXTENDED ENTRIES id in current	 */
	line1 = line1 || (4)" ";			/*  output lines, if not already there.	 */
	line2 = line2 || (4)" ";
	line3 = line3 || (4)" ";
	line1 = line1 || Pprefix1;
	line2 = line2 || Pprefix2;
	line3 = line3 || Pprefix3;
	end;
       end;
    else if length(line1) + field.L + length((2)" ") > max_lineL then
       call TOTAL_print_end (Pprefix1, Pprefix2, Pprefix3);	/* Emit output lines if they are about 	 */
						/*  to overflow.			 */

    if length(line1) > 0 then do;			/* Put label and value into output lines.*/
       line1 = line1 || (2)" ";
       line2 = line2 || (2)" ";
       line3 = line3 || (2)" ";
       end;
    line1 = line1 || substr(SPACES,1,field.typeI);
    line2 = line2 || substr(SPACES,1,field.countI);
    line3 = line3 || substr(SPACES,1,field.lengthI);
    line1 = line1 || field.type;
    line2 = line2 || field.count;
    line3 = line3 || field.length;
    line1 = line1 || substr(SPACES,1,field.L - field.typeI - length(field.type));
    line2 = line2 || substr(SPACES,1,field.L - field.countI - length(field.count));
    line3 = line3 || substr(SPACES,1,field.L - field.lengthI - length(field.length));

    end TOTAL_print;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* TOTAL_print_end:									 */
/*   Print current output lines.  Put prefix on a new set of output lines.			 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

TOTAL_print_end:
    procedure (Pprefix1, Pprefix2, Pprefix3);

dcl (Pprefix1, Pprefix2, Pprefix3)	char(*) parm;

    if length(line2) > length(Pprefix2) then 
       call ioa_ ("^a^/^a^/^[^a^/^]", line1, line2,
	hd.args.length & (sum(hd.ext_ent.lengths)>0), line3);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */
/*										 */
/* TOTAL_print_init:								 */
/*   Put prefix on a new set of output lines.						 */
/*										 */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

TOTAL_print_init:
    entry (Pprefix1, Pprefix2, Pprefix3);

    line1 = Pprefix1;
    line2 = Pprefix2;
    line3 = Pprefix3;
    return;

    end TOTAL_print_end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	 */

%include fs_star_;

%include status_structures;

dcl  1 status			aligned auto like status_branch;

    end list_sub_tree;




		    print.pl1                       06/09/89  1259.1rew 06/09/89  1255.2      616140



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



/****^  HISTORY COMMENTS:
  1) change(68-04-28,Garman), approve(), audit(), install():
     Written by C. Garman.
  2) change(68-10-02,Garman), approve(), audit(), install():
     Modified to call write directly for entire segment or portion
      thereof, give ending-line request.
  3) change(69-07-16,Weaver), approve(), audit(), install():
     Modified by M. Weaver to change smm$initiate and some write_out
      calls.
  4) change(69-08-03,Voydock), approve(), audit(), install():
     Modified by V. Voydock.
  5) change(69-08-06,Weaver), approve(), audit(), install():
     Modified by M. Weaver (August 6 and August 8).
  6) change(69-08-11,Weaver), approve(), audit(), install():
     Modified by M. Weaver (add hcs_$status_minf)
  7) change(70-03-04,Karger), approve(), audit(), install():
     Modified by P. Karger (compiled under PL/I and prints date and time
      in header)
  8) change(70-03-25,Karger), approve(), audit(), install():
     Modified by P. Karger to change calls to tio_ to ios_
  9) change(70-06-19,Stone), approve(), audit(), install():
     Modified by E. Stone.
 10) change(76-10-27,VanVleck), approve(), audit(), install():
     Rewritten by THVV for new arguments, iox, etc.
 11) change(79-08-03,VanVleck), approve(), audit(), install():
     Modified by THVV for archive stuff.  Much help by MND.
 12) change(82-09-13,GDixon), approve(), audit(), install():
     Modified by G. Dixon -- when indenting, properly indent lines preceded
      by NP and VT chars.  Accept -in as short name for -indent (-ind).  Use
      prt_conv_ when -indent I is specified, where mod(I,10) ^= 0.  Fix bug
      which prevents -line_length from being honored.
 13) change(82-11-22,Wallman), approve(), audit(), install():
     Modified by E. Wallman:  Fixed bug that printed extra lines when -for
      was used with -pn.  Reformatted with format_pl1.
 14) change(82-11-24,Wallman), approve(), audit(), install():
     Modified by E. Wallman:  Fixed bug that left the last page short when
      -ppl and -no_vertsp were given.  Renamed many variables for readability.
 15) change(82-11-26,Wallman), approve(), audit(), install():
     Modified by E. Wallman:  Fixed remaining problems in error list thru #10.
 16) change(83-07-11,Texada), approve(), audit(), install():
     Modified by Greg Texada:  added -output_switch, -osw control args.
 17) change(83-09-28,GDixon), approve(), audit(), install():
     Modified by Gary Dixon:  simplify scheme for processing a line.
 18) change(83-12-01,Spitzer), approve(), audit(), install():
     Modified by C. Spitzer:  fix error msg, use pathname_.
 19) change(84-03-08,Spitzer), approve(), audit(), install():
     Modified by C. Spitzer:  use iox_$get_line to pause.
 20) change(84-07-10,Rochlis), approve(), audit(), install():
     Modified by Jon A. Rochlis:  do a reset_more control order before
      printing each file to make video users happy.
 21) change(84-08-21,Falksenj), approve(), audit(), install():
     Modified by J. A. Falksen:  utilize date_time_$format ("date_time",...
 22) change(85-01-10,Lippard), approve(85-01-30,MCR7165),
     audit(85-10-07,Blair), install(85-12-16,MR12.0-1001):
     Modified by Jim Lippard:  force vertsp mode when -vertsp is used, use
      initiate_file_ and terminate_file_, fix bug where -left_col blows up
      on first line of length greater than lc value.
 23) change(86-10-09,TLNguyen), approve(86-10-28,MCR7563),
     audit(86-10-29,Gilcrease), install(86-11-20,MR12.0-1217):
     Modified by Tai Nguyen: make the print command to display exactly
      n lines for a specified segment when the "-for" control argument
      was used.  Fixed an array subscriptrange codition at the run time
      when compiled with the following:
      -table -prefix size, strz, strg, subrg
 24) change(86-11-17,TLNguyen), approve(86-10-28,MCR7563),
     audit(86-11-17,Gilcrease), install(86-11-20,MR12.0-1217):
     Fixed bug which occurs when the line starts with a New Page character
     and the "-from" control argument is entered in the "print" command.
 25) change(86-11-26,TLNguyen), approve(86-11-26,MCR7563),
     audit(86-12-01,Gilcrease), install(86-12-02,MR12.0-1230):
     Fixed error which occurs when the two control arguments -for and -match
     work together in the print command.
 26) change(87-01-02,TLNguyen), approve(87-01-02,MCR7597),
     audit(87-01-09,Lippard), install(87-03-20,MR12.1-1006):
     Make the print command display an appropriative error message and do a
     reset_more control order between archive components for archive case.
 27) change(88-08-02,TLNguyen), approve(88-08-02,MCR7935),
     audit(88-08-30,Parisek), install(88-09-02,MR12.2-1097):
     make the print command with the -from_page P work as documented.
 28) change(89-04-28,Vu), approve(89-04-28,MCR8098), audit(89-05-08,Lee),
     install(89-06-09,MR12.3-1057):
     The print command will not enable the user's terminal mode to "vertsp".
     Delete all references to iox_$modes and sws.reset_modes by vp
     (phx20749 - Commands 514) and (phx20361 - Commands 762).
     Reformatted print.pl1
                                                   END HISTORY COMMENTS */


/* format: style2,ind3,ll80,dclind4,comcol51,linecom */

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* Name: print, pr						       */
/*							       */
/* print ASCII text file on user console.			       */
/*							       */
/* Note: There is a known bug in this program which is fixable only by an    */
/* unreasonable amount of effort.  The -match, -exclude, -from and -to       */
/* control arguments will not find their target strings if it happens that   */
/* they are split across MSF components. Fixing this bug would require a lot */
/* of hair, incluing a buffer somewhere big enough for the reassembly of the */
/* split line.  For now we ignore it.  Anybody who wants to fix it is        */
/* welcome to.						       */
/*							       */
/*							       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * *  *  *  * */


print:
pr:
   procedure;

      dcl arg		   char (arg_len) unaligned based (arg_ptr);
      dcl arg_len		   fixed bin (21);
      dcl arg_list_ptr	   ptr;
      dcl arg_ptr		   ptr;
      dcl c		   fixed bin (35);
      dcl error_code	   fixed bin (35);
      dcl exclude_arg_count	   fixed bin;	/* number of -exclude args */
      dcl forcount		   fixed bin;	/* # of input lines to print */
      dcl from_line		   fixed bin;	/* starting line */
      dcl from_page		   fixed bin;	/* lowest page number to print */
      dcl from_regexpr	   char (from_regexpr_len + 2)
			   based (from_regexpr_ptr);
      dcl from_regexpr_len	   fixed bin (21);	/* length of above */
      dcl from_regexpr_ptr	   ptr;		/* starting reg exp */
      dcl iarg		   fixed bin;	/* arg number */
      dcl indentation	   fixed bin (21);	/* indentation */
      dcl input_path_count	   fixed bin;	/* number of pathnames (zero, one, or more) */
      dcl junk		   fixed bin;
      dcl last_count	   fixed bin;
      dcl left_col		   fixed bin;	/* left side of print band */
      dcl match_arg_count	   fixed bin;	/* number of -match args */
      dcl nargs		   fixed bin;	/* arg count */
      dcl output_buffer_size	   fixed bin;	/* size of print buffer */
      dcl out_switch	   ptr;		/* write output on this */
					/* switch; its assumed */
					/* attached & open for */
					/* stream output. */
      dcl right_col		   fixed bin;	/* right side of print band */
      dcl star_sel		   fixed bin (2);	/* branches, or branches+links */
      dcl switch_name	   char (32);	/* plain talk name of -osw */
      dcl to_line		   fixed bin;	/* ending line */
      dcl to_page		   fixed bin;	/* highest */
      dcl to_regexpr_len	   fixed bin (21);
      dcl to_regexpr_ptr	   ptr;		/* ending reg exp */

      dcl 1 sws,				/* switch bits */
	  2 check_lines	   bit (1),	/* TRUE if -match or -ex */
	  2 dont_want_archive  bit (1),	/* TRUE if print archive as big file */
	  2 from_line_given	   bit (1),
	  2 from_page_given	   bit (1),
	  2 had_an_arg	   bit (1),	/* TRUE if any arg */
	  2 last_given	   bit (1),
	  2 no_heading	   bit (1),	/* TRUE if dont want heading */
	  2 no_vertsp	   bit (1),	/* TRUE if simulating NP and VT */
	  2 one_iox_call	   bit (1),	/* TRUE if can do in one call to iox */
	  2 paging	   bit (1),	/* TRUE if paged output is wanted */
	  2 pause_after_page   bit (1),	/* TRUE if pause after page */
	  2 pause_before_print bit (1),	/* TRUE if pause before printing */
	  2 print_quick_way	   bit (1),	/* TRUE if can do without prt_conv */
	  2 print_trailing_nls bit (1),	/* TRUE if print some NLs at end like old print */
	  2 to_line_given	   bit (1),
	  2 to_page_given	   bit (1),
	  2 want_heading	   bit (1),	/* TRUE if print heading */
	  2 want_line_numbers  bit (1);	/* TRUE if print line numbers */

      dcl archive_$next_component_info
			   entry (ptr, fixed bin (24), ptr, ptr,
			   fixed bin (35));
      dcl check_star_name_$entry entry (char (*), fixed bin (35));
      dcl com_err_		   entry options (variable);
      dcl cu_$arg_count	   entry (fixed bin, fixed bin (35));
      dcl cu_$arg_list_ptr	   entry (ptr);
      dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin (21),
			   fixed bin (35));
      dcl cu_$arg_ptr_rel	   entry (fixed bin, ptr, fixed bin (21),
			   fixed bin (35), ptr);
      dcl cv_dec_check_	   entry (char (*), fixed bin (35))
			   returns (fixed bin);
      dcl date_time_$format	   entry (char (*), fixed bin (71), char (*),
			   char (*)) returns (char (250) var);
      dcl expand_pathname_$component
			   entry (char (*), char (*), char (*), char (*),
			   fixed bin (35));
      dcl get_system_free_area_  entry () returns (ptr);
      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 initiate_file_	   entry (char (*), char (*), bit (*), ptr,
			   fixed bin (24), fixed bin (35));
      dcl ioa_$ioa_switch	   entry options (variable);
      dcl ioa_$ioa_switch_nnl	   entry options (variable);
      dcl ioa_$rsnp		   entry options (variable);
      dcl iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
      dcl iox_$get_line	   entry (ptr, ptr, fixed bin (21),
			   fixed bin (21), fixed bin (35));
      dcl iox_$look_iocb	   entry (char (*), ptr, fixed bin (35));
      dcl iox_$put_chars	   entry (ptr, ptr, fixed bin (21),
			   fixed bin (35));
      dcl match_star_name_	   entry (char (*), char (*), 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 pathname_		   entry (char (*), char (*))
			   returns (char (168));
      dcl pathname_$component	   entry (char (*), char (*), char (*))
			   returns (char (194));
      dcl print_conv_$print_conv_
			   entry;
      dcl prt_conv_		   entry (ptr, fixed bin (21), ptr,
			   fixed bin (21), ptr);
      dcl search_file_	   entry (ptr, fixed bin (21), fixed bin (21),
			   ptr, fixed bin (21), fixed bin (21),
			   fixed bin (21), fixed bin (21), fixed bin (35))
			   ;
      dcl search_file_$silent	   entry (ptr, fixed bin (21), fixed bin (21),
			   ptr, fixed bin (21), fixed bin (21),
			   fixed bin (21), fixed bin (21), fixed bin (35))
			   ;
      dcl terminate_file_	   entry (ptr, fixed bin (24), bit (*),
			   fixed bin (35));

      dcl (addr, clock, codeptr, divide, index, length, max, min, mod, null,
	reverse, rtrim, search, string, substr, sum, unspec)
			   builtin;
      dcl cleanup		   condition;

      dcl CR		   char (1) int static options (constant)
			   init ("");
      dcl NL		   char (1) int static options (constant) init ("
");
      dcl NLCRVTNP		   char (4) int static options (constant) init ("
");
      dcl NP		   char (1) int static options (constant) init ("");
      dcl NUL		   char (1) int static options (constant)
			   init ("");
      dcl VT		   char (1) int static options (constant) init ("");
      dcl LONGEST_SEARCH_FILE_REXP
			   fixed bin static options (constant) init (132);
      dcl MAX_BUFFER_LTH	   fixed bin int static options (constant)
			   init (1025);	/* types returned by check_star_name_ */
      dcl 1 type		   static options (constant),
	  2 NOSTAR	   fixed bin (35) init (0),
	  2 STAR		   fixed bin (35) init (1),
	  2 STARSTAR	   fixed bin (35) init (2);
      dcl TERMINATE_SEG	   bit (4) internal static options (constant)
			   init ("0010"b);

      dcl error_table_$bad_conversion
			   fixed bin (35) ext static;
      dcl error_table_$badopt	   fixed bin (35) ext static;
      dcl error_table_$dirseg	   fixed bin (35) ext static;
      dcl error_table_$inconsistent
			   fixed bin (35) ext static;
      dcl error_table_$long_record
			   fixed bin (35) ext static;
      dcl error_table_$noarg	   fixed bin (35) ext static;
      dcl error_table_$no_component
			   fixed bin (35) ext static;
      dcl error_table_$nomatch   fixed bin (35) ext static;
      dcl error_table_$regexp_undefined
			   fixed bin (35) ext static;
      dcl error_table_$zero_length_seg
			   fixed bin (35) ext static;
      dcl iox_$user_input	   ptr ext static;
      dcl iox_$user_output	   ptr ext static;
%page (2);
/* ======================================================== */

/* Set up default values */

      star_sel = star_BRANCHES_ONLY;		/* default is -no_chase */
      from_line, from_page = 1;		/* default is to print whole file */
      to_page = -1;
      match_arg_count, exclude_arg_count, to_line, indentation, forcount,
	 from_regexpr_len, to_regexpr_len, input_path_count = 0;
      string (sws) = "0"b;
      right_col = MAX_BUFFER_LTH;
      last_count, left_col = 1;

      pcip = addr (PCI);
      unspec (PCI) = ""b;
      pci.cv_proc = codeptr (print_conv_$print_conv_);
      pci.line = 1;
      pci.phys_line_length = MAX_BUFFER_LTH;
      pci.ctl_char = "1"b;
      pci.lpi = 6;
      pci.sheets_per_page = 1;
      pci.top_label_line = "";
      pci.bot_label_line = "";
      pci.overflow_off = "1"b;		/* Don't put in NP */
      pci.label_wksp = null;
      pci.label_nelem = 0;
      switch_name = "user_output";		/* default switch */
      out_switch = iox_$user_output;

/* Analyze all the control arguments. */

      call cu_$arg_list_ptr (arg_list_ptr);
      call cu_$arg_count (nargs, error_code);
      if error_code ^= 0
      then
         do;
	  call com_err_ (error_code, "print");	/* can't be AF */
	  return;
         end;

      do iarg = 1 to nargs;			/* preprocess the args */
         call cu_$arg_ptr (iarg, arg_ptr, arg_len, error_code);
         if error_code ^= 0
         then
	  do;
ARG_READ_ERR:
	     call com_err_ (error_code, "print", "Argument ^d.", iarg);
RETURN:
	     return;
	  end;

         if index (arg, "-") ^= 1		/* number or pathname? */
         then
	  do;
	     junk = cv_dec_check_ (arg, error_code);

	     if error_code = 0		/* its a number */
	     then
	        do;
		 if input_path_count = 0	/* make "print 0" work as it used to */
		 then goto its_a_name;

		 if junk = 0		/* 0's are not allowed */
		 then
		    do;
		       error_code = error_table_$bad_conversion;
		       goto ARG_ERR;
		    end;

		 if ^sws.from_line_given
		 then
		    do;
		       from_line = junk;
		       sws.from_line_given = "1"b;
		    end;

		 else if ^sws.to_line_given
		 then
		    do;
		       to_line = junk;
		       sws.to_line_given = "1"b;
		    end;

		 else
		    do;
		       call com_err_ (error_table_$inconsistent, "print",
			  "Only one line range is allowed. ^a", arg);
		       return;
		    end;
		 sws.had_an_arg = "1"b;
	        end;

	     else
	        do;			/* non-numeric */
		 if search (arg, "*?") ^= 0	/* pretend starname matches 2 */
		 then input_path_count = input_path_count + 1;
its_a_name:				/* count file names */
		 input_path_count = input_path_count + 1;
	        end;
	  end;

         else
	  do;
	     sws.had_an_arg = "1"b;

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

		 if iarg > nargs
		 then
		    do;
miss_arg:
		       call com_err_ (error_table_$noarg, "print",
			  "After ^a.", arg);
		       return;
		    end;			/* count file names */
		 input_path_count = input_path_count + 1;
	        end;

	     else if arg = "-from" | arg = "-fm"
	     then call GET_FROM_TO (sws.from_line_given, from_regexpr_ptr,
		     from_regexpr_len, from_line);

	     else if arg = "-to"
	     then call GET_FROM_TO (sws.to_line_given, to_regexpr_ptr,
		     to_regexpr_len, to_line);

	     else if arg = "-for"
	     then forcount = GETNUM ();

	     else if arg = "-from_page"
	     then
	        do;
		 sws.from_page_given = "1"b;
		 from_page = GETNUM ();
	        end;

	     else if arg = "-to_page"
	     then
	        do;
		 sws.to_page_given = "1"b;
		 to_page = GETNUM ();
	        end;

	     else if arg = "-indent" | arg = "-ind" | arg = "-in"
	     then indentation = GETNUM ();

	     else if arg = "-last" | arg = "-lt"
	     then
	        do;
		 sws.last_given = "1"b;
		 last_count = GETNUM ();
	        end;

	     else if arg = "-left_col" | arg = "-lc"
	     then left_col = GETNUM ();

	     else if arg = "-right_col" | arg = "-rc"
	     then right_col = GETNUM ();

	     else if arg = "-line_length" | arg = "-ll"
	     then pci.phys_line_length = GETNUM ();

	     else if arg = "-page_length" | arg = "-pl"
	     then
	        do;
		 pci.page_length = GETNUM ();
		 pci.overflow_off = "0"b;	/* Do NP */
	        end;

	     else if arg = "-phys_page_length" | arg = "-ppl"
	     then pci.phys_page_length = GETNUM ();

	     else if arg = "-stop" | arg = "-sp"
	     then
	        do;			/* pause after each page */
		 sws.pause_after_page = "1"b;
		 sws.pause_before_print = "1"b;
	        end;

	     else if arg = "-wait" | arg = "-wt"
	     then sws.pause_before_print = "1"b;

	     else if arg = "-header" | arg = "-he"
	     then
	        do;
		 sws.want_heading = "1"b;
		 sws.no_heading = "0"b;
	        end;

	     else if arg = "-no_header" | arg = "-nhe"
	     then sws.no_heading = "1"b;

	     else if arg = "-no_archive" | arg = "-nac"
	     then sws.dont_want_archive = "1"b;

	     else if arg = "-archive" | arg = "-ac"
	     then sws.dont_want_archive = "0"b;

	     else if arg = "-no_vertsp"
	     then sws.no_vertsp = "1"b;

	     else if arg = "-vertsp"
	     then sws.no_vertsp = "0"b;

	     else if arg = "-match"
	     then
	        do;
		 if iarg >= nargs
		 then goto miss_arg;

		 iarg = iarg + 1;
		 match_arg_count = match_arg_count + 1;
	        end;

	     else if arg = "-ex" | arg = "-exclude"
	     then
	        do;
		 if iarg >= nargs
		 then goto miss_arg;

		 iarg = iarg + 1;
		 exclude_arg_count = exclude_arg_count + 1;
	        end;

	     else if arg = "-number" | arg = "-nb"
	     then sws.want_line_numbers = "1"b;

	     else if arg = "-chase"
	     then star_sel = star_ALL_ENTRIES;

	     else if arg = "-no_chase"
	     then star_sel = star_BRANCHES_ONLY;

	     else if arg = "-output_switch" | arg = "-osw"
	     then
	        do;
		 iarg = iarg + 1;
		 call cu_$arg_ptr (iarg, arg_ptr, arg_len, error_code);
		 if error_code ^= 0
		 then goto ARG_READ_ERR;

		 call iox_$look_iocb (arg, out_switch, error_code);
		 if error_code ^= 0
		 then
		    do;
		       call com_err_ (error_code, "print",
			  "Looking for output switch ^a", arg);
		       goto RETURN;
		    end;
		 switch_name = arg;
	        end;

	     else
	        do;			/* illegal */
		 error_code = error_table_$badopt;
ARG_ERR:
		 call com_err_ (error_code, "print", "^a", arg);
		 return;
	        end;
	  end;
      end;

/* Control arguments are processed */

      if input_path_count = 0
      then
         do;
	  call com_err_ (error_table_$noarg, "print", "No pathname given.");
	  return;
         end;

      if (switch_name ^= "user_output")
	 & (sws.pause_before_print | sws.pause_after_page)
      then				/* Can't give -stop or */
         do;				/* -wait with -osw */
	  call com_err_ (error_table_$inconsistent, "print",
	       "-output_switch cannot be used with ^[-stop^;-wait^].",
	       sws.pause_after_page);
	  return;
         end;

      if (sws.to_page_given | sws.from_page_given)
	 & (sws.from_line_given | sws.to_line_given)
      then
         do;
	  call com_err_ (error_table_$inconsistent, "print",
	       "Page and line specifiers cannot be used together.");
	  return;
         end;

      if sws.from_line_given & sws.last_given
      then
         do;
	  call com_err_ (error_table_$inconsistent, "print",
	       "-from and -last cannot be used together.");
	  return;
         end;

      if sws.to_line_given & sws.from_line_given & to_line < from_line
	 & from_regexpr_len + to_regexpr_len = 0/* but no REs in the range */
      then
         do;
	  call com_err_ (error_table_$inconsistent, "print",
	       "-from ^d > -to ^d", from_line, to_line);
	  return;
         end;

      if sws.from_page_given & sws.to_page_given & to_page < from_page
      then
         do;
	  call com_err_ (error_table_$inconsistent, "print",
	       "-from_page ^d > -to_page ^d", from_page, to_page);
	  return;
         end;

      if right_col < left_col
      then
         do;
	  call com_err_ (error_table_$inconsistent, "print",
	       "-left_col ^d > -right_col ^d", left_col, right_col);
	  return;
         end;

      if pci.phys_line_length < 5		/* prt_conv_ cannot handle length < 5. */
      then				/* It gives fatal process errors when  */
         do;				/* attempting to process HT char. */
	  call com_err_ (0, "print",
	       "Implementation restriction: -line_length must be greater than 4."
	       );
	  return;
         end;

      sws.check_lines = match_arg_count > 0 | exclude_arg_count > 0;

      sws.paging =
	 (pci.page_length ^= 0) | (pci.phys_page_length ^= 0)
	 | sws.from_page_given | sws.to_page_given;

      sws.print_quick_way =
	 (left_col <= 1) & (right_col = MAX_BUFFER_LTH)
	 & (pci.phys_line_length = MAX_BUFFER_LTH) & (^sws.paging)
	 & (mod (indentation, 10) = 0) & (^sws.no_vertsp);

      sws.one_iox_call =
	 (forcount = 0) & ^sws.from_page_given & ^sws.to_page_given
	 & (indentation = 0) & ^sws.pause_after_page & ^sws.no_vertsp
	 & ^sws.from_line_given & ^sws.to_line_given & ^sws.last_given
	 & ^sws.check_lines & ^sws.want_line_numbers;

      output_buffer_size = min (pci.phys_line_length, MAX_BUFFER_LTH);

      if right_col = MAX_BUFFER_LTH
      then right_col = output_buffer_size;

      if pci.phys_line_length = MAX_BUFFER_LTH
      then pci.phys_line_length = output_buffer_size;

      pci.rmarg = output_buffer_size;

      if pci.page_length = 0
      then pci.page_length = 131071;

      if pci.phys_page_length = 0
      then pci.phys_page_length = 66;

      if input_path_count = 1 & ^sws.had_an_arg	/* old way? */
      then sws.want_heading, sws.print_trailing_nls = "1"b;

      else if input_path_count > 1
      then sws.want_heading = "1"b;		/* default to head if many segs */

      if sws.no_heading
      then sws.want_heading = "0"b;		/* .. but may over-ride */

      match_arg_count = max (match_arg_count, 1); /* Illegal PL/I to have match_arg_count = 0 */
      exclude_arg_count = max (exclude_arg_count, 1);
					/* .. anything to make Monte happy */
%page (2);
/* ------------------------------------------------------- */

GET_FROM_TO:
   proc (bv_had, bv_regexpr_ptr, bv_regexpr_len, bv_line);

      dcl bv_had		   bit (1),
	bv_regexpr_ptr	   ptr,
	bv_regexpr_len	   fixed bin (21),
	bv_line		   fixed bin;

      dcl range_arg		   char (6) var;

      if iarg >= nargs			/* nothing to look at? */
      then goto miss_arg;

      range_arg = arg;
      iarg = iarg + 1;

      call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code, arg_list_ptr);
      if error_code ^= 0
      then goto ARG_READ_ERR;

      junk = cv_dec_check_ (arg, error_code);

      if bv_had				/* if we have already had */
      then
         do;				/* one of these */
	  call com_err_ (error_table_$inconsistent, "print",
	       "Only one line range is allowed. ^a ^[^i^;^s^a^]", range_arg,
	       (error_code ^= 0), junk, arg);
	  goto RETURN;
         end;

      bv_had = "1"b;			/* well, we have one one */

      if arg_len >= 2 &			/* check for /RE/ */
	 index (arg, "/") = 1 & index (reverse (arg), "/") = 1
      then
         do;
	  if arg_len = 2
	  then error_code = error_table_$regexp_undefined;
	  else call search_file_$silent (arg_ptr, 2, arg_len - 2, arg_ptr, 1,
		  arg_len, 0, 0, error_code);
	  if error_code ^= 0 & error_code ^= error_table_$nomatch
	  then
	     do;
	        call com_err_ (error_code, "print", "^a ^a", range_arg, arg);
	        goto RETURN;
	     end;

	  if arg_len > LONGEST_SEARCH_FILE_REXP + 2
	  then				/* too long? */
	     do;
	        call com_err_ (0, "print",
		   "Regular expressions may not be longer than ^d characters. ^/^-^a",
		   LONGEST_SEARCH_FILE_REXP + 2, arg);
	        goto RETURN;
	     end;

	  bv_regexpr_ptr = arg_ptr;
	  bv_regexpr_len = arg_len - 2;
         end;

      else
         do;
	  bv_line = cv_dec_check_ (arg, error_code);
	  if error_code ^= 0 | bv_line < 1
	  then
	     do;
	        error_code = error_table_$bad_conversion;
ARG_OPERAND_ERR:
	        call com_err_ (error_code, "print", "^a ^a", range_arg, arg);
	        go to RETURN;
	     end;
         end;

      return;

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

GETNUM:
   entry () returns (fixed bin);

      dcl answer		   fixed bin;

      range_arg = arg;
      iarg = iarg + 1;			/* yes */
      call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code, arg_list_ptr);
      if error_code ^= 0
      then goto ARG_READ_ERR;

      answer = cv_dec_check_ (arg, error_code);
      if error_code ^= 0 | answer < 1
      then
         do;
	  error_code = error_table_$bad_conversion;
	  goto ARG_OPERAND_ERR;
         end;
      return (answer);

   end GET_FROM_TO;
%page;
/* Make a second pass over the arguments and store operands of -match & -exclude */

      begin;				/* needed because of adjustable arrays */

         dcl arg_token	      char (6) var;
         dcl star_area	      area based (star_area_ptr);
         dcl star_area_ptr	      ptr;
         dcl star_entry_array	      (star_entry_count) fixed bin
			      based (star_entry_array_ptr);
         dcl star_entry_array_ptr   ptr;
         dcl match_string_ptr	      (match_arg_count) ptr;
         dcl match_string_len	      (match_arg_count) fixed bin (21);
         dcl match_string_count     fixed bin;
         dcl exclude_string_ptr     (exclude_arg_count) ptr;
         dcl exclude_string_len     (exclude_arg_count) fixed bin (21);
         dcl exclude_string_count   fixed bin;
         dcl ever_printed	      bit (1);	/* global this command */
         dcl ever_had_err	      bit (1);
         dcl ever_found_from	      bit (1);
         dcl ever_found_page	      bit (1);
         dcl seg_ptr	      ptr;	/* -> msf component */
         dcl FCB_ptr	      ptr;	/* -> FCB for msf */
         dcl had_err	      bit (1);
         dcl dir_name	      char (168);	/* directory name */
         dcl entry_name	      char (32);
         dcl archive_element	      char (32);
         dcl entry_star_type	      fixed bin (35);
         dcl archive_element_star_type
			      fixed bin (35);
         dcl archive_elements_found bit (1);
         dcl star_entry_array_index fixed bin;
         dcl star_entry_name	      char (32);

         ever_printed, ever_had_err, ever_found_from, ever_found_page = "0"b;
         match_string_count, exclude_string_count = 0;

         if sws.check_lines
         then
	  do iarg = 1 to nargs;
	     call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
		arg_list_ptr);
	     if error_code ^= 0
	     then goto ARG_READ_ERR;

	     if arg = "-match"
	     then
	        do;
		 iarg = iarg + 1;
		 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
		      arg_list_ptr);
		 if error_code ^= 0
		 then goto ARG_READ_ERR;

		 if arg_len >= 2 &		/* check for /RE/ */
		      index (arg, "/") = 1 & index (reverse (arg), "/") = 1
		 then
		    do;

		       if arg_len = 2
		       then c = error_table_$regexp_undefined;
		       else call search_file_$silent (arg_ptr, 2,
			       arg_len - 2, arg_ptr, 1, arg_len, 0, 0, c);
		       if c ^= 0 & c ^= error_table_$nomatch
		       then
			do;
			   call com_err_ (c, "print", "-match ^a", arg);
			   goto RETURN;
			end;
		    end;

		 match_string_count = match_string_count + 1;
		 match_string_ptr (match_string_count) = arg_ptr;
		 match_string_len (match_string_count) = arg_len;
	        end;

	     else if arg = "-ex" | arg = "-exclude"
	     then
	        do;
		 arg_token = arg;
		 iarg = iarg + 1;
		 call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
		      arg_list_ptr);
		 if error_code ^= 0
		 then goto ARG_READ_ERR;

		 if arg_len >= 2 &		/* check for RE */
		      index (arg, "/") = 1 & index (reverse (arg), "/") = 1
		 then
		    do;

		       if arg_len = 2
		       then c = error_table_$regexp_undefined;
		       else call search_file_$silent (arg_ptr, 2,
			       arg_len - 2, arg_ptr, 1, arg_len, 0, 0, c);
		       if c ^= 0 & c ^= error_table_$nomatch
		       then
			do;
			   call com_err_ (c, "print", "^a ^a", arg_token,
			        arg);
			   goto RETURN;
			end;
		    end;

		 exclude_string_count = exclude_string_count + 1;
		 exclude_string_ptr (exclude_string_count) = arg_ptr;
		 exclude_string_len (exclude_string_count) = arg_len;
	        end;			/**/

	     else if arg = "-name" | arg = "-nm"/* NAME can also look like a ctlarg */
	     then iarg = iarg + 1;
	  end;

         star_area_ptr = get_system_free_area_ ();
         star_names_ptr, star_entry_ptr, star_entry_array_ptr, seg_ptr,
	    FCB_ptr = null;

         on cleanup call CLEANER;

         input_path_count = 0;

/* Make third pass over arguments to print each file named. */

         do iarg = 1 to nargs;
	  had_err = "0"b;
	  call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len, error_code,
	       arg_list_ptr);
	  if error_code ^= 0
	  then goto ARG_READ_ERR;

	  junk = cv_dec_check_ (arg, error_code);
	  if error_code = 0 & input_path_count > 0
	  then ;				/* ignore numeric args */

	  else if index (arg, "-") = 1
	  then
	     do;				/* skip other ctls */
	        if arg = "-name" | arg = "-nm"
	        then
		 do;
		    iarg = iarg + 1;
		    call cu_$arg_ptr_rel (iarg, arg_ptr, arg_len,
		         error_code, arg_list_ptr);
		    if error_code ^= 0
		    then goto ARG_READ_ERR;

		    goto segname;
		 end;

	        else if arg = "-from" | arg = "-fm" | arg = "-to"
		   | arg = "-for" | arg = "-from_page" | arg = "-to_page"
		   | arg = "-indent" | arg = "-ind" | arg = "-in"
		   | arg = "-left_col" | arg = "-lc" | arg = "-right_col"
		   | arg = "-rc" | arg = "-line_length" | arg = "-ll"
		   | arg = "-page_length" | arg = "-pl"
		   | arg = "-phys_page_length" | arg = "-ppl"
		   | arg = "-match" | arg = "-exclude" | arg = "-ex"
		   | arg = "-output_switch" | arg = "-osw" | arg = "-last"
		   | arg = "-lt"
	        then iarg = iarg + 1;
	     end;

	  else
	     do;				/* non-ctl arg */
segname:
	        call expand_pathname_$component (arg, dir_name, entry_name,
		   archive_element, error_code);
	        if error_code ^= 0
	        then goto ARG_ERR;

	        input_path_count = input_path_count + 1;

	        call check_star_name_$entry (entry_name, entry_star_type);

	        if entry_star_type ^= type.NOSTAR
		   & entry_star_type ^= type.STAR
		   & entry_star_type ^= type.STARSTAR
	        then
		 do;
		    had_err = "1"b;
		    call com_err_ (entry_star_type, "print", "^a",
		         entry_name);
		 end;

	        else
		 do;
		    if archive_element = ""
		    then archive_element_star_type = type.NOSTAR;
		    else call check_star_name_$entry (archive_element,
			    archive_element_star_type);

		    if archive_element_star_type ^= type.NOSTAR
		         & archive_element_star_type ^= type.STAR
		         & archive_element_star_type ^= type.STARSTAR
		    then
		       do;
			had_err = "1"b;
			call com_err_ (archive_element_star_type, "print",
			     "^a", archive_element);
		       end;

		    else
		       do;
			archive_elements_found = "0"b;

			if entry_star_type = type.NOSTAR
			then		/* No stars */
			     call PRINT_ONE_ENTRYNAME (dir_name,
				entry_name, archive_element,
				star_SEGMENT);

			else
			   do;		/* Has stars */
			      call hcs_$star_ (dir_name, entry_name,
				 star_sel, star_area_ptr,
				 star_entry_count, star_entry_ptr,
				 star_names_ptr, error_code);
			      if error_code ^= 0
			      then
			         do;
				  call com_err_ (error_code, "print",
				       "^a",
				       pathname_ (dir_name, entry_name))
				       ;
				  had_err = "1"b;
			         end;

			      else
			         do;	/* Found some */
				  allocate star_entry_array
				       set (star_entry_array_ptr)
				       in (star_area);
					/* print starname segs in alpha order */
				  do star_entry_array_index = 1
				       to star_entry_count;
				     star_entry_array (
					star_entry_array_index) =
					star_entry_array_index;
				  end;

				  call SORT_STAR_ARRAY;

				  do star_entry_array_index = 1
				       to star_entry_count;
				     star_entry_name =
					star_names (
					star_entries (
					star_entry_array (
					star_entry_array_index))
					.nindex);
				     call PRINT_ONE_ENTRYNAME (dir_name,
					star_entry_name,
					archive_element,
					(
					star_entries (
					star_entry_array (
					star_entry_array_index)).type)
					);
				  end;
			         end;

			      call CLEANER; /* Free storage */
			   end;
		       end;
		 end;

	        if ^had_err & archive_element ^= "" & ^archive_elements_found
	        then
		 do;
		    had_err = "1"b;		/* fix bug for TR number 20687 */
		    error_code = error_table_$no_component;
					/* end of fixing bug */
		    call com_err_ (error_code, "print", "^a",
		         pathname_$component (dir_name, entry_name,
		         archive_element));
		 end;
	     end;

	  if had_err
	  then ever_had_err = "1"b;
         end;

         if ^ever_printed & ^ever_had_err
         then
	  do;				/* gotta tell him something for his dime */
	     if sws.from_line_given & ^ever_found_from & ^sws.last_given
	     then if from_regexpr_len > 0
		then call com_err_ (0, "print", "^a not matched.",
			from_regexpr);
		else call com_err_ (0, "print", "Line ^d not found.",
			from_line);

	     else if sws.from_page_given & ^ever_found_page
	     then call com_err_ (0, "print", "Page ^d not found.", from_page);

	     else call com_err_ (0, "print", "No lines selected.");
	  end;

         else if sws.print_trailing_nls & ^ever_had_err
         then call ioa_$ioa_switch (out_switch, "^/");


/*         return;				/* Normal program exit (from inside begin block) */

/* ------------------------------------------------------- */

SORT_STAR_ARRAY:
   proc;

      dcl d		   fixed bin,
	swap		   bit (1),
	t		   fixed bin;

      d = star_entry_count;
      do while (d > 1);
         d = divide (d + 1, 2, 17, 0);
         swap = "1"b;
         do while (swap);
	  swap = "0"b;
	  do star_entry_array_index = 1 to star_entry_count - d;
	     if star_names (
		star_entries (star_entry_array (star_entry_array_index))
		.nindex)
		>
		star_names (
		star_entries (star_entry_array (star_entry_array_index + d))
		.nindex)
	     then
	        do;
		 swap = "1"b;
		 t = star_entry_array (star_entry_array_index);
		 star_entry_array (star_entry_array_index) =
		      star_entry_array (star_entry_array_index + d);
		 star_entry_array (star_entry_array_index + d) = t;
	        end;
	  end;
         end;
      end;

   end SORT_STAR_ARRAY;
%page;
CLEANER:
   proc;

      if star_names_ptr ^= null
      then free star_names in (star_area);

      if star_entry_ptr ^= null
      then free star_entries in (star_area);

      if star_entry_array_ptr ^= null
      then free star_entry_array in (star_area);

      if FCB_ptr ^= null
      then call msf_manager_$close (FCB_ptr);

      else if seg_ptr ^= null
      then call terminate_file_ (seg_ptr, (0), TERMINATE_SEG, (0));

      star_names_ptr, star_entry_ptr, star_entry_array_ptr, seg_ptr, FCB_ptr =
	 null;

   end CLEANER;
%page (2);
/* ------------------------------------------------------- */

/* This subroutine handles the file system stuff.
   It knows how to handle MSFs and archives. */

PRINT_ONE_ENTRYNAME:
   proc (dirname, ename, arch_elem_wanted, en_type);

      dcl dirname		   char (168);	/* (arg) directory */
      dcl ename		   char (32);	/* (arg) entry */
      dcl arch_elem_wanted	   char (32);	/* (arg) element */
      dcl en_type		   fixed bin (2) uns;
					/* (arg) whether to bitch */

      dcl 1 sws1,				/* switch bits */
	  2 doing_archive	   bit (1),	/* TRUE if doing an archive */
	  2 found_first	   bit (1),	/* flags for line select */
	  2 found_last	   bit (1),
	  2 found_to	   bit (1),
	  2 last_msf_component bit (1),	/* TRUE for last MSF component, */
					/* and all segs & archive elements */
	  2 more_in_archive	   bit (1),	/* TRUE if archive scanning */
	  2 print_heading_first
			   bit (1),	/* TRUE if printing heading */
	  2 stop_after_first_elem
			   bit (1),	/* TRUE if doing nonstar archive elem */
	  2 paused	   bit (1);	/* TRUE if we paused at the beginning of this entry */

      dcl 1 ACI		   like archive_component_info aligned;
      dcl (
	ARCH_COMP		   init (3),
	MSF_COMP		   init (2),
	SEG		   init (1)
	)		   fixed bin int static options (constant);
      dcl bitc		   fixed bin (24);	/* bit count */
      dcl comp_ptr		   ptr;		/* if print archive */
					/* MSF part or archive element */
      dcl component		   char (seg_charct) based (comp_ptr);
      dcl ec1		   fixed bin (35);	/* err code */
      dcl entry_type	   fixed bin (2);	/* arg to status */
      dcl error_code	   fixed bin (35);	/* err code */
      dcl indent_string	   char (indentation) init ("");
      dcl last_line_number	   fixed bin;	/* number of input line last output. */
      dcl line_count	   fixed bin;
      dcl last_slew		   char (1);
      dcl line_length	   fixed bin (21);	/* length of one line */
      dcl line_number	   fixed bin;	/* line number to print */
      dcl msf_component	   fixed bin;	/* component number */
      dcl msf_component_count	   fixed bin (24);	/* highest component */
      dcl output_buffer	   char (MAX_BUFFER_LTH);
      dcl output_buffer_ch	   (MAX_BUFFER_LTH) char (1)
			   defined output_buffer;
      dcl output_buffer_length   fixed bin (21);	/* amount currently used */
      dcl page_number	   fixed bin;	/* current page number */
      dcl seg_charct	   fixed bin (21);	/* char count of current seg */
      dcl seg_type		   fixed bin;	/* type of entry passed to PRINT_ONE_SEG */
					/*   can be: SEG, MSF_COMP, ARCH_COMP */
      dcl segment		   char (seg_charct) based (seg_ptr);
      dcl slew		   char (1);	/* vertical motion char */
      dcl vt_length		   fixed bin (21);	/* length of line up to next VT */
      dcl wanted_elem	   char (32);

      call iox_$control (out_switch, "reset_more", null (), (0));
					/* for video system users ... */

      last_line_number = 0;
      last_slew = NUL;
      sws1.doing_archive, sws1.found_to, sws1.paused = "0"b;
      sws1.last_msf_component = "1"b;

      call initiate_file_ (dirname, ename, R_ACCESS, seg_ptr, bitc, error_code);

      if seg_ptr = null
      then
         do;				/* Can't initiate: missing? or directory/msf? */
	  call hcs_$status_minf (dirname, ename, 1, entry_type,
	       msf_component_count, ec1);
	  if ec1 ^= 0
	  then
	     do;
	        if en_type = star_LINK
	        then return;		/* don't complain about missing link target if * convention */

	        else
		 do;
		    error_code = ec1;
abort:
		    call com_err_ (error_code, "print", "^a",
		         pathname_ (dirname, ename));
		    had_err = "1"b;
		    return;
		 end;
	     end;

	  if entry_type ^= star_DIRECTORY
	  then goto abort;			/* A seg we can't initiate */

/* Directory */

	  if msf_component_count < 1
	  then
	     do;				/* really dir */
	        if en_type ^= star_SEGMENT
	        then return;		/* quiet if star convention */
	        error_code = error_table_$dirseg;
					/* don't print dirs */
	        goto abort;			/* .. just fuss */
	     end;

/* Multisegment file case */

	  else
	     do;
	        seg_type = MSF_COMP;
	        call msf_manager_$open (dirname, ename, FCB_ptr, error_code);
	        if error_code ^= 0
	        then goto abort;

	        call RESET;

	        if sws.last_given		/* for -last */
	        then
		 do;
		    from_line = 0;

		    if sws.to_line_given & to_regexpr_len = 0
		    then from_line = max (to_line - last_count + 1, 1);
					/* count lines in the MSF */
		    else
		       do;
			do msf_component = 0
			     to msf_component_count - 1
			     while (^sws1.found_to);
			   call msf_manager_$get_ptr (FCB_ptr,
			        msf_component, "0"b, comp_ptr, bitc,
			        error_code);
			   if error_code ^= 0
			   then goto MSF_err;

			   seg_charct = divide (bitc + 8, 9, 21, 0);

			   if seg_charct > 0
			   then
			      do;
			         call COUNT_LINES (component,
				    msf_component
				    = msf_component_count - 1,
				    line_count, sws1.found_to);
			         from_line = from_line + line_count;
			      end;
			end;
			from_line = max (from_line - last_count + 1, 1);
		       end;
		 end;

	        line_number = 1;
	        sws1.paused = "0"b;

	        do msf_component = 0 to msf_component_count - 1
		   while (^sws1.found_last);

		 call msf_manager_$get_ptr (FCB_ptr, msf_component, "0"b,
		      comp_ptr, bitc, error_code);
		 if error_code ^= 0
		 then goto MSF_err;

		 sws1.last_msf_component =
		      (msf_component = msf_component_count - 1);
		 seg_charct = divide (bitc + 8, 9, 21, 0);
		 if seg_charct = 0
		 then error_code = error_table_$zero_length_seg;
					/* Actually print component */
		 else call PRINT_ONE_SEG (component);
					/* dont count nnl lines twice */
		 if ^sws1.last_msf_component
		 then if substr (component, seg_charct, 1) ^= NL
		      then line_number = line_number - 1;
	        end;

MSF_err:
	        if error_code ^= 0
	        then
		 do;
		    had_err = "1"b;
		    call com_err_ (error_code, "print",
		         "Component ^d of multisegment file ^a.",
		         msf_component, pathname_ (dirname, ename));
		 end;

	        call msf_manager_$close (FCB_ptr);
	     end;				/* of MSF */
	  return;				/* exit from MSF case */
         end;				/* seg_ptr = null */

/* Segment case */

      error_code = 0;
      sws1.doing_archive =
	 arch_elem_wanted ^= ""
	 | (^sws.dont_want_archive
	 & index (reverse (rtrim (ename)), reverse (".archive")) = 1);

/* Archive case */

      if sws1.doing_archive
      then
         do;
	  seg_type = ARCH_COMP;
	  stop_after_first_elem = (archive_element_star_type = type.NOSTAR);

	  if arch_elem_wanted = ""
	  then
	     do;
	        wanted_elem = "**";		/* print whole archive? */
	        stop_after_first_elem = "0"b;
	     end;
	  else wanted_elem = arch_elem_wanted;

	  comp_ptr = null;
	  ACI.version = ARCHIVE_COMPONENT_INFO_VERSION_1;
	  sws1.more_in_archive = "1"b;

	  do while (sws1.more_in_archive & error_code = 0);
	     call archive_$next_component_info (seg_ptr, bitc, comp_ptr,
		addr (ACI), error_code);
	     if error_code = 0
	     then
	        do;
		 if comp_ptr = null
		 then sws1.more_in_archive = "0"b;

		 else
		    do;
		       call match_star_name_ (ACI.name, wanted_elem,
			  error_code);
		       if error_code ^= 0
		       then error_code = 0;
		       else
			do;
			   call RESET;

			   seg_charct =
			        divide (ACI.comp_bc + 8, 9, 21, 0);
			   if seg_charct = 0
			   then
			      do;		/* archive wont let this happen, but ... */
			         call com_err_ (
				    error_table_$zero_length_seg,
				    "print", "^a",
				    pathname_$component (dirname, ename,
				    ACI.name));
			         had_err = "1"b;
			      end;

			   else
			      do;
			         archive_elements_found = "1"b;

			         if sws.last_given
					/* for -last */
			         then
				  do;
				     if sws.to_line_given
					& to_regexpr_len = 0
				     then from_line =
					     max (to_line
					     - last_count + 1, 1);
				     else
				        do;
					 call COUNT_LINES (component,
					      "1"b, from_line,
					      sws1.found_to);
					 from_line =
					      max (from_line
					      - last_count + 1, 1);
				        end;
				  end;

			         line_number = 1;
			         sws1.paused = "0"b;
					/* fixed bug for TR number 18887 */
			         call iox_$control (out_switch,
				    "reset_more", null (), (0));
					/* for video system users ... */
					/* end of fixing bug */

			         call PRINT_ONE_SEG (component);
					/* Terminate loop */
			         if stop_after_first_elem
			         then sws1.more_in_archive = "0"b;
			      end;
			end;
		    end;
	        end;			/* error_code =  0 */
	  end;				/* loop */
         end;				/* of archive case */

/* Single segment file case. */

      else
         do;
	  seg_type = SEG;
	  call RESET;

	  seg_charct = divide (bitc + 8, 9, 21, 0);
	  if seg_charct ^= 0
	  then
	     do;
	        if sws.last_given		/* for -last */
	        then
		 do;
		    if sws.to_line_given & to_regexpr_len = 0
		    then from_line = max (to_line - last_count + 1, 1);
		    else
		       do;
			call COUNT_LINES (segment, "1"b, from_line,
			     sws1.found_to);
			from_line = max (from_line - last_count + 1, 1);
		       end;
		 end;

	        line_number = 1;
	        sws1.paused = "0"b;

	        call PRINT_ONE_SEG (segment);
	     end;

	  else error_code = error_table_$zero_length_seg;
         end;				/* of ssf case */

      call terminate_file_ (seg_ptr, (0), TERMINATE_SEG, (0));
					/* done with segment */
      seg_ptr = null;
      if error_code ^= 0
      then
         do;
	  had_err = "1"b;
	  call com_err_ (error_code, "print", "^a",
	       pathname_ (dirname, ename));
         end;

      return;				/* Normal exit from PRINT_ONE_ENTRYNAME */
%page;
/* ------------------------------------------------------- */

RESET:
   proc;

      sws1.print_heading_first = sws.want_heading;/* treat archive elements as single files */
					/* clear items not to be carried from one file to next */
      pci.level, pci.pos, pci.slew_residue, pci.sav_pos, pci.esc_state,
	 pci.esc_num = 0;
      pci.temp, sws1.found_first, sws1.found_last = "0"b;
      page_number, pci.line = 1;
      line_count = 0;
      slew = NL;
   end RESET;
%page;
/* ------------------------------------------------------- */

COUNT_LINES:				/* count lines in a segment */
   proc (seg, last_seg, lines, found_to);

/* PARAMETERS */

      dcl seg		   char (*);
      dcl last_seg		   bit (1);
      dcl lines		   fixed bin;
      dcl found_to		   bit (1);

/* LOCAL */

      dcl c		   fixed bin (35),
	char_index	   fixed bin (21);

      char_index = 0;
      lines = 0;

      do while (char_index < seg_charct);
         line_length = index (substr (seg, char_index + 1), NL);
         if line_length > 0
         then lines = lines + 1;
         else
	  do;				/* Last line of seg does   */
	     if last_seg
	     then				/* NOT end with NL.  Count */
		lines = lines + 1;		/* it if no more MSF comps.*/
	     line_length = length (substr (seg, char_index + 1));
	  end;

         if to_regexpr_len > 0		/* using regexpr for to? */
         then
	  do;
	     call search_file_ (to_regexpr_ptr, 2, to_regexpr_len, addr (seg),
		char_index + 1, char_index + line_length, 0, 0, c);
	     if c = 0
	     then
	        do;
		 found_to = "1"b;
		 if substr (seg, char_index + line_length, length (NL))
		      ^= NL
		 then			/* if last line of segment */
		      lines = lines + 1;	/* matches /RE/, but does  */
		 return;			/* not end with NL, count  */
	        end;			/* this line.	       */
	  end;
         char_index = char_index + line_length;
      end;

   end COUNT_LINES;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

/* This subroutine does the actual printing.
   It deals with one segment at a time, which may be either an SSF,
   one component of a MSF, or an archive element. */

PRINT_ONE_SEG:
   proc (segment);

      dcl segment		   char (*);	/* seg to be printed */

      dcl char_index	   fixed bin (21);	/* index of last char used */
      dcl line_count_this_page   fixed bin;	/* lines per page, for paging */
      dcl line_length	   fixed bin (21);	/* length of one line */
      dcl print_this_line	   bit (1);
      dcl region_begin	   fixed bin (21);	/* char_index at sws1.found_first */
      dcl seg_ptr		   ptr;		/* -> seg to be printed */
      dcl segarray		   (seg_charct) char (1) based (seg_ptr);

      seg_ptr = addr (segment);

      char_index, line_count_this_page = 0;

      if (sws.print_quick_way & sws.one_iox_call) /* Print whole segment */
      then				/* without from/to */
PRINT_QUICK_WAY:				/* tests, etc */
         do;
	  if sws.pause_before_print
	  then call PAUSE;

	  call PRINT_HEAD;
	  call PRINT_STRING (seg_ptr, seg_charct);
	  ever_printed = "1"b;
	  return;				/* Normal exit, easy case */
         end PRINT_QUICK_WAY;

PRINT_SEG:				/* loop through lines of */
      do while (char_index < seg_charct & ^sws1.found_last);
					/* segment, printing those*/
					/* that pass tests. */
         line_length = index (substr (segment, char_index + 1), NL);
         if line_length = 0			/* no EOL, take the rest */
         then line_length = length (substr (segment, char_index + 1));

         call PRINT_ONE_LINE ();
         line_number = line_number + 1;

      end PRINT_SEG;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* If file doesn't end with a NP character as its very last character, then we must	*/
/* output final NP when paging.  This is ONLY done for last component of MSF, not for	*/
/* earlier components.							*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

      if (seg_type ^= MSF_COMP | sws1.last_msf_component)
	 &
	 ^(pci.line = 1 & pci.pos = 0 & pci.level = 0 & pci.slew_residue = 0)
      then				/* This tests for file not */
         do;				/* ending with NP. */

	  if pci.pos > 0 | pci.slew_residue = -1
	  then				/* If file doesn't end */
	     do;				/* with a NL, NP or VT, */
	        slew = NL;			/* force NL to be present. */
	        call SLEW ();
	     end;

	  if sws.paging			/* When paging, end file */
	  then				/* with a NP char. */
	     do;
	        slew = NP;
	        call SLEW ();
	     end;
         end;

      return;				/* Normal exit, medium and hard cases */
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

/* This routine is used if we are printing one line at a time.
   It knows how to mess with the insides of the line */

PRINT_ONE_LINE:
   proc;

      print_this_line = "1"b;

      call CHECK_FROM_LINE ();		/* Check -from/-to line. */
      if print_this_line
      then call CHECK_TO_LINE ();
      if print_this_line
      then print_this_line = MATCH_EXCLUDE ();

      if print_this_line
      then				/* check page boundaries. */
	 if sws.to_page_given
	 then if page_number > to_page
	      then
	         do;
		  sws1.found_last = "1"b;
		  return;
	         end;

      if print_this_line & (page_number >= from_page)
      then
         do;
	  if sws.pause_before_print & ^sws1.paused
	  then
	     do;
	        call PAUSE;
	        sws1.paused = "1"b;
	     end;

	  call PRINT_HEAD;			/* Print heading before 1st line of file. */
	  ever_found_page = "1"b;
	  ever_printed = "1"b;
         end;
      else print_this_line = "0"b;

      if sws.print_quick_way
      then
         do;
	  if print_this_line
	  then call PROCESS_LINE_VIA_IOX (addr (segarray (char_index + 1)),
		  line_length);

         end;
      else
         do;
	  if ^sws.no_vertsp			/* prt_conv_ converts VT  */
	  then				/* to some number of NLs. */
	     do;				/* In vertsp mode, we     */
	        vt_length =			/* want VT itself to be   */
		   index (substr (segment, char_index + 1, line_length), VT)
		   ;
	        do while (vt_length > 0);	/* output. Special-case VT*/
		 call			/* in this code.          */
		      PROCESS_LINE_VIA_PRT_CONV (
		      addr (segarray (char_index + 1)), vt_length,
		      print_this_line, "0"b, "1"b);
		 char_index = char_index + vt_length;
		 line_length = line_length - vt_length;
		 vt_length =
		      index (substr (segment, char_index + 1, line_length),
		      VT);
	        end;			/* do while (vt_length) */
	     end;				/* if ^sws.no_vertsp */

	  call				/* Call prt_conv_ on line */
	       PROCESS_LINE_VIA_PRT_CONV (addr (segarray (char_index + 1)),
	       line_length, print_this_line, "0"b, "0"b);
         end;				/* else do */

      char_index = char_index + line_length;

      if forcount > 0
      then
         do;				/* forcount and line_count */
	  if line_count >= forcount
	  then
	     do;				/* must be check here after */
	        sws1.found_last = "1"b;	/* printing each line.     */
	        seg_charct = char_index + line_length;
	     end;
         end;

   end PRINT_ONE_LINE;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

CHECK_FROM_LINE:
   proc;

      dcl c		   fixed bin (35);

      region_begin = char_index;
      if sws1.found_first
      then return;

      if from_regexpr_len > 0
      then
         do;
	  call search_file_ (from_regexpr_ptr, 2, from_regexpr_len,
	       addr (segment), char_index + 1, char_index + line_length, 0, 0,
	       c);
	  if c = 0
	  then
	     do;
	        ever_found_from, sws1.found_first = "1"b;
	        from_line = line_number;
	     end;
	  else print_this_line = "0"b;
         end;
      else if line_number >= from_line
      then ever_found_from, sws1.found_first = "1"b;
      else print_this_line = "0"b;

   end CHECK_FROM_LINE;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

CHECK_TO_LINE:
   proc;

      dcl c		   fixed bin (35);

      if ^sws.to_line_given & (forcount = 0)
      then return;

      if to_regexpr_len > 0			/* need regexpr for to? */
      then
         do;
	  call search_file_ (to_regexpr_ptr, 2, to_regexpr_len,
	       addr (segment), char_index + 1, char_index + line_length, 0, 0,
	       c);
	  if c = 0
	  then
	     do;
	        sws1.found_last = "1"b;
	        seg_charct = char_index + line_length;
	     end;
         end;

      else if to_line > 0
      then
         do;
	  if line_number >= to_line
	  then
	     do;
	        if substr (segment, char_index + line_length, 1) = NL
	        then
		 do;
		    sws1.found_last = "1"b;
		    seg_charct = char_index + line_length;
		 end;
	     end;
         end;

   end CHECK_TO_LINE;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

LINENO_AND_INDENT:
   proc (strike_level, chars_for_line);

      dcl strike_level	   fixed bin,
	chars_for_line	   fixed bin (21);

      if last_slew = ""
      then
         do;
	  last_line_number = line_number;
	  last_slew = slew;
	  return;
         end;

      if sws.want_line_numbers
      then if strike_level = 0 & last_slew ^= CR
	 then if line_number ^= last_line_number
	      then call ioa_$ioa_switch_nnl (out_switch, "^8i  ", line_number)
		      ;
	      else call ioa_$ioa_switch_nnl (out_switch, "^8i+ ", line_number)
		      ;
	 else call ioa_$ioa_switch_nnl (out_switch, "^-");
      last_line_number = line_number;
      last_slew = slew;

      if indentation > 0 & chars_for_line > 0	/* Indent? */
      then call PRINT_STRING (addr (indent_string), indentation);

   end LINENO_AND_INDENT;
%page (2);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

/*  This subroutine checks if the current line is printable in the presence
   of the control args -match and -exclude */

MATCH_EXCLUDE:
   proc returns (bit (1));

      dcl jj		   fixed bin;
      dcl c		   fixed bin (35);
      dcl srchp		   ptr,
	srchl		   fixed bin (21);
      dcl srch		   char (srchl) based (srchp);
      dcl (matched, excluded)	   bit (1);

      if ^sws.check_lines
      then return ("1"b);

      matched = "0"b;
      do jj = 1 to match_string_count while (^matched);
         srchp = match_string_ptr (jj);
         srchl = match_string_len (jj);

         if srchl > 2 & index (srch, "/") = 1 & index (reverse (srch), "/") = 1
         then
	  do;
	     call search_file_ (srchp, 2, srchl - 2, addr (segment),
		char_index + 1, char_index + line_length, 0, 0, c);
	     if c = 0
	     then matched = "1"b;
	  end;

         else if index (substr (segment, char_index + 1, line_length), srch)
	    ^= 0
         then matched = "1"b;
      end;

      if match_string_count > 0 & ^matched
      then return ("0"b);

      excluded = "0"b;
      do jj = 1 to exclude_string_count;
         srchp = exclude_string_ptr (jj);
         srchl = exclude_string_len (jj);

         if srchl > 2 & index (srch, "/") = 1 & index (reverse (srch), "/") = 1
         then
	  do;
	     call search_file_ (srchp, 2, srchl - 2, addr (segment),
		char_index + 1, char_index + line_length, 0, 0, c);
	     if c = 0
	     then excluded = "1"b;
	  end;

         else if index (substr (segment, char_index + 1, line_length), srch)
	    ^= 0
         then excluded = "1"b;
      end;

      return (^excluded);

   end MATCH_EXCLUDE;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

PAUSE:
   proc;

      dcl buffer		   char (256);

      error_code = error_table_$long_record;
      do while (error_code = error_table_$long_record);
					/* This call skips one input line: i.e. pauses */
         call iox_$get_line (iox_$user_input, addr (buffer), 256, (0),
	    error_code);
      end;

      call iox_$control (iox_$user_input, "resetread", null, (0));

   end PAUSE;

%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

/* Print the heading. Uglinesses of this output format are for compatibility
   with the old print. I don't like them either. */

PRINT_HEAD:
   proc;

      dcl date		   char (64) var,
	head_line		   char (250),
	head_line_len	   fixed bin (21);

      if ^sws1.print_heading_first
      then return;

      if sws1.doing_archive
      then
         do;				/* New format */
	  date = date_time_$format ("date_time", ACI.time_modified, "", "");
	  call ioa_$rsnp ("^/^2-^a::^a^-^a^/", head_line, head_line_len,
	       ename, ACI.name, date);
         end;

      else
         do;
	  date = date_time_$format ("date_time", clock (), "", "");
	  call ioa_$rsnp ("^/^2-^a^-^a^2/", head_line, head_line_len, ename,
	       date);
         end;
      if sws.print_quick_way | sws.one_iox_call
      then call PRINT_STRING (addr (head_line), head_line_len);
      else
         do;
	  call PROCESS_LINE_VIA_PRT_CONV (addr (head_line), head_line_len,
	       "1"b, "1"b, "0"b);
	  line_count = line_count - 1;	/* After printed the heading,  */
         end;				/* "line_count" must not be    */
      sws1.print_heading_first = "0"b;		/* incremented by one. Avoid   */
					/* errors error when enters    */
   end PRINT_HEAD;				/* print foo -for N -he -ind N */
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

PRINT_STRING:
   proc (ptr, len);

      dcl ptr		   ptr,
	len		   fixed bin (21);

      call iox_$put_chars (out_switch, ptr, len, error_code);
      if error_code ^= 0
      then
         do;
	  call com_err_ (error_code, "print", "Writing to switch ^a.",
	       switch_name);
	  go to RETURN;
         end;

   end PRINT_STRING;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

/* This routine processes line fragments where each       */
/* fragment ends with a NL, VT, NP or CR.  These are the  */
/* slew characters needed to drive proper slew processing.*/

PROCESS_LINE_VIA_IOX:
   proc (line_ptr_parm, line_len_parm);

      dcl line_ptr_parm	   ptr,		/* ptr to output line. */
	line_len_parm	   fixed bin (21);	/* length of output line. */

      dcl end_of_output_line	   fixed bin (21);	/* location in line of */
					/* VT, NL, or NP char. */

      dcl line_len		   fixed bin (21),
	line_ptr		   ptr,
	line		   char (line_len) based (line_ptr),
	line_array	   (line_len) char (1) based (line_ptr);

      line_ptr = line_ptr_parm;		/* copy, because we change */
      line_len = line_len_parm;		/* these values.	       */

      do while (line_len > 0);
         end_of_output_line = search (line, NLCRVTNP);
         if end_of_output_line > 0
         then
	  do;
	     slew = line_array (end_of_output_line);
	     end_of_output_line = end_of_output_line - 1;
	  end;				/* remove slew char from */
					/* end of output line.   */
         else
	  do;
	     slew = "";
	     end_of_output_line = length (line);
	  end;

         ever_found_page = "1"b;
         call LINENO_AND_INDENT (0, end_of_output_line);

         if end_of_output_line ^= 0
         then call PRINT_STRING (addr (line), end_of_output_line);

         call SLEW ();

         if (end_of_output_line + 1) < line_len	/* not at the end of the line*/
         then line_ptr = addr (line_array (end_of_output_line + 2));
         line_len = line_len - (end_of_output_line + 1);

      end;

      line_count = line_count + 1;

   end PROCESS_LINE_VIA_IOX;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

/* This routine calls prt_conv_ to process a single line.  It may be called */
/* many times for lines which are overlength or contain overstrikes.        */
/* HTs are converted to SP chars, VT to NLs (unless vertical_tab = "1"b),   */
/* and NP to NLs.  Overstriking is handling by using CR to overlay line     */
/* images atop one another.					      */

PROCESS_LINE_VIA_PRT_CONV:
   proc (line_ptr_parm, line_len_parm, print_this_line, header, vertical_tab);

      dcl line_ptr_parm	   ptr,		/* ptr to output line. */
	line_len_parm	   fixed bin (21),	/* length of output line. */
	print_this_line	   bit (1),	/* on if line passed all */
					/* tests for printing      */
					/* except -from_page.  We  */
					/* do -from_page test here */
					/* since line may span     */
					/* pages		       */
	header		   bit (1),	/* on when printing header */
	vertical_tab	   bit (1);	/* on when line fragment  */
					/* ends with VT, not NL   */

      dcl chars_done	   fixed bin (21);	/* number of chars processed from line. */
      dcl chars_for_line	   fixed bin (21);	/* amount of output buffer to actually print */
      dcl chars_to_do	   fixed bin (21);	/* number of chars left on page */
      dcl (saved_line_length, saved_rmarg)
			   fixed bin;

      dcl line_len		   fixed bin (21),
	line_ptr		   ptr,
	line		   char (line_len) based (line_ptr),
	line_array	   (line_len) char (1) based (line_ptr);

      if header				/* When printing header, */
      then				/* don't honor	     */
         do;				/* -line_length	     */
	  saved_line_length = pci.phys_line_length;
	  pci.phys_line_length = length (output_buffer);
	  saved_rmarg = pci.rmarg;
	  pci.rmarg = length (output_buffer);
         end;

      line_ptr = line_ptr_parm;		/* copy, because we change */
      line_len = line_len_parm;		/* these values.	       */

      chars_to_do = length (line);		/* loop, calling prt_conv_ */
      do while (chars_to_do > 0 | pci.slew_residue > 0);
         line_count_this_page = pci.line;	/* remember line count     */
					/* before output. SLEW uses*/
					/* this.		       */
         call prt_conv_ (addr (line), chars_to_do, addr (output_buffer),
	    output_buffer_length, addr (pci));
         chars_done = length (line) - chars_to_do;

         if chars_done > 0			/* prevent subcriptrange  */
					/* (underflow) condition  */
					/* when a line contains   */
					/* BACK SPACES characters.*/
         then line_ptr = addr (line_array (chars_done));

         slew = output_buffer_ch (output_buffer_length);

         output_buffer_length = output_buffer_length - 1;
					/* remove slew char from */
					/* end of output line.   */

         if vertical_tab & slew = NL		/* For VT mapped in NL   */
         then				/* (rather than NP),     */
	  do;				/* change slew to VT and */
	     slew = VT;			/* ignore prt_conv_ NLs. */
	     pci.slew_residue = 0;		/* SLEW proc outputs VT. */
	  end;

         if header				/* Ignore -left_col and    */
					/* -right_col for header.  */
         then chars_for_line = output_buffer_length;
         else chars_for_line =
	         min (right_col, output_buffer_length) - left_col + 1;

/* watch for negative character counts */
         if chars_for_line < 0
         then chars_for_line = 0;

         if print_this_line & (page_number >= from_page)
         then				/* Do -from_page test, and */
	  do;				/* print line if it passes */
	     ever_found_page = "1"b;
	     if ^header
	     then call LINENO_AND_INDENT (pci.level, chars_for_line);
	     call PRINT_STRING (addr (output_buffer_ch (left_col)),
		chars_for_line);
	     call SLEW ();
	  end;				/* if have not done yet    */
         if chars_done < line_len		/* then always moves the   */
         then line_ptr = addr (line_array (2));	/* pointer to the NEXT     */
         line_len = line_len - chars_done;	/* character in the line.  */
					/* Then update line_len by */
					/* starting from the char  */
					/* pointed by the pointer  */
					/* to the remaining line.  */

         if slew = NP			/* After NP, redo the   */
         then				/* -to_page test.	    */
	  do;
	     page_number = page_number + 1;
	     if sws.to_page_given
	     then
	        do;
		 if page_number > to_page
		 then
		    do;
		       sws1.found_last = "1"b;
		       return;
		    end;
	        end;
	  end;
      end;

      if header				/* After header, restore */
      then				/* -line_length info.    */
         do;
	  pci.phys_line_length = saved_line_length;
	  pci.rmarg = saved_rmarg;
         end;

      line_count = line_count + 1;

   end PROCESS_LINE_VIA_PRT_CONV;
%page;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - -  */

SLEW:
   proc;

      dcl needct		   fixed bin;

      if slew = ""				/* no slew */
      then return;

      if slew = CR
      then go to real_slew;

      if slew = NP				/* ejecting a page? */
      then
         do;
	  if sws.pause_after_page
	  then
	     do;
	        call PRINT_STRING (addr (NL), 1);
	        call PAUSE;
	     end;
	  else if ^sws.no_vertsp
	  then goto real_slew;

	  else				/* Compute lines needed */
	     do;
	        needct = pci.phys_page_length - line_count_this_page + 1;
	        call ioa_$ioa_switch_nnl (out_switch, "^v/", needct);
	        line_count_this_page = 0;
	     end;
         end;

      else if slew = VT			/* VT is never simulated */
      then go to real_slew;			/* by us. prt_conv_ does */
					/* the simulation.	     */

      else				/* NL slew.	     */
         do;
	  line_count_this_page = line_count_this_page + 1;
real_slew:
	  call PRINT_STRING (addr (slew), 1);
         end;

   end SLEW;

   end PRINT_ONE_SEG;

   end PRINT_ONE_ENTRYNAME;

      end;				/* of begin block */

%include prt_conv_info;

      dcl 1 PCI		   like pci aligned;
%page;
%include star_structures;
%page;
%include archive_component_info;
%page;
%include access_mode_values;

   end print;




		    process_switch_on.pl1           10/25/83  1546.3r w 10/25/83  1444.3       27711



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
process_switch_on: pswn: proc;

/* Syntax:  process_switch_on switch_names
	  process_switch_off switch_names

Turns on or off the specified perprocess switches. */

/* Written 07/14/83 by S. Herbst */


/* Constants */

dcl long_key (1) char (32) int static options (constant) init
	( "256K");

dcl short_key (1) char (32) int static options (constant) init
	( "256k");

dcl long_long_key (1) char (32) int static options (constant) init
	( "256k_switch");

dcl short_long_key (1) char (32) int static options (constant) init
	( "256ksw");


/* Based */

dcl arg char (arg_len) based (arg_ptr);


/* Automatic */

dcl me char (32);
dcl switch_value bit (1);
dcl arg_ptr ptr;
dcl (arg_count, i, j) fixed bin;
dcl arg_len fixed bin (21);
dcl code fixed bin (35);

dcl error_table_$badopt fixed bin (35) 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 (21), fixed bin (35));
dcl hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35));
%page;
	me = "process_switch_on";
	switch_value = "1"b;
	go to COMMON;

process_switch_off: pswf: entry;

	me = "process_switch_off";
	switch_value = "0"b;

COMMON:	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, me);
	     return;
	end;
	if arg_count = 0 then do;
	     call com_err_$suppress_name (0, me, "Usage:  ^a switch_names", me);
	     return;
	end;

	do i = 1 to arg_count;

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

	     if index (arg, "-") = 1 then do;
		call com_err_ (error_table_$badopt, me, "^a", arg);
		return;
	     end;
	end;
	
	do i = 1 to arg_count;

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

	     do j = hbound (long_key, 1) by -1 to 1 while (long_key (j) ^= arg); end;
	     if j = 0 then do;
		do j = hbound (short_key, 1) by -1 to 1 while (short_key (j) ^= arg); end;
		if j = 0 then do;
		     do j = hbound (long_long_key, 1) by -1 to 1 while
			(long_long_key (j) ^= arg); end;
		     if j = 0 then do;
			do j = hbound (short_long_key, 1) by -1 to 1 while
			     (short_long_key (j) ^= arg); end;
			if j = 0 then do;
			     call com_err_ (0, me, "Invalid switch_name ^a", arg);
			     return;
			end;
		     end;
		end;
	     end;

	     call set_one (j);
	end;

	return;
%page;
set_one: proc (P_index);

/* Sets the value of one switch */

dcl P_index fixed bin;
dcl K256_switch bit (2) aligned;

	go to SET (P_index);

SET (1):
	if switch_value = "1"b then K256_switch = "11"b;
	else K256_switch = "10"b;

	call hcs_$set_256K_switch (K256_switch, ("0"b), code);
	if code ^= 0 then call com_err_ (code, me, "Setting 256K switch.");

	return;

end set_one;


end process_switch_on;




		    safety_sw_on.pl1                10/25/83  1546.3r w 10/25/83  1444.4       34047



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


safety_sw_on: ssn: proc;

dcl (dirname, new_path) char (168);
dcl (entname, ename) char (32);

dcl  arg char (alng) based (aptr) unaligned;
dcl  b_name char (32) based;

dcl (aptr, eptr, nptr, bentp, npp, dirp, entp) ptr init (null);

dcl (i, j, argcnt, alng, ecount, retc) fixed bin (17);
dcl  code fixed bin (35);

dcl  whoami char (16);

dcl  new_value bit (1);
dcl safety_sw bit (1);

dcl (error_table_$badopt,
     error_table_$incorrect_access,
     error_table_$no_info,
     error_table_$noarg) ext fixed bin (35);

dcl  check_path_name_ ext entry (ptr, fixed bin (17), bit (1), char (16), ptr, ptr, ptr,
     fixed bin (17), ptr, ptr, fixed bin (17));
dcl  check_path_name_$indiv ext entry (ptr, ptr, bit (1));
dcl  cu_$arg_ptr ext entry (fixed bin (17), ptr, fixed bin (17), fixed bin (35));
dcl  freen_ ext entry (ptr);
dcl  com_err_ ext entry options (variable);

dcl  hcs_$set_safety_sw ext entry (char (*), char (*), bit (1), fixed bin (35));
dcl  hcs_$set_damaged_sw ext entry (char (*), char (*), bit (1), fixed bin (35));

dcl (null, substr, addr) builtin;
dcl  cleanup condition;

	new_value = "1"b;
	whoami = "safety_sw_on";
	safety_sw = "1"b;
	goto start;

safety_sw_off: ssf: entry;
	new_value = "0"b;
	whoami = "safety_sw_off";
	safety_sw = "1"b;
	goto start;

damaged_sw_on: dsn: entry;

	new_value = "1"b;
	whoami = "damaged_sw_on";
	safety_sw = "0"b;
	goto start;

damaged_sw_off: dsf: entry;

	new_value = "0"b;
	whoami = "damaged_sw_off";
	safety_sw = "0"b;

start:

	npp = addr (new_path);
	dirp = addr (dirname);
	entp = addr (entname);

	on cleanup call ss_cleanup;

	do i = 1 by 1;				/* loop through all arguments */

	     call cu_$arg_ptr (i, aptr, alng, code);
	     if code ^= 0 then do;
		if i = 1 then go to no_pathname;	/* no argument means safety switch of working directory */
		return;				/* otherwise we are done */
	     end;

	     if (arg = "-wd")| (arg = "-working_directory") then do;
no_pathname:	aptr = dirp;
		alng = 3;
		dirname = "-wd";
		goto check_name;
	     end;

	     if substr (arg, 1, 1) = "-" then do;
		call com_err_ (error_table_$badopt, whoami, "^a", arg);
		return;
	     end;

check_name:
	     call check_path_name_ (aptr, alng, "0"b, whoami, dirp, entp, npp, ecount, eptr, nptr, retc);
	     if retc = 2 then go to free_up;		/* error message was already printed */
	     ename = entname;

	     do j = 1 to ecount;			/* loop through all enames */

		if retc = 1 then do;		/* a star name */
		     call check_path_name_$indiv (dirp, bentp, "0"b);
		     ename = bentp -> b_name;
		end;

		if safety_sw			/* See if to set safety sw or damaged sw */
		then call hcs_$set_safety_sw (dirname, ename, new_value, code);
		else call hcs_$set_damaged_sw (dirname, ename, new_value, code);
		if code ^= 0 then do;
		     call com_err_ (code, whoami, new_path);
						/* if user lacks modify permission on parent */
		     if (code = error_table_$incorrect_access) | (code = error_table_$no_info) then
			go to free_up;		/* skip processing segments in this directory */
		end;
	     end;
free_up:
	     call ss_cleanup;

	end;					/* loop through pathnames */

ss_cleanup: proc;

	     if eptr ^= null then call freen_ (eptr);
	     if nptr ^= null then call freen_ (nptr);

	end ss_cleanup;

     end safety_sw_on;




		    set_max_length.pl1              03/10/85  1722.3r w 03/08/85  1005.7      128331



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



/* format: style2,idind30,indcomtxt */

set_max_length:
sml:
     procedure options (variable);

/* Changed to round up mod 1024 instead of mod 16 by Steve Herbst 11/20/75 */
/* MCR 4271, 4272 Add -record and make args nonpositional 01/08/80 S. Herbst */
/* Made to work on mailboxes and queues 03/28/80 S. Herbst */
/* Add -maximum 05/12/80 S. Herbst */
/* Modified 2/20/83 Jay Pattin for object_type_ */
/* 256K max length check, 3/1 E. N. Kittlitz */
/* 830927 BIM object_type_ -> fs_util_ */
/* 850206 MSharpe to replace -fcnt with -inase/inaee */

          dcl     (dirname, new_path)           char (168);
          dcl     (entname, ename)              char (32);
          dcl     (length_string, seg_type)     char (32);
          dcl     answer                        char (3) var;

          dcl     arg                           char (alng) based (aptr) unaligned;
          dcl     b_name                        char (32) based;

          dcl     (aptr, bentp)                 ptr;
          dcl     (eptr, nptr)                  ptr init (null);

          dcl     (arg_count, ecount, entry_len, j, retc)
                                                fixed bin;
          dcl     alng                          fixed bin (21);
          dcl     base                          fixed bin;
          dcl     code                          fixed bin (35);
          dcl     (max_length, fixed_max_length)
                                                fixed bin (19);

          dcl     (brf_sw, len_sw, mbx_sw, max_sw, pth_sw, record_sw)
                                                bit (1);

          dcl     whoami                        char (16) int static init ("set_max_length");

          dcl     decimal                       fixed bin int static init (1);
          dcl     octal                         fixed bin int static init (2);

          dcl     label                         (2) char (8) init ("decimal", "octal");

          dcl     sys_info$max_seg_size         fixed bin (18) ext;

          dcl     (
                  error_table_$action_not_performed,
                  error_table_$argerr,
                  error_table_$badopt,
                  error_table_$dirseg,
                  error_table_$incorrect_access,
                  error_table_$invalid_max_length,
                  error_table_$no_info,
                  error_table_$noarg
                  )                             ext fixed bin (35);

          dcl     1 query_info                  aligned,
                    2 version                   fixed bin init (2),
                    2 yes_or_no_sw              bit (1) unaligned init ("1"b),
                    2 suppress_name_sw          bit (1) unaligned init ("0"b),
                    2 status_code               fixed bin (35),
                    2 query_code                fixed bin (35) init (0);

          dcl     sml_entry                     entry (char (*), char (*), fixed bin (19), fixed bin (35)) variable;
          dcl     sbc_entry                     entry (char (*), char (*), fixed bin (24), fixed bin (35)) variable;

          dcl     check_path_name_              ext
                                                entry (ptr, fixed bin (21), bit (1) aligned, char (16) aligned, ptr, ptr,
                                                ptr, fixed bin (17), ptr, ptr, fixed bin (17));
          dcl     check_path_name_$indiv        ext entry (ptr, ptr, bit (1) aligned);
          dcl     cu_$arg_ptr                   ext entry (fixed bin (17), ptr, fixed bin (21), fixed bin (35));
          dcl     cv_dec_check_                 ext entry (char (*), fixed bin (35)) returns (fixed bin (35));
          dcl     cv_oct_check_                 ext entry (char (*), fixed bin (35)) returns (fixed bin (35));
          dcl     (
                  com_err_,
                  com_err_$suppress_name,
                  command_query_
                  )                             ext entry options (variable);

          dcl     (
                  hcs_$set_max_length,
                  fs_util_$set_max_length
                  )                             ext entry (char (*), char (*), fixed bin (19), fixed bin (35));
          dcl     hcs_$truncate_file            ext entry (char (*), char (*), fixed bin (19), fixed bin (35));
          dcl     (
                  hcs_$set_bc,
                  fs_util_$set_bit_count
                  )                             ext entry (char (*), char (*), fixed bin (24), fixed bin (35));

          dcl     cleanup                       condition;

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

          on cleanup call sml_cleanup;

          brf_sw, len_sw, max_sw, pth_sw, record_sw = "0"b;
          base = decimal;
          sml_entry = fs_util_$set_max_length;
          sbc_entry = fs_util_$set_bit_count;

          do arg_count = 1 by 1;

               call cu_$arg_ptr (arg_count, aptr, alng, code);
               if code ^= 0
               then do;
                         if arg_count < 2
                         then do;                           /* must have at least 2 args */
USAGE:
                                   call com_err_$suppress_name (0, whoami,
                                        "Usage:  set_max_length path length {-control_args}");
                                   goto free_up;
                              end;
                         goto process_request;              /* ready to do work */
                    end;
               if index (arg, "-") = 1
               then do;

                         if (arg = "-dc") | (arg = "-decimal")
                         then base = decimal;

                         else if (arg = "-oc") | (arg = "-octal")
                         then base = octal;

                         else if (arg = "-bf") | (arg = "-brief")
                         then brf_sw = "1"b;

                         else if (arg = "-rec") | (arg = "-record")
                         then record_sw = "1"b;

                         else if (arg = "-word")
                         then record_sw = "0"b;

                         else if (arg = "-maximum") | (arg = "-max")
                         then if len_sw
                              then do;
MAX_USAGE:
                                        call com_err_ (0, whoami, "-maximum inconsistent with length argument.");
                                        return;
                                   end;
                              else max_sw = "1"b;

		     else if arg = "-interpret_as_standard_entry" | arg = "-inase"
                              then do;
                                   sml_entry = hcs_$set_max_length;
                                   sbc_entry = hcs_$set_bc;
                              end;
		     else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
		     then do;
			     sml_entry = fs_util_$set_max_length;
			     sbc_entry = fs_util_$set_bit_count;
			end;

                         else do;                           /* not a legal control argument */
                                   call com_err_ (error_table_$badopt, whoami, arg);
                                   return;
                              end;

                    end;                                    /* must be pathname */
               else if ^pth_sw
               then do;
                         call check_path_name_ (aptr, alng, "0"b, (whoami), addr (dirname), addr (entname),
                              addr (new_path), ecount, eptr, nptr, retc);
                         if retc = 2
                         then return;                       /* err and freeing all done */
                         ename = entname;
                         pth_sw = "1"b;
                    end;
               else do;                                     /* max length number */
                         if len_sw
                         then go to USAGE;                  /* supplied two length strings */
                         if max_sw
                         then go to MAX_USAGE;
                         length_string = arg;
                         len_sw = "1"b;                     /* indicate that have length (and pathname) */
                    end;

          end;

process_request:
          if max_sw
          then do;
                    max_length = sys_info$max_seg_size;
                    go to SET;
               end;

          if ^len_sw
          then go to USAGE;

          if base = decimal
          then max_length = cv_dec_check_ (length_string, code);
          else max_length = cv_oct_check_ (length_string, code);
          if code ^= 0
          then do;                                          /* code indicates which digit failed */
                    call com_err_ (0, whoami, "Invalid ^a number ^a", label (base), length_string);
                    go to free_up;
               end;

          if record_sw
          then max_length = max_length * 1024;

          else if mod (max_length, 1024) ^= 0
          then do;                                          /* must be in terms of records used */
                    fixed_max_length = divide (max_length + 1023, 1024, 19, 0) * 1024;
                    if ^brf_sw
                    then do;
                              if base = decimal
                              then call com_err_ (0, whoami, "^d is not a multiple of 1024 words, ^d used for max length",
                                        max_length, fixed_max_length);
                              else call com_err_ (0, whoami,
                                        "^o is not a multiple of 2000 (1024 decimal) words, ^o used for max length",
                                        max_length, fixed_max_length);
                         end;
                    max_length = fixed_max_length;
               end;

          if max_length > sys_info$max_seg_size
          then do;
                    call com_err_ (0, whoami,
                         "The specified value exceeds the supported maximum length for a segment. Please type ""help 256K_segments.gi""."
                         );
                    go to free_up;
               end;

SET:
          do j = 1 to ecount;                               /* loop through all enames */

               if retc = 1
               then do;                                     /* a star name */
                         call check_path_name_$indiv (addr (dirname), bentp, "0"b);
                         ename = bentp -> b_name;
                    end;

               call sml_entry (dirname, ename, max_length, code);
               if code ^= 0
               then do;
                         if retc = 1
                         then if code = error_table_$dirseg
                              then go to loop_end;          /* skip directories */
                         if code = error_table_$argerr
                         then do;                           /* wrong max length */
argerr:
                                   if base = decimal
                                   then call com_err_ (0, whoami, "Invalid max length ^d.", max_length);
                                   else call com_err_ (0, whoami, "Invalid max length ^o.", max_length);
                                   go to free_up;
                              end;
                         else if code = error_table_$invalid_max_length
                         then do;
                                   query_info.status_code = code;
                                   if base = decimal
                                   then call command_query_ (addr (query_info), answer, whoami,
                                             "Max length is less than current length, do you want to truncate ^a to ^d?",
                                             new_path, max_length);
                                   else call command_query_ (addr (query_info), answer, whoami,
                                             "Max length is less than current length, do you want to truncate ^a to ^o?",
                                             new_path, max_length);
                                   if answer = "no"
                                   then go to loop_end;
                                   call hcs_$truncate_file (dirname, ename, max_length, code);
                                   if code ^= 0
                                   then goto dont_care_err;
                                   call sbc_entry (dirname, ename, max_length * 36, code);
                                   call sml_entry (dirname, ename, max_length, code);
                                   if code ^= 0
                                   then goto dont_care_err;
                              end;
                         else do;
dont_care_err:
                                   call com_err_ (code, whoami, new_path);
                                                            /* if incorrect access on parent directory */
                                   if (code = error_table_$incorrect_access) | (code = error_table_$no_info)
                                   then go to free_up;      /* skip processing rest of star names */
                              end;                          /* code is 0, continue loop */
                    end;

loop_end:
          end;

free_up:
          call sml_cleanup;
          return;

sml_cleanup:
     proc;
          declare freen_                        entry (pointer);
                                                            /* Ycch, but we have no structure to free */

          if eptr ^= null
          then call freen_ (eptr);
          if nptr ^= null
          then call freen_ (nptr);                          /* proc */
     end;

/* proc */
     end set_max_length;




		    switch_on.pl1                   08/23/88  0817.3rew 08/23/88  0814.4      241587



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


/****^  HISTORY COMMENTS:
  1) change(86-11-11,Lippard), approve(86-12-08,MCR7589),
     audit(87-02-16,Farley), install(87-03-23,MR12.1-1009):
     Modified to allow damaged switch for directories.
  2) change(87-08-21,TLNguyen), approve(87-08-21,MCR7556),
     audit(87-09-01,Lippard), install(87-12-07,MR12.2-1009):
     a. Change the switch_on to return an error message to the user when
        it fails to determine the type of a specified non-existent entry.
     
     b. Change the switch_on to set a specified support switch name on
        for a specified existing extended entry type such as forum.
  3) change(88-05-12,Lippard), approve(88-05-02,MCR7881),
     audit(88-06-16,Fawcett), install(88-08-02,MR12.2-1074):
     Changed to allow setting of audit_switch.
  4) change(88-08-16,TLNguyen), approve(88-08-16,MCR7921),
     audit(88-08-17,Parisek), install(88-08-23,MR12.2-1091):
     Prevents an infinitive loop when one of the specified existent paths is a
     Multisegment-file (MSF).
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */
switch_on:
swn:
     procedure options (variable);

/****
      Syntax:  switch_on name paths {-chase/-no_chase}
      switch_off name paths {-chase/-no_chase}

      Turns on or off the named switch (safety, copy, no_complete_volume_dump, etc.) for the
      specified pathnames. The star convention is allowed in paths.

      For an MSF, the switches of the MSF dir (when possible) and those of all the non-link components are set. */

/* Written 06/18/80 by S. Herbst */
/* Fixed to see links with starname only if -chase 11/17/80 S. Herbst */
/* Modified September 1982, J. Bongiovanni, for synchronized switch */
/* Added -name 10/26/82 S. Herbst */
/* Modified 2/20/83 Jay Pattin for object_type_ */
/* Modified 830927 BIM for object_type_ --> fs_util_ */
/* Fixed to detect "Entry not found" 12/13/83 S. Herbst */
/* Fixed to not blow out trying to find obj map of null seg, 1984.08.26, MAP */
/* 850206 MSharpe to replace -fcnt with -inase/inaee */
/* 850226 MSharpe to give better error messages when invalid switch names
   are given in conjunction with starnames */

/* Constants */

	dcl     long_key		        (8) char (32) int static options (constant)
				        init ("copy", "damaged", "complete_volume_dump",
				        "incremental_volume_dump", "perprocess_static", "safety", "synchronized","audit");

	dcl     short_key		        (8) char (32) int static options (constant)
				        init ("cp", "dm", "cvd", "ivd", "pps", "sf", "synch", "ad");

	dcl     long_long_key	        (8) char (32) int static options (constant)
				        init ("copy_switch", "damaged_switch", "complete_volume_dump_switch",
				        "incremental_volume_dump_switch", "perprocess_static_switch",
				        "safety_switch", "synchronized_switch","audit_switch");

	dcl     short_long_key	        (8) char (32) int static options (constant)
				        init ("csw", "dsw", "cvds", "ivds", "ppsw", "ssw", "synsw","asw");

	dcl     DIR_ALLOWED		        bit (8) aligned static options (constant) init ("01000101"b);

	dcl     (UNKNOWN_KEY, GENERAL_SET)    fixed bin int static options (constant) init (9);

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

	dcl     BRANCHES_ONLY	        fixed bin int static options (constant) init (2);
	dcl     BRANCHES_AND_LINKS	        fixed bin int static options (constant) init (3);

	dcl     (
	        LINK_TYPE		        init (0),
	        SEG_TYPE		        init (1),
	        DIR_TYPE		        init (2),
	        MSF_TYPE		        init (3),
	        EXTENDED_TYPE	        init (4)
	        )			        fixed bin static options (constant);


/* Based */

	dcl     arg		        char (arg_len) based (arg_ptr);

	dcl     1 entries		        (entries_count) aligned based (entries_ptr),
		2 type		        fixed bin (2) unaligned unsigned,
		2 nnames		        fixed bin (15) unaligned,
		2 nindex		        fixed bin (17) unaligned;

	dcl     names		        (99 /* arbitrary */) char (32) aligned based (names_ptr);


/* Automatic */

	dcl     (dn, target_dn)	        char (168);
	dcl     (en, key_name, me, star_en, target_en)
				        char (32);

	dcl     (chase_arg_given_sw, chase_sw, force_no_type_sw, got_key, got_path, name_sw, some_sw, star_sw,
	        switch_value)	        bit (1) aligned;

	dcl     area		        area based (area_ptr);

	dcl     (area_ptr, arg_ptr, entries_ptr, names_ptr)
				        ptr;

	dcl     (arg_count, arg_len, entries_count, i, j, key_index, star_type, type)
				        fixed bin;
	dcl     code		        fixed bin (35);

	dcl     error_table_$argerr	        fixed bin (35) ext;
	dcl     error_table_$badopt	        fixed bin (35) ext;
	dcl     error_table_$incorrect_access fixed bin (35) ext;
	dcl     error_table_$moderr	        fixed bin (35) ext;
	dcl     error_table_$no_dir	        fixed bin (35) ext;
	dcl     error_table_$no_s_permission  fixed bin (35) ext;
	dcl     error_table_$nomatch	        fixed bin (35) ext;
	dcl     error_table_$not_a_branch     fixed bin (35) ext;
	dcl     error_table_$root	        fixed bin (35) ext;

	dcl     (
	        com_err_,
	        com_err_$suppress_name
	        )			        entry options (variable);
	dcl     check_star_name_$entry        entry (char (*), fixed bin (35));
	dcl     cu_$arg_count	        entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		        entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_group_id_	        entry returns (char (32));
	dcl     get_system_free_area_	        entry returns (ptr);
	dcl     get_wdir_		        entry returns (char (168));
	dcl     hcs_$add_acl_entries	        entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delete_acl_entries       entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$get_link_target	        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$initiate_count	        entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr,
				        fixed bin (35));
	dcl     hcs_$list_acl	        entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     hcs_$set_copysw	        entry (char (*), char (*), fixed bin (1), fixed bin (35));
	dcl     hcs_$set_damaged_sw	        entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     hcs_$set_safety_sw	        entry (char (*), char (*), bit (1), fixed bin (35));
	dcl     hcs_$set_synchronized_sw      entry (char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     hcs_$set_volume_dump_switches entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35));
	dcl     hcs_$star_		        entry (char (*), char (*), fixed bin, ptr, fixed bin, ptr, ptr,
				        fixed bin (35));
	dcl     hcs_$status_minf	        entry (char (*), char (*), fixed bin (1), fixed bin, fixed bin (24),
				        fixed bin (35));
	dcl     hcs_$terminate_noname	        entry (ptr, fixed bin (35));
	dcl     fs_util_$set_switch	        entry (char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     fs_util_$get_type	        entry (character (*), character (*), character (*), fixed binary (35));
	dcl     pathname_		        entry (char (*), char (*)) returns (char (168));
          dcl     system_privilege_$set_entry_audit_switch
    	        entry (char (*), char (*), bit (1), fixed bin (35));

	dcl     (addr, addrel, divide, fixed, hbound, index, null, rtrim, substr)
				        builtin;

          dcl     test_linkage_entry	        entry variable options (variable);


	dcl     cleanup		        condition;
          dcl     linkage_error	        condition;
%page;
	me = "switch_on";
	switch_value = "1"b;
	go to COMMON;

switch_off:
swf:
     entry;

	me = "switch_off";
	switch_value = "0"b;

COMMON:
	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, me);
		return;
	     end;

/* Read control args */

	chase_sw, chase_arg_given_sw, force_no_type_sw = "0"b;

	do i = 1 to arg_count;

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

	     if substr (arg, 1, 1) = "-"
	     then if arg = "-chase"
		then chase_sw, chase_arg_given_sw = "1"b;
		else if arg = "-no_chase"
		then do;
			chase_sw = "0"b;
			chase_arg_given_sw = "1"b;
		     end;

		else if arg = "-interpret_as_standard_entry" | arg = "-inase"
		then force_no_type_sw = "1"b;

		else if arg = "-interpret_as_extended_entry" | arg = "-inaee"
		then force_no_type_sw = "0"b;

		else if arg = "-name" | arg = "-nm"
		then do;				/* skip following arg */
			i = i + 1;
			if i > arg_count
			then do;
				call com_err_ (0, me, "No value specified for -name");
				return;
			     end;
		     end;
		else do;
			call com_err_ (error_table_$badopt, me, "^a", arg);
			return;
		     end;
	end;

/* Read and process other args */

	got_key, got_path, name_sw = "0"b;
	area_ptr, entries_ptr, names_ptr = null;
	on cleanup call clean_up;

	do i = 1 to arg_count;

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

	     if arg = "-name" | arg = "-nm"
	     then name_sw = "1"b;
	     else if index (arg, "-") ^= 1
	     then if ^got_key
		then do;
			key_name = arg;
			do j = hbound (long_key, 1) by -1 to 1 while (long_key (j) ^= key_name);
			end;
			if j = 0
			then do;
				do j = hbound (short_key, 1) by -1 to 1 while (short_key (j) ^= key_name);
				end;
				if j = 0
				then do;
					do j = hbound (long_long_key, 1) by -1 to 1
					     while (long_long_key (j) ^= key_name);
					end;
					if j = 0
					then do;
						do j = hbound (short_long_key, 1) by -1 to 1
						     while (short_long_key (j) ^= key_name);
						end;
						if j = 0
						then if force_no_type_sw
						     then do;
							     call com_err_ (0, me,
								"Invalid switch name: ^a", key_name);
							     goto RETURN;
							end;
						     else j = UNKNOWN_KEY;
						/* MAY BE EXTENDED OBJECT */
					     end;
				     end;
			     end;
			key_index = j;
			got_key = "1"b;
			name_sw = "0"b;
		     end;

		else do;

			got_path = "1"b;

			if name_sw
			then do;
				name_sw = "0"b;
				dn = get_wdir_ ();
				en = arg;
				go to LITERAL_NAME;
			     end;

			call expand_pathname_ (arg, dn, en, code);
			if code ^= 0
			then do;
				call com_err_ (code, me, "^a", arg);
				return;
			     end;

			if dn = ">" & en = ""
			then do;
				call com_err_ (error_table_$root, me, "^a", arg);
				go to NEXT_ARG;
			     end;

			call check_star_name_$entry (en, code);
			if code = 0
			then do;
LITERAL_NAME:
				star_sw = "0"b;

				type = get_type (dn, en);
						/* no stars */

				if type = LINK_TYPE
				then if chase_arg_given_sw & ^chase_sw
				     then call com_err_ (error_table_$not_a_branch, me, "^a", pathname_ (dn, en));

				     else do;	/* default: chase if not stars */

					     call resolve_link (dn, en, target_dn, target_en, type, code);

					     if code = 0
					     then call set_one (target_dn, target_en, type, key_index,
						     switch_value, code);
					     else call com_err_ (code, me, "Chasing link ^a",
						     pathname_ (target_dn, target_en));

					end;

				else call set_one (dn, en, type, key_index, switch_value, code);
			     end;

			else if code > 2
			then do;			/* bad syntax in starname */
				call com_err_ (code, me, "^a", arg);
				return;
			     end;

			else do;
				star_sw = "1"b;
				star_en = en;

				if area_ptr = null
				then area_ptr = get_system_free_area_ ();

				entries_ptr, names_ptr = null;

				if chase_sw
				then star_type = BRANCHES_AND_LINKS;
				else star_type = BRANCHES_ONLY;

				some_sw = "0"b;

				call hcs_$star_ (dn, en, star_type, area_ptr, entries_count, entries_ptr,
				     names_ptr, code);
				if code ^= 0
				then do;
					call com_err_ (code, me, "^a", pathname_ (dn, en));
					go to NEXT_ARG;
				     end;

				else do j = 1 to entries_count;

					type = entries_ptr -> entries (j).type;
					if type = SEG_TYPE | type = DIR_TYPE
					then do;	/* not a link */

						target_dn = dn;
						target_en =
						     names_ptr -> names (entries_ptr -> entries (j).nindex);

BRANCH:
						type = get_type (target_dn, target_en);
						/* MSF?, EXTENDED? */

						if (type ^= EXTENDED_TYPE) & key_index = UNKNOWN_KEY
						then ;
						else do;
							call set_one (target_dn, target_en, type, key_index,
							     switch_value, code);

							if code ^= 0
							then if code = error_table_$no_s_permission
								| code = error_table_$incorrect_access
								| code = error_table_$no_dir
							     then go to NEXT_ARG;
						     end;
					     end;

					else if chase_sw
					then do;	/* link */

						en = names_ptr -> names (entries_ptr -> entries (j).nindex);

						call resolve_link (dn, en, target_dn, target_en, type, code);

						if code = 0
						then go to BRANCH;
						else if key_index = UNKNOWN_KEY
						then ;
						/* Quiet! Wasn't meant for this one anyway */
						else call com_err_ (code, me, "Chasing link ^a",
							pathname_ (dn, en));
					     end;
				     end;

				if star_sw & ^some_sw
				then if key_index = UNKNOWN_KEY
				     then call com_err_ (0, me, "Invalid switch name: ^a", key_name);
				     else call com_err_ (error_table_$nomatch, me, "^a", pathname_ (dn, star_en));

NEXT_ARG:
				call clean_up;
			     end;
		     end;
	end;

	if ^got_path
	then do;
		call com_err_$suppress_name (0, me, "Usage:  ^a keyword paths {-control_args}", me);
		return;
	     end;

RETURN:
	call clean_up;

	return;
%page;
get_type:
     proc (P_dn, P_en) returns (fixed bin);

/* Decides whether an entry is a segment, directory, or MSF */

	dcl     (P_dn, P_en)	        char (*);
	dcl     type		        fixed bin;
	dcl     bit_count		        fixed bin (24);
	dcl     fs_util_type	        char (32);

          code = 0;                                         /* make get_type happy */
	fs_util_type = "";

	if ^force_no_type_sw
	then do;
		call fs_util_$get_type (P_dn, P_en, fs_util_type, code);

		if code = 0 & ((substr (fs_util_type, 1, 1) ^= "-") | (fs_util_type = FS_OBJECT_TYPE_DM_FILE))
		then return (EXTENDED_TYPE);		/* extended object or DM files,i.e., non-hcs */
		else if code ^= 0
		     then do;
			call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
			goto RETURN;
		     end;
		else;
	     end;

	call hcs_$status_minf (P_dn, P_en, NO_CHASE, type, bit_count, code);
	if code ^= 0 & code ^= error_table_$no_s_permission
	then do;
		if key_index = UNKNOWN_KEY
		then call com_err_ (0, me, "Invalid switch name: ^a.", key_name);
		else call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
		go to RETURN;
	     end;

	if type = DIR_TYPE & bit_count > 0
	then return (MSF_TYPE);
	else return (type);

%include suffix_info;
%include copy_flags;
     end get_type;
%page;
resolve_link:
     proc (P_dn, P_en, P_target_dn, P_target_en, P_type, P_code);

/* Chases a link and gets the type of the target */

	dcl     (P_dn, P_en, P_target_dn, P_target_en)
				        char (*);
	dcl     P_type		        fixed bin;
	dcl     P_code		        fixed bin (35);

	call hcs_$get_link_target (P_dn, P_en, P_target_dn, P_target_en, P_code);
	if P_code ^= 0
	then return;

	P_type = get_type (P_target_dn, P_target_en);

     end resolve_link;
%page;
set_one:
     proc (P_dn, P_en, P_type, P_key_index, P_switch_value, P_code);

/* Sets the switch of one segment by calling the appropriate routine */

	dcl     (P_dn, P_en)	        char (*);
	dcl     P_switch_value	        bit (1) aligned;
	dcl     (P_key_index, P_type)	        fixed bin;
	dcl     P_code		        fixed bin (35);

	dcl     (entries_ptr, names_ptr)      ptr;
	dcl     entries_count	        fixed bin;
	dcl     code		        fixed bin (35);

	dcl     msf_path		        char (168);
	dcl     component_name	        char (32);
          dcl     msf_component_index           fixed bin;  /* local */
     
          code = 0;                                         /* must initialize to avoid it was previously contained garbage */

	if P_type = MSF_TYPE
	then do;					/* first set the switch on all the components */

		if long_key (P_key_index) = "perprocess_static"
		then do;
			call com_err_ (0, me, "Operation not allowed on MSF's.  ^a", pathname_ (P_dn, P_en));
			return;
		     end;

		msf_path = P_dn;
		if msf_path ^= ">"
		then msf_path = rtrim (msf_path) || ">";
		msf_path = rtrim (msf_path) || P_en;

		if area_ptr = null
		then area_ptr = get_system_free_area_ ();
		entries_ptr, names_ptr = null;

		on cleanup call msf_cleanup;

		call hcs_$star_ (msf_path, "**", BRANCHES_ONLY, area_ptr, entries_count, entries_ptr, names_ptr, code);

		if code = 0 & entries_count > 0
		then do;
			do msf_component_index = 1 to entries_count;
			     component_name = names_ptr -> names (entries_ptr -> entries (msf_component_index).nindex);

			     call set_whichever (msf_path, component_name, (entries_ptr -> entries (msf_component_index).type),
				P_key_index, P_switch_value);
			end;

			call msf_cleanup;
		     end;
	     end;

	if P_type ^= MSF_TYPE | substr (DIR_ALLOWED, P_key_index, 1)
	then call set_whichever (P_dn, P_en, P_type, P_key_index, P_switch_value);

	return;

msf_cleanup:
     proc;

	if entries_ptr ^= null
	then free entries_ptr -> entries in (area);
	if names_ptr ^= null
	then free names_ptr -> names in (area);

     end msf_cleanup;


     end set_one;
%page;
set_whichever:
     proc (P_dn, P_en, P_type, P_key_index, P_switch_value);

/* Calls the appropriate entry point to set a switch */

	dcl     (P_dn, P_en)	        char (*);
	dcl     (P_type, P_key_index)	        fixed bin;
	dcl     P_switch_value	        bit (1) aligned;
	dcl     code		        fixed bin (35);

	dcl     (ncvd_value, nivd_value)      fixed bin;

          code = 0;                                         /* must initialize to avoid it was previously contained an unexpected value */

	if P_type = EXTENDED_TYPE
	then goto SET (GENERAL_SET);

	if P_type = DIR_TYPE & ^substr (DIR_ALLOWED, P_key_index, 1)
	then do;
		if ^star_sw
		then call com_err_ (0, me, "Directories do not support the ^a switch. ^a.", key_name,
			pathname_ (P_dn, P_en));
		return;
	     end;

	go to SET (P_key_index);

SET (1):						/* copy switch */
	some_sw = "1"b;
	call hcs_$set_copysw (P_dn, P_en, fixed (P_switch_value, 1), code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
	return;


SET (2):						/* damaged_switch */
	some_sw = "1"b;
	call hcs_$set_damaged_sw (P_dn, P_en, (P_switch_value), code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
	return;

SET (3):						/* complete_volume_dump switch */
	some_sw = "1"b;				/* use NOT of user's arg "complete_volume_dump_switch" */
	if P_switch_value
	then ncvd_value = -1;
	else ncvd_value = 1;
	call hcs_$set_volume_dump_switches (P_dn, P_en, 0, ncvd_value, code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
	return;

SET (4):						/* incremental_volume_dump switch */
	some_sw = "1"b;				/* use NOT of user's arg "incremental_volume_dump_switch" */
	if P_switch_value
	then nivd_value = -1;
	else nivd_value = 1;
	call hcs_$set_volume_dump_switches (P_dn, P_en, nivd_value, 0, code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));

	return;

SET (5):						/* perprocess_static switch */
	some_sw = "1"b;
	call set_perprocess (P_dn, P_en, P_switch_value, code);
	return;

SET (6):						/* safety switch */
	some_sw = "1"b;
	call hcs_$set_safety_sw (P_dn, P_en, (P_switch_value), code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
	return;

SET (7):						/* synchronized switch */
	some_sw = "1"b;
	call hcs_$set_synchronized_sw (P_dn, P_en, (P_switch_value), code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
	return;

SET (8):	                                                  /* entry audit switch */
	some_sw = "1"b;
	on linkage_error begin;
	   call com_err_ (error_table_$moderr, me, "system_privilege_");
	   goto no_sys_priv;
	   end;
	test_linkage_entry = system_privilege_$set_entry_audit_switch;
	call system_privilege_$set_entry_audit_switch (P_dn, P_en, (P_switch_value), code);
	if code ^= 0
	then call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));

no_sys_priv:
	
	return;
SET (9):						/* unknown keyname, only allowed for extended objects */
	if type ^= EXTENDED_TYPE
	then do;
		if ^star_sw
		then call com_err_ (0, me, "Invalid switch name: ^a.", key_name);
		return;
	     end;

	if key_index = UNKNOWN_KEY                        /* users specified a switch name for a specified extended entry */
	then call fs_util_$set_switch (P_dn, P_en, key_name, P_switch_value, code); 
	else call fs_util_$set_switch (P_dn, P_en, long_key (key_index), P_switch_value, code);

	if code ^= 0
	then do;
	     
	     if code = error_table_$argerr

	     then if star_sw & P_key_index = UNKNOWN_KEY
		then return;			/* we don't support this switch; if nobody else does,
						   the Invalid switch error will be printed at the end */
		else call com_err_ (code, me, "^/This object does not support the ^a switch.  ^a", key_name,
			pathname_ (P_dn, P_en));      /* must display error code value to users */

	     else call com_err_ (code, me, "^[Res^;S^]etting ^a switch on ^a.", ^P_switch_value, key_name,
		     pathname_ (P_dn, P_en));
	     end;

	some_sw = "1"b;
	return;

     end set_whichever;
%page;
set_perprocess:
     proc (P_dn, P_en, P_switch_value, P_code);

/* Sets the perprocess_static switch of an object segment, which is in the segment itself */

	dcl     (P_dn, P_en)	        char (*);
	dcl     P_switch_value	        bit (1) aligned;
	dcl     P_code		        fixed bin (35);

%include object_map;

	dcl     1 segment_acl	        (1) aligned,/* to force access to Person.Project.a */
		2 access_name	        char (32),
		2 mode		        bit (36),
		2 pad		        bit (36),
		2 status_code	        fixed bin (35);

	dcl     saved_mode		        bit (36);
	dcl     delete_acl_sw	        bit (1);
	dcl     (last_word_ptr, object_map_ptr, seg_ptr)
				        ptr;
	dcl     object_map_index	        fixed bin;
	dcl     word_count		        fixed bin (18);
	dcl     bit_count		        fixed bin (24);
	dcl     code		        fixed bin (35);

	seg_ptr = null;
	delete_acl_sw = "0"b;

	on cleanup call sp_cleanup;

	call hcs_$initiate_count (P_dn, P_en, "", bit_count, 0, seg_ptr, P_code);
	if seg_ptr = null
	then do;
		call com_err_ (code, me, "^a", pathname_ (P_dn, P_en));
		return;
	     end;

	if bit_count = 0
	then do;
BAD_OBJECT:
		if ^star_sw
		then call com_err_ (0, me, "Obsolete or non-object segment ^a", pathname_ (P_dn, P_en));
		P_code = 0;
		go to SP_RETURN;
	     end;

	word_count = divide (bit_count + 35, 36, 18, 0);
	last_word_ptr = addrel (seg_ptr, word_count - 1);

	object_map_index = fixed (last_word_ptr -> map_ptr, 18);
	if object_map_index <= 0 | object_map_index > word_count
	then go to BAD_OBJECT;

	object_map_ptr = addrel (seg_ptr, last_word_ptr -> map_ptr);
	if object_map_ptr -> object_map.identifier ^= "obj_map "
	then go to BAD_OBJECT;

	if object_map_ptr -> object_map.decl_vers ^= 2
	then go to BAD_OBJECT;			/* obsolete version */

/* Force write access if necessary */

	segment_acl (1).access_name = get_group_id_ ();	/* Person.Project.a */

	call hcs_$list_acl (P_dn, P_en, null, null, addr (segment_acl), 1, P_code);
	if P_code ^= 0
	then do;
		call com_err_ (P_code, me, "^a", pathname_ (P_dn, P_en));
		go to SP_RETURN;
	     end;

	if segment_acl (1).status_code ^= 0
	then delete_acl_sw = "1"b;			/* no such previous ACL term */
	else do;
		delete_acl_sw = "0"b;		/* have to restore previous access */
		saved_mode = segment_acl (1).mode;
	     end;

	segment_acl (1).mode = "101"b;		/* set rw */

	call hcs_$add_acl_entries (P_dn, P_en, addr (segment_acl), 1, P_code);
	if P_code ^= 0
	then do;
		call com_err_ (P_code, me, "^a", pathname_ (P_dn, P_en));
		go to SP_RETURN;
	     end;

	on cleanup
	     begin;
		call restore_acl;
		call sp_cleanup;
	     end;

	object_map_ptr -> object_map.format.perprocess_static = P_switch_value;

	call restore_acl;

SP_RETURN:
	call sp_cleanup;

	return;


restore_acl:
     proc;

	if delete_acl_sw
	then call hcs_$delete_acl_entries (P_dn, P_en, addr (segment_acl), 1, code);
	else do;
		segment_acl (1).mode = saved_mode;	/* restore previous access */
		call hcs_$add_acl_entries (P_dn, P_en, addr (segment_acl), 1, code);
	     end;

     end restore_acl;


sp_cleanup:
     proc;

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

     end sp_cleanup;

     end set_perprocess;
%page;
/* SAVED FOR LATER SHAPING UP
   set_soos: proc (P_dn, P_en, P_switch_value, P_code);

   /* Turns soos on, or tests for consistent AIM attributes and turns soos off

   dcl (P_dn, P_en) char (*);
   dcl P_switch_value bit (1);
   dcl P_code fixed bin (35);

   dcl (code, old_dir_priv, old_soos_priv) fixed bin (35);

   on linkage_error begin;
   call com_err_ (error_table_$moderr, me, "system_privilege_.");
   go to RETURN;
   end;

   if P_switch_value = "1"b then call system_privilege_$soos_on (P_dn, P_en, P_code);

   else do;

   old_dir_priv, old_soos_priv = 1;               /* don't restore privileges unless set

   on cleanup call clean_up_privs;

   call system_privilege_$dir_priv_on (old_dir_priv);       /* ensure necessary privileges
   call system_privilege_$soos_priv_on (old_soos_priv);

   call system_privilege_$check_mode_reset (P_dn, P_en, P_code);
   /* this entry point only succeeds if the branch's
   AIM attributes are consistent
   if P_code ^= 0 then call com_err_ (P_code, me, "^a", pathname_ (P_dn, P_en));
   end;


   clean_up_privs: proc;

   if old_dir_priv = 0 then call system_privilege_$dir_priv_off (code);
   if old_soos_priv = 0 then call system_privilege_$soos_priv_off (code);

   end clean_up_privs;


   end set_soos;
*/
%page;
clean_up:
     proc;

	if area_ptr = null
	then return;
	if entries_ptr ^= null
	then free entries in (area);
	if names_ptr ^= null
	then free names in (area);
	return;

     end clean_up;


     end switch_on;




		    terminate_file_.pl1             12/17/85  1347.3rew 12/17/85  1315.4       38232



/****^  ******************************************************
        *                                                    *
        * Copyright (c) 1985 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(85-09-12,Spitzer), approve(85-09-12,MCR7265),
     audit(85-09-13,Blair):  Bugfix.  Don't attempt further operations on the
     segptr if the segment is actually deleted.
                                                   END HISTORY COMMENTS */
/* Utility subroutine to perform standard completion operations when a program has finished with a segment.

   Written 25 July 1980 by M. N. Davidoff after THVV suggested at the right
	time of the week, Friday 6:00, that doing force_writes in some
	places would improve reliablity.
   Modified 26 Aug 1985 by C Spitzer. If successful delete, don't attempt to
	do the rest of the options.
*/
/* format: style2 */
terminate_file_:
     procedure (P_seg_ptr, P_bit_count, P_switches, P_code);

	declare P_seg_ptr		 pointer;		/* (Input/Output) segment to finish,
						   set to null after segment is terminated */
	declare P_bit_count		 fixed binary (24); /* (Input) number of used bits */
	declare P_switches		 bit (*);		/* (Input) control switches */
	declare P_code		 fixed binary (35); /* (Output) standard status code */

/* automatic */

	declare bit_count		 fixed binary (24);
	declare code		 fixed binary (35);
	declare seg_ptr		 pointer;
	declare 1 tfs		 aligned like terminate_file_switches;

/* based */

	declare segment		 bit (36 * sys_info$max_seg_size) based;

/* builtin */

	declare (divide, mod, null, pointer, string, substr)
				 builtin;

/* external static */

	declare error_table_$invalidsegno
				 fixed binary (35) external static;
	declare sys_info$max_seg_size	 fixed binary (19) external static;

/* entry */

          declare delete_$ptr            entry (pointer, bit (6), character (*), fixed binary (35));
	declare hcs_$force_write	 entry (pointer, bit (36), fixed binary (35));
	declare hcs_$set_bc_seg	 entry (pointer, fixed binary (24), fixed binary (35));
	declare hcs_$terminate_noname	 entry (pointer, fixed binary (35));
	declare hcs_$truncate_seg	 entry (pointer, fixed binary (19), fixed binary (35));

%include terminate_file;
%include force_write_flags;

/* program */

	P_code = 0;
	seg_ptr = P_seg_ptr;
	bit_count = P_bit_count;
	string (tfs) = P_switches;

	if seg_ptr = null
	then return;

	seg_ptr = pointer (seg_ptr, 0);

/* Completion operations continue if code ^= 0 since the caller is done with
   the segment, and there is nothing left to do with this segment except the
   stuff below.  Might as well do as much as we can. */


/* We continue in delete case, in case it fails and user has set other */
/* bits that we can do */

	if tfs.delete
	then do;
	     call delete_$ptr (seg_ptr, "100111"b, "", code); /* Force, dont question, dirs and segs ignored, links okay, chase them. "" for unised questioner name. */
	     P_code = code;
	     if code = 0
	     then return;				/* no other options make sense after deleting */
	end;

	if tfs.truncate
	then do;
		substr (seg_ptr -> segment, bit_count + 1, mod (-bit_count, 36)) = ""b;

		call hcs_$truncate_seg (seg_ptr, divide (bit_count + 35, 36, 19), code);
		if code ^= 0
		then P_code = code;
	     end;

	if tfs.set_bc
	then do;
		call hcs_$set_bc_seg (seg_ptr, bit_count, code);
		if code ^= 0 & P_code = 0
		then P_code = code;
	     end;

	if tfs.force_write
	then begin;
		declare 1 fwf		 aligned like force_write_flags;

		string (fwf) = ""b;
		call hcs_$force_write (seg_ptr, string (fwf), code);
		if code ^= 0 & code ^= error_table_$invalidsegno & P_code = 0
		then P_code = code;
	     end;

	if tfs.terminate
	then do;
		P_seg_ptr = null;
		call hcs_$terminate_noname (seg_ptr, code);
		if code ^= 0 & P_code = 0
		then P_code = code;
	     end;
     end terminate_file_;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
