


		    access_commands_tv_.alm         11/05/86  1500.0r w 11/04/86  1039.3       17046


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


"" MCR 4232 Add l_names and hp_names 12/13/79 S. Herbst 

	name	access_commands_tv_

	segdef	l_set_acl
	segdef	lsetacl
	segdef	lsa
	segdef	l_delete_acl
	segdef	ldeleteacl
	segdef	lda
	segdef	hp_set_acl
	segdef	hpsetacl
	segdef	hpsa
	segdef	hp_delete_acl
	segdef	hpdeleteacl
	segdef	hpda
	segdef	l_set_ring_brackets
	segdef	lset_ring_brackets
	segdef	lsrb
	segdef	hp_set_ring_brackets
	segdef	hpset_ring_brackets
	segdef	hpsrb
	segdef	l_set_dir_ring_brackets
	segdef	lset_dir_ring_brackets
	segdef	lsdrb
	segdef	hp_set_dir_ring_brackets
	segdef	hpset_dir_ring_brackets
	segdef	hpsdrb

	include	stack_header;
"
l_set_acl: null
lsetacl:  null
lsa:	getlp
	tra	<set_acl>|[lsetacl]

l_delete_acl: null
ldeleteacl: null
lda:	getlp
	tra	<set_acl>|[ldeleteacl]

hp_set_acl: null
hpsetacl: null
hpsa:	getlp
	tra	<set_acl>|[hp_set_acl]

hp_delete_acl: null
hpdeleteacl: null
hpda:	getlp
	tra	<set_acl>|[hp_delete_acl]

l_set_ring_brackets: null
lset_ring_brackets: null
lsrb:	getlp
	tra	<set_ring_brackets>|[lset_ring_brackets]

hp_set_ring_brackets: null
hpset_ring_brackets: null
hpsrb:	getlp
	tra	<set_ring_brackets>|[hpset_ring_brackets]

l_set_dir_ring_brackets: null
lset_dir_ring_brackets: null
lsdrb:	getlp
	tra	<set_dir_ring_brackets>|[lset_dir_ring_brackets]

hp_set_dir_ring_brackets: null
hpset_dir_ring_brackets: null
hpsdrb:	getlp
	tra	<set_dir_ring_brackets>|[hpset_dir_ring_brackets]

	end
  



		    compare_entry_names.pl1         11/12/82  1417.3rew 11/12/82  1111.9       49779


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


compare_entry_names: cen: proc;

	/*  Modified 02/05/79: P. B. Kelley - to fix uninitialized pointer bug	*/

dcl  area area based (Parea);
dcl  cleanup condition;
dcl  code fixed bin (35);
dcl (Larg, N1, N2, j, k) fixed bin;
dcl (Parg, Parea int static init (null), Pn1, Pn2) ptr;
dcl (head_sw, ok_switch) bit (1) aligned;
dcl (addr, null, ptr) builtin;
dcl  com_err_ ext entry options (variable);
dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  get_equal_name_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  ioa_ entry options (variable);
dcl  hcs_$status_long ext entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35));
dcl  cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl 1 branch1 aligned,				/*  for old segment status  */
    (2 type bit (2),
    2 nnames bit (16),
    2 nrp bit (18),
    2 padding bit (288),
    2 uid bit (36)) unaligned;			/* need uid to make sure segs are different  */
dcl 1 branch2 aligned,				/*  for new segment status  */
    (2 type bit (2),
    2 nnames bit (16),
    2 nrp bit (18),
    2 padding bit (288),
    2 uid bit (36)) unaligned;			/* need uid to make sure segs are different  */
dcl  names1 (N1) char (32) aligned based (Pn1);
dcl  names2 (N2) char (32) aligned based (Pn2);
dcl 1 over_names2 (N2) aligned based (Pn2),		/* overlay for names2. */
    2 value2 fixed bin (35),
    2 pad (7) fixed bin (35);
dcl  arg char (Larg) based (Parg);
dcl (error_table_$sameseg, error_table_$noalloc) ext static fixed bin (35);
dcl (dname1, dname2) char (168) aligned;
dcl (ename1, ename2) char (32) aligned;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*	make sure we have an allocation area, and establish a cleanup on-unit.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Pn1 = null;				/* set to null to begin with */
	Pn2 = null;				/*  ""		         */

	if Parea = null then
	     Parea = get_system_free_area_ ();		/* get an allocation area.			*/
	on cleanup call cleaner;

	call cu_$arg_ptr (1, Parg, Larg, code);		/*  pick up first arg   */
	if code ^= 0 then goto common_error;

	call expand_path_ (Parg, Larg, addr (dname1), addr (ename1), code);
	if code ^= 0 then goto common_error;


	call cu_$arg_ptr (2, Parg, Larg, code);		/*  pick up second arg  */
	if code ^= 0 then goto common_error;

	call expand_path_ (Parg, Larg, addr (dname2), addr (ename2), code);
	if code ^= 0 then goto common_error;

	call get_equal_name_ (ename1, ename2, ename2, code);
	if code ^= 0 then goto common_error;

	call hcs_$status_long (dname1, ename1, 1b, addr (branch1), Parea, code); /* pick up entrynames for old seg */
	if code ^= 0 then do;
	     call com_err_ (code, "compare_entry_names", "^a>^a", dname1, ename1);
	     return;
	end;
	Pn1 = ptr (Parea, branch1.nrp);
	N1 = fixed (branch1.nnames);

	call hcs_$status_long (dname2, ename2, 1b, addr (branch2), Parea, code); /* pick up entry names for new seg */
	if code ^= 0 then do;
	     call com_err_ (code, "compare_entry_names", "^a>^a", dname2, ename2);
	     call cleaner;
	     return;
	end;
	Pn2 = ptr (Parea, branch2.nrp);
	N2 = fixed (branch2.nnames);

	if branch1.uid = branch2.uid then do;		/* the segments are the same... */
	     code = error_table_$sameseg;		/*     complain  */
	     call cleaner;
	     goto common_error;
	end;

	ok_switch = "0"b;
	head_sw = "1"b;
	do j = 1 to N1;				/* find any names deleted from old segment */
	     do k = 1 to N2;
		if value2 (k) = -1 then;		/* if 2nd name matches one in 1st array, skip it. */
		else if names1 (j) = names2 (k) then do;
		     value2 (k) = -1;		/* mark the name in the 2nd array as non-unique */
		     go to next_name1;
		end;
	     end;

	     if head_sw then do;			/* let user know which segment  */
		call ioa_ ("^/Names unique to ^a>^a", dname1, ename1);
		head_sw = "0"b;
		ok_switch = "1"b;
	     end;

	     call ioa_ ("^2x^a", names1 (j));		/* print names deleted from old segment */

next_name1: end;

	head_sw = "1"b;
	do k = 1 to N2;				/* find any names added to new segment */
	     if value2 (k) = -1 then			/* name matches one in 1st name array. */
		go to next_name2;
	     if head_sw then do;			/* let user know which segment */
		call ioa_ ("^/Names unique to ^a>^a", dname2, ename2);
		head_sw = "0"b;
		ok_switch = "1"b;
	     end;

	     call ioa_ ("^2x^a", names2 (k));		/* print unique names on new segment */

next_name2: end;

	if ok_switch then
	     call ioa_ ("^/Comparison finished.^/");
	else
	     call ioa_ ("Entry names are identical.^/");
	call cleaner;
	return;


common_error: call com_err_ (code, "compare_entry_names");	/*  for error in external calls  */
	return;


cleaner:	procedure;

	     if Pn1 ^= null then free names1 in (area);
	     if Pn2 ^= null then free names2 in (area);

	end cleaner;


     end compare_entry_names;
 



		    date_deleter.pl1                01/26/88  1338.8rew 01/26/88  1328.8      173619


/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


date_deleter: proc;

/* Command to delete everything in a given directory greater than N days old.
   Usage:

	date_deleter dir_path n_days {starnames} {-control_args}

   optionally providing starnames for match. */
/* Written 04/23/79 S. Herbst */
/* Fixed to work on MSF's with no_s 05/12/80 S. Herbst */
/* Added -dtem, etc. and fix to diagnose badstar ahead of time 06/10/81 S. Herbst */
/* Fixed bugs that deleted all MSF's and took fault for incacc 11/03/82 S. Herbst */
/* Changed to allow dtm cutoff; added selection ctl args -sm, etc. 12/15/83 S. Herbst */
/* Added -query_all, -query_each, -long, -absp 12/19/83 S. Herbst */
/* Fixed bug causing directories to be deleted regardless of date-time 04/20/84 S. Herbst */
/* Understand "new" hardcore error code from hcs_$star_, Keith Loepere, 01/06/85. */


/****^  HISTORY COMMENTS:
  1) change(87-12-01,Gilcrease), approve(87-12-15,MCR7815),
     audit(88-01-20,RBarstad), install(88-01-26,MR12.2-1018):
               Accept dates with leading hyphens.
                                                   END HISTORY COMMENTS */


%include branch_status;

dcl ME char (32) int static options (constant) init ("date_deleter");
dcl (NO_STARS init (0), STAR_STAR init (2)) fixed bin int static options (constant);

dcl 1 bs aligned like branch_status based;

dcl 1 entries (branch_count) aligned based (entries_ptr),	/* for hcs_$star lists */
     2 pad (4) fixed bin;
dcl names (99/* arbitrary */) char (32) aligned based (names_ptr);

dcl 1 starnames (arg_count) based (starnames_ptr),
   2 starname char (32),
   2 star_code fixed bin;

dcl 1 select aligned,
   2 (directory, msf, segment) bit (1) aligned;

dcl 1 option_switches aligned,
   2 (absp_sw, long_sw, query_all_sw, query_each_sw) bit (1) aligned;

dcl 1 query_array (query_bound) based (query_ptr),
   2 query_dn char (168),
   2 query_en char (32),
   2 query_type_name char (32);
dcl query_ptr ptr;
dcl (query_bound, query_count) fixed bin;

dcl arg char (arg_len) based (arg_ptr);
dcl (dn, msf_dn) char (168);
dcl (name, what) char (32);

dcl dtm72 bit (72);
dcl (got_cutoff_sw, got_dirname_sw, same_dir_sw, same_type_sw, yes_sw) bit (1);
dcl delete_switches bit (6);
dcl delete_force_sw bit (1) unaligned defined (delete_switches) position (1);
dcl delete_question_sw bit (1) unaligned defined (delete_switches) position (2);
dcl delete_directory_sw bit (1) unaligned defined (delete_switches) position (3);
dcl delete_segment_sw bit (1) unaligned defined (delete_switches) position (4);
dcl delete_link_sw bit (1) unaligned defined (delete_switches) position (5);
dcl delete_chase_sw bit (1) unaligned defined (delete_switches) position (6);

dcl area area based (area_ptr);

dcl (area_ptr, arg_ptr, bs_ptr, component_info_ptr, starnames_ptr) ptr;
dcl (entries_ptr, names_ptr) ptr;
dcl (msf_entries_ptr, msf_names_ptr) ptr;

dcl  DIR_TYPE init (2) fixed bin (2) int static options (constant);
dcl (DTCM_TYPE init (0), DTEM_TYPE init (1), DTD_TYPE init (2), DTU_TYPE init (3)) fixed int static options (constant);
dcl MSEC_PER_DAY fixed bin (71) int static options (constant) init (86400000000);
dcl (cutoff_dtm, msdays) fixed bin (71);
dcl bit_count fixed bin (24);
dcl type fixed bin (2);
dcl (arg_count, arg_len, branch_count, date_type, days) fixed bin;
dcl (i, j, msf_component_count, starname_count, starname_index) fixed bin;

dcl code fixed bin (35);
dcl error_table_$action_not_performed fixed bin (35) ext;
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$badstar 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_s_permission fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;

dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl check_star_name_$entry entry (char (*), fixed bin (35));
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl command_query_$yes_no entry options (variable);
dcl convert_date_to_binary_ entry (char (*), fixed bin (71), 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);
dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_wdir_ entry returns (char (168));
dcl hcs_$get_dates entry (char (*), char (*), (5) bit (36), fixed bin (35));
dcl hcs_$get_safety_sw entry (char (*), char (*), bit (1), fixed bin (35));
dcl hcs_$star_list_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, fixed bin,
	ptr, ptr, fixed bin (35));
dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl pathname_ entry (char (*), char (*)) returns (char (168));

dcl (addr, bit, clock, fixed, index, max, null, substr, unspec) builtin;

dcl cleanup condition;
%page;
	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;

	entries_ptr, msf_entries_ptr, msf_names_ptr, names_ptr, query_ptr, starnames_ptr = null;

	if arg_count = 0 then do;
USAGE:	     call com_err_$suppress_name (0, ME, "Usage:  date_deleter dir_path cutoff {starnames} {-control_args}");
	     go to RETURN;
	end;

	area_ptr = get_system_free_area_ ();
	on cleanup call clean_up;
	allocate starnames in (area) set (starnames_ptr);
	starname_count = 0;

	unspec (select) = "0"b;
	unspec (option_switches) = "0"b;
	date_type = DTCM_TYPE;			/* default is date_time_contents_modified */
	got_cutoff_sw, got_dirname_sw = "0"b;

	do i = 1 to arg_count;

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

	     if index (arg, "-") = 1 then
		if arg = "-working_directory" | arg = "-working_dir" | arg = "-wd" then do;
		     got_dirname_sw = "1"b;
		     dn = get_wdir_ ();
		end;

		else if arg = "-date_time_contents_modified" | arg = "-dtcm" then date_type = DTCM_TYPE;
		else if arg = "-date_time_dumped" | arg = "-dtd" then date_type = DTD_TYPE;
		else if arg = "-date_time_entry_modified" | arg = "-dtem" then date_type = DTEM_TYPE;
		else if arg = "-date_time_used" | arg = "-dtu" then date_type = DTU_TYPE;

		else if arg = "-all" | arg = "-a" then select.directory, select.msf, select.segment = "1"b;
		else if arg = "-directory" | arg = "-dr" then select.directory = "1"b;
		else if arg = "-file" | arg = "-f" then select.msf, select.segment = "1"b;
		else if arg = "-multisegment_file" | arg = "-msf" then select.msf = "1"b;
		else if arg = "-segment" | arg = "-sm" then select.segment = "1"b;

		else if arg = "-absolute_pathname" | arg = "-absp" then absp_sw = "1"b;
		else if arg = "-brief" | arg = "-bf" then long_sw = "0"b;
		else if arg = "-entryname" | arg = "-etnm" then absp_sw = "0"b;
		else if arg = "-long" | arg = "-lg" then long_sw = "1"b;
		else if arg = "-query_all" | arg = "-qya" then query_all_sw = "1"b;
		else if arg = "-query_each" | arg = "-qye" then query_each_sw = "1"b;
		else do;
		     call convert_date_to_binary_ (arg, cutoff_dtm, code);
		     if code = 0 then do;
			got_cutoff_sw = "1"b;
		     end;
		     else do;
		          call com_err_ (error_table_$badopt, ME, "^a", arg);
		          go to RETURN;
		     end;
		end;

	     else if ^got_dirname_sw then do;

		got_dirname_sw = "1"b;

		call absolute_pathname_ (arg, dn, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "^a", arg);
		     go to RETURN;
		end;
	     end;

	     else if ^got_cutoff_sw then do;

		got_cutoff_sw = "1"b;

		days = cv_dec_check_ (arg, code);
		if code = 0 then do;
		     msdays = days * MSEC_PER_DAY;
		     cutoff_dtm = clock () - msdays;
		end;
		else do;
		     call convert_date_to_binary_ (arg, cutoff_dtm, code);
		     if code ^= 0 then do;
			call com_err_ (code, ME, "^a", arg);
			go to RETURN;
		     end;
		end;
	     end;

	     else do;				/* starname */
		call check_star_name_$entry (arg, code);
		if code = error_table_$badstar then do;
		     call com_err_ (code, ME, "^a", arg);
		     go to RETURN;
		end;
		starname_count = starname_count + 1;
		starname (starname_count) = arg;
		star_code (starname_count) = code;
	     end;
	end;

	if unspec (select) = "0"b then select.msf, select.segment = "1"b;

	if ^got_dirname_sw | ^got_cutoff_sw then go to USAGE;

	if query_all_sw then do;
	     query_bound = 20;			/* will be grown if necessary */
	     allocate query_array in (area) set (query_ptr);
	     query_count = 0;
	end;

	delete_directory_sw, delete_force_sw, delete_segment_sw = "1"b;  /* switches for delete_$path */
	delete_chase_sw, delete_link_sw, delete_question_sw = "0"b;

	if starname_count = 0 then call delete_starname ("**", STAR_STAR);  /* no starnames specified */

	else do starname_index = 1 to starname_count;

	     call delete_starname (starname (starname_index), star_code (starname_index));
	end;

	if query_all_sw & query_count > 0 then do;

	     if select.directory then
		if (select.msf | select.segment) then what = "Entries";
		else what = "Directories";
	     else if select.msf then
		if select.segment then what = "Files";
		else what = "multisegment files";
	     else what = "Segments";

	     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;
	     same_type_sw = "1"b;
	     do i = 2 to query_count;
		if query_type_name (i) ^= query_type_name (1) then same_type_sw = "0"b;
	     end;
	     if ^same_type_sw then what = "Entries";
	     call ioa_ ("^a to be deleted^[ in ^a^]:", what, same_dir_sw, query_dn (1));
	     do i = 1 to query_count;
		call ioa_ ("^3x^[^s^;(^a)  ^]^[^a^s^;^s^a^]",
		     same_type_sw, query_type_name (i),
		     same_dir_sw, query_en (i), pathname_ (query_dn (i), query_en (i)));
	     end;

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

	     if yes_sw then do i = 1 to query_count;
		call delete_$path (query_dn (i), query_en (i), delete_switches, ME, code);
		if code ^= 0 & code ^= error_table_$action_not_performed then
		     call com_err_ (code, ME, "^a", pathname_ (query_dn (i), query_en (i)));
		else 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;
	end;

RETURN:	call clean_up;

	return;
%page;
clean_up: proc;

	if entries_ptr ^= null then free entries_ptr -> entries in (area);
	if msf_entries_ptr ^= null then free msf_entries_ptr -> entries in (area);
	if msf_names_ptr ^= null then free msf_names_ptr -> names in (area);
	if names_ptr ^= null then free names_ptr -> names in (area);
	if query_ptr ^= null then free query_array in (area);
	if starnames_ptr ^= null then free starnames_ptr -> starnames in (area);

end clean_up;
%page;
delete_starname: proc (P_name, P_star_code);

dcl P_name char (*);
dcl P_star_code fixed bin;

	if P_star_code = NO_STARS then do;

	     name = P_name;
	     call get_dates (dn, name, code);
	     if code ^= 0 then do;
		if code ^= error_table_$action_not_performed then
		     call com_err_ (code, ME, "^a^[>^]^a", dn, dn ^= ">", name);
	     end;

	     else call delete_if;
	end;
	else do;					/* starname */

	     call hcs_$star_list_ (dn, P_name, 2 /* branches */, area_ptr, branch_count, 0,
		entries_ptr, names_ptr, code);

	     if code ^= 0 then do;
		if code ^= error_table_$nomatch then
		     call com_err_ (code, ME, "^a^[>^]^a", dn, dn ^= ">", P_name);
	     end;
	     else do i = 1 to branch_count;

		bs_ptr = addr (entries_ptr -> entries (i));
		name = names_ptr -> names (fixed (bs_ptr -> bs.names_rel_pointer, 17));

		if date_type = DTEM_TYPE | date_type = DTD_TYPE | bs_ptr -> bs.type = directory_type then do;
		     call get_dates (dn, name, code);
		     if code ^= 0 then go to SKIP_MATCH;
		end;
		else do;
		     branch_status.type = bs_ptr -> bs.type;
		     branch_status.date_time_modified = bs_ptr -> bs.date_time_modified;
		     branch_status.date_time_used = bs_ptr -> bs.date_time_used;
		end;
		branch_status.number_names = bs_ptr -> bs.number_names;
		branch_status.names_rel_pointer = bs_ptr -> bs.names_rel_pointer;

		call delete_if;
SKIP_MATCH:    end;

	     if entries_ptr ^= null then do;
		free entries_ptr -> entries in (area);
		entries_ptr = null;
	     end;
	     if names_ptr ^= null then do;
		free names_ptr -> names in (area);
		names_ptr = null;
	     end;
	end;
%page;
delete_if: proc;

/* Applies the test to dn>name and deletes if too old */
/* For MSF's, it deletes if all components are too old. */

dcl type_name char (32);
dcl date36 bit (36) aligned;
dcl (safety_sw, saved_delete_force_sw, saved_force_sw_sw, yes_sw) bit (1);

	if branch_status.type = link_type then return;	/* never delete links */
	else if branch_status.type = segment_type then do;
	     if ^select.segment then return;
	     type_name = "segment";
	end;
	else if branch_status.type = directory_type then
	     if branch_status.bit_count ^= "0"b then do;
		if ^select.msf then return;
		type_name = "multisegment file";
	     end;
	     else do;
		if ^select.directory then return;
		type_name = "directory";
	     end;

	if date_type = DTCM_TYPE then date36 = branch_status.date_time_modified;
	else if date_type = DTEM_TYPE then date36 = branch_status.date_time_entry_modified;
	else if date_type = DTD_TYPE then date36 = branch_status.date_time_dumped;
	else if date_type = DTU_TYPE then date36 = branch_status.date_time_used;

	dtm72 = "0"b;
	substr (dtm72, 21, 36) = date36;

	if branch_status.type ^= directory_type then do;

	     if fixed (dtm72, 71) < cutoff_dtm then do;

DELETE:		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) = name;
		     query_type_name (query_count) = type_name;

		     return;
		end;

		saved_force_sw_sw = "0"b;
		if query_each_sw then do;
		     call hcs_$get_safety_sw (dn, name, safety_sw, 0);
		     if P_star_code ^= NO_STARS then
			call hcs_$status_long (dn, name, 0, addr (branch_status), null, 0);

		     call command_query_$yes_no (yes_sw, 0, ME, "",
			"Delete ^a ^[^a^s^;^s^a^] ?^[ (safety switch is on)^]^[ (copy switch is on)^]",
			type_name, absp_sw, pathname_ (dn, name), name, safety_sw, branch_status.copy_switch);

		     if ^yes_sw then return;

		     if safety_sw | branch_status.copy_switch then do;
			saved_delete_force_sw = delete_force_sw;
			saved_force_sw_sw = "1"b;
			delete_force_sw = "1"b;
		     end;
		end;

		call delete_$path (dn, name, delete_switches, ME, code);

		if saved_force_sw_sw then delete_force_sw = saved_delete_force_sw;

		if code ^= 0 then do;
		     call com_err_ (code, ME, "^a^[>^]^a", dn, dn ^= ">", name);
		     if code = error_table_$incorrect_access then go to RETURN;
		end;
		else if long_sw & ^query_each_sw then
		     call ioa_ ("Deleted ^a ^[^a^s^;^s^a^]", type_name, absp_sw, pathname_ (dn, name), name);
	     end;
	end;

	else do;					/* directory; might be an MSF */

	     call hcs_$status_minf (dn, name, 0, type, bit_count, code);
	     if code = error_table_$incorrect_access then go to RETURN;
	     else if code = 0 & type = DIR_TYPE & bit_count ^= 0 then do;  /* an MSF */

		if days = 0 then go to DELETE;

		msf_entries_ptr, msf_names_ptr = null;

		call ioa_$rsnnl ("^a^[>^]^a", msf_dn, 168, dn, dn ^= ">", name);

		call hcs_$star_list_ (msf_dn, "**", 3 /* All */, area_ptr, msf_component_count, 0,
		     msf_entries_ptr, msf_names_ptr, code);

		if code ^= 0 then
		     if code ^= error_table_$nomatch & code ^= error_table_$moderr &
		       code ^= error_table_$no_s_permission then do;
			call com_err_ (code, ME, "^a>**", msf_dn);
			return;
		     end;
		     else go to SKIP_MSF;		/* don't delete if error or no components */

		do j = 1 to msf_component_count;

		     component_info_ptr = addr (msf_entries_ptr -> entries (j));

		     if date_type = DTEM_TYPE | date_type = DTD_TYPE then do;
			call get_dates (msf_dn,
			     (msf_names_ptr -> names (fixed (component_info_ptr -> bs.names_rel_pointer, 17))),
			     code);
			if code ^= 0 | branch_status.type ^= segment_type then go to SKIP_MSF;
			if date_type = DTEM_TYPE then date36 = branch_status.date_time_entry_modified;
			else date36 = branch_status.date_time_dumped;
		     end;
		     else if date_type = DTCM_TYPE then date36 = component_info_ptr -> bs.date_time_modified;
		     else date36 = component_info_ptr -> bs.date_time_used;

		     dtm72 = "0"b;
		     substr (dtm72, 21, 36) = date36;
		     if fixed (dtm72, 71) >= cutoff_dtm then go to SKIP_MSF;
		end;

		call msf_cleanup;
		go to DELETE;
SKIP_MSF:
		call msf_cleanup;
	     end;

	     else					/* a directory */
		if fixed (dtm72, 71) < cutoff_dtm then go to DELETE;
	end;

msf_cleanup: proc;

	if msf_entries_ptr ^= null then do;
	     free msf_entries_ptr -> entries in (area);
	     msf_entries_ptr = null;
	end;
	if msf_names_ptr ^= null then do;
	     free msf_names_ptr -> names in (area);
	     msf_names_ptr = null;
	end;

end msf_cleanup;

end delete_if;

end delete_starname;
%page;
get_dates: proc (P_dn, P_en, P_code);

/* Fills in branch_status and, if -dtd, factors date-time-volume-dumped into branch_status.date_time_dumped */

dcl (P_dn, P_en) char (*);
dcl P_code fixed bin (35);
dcl dates_array (5) bit (36);

	call hcs_$status_long (P_dn, P_en, 0, addr (branch_status), null, P_code);
	if P_code ^= 0 then return;

	if date_type = DTD_TYPE then do;
	     call hcs_$get_dates (P_dn, P_en, dates_array, P_code);
	     if P_code ^= 0 then return;

	     branch_status.date_time_dumped =
		bit (max (fixed (branch_status.date_time_dumped, 36), fixed (dates_array (5), 36)), 36);

	     if branch_status.date_time_dumped = "0"b then P_code = error_table_$action_not_performed;
						/* don't delete if -dtd and entry never dumped */
	end;

end get_dates;
%page;
grow_query_array: proc;

/* Doubles the size of query_array */

dcl old_query_ptr ptr;
dcl (new_query_bound, old_query_bound) fixed bin;

	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;

end date_deleter;
 



		    get_archive_file_.pl1           11/12/82  1417.3rew 11/12/82  1112.1       42885


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


get_archive_file_:	procedure (dir_name, seg_name, ac_file, rtn_code);

     dcl	dir_name			char(*),		/* directory name for archives */
	seg_name			char(*), 		/* source segment name */
	ac_file			char(2),		/* first name component of archive */
	rtn_code			fixed bin(17);	/* error code */
dcl	substr	builtin;
dcl	fd_file		char(32);
dcl	gls_switch	bit(1);	/*switch to pick entry*/


/*

	     get_archive_file_:  Procedure to locate a segment in
	     a series of archives (a1...a9, b1...b9, etc.).  The
	     first character of the archive name must match the
	     first character of the name of the desired segment.

	     Possible return codes are:

		0 - Segment found, ac_file is containing archive
		1 - Segment not found, ac_file is shortest archive
		2 - Format error in archive file (ac_file)
	      other - A standard file system error code

	     P. R. Bos, April 1971

	14 apr 72

		entry point "srchgls" added by steve tepper.  returns entire archive segment name
		instead of just first name component.

*/


     dcl	archive_util_$first_element	ext entry (ptr, fixed bin(17)),
	archive_util_$search	ext entry (ptr, ptr, char (*) aligned, fixed bin),
	cv_bin_$dec		ext entry (fixed bin(17), char(12) aligned),
     hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2),
     ptr, fixed bin),
	hcs_$terminate_noname	ext entry (ptr, fixed bin(17));

     dcl (error_table_$noentry,
	error_table_$segknown)	ext fixed bin(17);

     dcl (p, q, s)			ptr;

     dcl (cd, code, i)		fixed bin(17),
         (bc, shortest_bc)		fixed bin(24);

     dcl (ac_name			char(32),
	chr			char(1),
	dir			char(168),
	seg			char(32),
	shortest_ac_file		char(2),
	string			char(12)) aligned;


	gls_switch="0"b;	/* we are not called by gls*/
	go to crud;


srchgls:	entry(dir_name,seg_name,fd_file,rtn_code);   /*entry from gls*/

	gls_switch="1"b; 	/*we _a_r_e called by gls*/

crud:	;
/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	dir = dir_name;				/* align directory name */
	seg = seg_name;				/* align segment name */
	chr = substr(seg, 1, 1);			/* first char of segment name */
	shortest_ac_file = chr || "1";		/* initialize */
	shortest_bc = 1000000;

	do i = 1 to 9;				/* search in order: x1 x2 x3 ... */
	     call cv_bin_$dec(i, string);		/* convert to char. */
	     ac_file = chr || substr(string, 12, 1);	/* form archive name component */
	     ac_name = ac_file || ".archive";		/* archive file name */
	     call hcs_$initiate_count(dir, ac_name, "", bc, 1, s, code);     /* get bit count and ptr */
	     p = s;				/* copy it: archive_util clobbers ptr */
	     if code ^= 0 then if code ^= error_table_$segknown then do;
		if code = error_table_$noentry then do;	/* segment not found */
		     if shortest_bc < 450000 then	/* .. about 12 pages */
			ac_file = shortest_ac_file;	/* return name of shortest file */
		     rtn_code = 1;			/* indicate segment not found in archives */
		     go to return;
		     end;
		else				/* unexpected error (no dir, etc.) */
		     go to ac_err;			/* abort */
		end;
	     call archive_util_$first_element(p, code);	/* check file */
	     if code ^= 0 then			/* empty archive or error condition */
		go to ck_code;
	     call archive_util_$search(p, q, seg, code);	/* search archive for source segment */
ck_code:	     call hcs_$terminate_noname(s, cd);	/* terminate segment */
	     if code = 0 then do;			/* segment found */
		rtn_code = 0;			/* set return code */
		go to return;
		end;
	     else if code = 1 then			/* code 1, segment not found in archive */
		if bc < shortest_bc then do;		/* remember name and bit count */
		     shortest_bc = bc;		/* .. of shortest archive */
		     shortest_ac_file = ac_file;
		end;
		else;				/* null clause */
	     else do;				/* code > 1, error condition */
ac_err:		rtn_code = code;			/* reflect code to caller */
		go to return;
		end;
	     end;
	ac_file = shortest_ac_file;		/* all 9 archives used, return shortest */
	rtn_code = 1;				/* indicate segment not found */
	go to return;


/*	return code fudger*/
return:	if gls_switch="0"b then return;
	else do;
		fd_file=ac_name;
		return;
		end;


	end get_archive_file_;
   



		    get_library_segment.pl1         10/22/86  1517.0rew 10/22/86  1512.9      189522


/****^  ***********************************************************
        *                                                         *
        * 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-10-20,TLNguyen), approve(86-10-22,MCR7561),
     audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1194):
     Fix bug which occurs when the return value has a leading space.
                                                   END HISTORY COMMENTS */


get_library_segment: gls: procedure;

/*

   get_library_segment (gls): Special command used to copy source
   segments from the library archives to the user's working directory.
   It will call get_archive_file_ to search the source archives
   in the "source" directories off of specified "system" directories
   in >ldd.

   The option "-sys" is followed by a system name (ie, "hard") and
   specifies what directories to search (ie, ">ldd>hard>source").
   Up to 32 system names may be specified.  The systems are searched
   in the order given.

   The "-long" ("-lg") option is used the cause the printing
   of a message specifying where each segment is found.
   The "-brief" ("-bf") option is used to suppress the printing
   of all messages except those associated with argument processing.


   If the -sys control arg is not specified all the
   directories specified in the system control files
   are searched.

   Up to 25 segments may be searched for.

   Usage:

   gls seg_name1_ ... seg_name_n opt1_ ... opt_n

   David M. Jordan, June 1971, from P. Bos and J. Spall
   Modified November, 1971 to add the brief and long options
   and to expand error messages. David M. Jordan

   modified June 1972 by steve tepper due to reorganization of
   source libraries.

   Modified on August 9, 1972 by Gary C. Dixon to correct
   errors in parsing the control file, to remove the "pl1"
   library from the default list of systems to be searched
   in order to prevent access violations for most users,
   and to improve error messages.

   Modified on September 30, 1972 by Gary C. Dixon to use
   a ptr to gls as the caller_ptr in the call to hcs_$make_entry
   which initiates the search routines so that gls users don't
   have to have tools in their search path.

   Modified on February 27, 1973 by Peter B. Kelley to rename the
   primary entry point "get_library_source" to "get_library_segment".
   The entry point get_library_source" was kept.  Also modified
   to remove "dev" from the default search paths as "sss" and "dev"
   are now one  and the same.

   Modified May 1974 by Arlene Scherer to add code for the Network library
   and to make it able to copy an archive component into the user's directory
   with the -rename option when a same-named component is already there.
   Also removed obsolete entry get_library_source.

   Modified July 1974 by Steve Herbst to fix namedup bug when returning from
   nd_handler_ with an answer of "no".

   Modified July 1974 by Arlene J. Scherer to fix bug which occurs when fetching
   a source segment with a two-character name (i.e. if.pl1).

   Modified Aprint 1978 by Michael R. Jordan to change the meaning of -brief to allow
   error message-less operation.

   Completely rewritten by D. Vinograd to make it maintainble and in up-to-date prog technology
   October 1979

   Modified 03/25/81, W. Olin Sibert, to make -rename implement equal convention. Isn't it strange how these
   journalization notices get longer and longer each time someone adds one?
   Modified 10/15/86, Tai Le Nguyen, to fix bug which occurs when the gls active function returned a pathname preceded by a space.

*/

dcl  arglp ptr;
dcl  ac fixed bin;					/* number of args processed */
dcl  active_fnc bit (1);
dcl  segx fixed bin;				/* loop varsegxable */
dcl  sysx fixed bin;				/* loop variable */
dcl  nargs fixed bin;				/* number of arguments */
dcl  segcount fixed bin;				/* number of segments to be found */
dcl  syscount fixed binary;				/* number of systems to be searched */
dcl  code fixed bin (35);				/* error code */
dcl  long_sw bit (1);				/* switch for -lg options */
dcl  brief_sw bit (1);				/* switch for -bf option */
dcl  argp ptr;					/* argument ptr */
dcl  argl fixed binary;				/* argument length */
dcl  arg character (argl) based (argp);			/* command argument */
dcl  segname (max_names) character (32);		/* array of segments to find */
dcl  new_name (max_names) char (32);
dcl  equal_name char (32);
dcl (dirname, ename, sname) char (168);
dcl (break, eof) bit (1);
dcl (break_f, eof_f) fixed bin (1);
dcl  errsw bit (1) aligned;
dcl  controlp ptr;
dcl  atom char (cc) unaligned based (controlp);
dcl  cc fixed bin;
dcl  lib_name char (32) ;
dcl  root char (168);
dcl  process_dir char (168);
dcl  working_dir char (168);
dcl  idx fixed bin;
dcl  sys (max_sys) character (32);			/* array of systems to search */
dcl  retp ptr;
dcl  retl fixed bin;
dcl  ret char (retl) based (retp) var;

dcl 1 segment_acl aligned,
    2 access_name char (32),
    2 modes bit (36) initial ("0"b),
    2 pad bit (36) initial ("0"b),
    2 status_code fixed bin (35);

dcl  myname character (32) static internal options (constant) init ("get_library_segment");
dcl  max_names fixed bin int static init (25) options (constant);
dcl  max_sys fixed bin int static init (100) options (constant);

dcl (addr,
     binary,
     divide,
     hbound,
     rtrim,
     bit,
     before,
     reverse,
     null,
     codeptr,
     substr) builtin;

dcl (error_table_$badopt,
     error_table_$namedup,
     error_table_$seg_not_found,
     error_table_$noarg,
     error_table_$too_many_names) fixed bin (35) ext;

dcl  search_entry entry (char (*), char (*), char (*), fixed bin (35)) variable;
dcl  suffixed_name_$make entry (char (*), char (*), char (*), fixed bin (35));
dcl  err_rnt entry variable options (variable);
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  archive entry options (variable);
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
dcl  hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35));
dcl  get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_wdir_ entry returns (char (168));
dcl  get_pdir_ entry returns (char (168));
dcl  get_group_id_$tag_star entry returns (char (32));
dcl  parse_file_$parse_file_init_name entry (char (*), char (*), ptr, fixed bin (35));
dcl  parse_file_$parse_file_set_break entry (char (*));
dcl  parse_file_$parse_file_unset_break entry (char (*));
dcl  parse_file_$parse_file_ptr entry (ptr, fixed bin, fixed bin (1), fixed bin (1));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  pathname_$component entry (char (*), char (*), char (*)) returns (char (194));
dcl  copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  requote_string_ entry (char(*)) returns (char(*));

%include star_structures;

	root = ">ldd";				/* set default root name*     (ast) */
	star_list_branch_ptr = null;
	star_list_names_ptr = null;
	star_select_sw = star_ALL_ENTRIES;
	lib_name = "";
	working_dir = get_wdir_ ();
	ac = 0;
	active_fnc = "0"b;
	err_rnt = com_err_;
	segcount = 0;
	syscount = 0;
	brief_sw = "0"b;				/* default is to print the missing segment error */
	long_sw = "0"b;				/* default is not to print a message */

	call cu_$arg_list_ptr (arglp);
	call cu_$af_return_arg (nargs, retp, retl, code);
	if code = 0 then do;
	     active_fnc = "1"b;
	     err_rnt = active_fnc_err_;
	     ret = "";
	end;
	if nargs = 0 then do;
	     call err_rnt (error_table_$noarg, myname,
		"Usage is: get_library_segment seg_name {seg_name} {-control_args}");
	     return;
	end;

/* * * * * * * * * * * * * * * * * * * * * * * * */
/*				         */
/* Argument processing, options start with "-",  */
/* otherwise assumed to be segment name.  The    */
/* arg following the "-sys" option is taken to   */
/* be a system (ldd directory) name.	         */
/*				         */
/* * * * * * * * * * * * * * * * * * * * * * * * */

	ac = 1;
	do while (ac <= nargs);

	     call cu_$arg_ptr_rel (ac, argp, argl, code, arglp);
	     if code ^= 0 then do;
noarg:		call err_rnt (code, myname, "no argument after ^a", arg);
		return;
	     end;

	     if substr (arg, 1, 1) ^= "-" then		/* Assumed to be source segment name */
		do;
		segcount = segcount + 1;
		if segcount > hbound (segname, 1) then do;
		     call err_rnt (error_table_$too_many_names, myname,
			"A maximum of ^d segment names may be specified.", hbound (segname, 1));
		     return;
		end;
		segname (segcount) = arg;
		new_name (segcount) = arg;
	     end;

	     else if arg = "-sys" then do;

/* * * * * * * * * * * * * * * * * * * * * * * * */
/*				         */
/* Must be followed by a system (ldd dir) name,  */
/* but we don't check the name for validity.     */
/*				         */
/* * * * * * * * * * * * * * * * * * * * * * * * */

		syscount = syscount + 1;
		if syscount > hbound (sys, 1) then do;
		     call err_rnt (error_table_$too_many_names, myname,
			"A maximum of ^d system names may be specified.", hbound (sys, 1));
		     return;
		end;
		sys (syscount) = get_arg ();
	     end;


	     else if arg = "-bf" | arg = "-brief" then do;

/* * * * * * * * * * * * * * * * * * * * * * * * */
/*				         */
/* Specifies that no message is to be printed    */
/*				         */
/* * * * * * * * * * * * * * * * * * * * * * * * */

		brief_sw = "1"b;
		long_sw = "0"b;
	     end;

	     else if arg = "-lg" | arg = "-long" then do;

/* * * * * * * * * * * * * * * * * * * * * * * * */
/*				         */
/* Specifies that a message should be printed    */
/*				         */
/* * * * * * * * * * * * * * * * * * * * * * * * */

		brief_sw = "0"b;
		long_sw = "1"b;
	     end;


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

   option "-control"

   sets the root node.
   the arg after "-root" is the new root node name.

   **************************************** */
	     else if arg = "-control" | arg = "-ct" then do;
		root = get_arg ();
		if root = "-working_directory" | root = "-wd" then
		     root = working_dir;
	     end;


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

   option "-rename" ("-rn")

   renames the source segment to a new name in the target directory.

   *********************************************************** */
	     else if arg = "-rename" | arg = "-rn" then do;
		equal_name = get_arg ();
		call get_equal_name_ (segname (segcount), equal_name, new_name (segcount), code);
		if code ^= 0 then do;
		     call err_rnt (code, myname, "-rename ^a", equal_name);
		     return;
		end;
	     end; 				/* of processing for -rename */


/* ***********   bad option  ************ */
	     else do;
		call err_rnt (error_table_$badopt, myname, "^a", arg); /* Unknown option */
		return;
	     end;

	     ac = ac + 1;
	end;

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


	if segcount = 0 then			/* No segment to look for specified */
	     do;
	     call err_rnt (error_table_$noarg, myname,
		"A segment name must be specified.");
	     return;
	end;

	if syscount = 0 then			/* No system specified, search them all */
	     do;
	     call hcs_$star_dir_list_ (root, "**.control", star_select_sw, get_system_free_area_ (),
		star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code);
	     if code ^= 0 then do;
		call err_rnt (code, myname, "Unable to list root");
		return;
	     end;
	     do idx = 1 to star_branch_count + star_link_count while (idx <= hbound (sys, 1));
		sys (idx) = star_list_names (star_dir_list_branch (idx).nindex);
	     end;
	     syscount = idx - 1;
	     if syscount = hbound (sys, 1) then
		call err_rnt (0, myname, "Warning - some control segs have been skipped");
	end;


/* * * * * * * * * * * * * * * * * * * * * * * * */
/*				         */
/*	     Main Search Loop	         */
/*				         */
/* * * * * * * * * * * * * * * * * * * * * * * * */

	do segx = 1 to segcount;
	     do sysx = 1 to syscount;

/*     	for each sys(sysx), make a ptr to [root || ">" || sys(sysx) || ".control"].
   read that file, which contains records of the format:
   [<directory name> <search seg name>].
   <search seg name> may be either <seg name>, or <seg name>$<entry name>.

   call the search segname, giving <directory  name> as an arg.

   the search seg will return the name of the segment (archive or otherwise)
   that contains the target segment.
   */
		call suffixed_name_$make (sys (sysx), "control", sys (sysx), code);
		if code ^= 0 then do;
		     call err_rnt (code, myname, "error constructing control file name for ^a",
			sys (sysx));
		     goto finish;
		end;
		call parse_file_$parse_file_init_name (root, sys (sysx), controlp, code); /* make a ptr to control file */
		if code ^= 0 then do;
		     call err_rnt (code, myname, " Unable to locate segment ^a>^a.",
			root, sys (sysx));
		     goto finish;
		end;
again:		dirname, sname = "";
		call parse_file_$parse_file_unset_break ("!""#%&'()+,-./;>?@[\]^_`{|}~");
		call get_atom;
		if eof then goto sys_done;		/* eof means done parsing file. */
		if break then goto syntax_err;	/* entry starting w/ break is an error */
		dirname = atom;

		call get_atom;
		if eof then goto eof_err;		/* to end file in mid-line is a no-no. */
		if break then			/* break must be ":"; else error. */
		     if atom ^= ":" then goto syntax_err;
		if substr (dirname, 1, 1) ^= ">" then dirname = rtrim (root) || ">" || dirname; /* fudge if rel. path */

		call parse_file_$parse_file_set_break (">;");
						/* absolute path name for search rtn is an error
						   name of routine terminate by a ";". */
		call get_atom;
		if eof then			/* ending file in mid-line is error. */
		     goto eof_err;
		if break then			/* segname starting w/ break is also bad. */
		     goto syntax_err;
		sname = atom;
		call get_atom;
						/* get entry name of search rtn, or ";" statement terminator. */
		if break then do;
		     if atom = ";" then
			ename = sname;		/* if end of stmt, use segname as entryname. */
		     else if atom = "$" then do;	/* look for entry name. */
			if eof then goto eof_err;	/* error to end file in mid-line */
			call get_atom;
			if eof then goto eof_err;	/* oops, forget stmt terminator. */
			if break then goto syntax_err; /* no breaks in valid entry name; error */
			ename = atom;

			call get_atom;
			if break then do;
			     if atom ^= ";" then goto syntax_err;
			end;
			else goto syntax_err;	/* non-break char is an error, too */
						/* eof is ignored at this time, if
						   it occurs, but will be caught on the
						   next parse call at top of this loop */
		     end;				/* break other than ";" or "$" is error */
		     else goto syntax_err;		/* non-break is an error, too	*/
		end;
		else goto syntax_err;
						/* eof is ignored at this point,
						   but caught next time at top of loop */
						/* now, dirname has directory to be searched,
						   sname   has segment name of search seg,
						   ename   has entry point name in search seg
						   */


dummy:		call hcs_$make_entry (codeptr (dummy), sname, ename, search_entry, code);
		if code ^= 0 then do;
		     call err_rnt (code, myname, "Unable to initiate search routine ^a$^a.",
			sname, ename);
		     goto finish;
		end;


/*   call search routine with "dirname", which contains the directory
   to be searched, and "segment", which contains the segname of what we are looking for.

   call it with:
   dirname	- name of node below which to search.
   segname(segx)	- target segname.
   lib_name	- file where we found it (may be an archive file).
   code	- error code (0 if ok, 1 if not found, n if other error).
   */
		call search_entry (dirname, segname (segx), lib_name, code);

/* now, analyze the return code from the searching seg.
   code=0 means that the segment was found, in segment lib_name
   (may be archive file).
   code=1 means that the segment was not found in the directory searched.
   */

		if code = 0 then do;		/* hooray, we found it */
		     if reverse (before (reverse (lib_name), ".")) = "archive" then do; /* is anarchive file */
			if long_sw then call ioa_ ("^a: Extracting ^a from ^a>^a.",
			     myname, segname (segx), dirname, lib_name);

/* *************************************************************************
   if rename option, extract segment into process directory and then copy it with
   new name to avoid name dups in the working directory
   ***************************************************** */

			if active_fnc then do;
			     if ret ^= "" then ret = ret || " ";
			     ret = ret || requote_string_ (rtrim (pathname_$component (dirname, lib_name, segname (segx))));
			end;
			else do;
			     if segname (segx) ^= new_name (segx) then do;
				process_dir = get_pdir_ ();

				call archive ("x", rtrim (dirname) || ">" || lib_name, rtrim (process_dir) || ">" || segname (segx));
				call copy_seg_ (process_dir, segname (segx), working_dir, new_name (segx), myname,
				     errsw, code);
				if code ^= 0 then if code ^= error_table_$namedup then
					call err_rnt (code, myname, "error copying from pdir");

				call hcs_$delentry_file (process_dir, segname (segx), code);
				if code ^= 0 then call err_rnt (code, myname, "error deleteing pdir copy");
			     end;

/* *****************************************************************
   if no rename option just extract it into the working directory
   ***************************************************************** */

			     else call archive ("x", rtrim (dirname) || ">" || lib_name, segname (segx));

/* ****************************************************
   In either case, set the acl to rew for user -extracter
   ***************************************************** */

			     segment_acl.access_name = get_group_id_$tag_star ();
			     segment_acl.modes = "1110"b;

			     call hcs_$add_acl_entries (working_dir, new_name (segx), addr (segment_acl), 1, code);
			     if (segment_acl.status_code ^= 0) | (code ^= 0) then
				call err_rnt (code, myname, "error adding access");

			end;
			goto seg_done;		/* in either case */
		     end;				/* end of archive code */
		     else do;
			if active_fnc then do;
			     if ret ^= "" then ret = ret || " ";
			     ret = ret || requote_string_ (rtrim (pathname_ (dirname, lib_name)));
			end;
			else do;
						/* copy from "dirname || ">" || lib_name" to "segment" */
			     if long_sw then call ioa_ ("^a: Copying ^a from ^a>^a.", myname,
				segname (segx), dirname, lib_name);
			     call copy_seg_ (dirname, lib_name, working_dir, new_name (segx), myname, errsw, code);
			     if code ^= 0 then if code ^= error_table_$namedup
				then if ^brief_sw
				     then call err_rnt (code, myname, "Error while attempting to copy ^a>^a to ^a.",
					dirname, lib_name, new_name (segx));
			end;
		     end;
		     goto seg_done;
		end;				/* end of loop for segments */
		if code ^= 1 then			/* Some other error (code = 1 means not found) */
		     if ^brief_sw & ^active_fnc then call err_rnt (code, myname,
			"^/Error encountered while searching ^a for ^a specified in ^a>^a.^/Search continues.",
			dirname, segname (segx), root, sys (sysx));
		goto again;
sys_done:
	     end;
	     if ^brief_sw then call err_rnt (error_table_$seg_not_found, myname, "^a.", segname (segx));
seg_done:
	end;
finish:
	if star_list_names_ptr ^= null then free star_list_names;
	if star_list_branch_ptr ^= null then free star_dir_list_branch;
	return;

syntax_err: call err_rnt (0, myname, "Syntax error in segment ^a>^a.", root, sys (sysx));
	goto finish;

eof_err:	call err_rnt (0, myname, "Premature EOF in segment ^a>^a.", root, sys (sysx));
	goto finish;

get_atom:	proc;
	     call parse_file_$parse_file_ptr (controlp, cc, break_f, eof_f);
	     break = bit (break_f, 1);		/* convert to bit string */
	     eof = bit (eof_f, 1);			/* ... */

	end get_atom;
get_arg:	proc returns (char (*));
	     ac = ac + 1;
	     call cu_$arg_ptr_rel (ac, argp, argl, code, arglp);
	     if code ^= 0 then goto noarg;
	     return (arg);
	end get_arg;
     end get_library_segment;
  



		    get_primary_name_.pl1           11/12/82  1417.3rew 11/12/82  1112.2       56322


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


get_primary_name_: procedure (P_dname, P_ename, P_found_ename, P_code);

/* *	GET_PRIMARY_NAME_
   *
   *	This routine is used by get_library_segment to search through new format (1972)
   *	Multics online and offline libraries. It looks for the segment or archive component
   *	called P_ename, in the P_dname directory. If it finds it, it returns the primary
   *	name of the segment it found in P_found_ename, and returns P_code as zero. If it
   *	doesn't find it, but had no problems looking, it returns P_code as 1 and leaves
   *	P_found_ename alone, to cause get_library_segment to keep looking. Otherwise, if
   *	it encounters an error searching, it returns the error code.
   *
   *	The search_archives entrypoint additionally looks through all the archives in the
   *	directory, in case the component names are not on the archives (as is the case for
   *	the CISL Development Machine libraries, for instance).
   *
   *	Written 08/07/72, by Gary C. Dixon
   *	Rewritten, to add $search_archives, 03/25/81, W. Olin Sibert
   */

dcl  P_dname char (*) parameter;			/* pathname of the directory to be searched. (Input) */
dcl  P_ename char (*) parameter;			/* entryname of the entry to be found. (Input) */
dcl  P_found_ename char (*) parameter;			/* primary name of the found entry. (Output) */
dcl  P_code fixed bin (35) parameter;			/* status code. (Output) */

dcl  dname char (168);
dcl  ename char (32);
dcl  code fixed bin (35);
dcl  first_error fixed bin (35);
dcl  search_sw bit (1) aligned;
dcl  idx fixed bin;
dcl  archive_ptr pointer;
dcl  archive_bc fixed bin (24);

dcl 1 status_buffer aligned like status_branch automatic;

dcl  status_area area aligned based (status_area_ptr);

dcl  archive_$get_component entry (pointer, fixed bin (24), char (*), pointer, fixed bin(24), fixed bin(35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), pointer, fixed bin (35));
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), pointer, pointer, fixed bin (35));
dcl  hcs_$terminate_noname entry (pointer, fixed bin (35));

dcl  error_table_$no_component fixed bin (35) external static;
dcl  error_table_$noentry fixed bin (35) external static;
dcl  error_table_$nomatch fixed bin (35) external static;

dcl  cleanup condition;

dcl (addr, null, sum, unspec, pointer) builtin;

/*  */

	search_sw = "0"b;				/* Just look at names, don't search archives */
	goto COMMON;


get_primary_name_$search_archives: entry (P_dname, P_ename, P_found_ename, P_code);

/* *	Entry to search all archives in the directory if it doesn't find what it
   *	wants when just looking up the name. */

	search_sw = "1"b;
	goto COMMON;


COMMON:	dname = P_dname;
	ename = P_ename;

	status_area_ptr = get_system_free_area_ ();
	status_ptr = addr (status_buffer);
	unspec (status_buffer) = ""b;
	star_names_ptr = null ();
	star_entry_ptr = null ();
	archive_ptr = null ();

	on condition (cleanup)
	     call clean_up ();

	call hcs_$status_ (dname, ename, 1, status_ptr, status_area_ptr, code);
	if code = 0 then do;			/* Found it */
	     P_found_ename = status_entry_names (1);
	     goto FINISHED;
	     end;

	else if code ^= error_table_$noentry then	/* An error. Just abort */
	     goto FINISHED;

	else if ^search_sw then do;			/* If we're not to search, just set code to 1 */
NOT_FOUND:     code = 1;
	     goto FINISHED; 			/* and finish */
	     end;

/*  */

	call hcs_$star_ (dname, "**.archive", star_ALL_ENTRIES, status_area_ptr,
	     star_entry_count, star_entry_ptr, star_names_ptr, code);

	if code = error_table_$nomatch then goto NOT_FOUND; /* Nothing there to look through -- not an error */
	else if code ^= 0 then goto FINISHED;		/* Treat anything else as an error */

	first_error = 0;				/* Set to nonzero by the first error */
	do idx = 1 to star_entry_count;		/* Loop through all the archives */
	     call hcs_$initiate_count (dname, star_names (star_entries (idx).nindex), "",
		archive_bc, 0, archive_ptr, code);
	     if archive_ptr = null () then do;		/* Just ignore errors searching archives */
		if first_error = 0 then		/* remember any errors other than not-found */
		     if code ^= error_table_$noentry then first_error = code;
		goto NEXT_ARCHIVE;
		end;

	     call archive_$get_component (archive_ptr, archive_bc, ename, (null ()), (0), code);
	     if code = 0 then do;			/* Found it */
		P_found_ename = star_names (star_entries (idx).nindex); /* Set the return name */
		goto FINISHED;			/* and finish up */
		end;

	     else if (code ^= error_table_$no_component) & (first_error = 0) then
		first_error = code; 		/* If a format error, etc., remember it */

	     call hcs_$terminate_noname (archive_ptr, (0)); /* Forget about this one */

NEXT_ARCHIVE:
	     end; 				/* of loop through possible archives */

	if first_error = 0 then			/* Didn't find it, anywhere, but had no problems looking */
	     code = 1;				/* indicate, and fall through */
	else code = first_error;			/* Otherwise, return the code for the first problem */


FINISHED:
	P_code = code;
	call clean_up ();
	return;

/*  */

clean_up: proc ();

/* Cleanup procedure */

	if status_branch.names_relp ^= ""b then
	     free status_entry_names in (status_area);
	if star_names_ptr ^= null () then
	     free star_names in (status_area);
	if star_entry_ptr ^= null () then
	     free star_entries in (status_area);
	if archive_ptr ^= null () then
	     call hcs_$terminate_noname (archive_ptr, (0));

	return;
	end clean_up;

%page; %include status_structures;
%page; %include star_structures;

	end get_primary_name_;
  



		    hp_delete.pl1                   10/25/83  1643.3r w 10/25/83  1441.4       57564


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


/* Delete a segment or directory (including inferior segments/links/directories)
   regardless of logical volume mounting, connection failure, etc. */

/* Last modified:
   April 1979 by D. Spector: created
*/

hp_delete:
hpdl:
     procedure;

/* AUTOMATIC */

	declare answer		 char (3) varying;
	declare area_ptr		 ptr;
	declare argl		 fixed binary;
	declare argp		 ptr;
	declare code		 fixed binary (35);
	declare count		 fixed binary;
	declare dirname		 char (168);
	declare entryname		 char (32);
	declare i			 fixed binary;
	declare pathname		 char (168);
	declare type		 fixed binary (2);

%include query_info;

/* EXTERNAL */

	declare absolute_pathname_	 entry (char (*), char (*), fixed binary (35));
	declare com_err_		 entry options (variable);
	declare com_err_$suppress_name entry options (variable);
	declare command_query_	 entry options (variable);
	declare cu_$arg_count	 entry (fixed binary);
	declare cu_$arg_ptr		 entry (fixed binary, ptr, fixed binary, fixed binary (35));
	declare error_table_$link	 external fixed binary (35);
	declare error_table_$moderr	 external fixed binary (35);
	declare error_table_$nomatch	 external fixed binary (35);
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed binary (35));
	declare get_system_free_area_	 entry () returns (ptr);
	declare hcs_$star_		 entry (char (*), char (*), fixed binary (2), ptr, fixed binary, ptr, ptr,
				 fixed binary (35));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed binary (1), fixed binary (2), fixed binary (24),
				 fixed binary (35));
	declare hcs_$terminate_file	 entry (char (*), char (*), fixed binary (1), fixed binary (35));
	declare hphcs_$delentry_file	 entry (char (*), char (*), fixed binary (35));
	declare system_privilege_$check_mode_reset
				 entry (char (*), char (*), fixed binary (35));

/* BUILTIN */

	declare (addr, null, rtrim)	 builtin;

/* MISCELLANEOUS */

	declare arg		 char (argl) based (argp);
	declare cleanup		 condition;
	declare linkage_error	 condition;
	declare me		 char (32) initial ("hp_delete") internal static options (constant);

/* Start of command */

/* Set up handler for insufficient access to gates */

	on linkage_error
	     begin;
		call com_err_ (error_table_$moderr, me, "hphcs_ and/or system_privilege_");
		go to quit;
	     end;

/* Make sure there is one argument */

	call cu_$arg_count (count);
	if count ^= 1
	then do;
		call com_err_$suppress_name (0, me, "Usage: ^a pathname", me);
		return;
	     end;

/* Get the pathname argument */

	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0
	then go to error;

/* Find branch type */

	call expand_pathname_ (arg, dirname, entryname, code);
	if code ^= 0
	then go to error;
	call absolute_pathname_ (arg, pathname, (0));
	call hcs_$status_minf (dirname, entryname, 0, type, (0), code);
	if code ^= 0
	then go to error;

/* Refuse to delete links due to ambiguity of chasing */

	if type = 0				/* Link */
	then do;
		call com_err_ (error_table_$link, me, "^a.", pathname);
		return;
	     end;

/* Query user whether to go ahead with deletion */

	query_info.version = query_info_version_4;
	query_info.yes_or_no_sw = "1"b;
	query_info.suppress_name_sw = "1"b;
	call command_query_ (addr (query_info), answer, me, "Do you really want to delete the^[ segment^; directory^] ^a ?",
	     type = 1, pathname);
	if answer ^= "yes"				/* Note dependency on English! */
	then return;

/* Do the deletion */

	area_ptr = get_system_free_area_ ();		/* For hcs_$star_ */
	call delete_branch (dirname, entryname, type);

/* Done */

	return;

/* Error handling */

error:
	call com_err_ (code, me, "^a.", arg);
quit:
	return;

/* Subroutines */

/* Delete a branch (seg, dir, or link) */

delete_branch:
     procedure (dirname, entryname, type);

	declare dirname		 char (168);
	declare entryname		 char (32);
	declare type		 fixed binary (2);

	declare 1 entries		 (entry_count) aligned based (entry_ptr),
		2 type		 fixed binary (2) unsigned unaligned,
		2 nnames		 fixed binary (16) unsigned unaligned,
		2 nindex		 fixed binary (18) unsigned unaligned;
	declare entry_count		 fixed binary;
	declare entry_ptr		 ptr;
	declare i			 fixed binary;
	declare n_ptr		 ptr;
	declare names		 (100) char (32) based (n_ptr);
	declare pathname		 char (168);

/* Construct pathname */

	if dirname = ">"
	then pathname = ">" || entryname;
	else pathname = rtrim (dirname) || ">" || entryname;

/* Reset security_out_of_service switch if set */

	if type = 2				/* Directory */
	then call system_privilege_$check_mode_reset (dirname, entryname, (0));

/* Delete the branch */

	if type = 2				/* Directory */
						/* Delete the contents of a directory */
	then do;

/* Handle errors and quit/release */

		entry_ptr = null;
		n_ptr = null;
		on cleanup
		     call clean;			/* Free allocated storage */

/* Find all entrynames in this directory */

		call hcs_$star_ (pathname, "**", 3, area_ptr, entry_count, entry_ptr, n_ptr, code);
		if code ^= 0
		then if code ^= error_table_$nomatch
		     then do;
			     call com_err_ (code, me, pathname);
			     go to quit;
			end;

/* Delete all branches contained in this directory */

		do i = 1 to entry_count;
		     call delete_branch (pathname, names (entries (i).nindex), (entries (i).type));
		end;

/* Clean up process changes caused by hcs_$star_ */

		call clean;			/* Free allocated storage */
		call hcs_$terminate_file (dirname, entryname, 0, (0));
	     end;

/* Delete the segment itself */

	call hphcs_$delentry_file (dirname, entryname, code);
	if code ^= 0
	then do;
		call com_err_ (code, me, pathname);
		go to quit;
	     end;
	return;

/* Subroutine to free storage used by hcs_$star_ */

clean:
     procedure;
	if entry_ptr ^= null
	then free entries;
	if n_ptr ^= null
	then free names;
	return;
     end;						/* clean */

     end;						/* delete_branch */

     end;						/* hp_delete */



		    l_names.pl1                     11/12/82  1417.3rew 11/12/82  1112.6       37728


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


/* MCR 4232 Add name l_names 12/13/79 S. Herbst */

l_names: lnames: proc;

/* This procedure either copies ($copy) or moves ($move) all
   the additional names from one segment to another designated
   segment. A copy is obviously impossible within a directory.
   Any number of pairs of arguments is allowed and the =-convention
   is followed in the second argument of a pair.

   Karolyn Martin 5/30/69 */
/* modified by M. Weaver 9 April 1970 6:35 PM -- recoded into PL/I */
/* last modified by M. Weaver 31 December 1970 */


dcl (copy, errsw) bit (1) aligned,
    (lng, i, n) fixed bin,
    (dir1, dir2) char (168),
    (en1, en2, qent) char (32),
     ap ptr;
dcl  name char (lng) based (ap);
dcl  whoami char (32);
dcl  code fixed bin (35);
dcl  type fixed bin (2);
dcl  bitcnt fixed bin (24);
dcl  addr builtin;
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  error_table_$namedup external fixed bin (35);
dcl  error_table_$segnamedup external fixed bin (35);
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  installation_tools_$copy_names_ entry
    (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  installation_tools_$move_names_ entry
    (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
dcl  get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)),
     cu_$arg_count entry (fixed bin);

copy:	entry;

/* The additional names are to be left on the original segment. */

	copy = "1"b;
	whoami = "l_names$copy";
	go to work;

move:	entry;

/* The additional names are to be removed from the original segment. */

	copy = "0"b;
	whoami = "l_names$move";

work:	call cu_$arg_count (n);
	if n = 0 then return;

/* The following master loop processes each pair of arguments completely
   unless some error code is returned by the file system. */

pairs:	do i = 1 to n by 2;

/* get first arg */
	     call cu_$arg_ptr (i, ap, lng, code);
	     if code ^= 0 then do;
err1:		call com_err_ (code, whoami, "arg ^d", i);
		go to next_pair;
	     end;
	     call expand_pathname_ (name, dir1, en1, code);
	     if code ^= 0 then go to err1;

/* get second arg */
	     if i = n then do;
		en2 = en1;			/* have odd no. of args */
		dir2 = get_wdir_ ();
	     end;
	     else do;
		call cu_$arg_ptr (i+1, ap, lng, code);
		if code ^= 0 then do;
err2:		     call com_err_ (code, whoami, "arg ^d", i);
		     go to next_pair;
		end;
		call expand_pathname_ (name, dir2, qent, code);
		if code ^= 0 then go to err2;
		call get_equal_name_ (en1, qent, en2, code);
		if code ^= 0 then go to err2;
	     end;


/* Does target segment exist?? */

	     call hcs_$status_minf (dir2, en2, 0, type, bitcnt, code);
	     if code ^= 0 then go to errseg2;

/* If so, then move the names. */

	     if copy then do;
		call installation_tools_$copy_names_ (dir1, en1, dir2, en2, whoami, errsw, code);
		if code ^= 0 then do;		/* if there's an error */
com_err:		     if code ^= error_table_$namedup then if code ^= error_table_$segnamedup then do;
			     if ^errsw then call com_err_ (code, whoami, "^a>^a", dir1, en1);
			     else do;
errseg2:				call com_err_ (code, whoami, "^a>^a", dir2, en2);
				go to next_pair;
			     end;
			end;
		end;
	     end;


	     else do;
		call installation_tools_$move_names_ (dir1, en1, dir2, en2, whoami, errsw, code);
		if code ^= 0 then go to com_err;
	     end;


next_pair: end pairs;

     end l_names;



		    l_patch.pl1                     11/12/82  1417.3rew 11/12/82  1112.7       77679


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


/* Modified 1/29/75 by Larry Johnson to use new acl calls */
/* MCR 4232 Rename to l_patch 12/13/79 S. Herbst */
/* MCR 5346 09/04/81 by GA Texada to call appropriate hcs_ entries on linkage_error */

l_patch: lpatch: proc;

/* External Procedures */

dcl  add_acl_entries_entry	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)) variable,
     list_acl_entry		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)) variable,
     delete_acl_entries_entry	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)) variable,
     com_err_ entry options (variable),
     command_query_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     get_group_id_ entry returns (char (32) aligned),
     hcs_$add_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
     hcs_$delete_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
     hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$list_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     installation_tools_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
     installation_tools_$list_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)),
     installation_tools_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
     ioa_ entry options (variable),
     patch_entry			entry(ptr, ptr, fixed bin, fixed bin(35)) variable,
     installation_tools_$patch_ptr entry (ptr, ptr, fixed bin, fixed bin (35)),
     ring_1_patch_$ptr		entry (ptr, ptr, fixed bin, fixed bin(35)),
     ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin (35));

dcl linkage_error condition;

dcl  error_table_$argerr ext fixed bin (35);

/* Builtin Functions */

dcl (addr, baseptr, substr, null, ptr) builtin;

/* Text References */

dcl  name int static fixed bin init (0),
     number int static fixed bin init (1);

/* Internal Static Variables */

dcl  id int static char (7) aligned init ("l_patch");

/* Automatic Variables */

dcl  argp ptr,
     current_access bit (3),
     patch_ptr ptr,
     segptr ptr;

dcl  answer char (16) varying,
     dir char (168),
     ename char (32);

dcl  old_acl_sw bit (1) aligned init ("0"b);		/* set if there was an old acl */
dcl  acl_sw bit (1) aligned init ("0"b);

dcl  arglen fixed bin,
     i fixed bin,
     narg fixed bin,
     nwords fixed bin,
     offset fixed bin,
     segno fixed bin,
     sw fixed bin;

dcl  code fixed bin (35);

dcl 1 new_acl aligned,
    2 access_name char (32),
    2 modes bit (36),
    2 zero_pad bit (36),
    2 status_code fixed bin (35);

dcl 1 old_acl aligned like new_acl;

dcl 1 acl_del_list aligned,
    2 access_name char (32),
    2 status_code fixed bin (35);

dcl 1 query_info aligned,
    2 version fixed bin init (1),
    2 yes_or_no_sw bit (1) unaligned init ("1"b),
    2 supress_name_sw bit (1) unaligned init ("0"b),
    2 status_code fixed bin (35) init (0),
    2 query_code fixed bin (35) init (0);

dcl  new_data (0:1023) fixed bin,
     old_data (0:1023) fixed bin;

/* Based Storage */

dcl  arg char (arglen) unaligned based;

/*
   
*/

	narg = 1;

	call cu_$arg_ptr (narg, argp, arglen, code);	/* get first arg - segment name or segment number */
	if code ^= 0 then go to err1;

	segno = cv_oct_check_ (argp -> arg, code);	/* try to convert to octal number */

	if code ^= 0 then do;			/* given a pathname */
	     sw = name;
	     call expand_pathname_ (argp -> arg, dir, ename, code);
	     if code ^= 0 then go to err2;
	end;

	else do;					/* given a segment number */
	     sw = number;
	     segptr = baseptr (segno);		/* construct a pointer */
	     call hcs_$fs_get_path_name (segptr, dir, arglen, ename, code);
	     if code ^= 0 then go to err2;		/* get the pathname of the segment */
	end;

	narg = 2;					/* get the offset to be patched */
	call cu_$arg_ptr (narg, argp, arglen, code);
	if code ^= 0 then go to err1;

	offset = cv_oct_check_ (argp -> arg, code);
	if code ^= 0 then go to err4;

	if sw = name then do;			/* initate the segment */
	     call hcs_$initiate (dir, ename, "", 0, 0, segptr, code);
	     if segptr = null then go to err3;		/* if given pathname */
	end;

	patch_ptr = ptr (segptr, offset);		/* get location in segment to be patched */

arg_fetch:
	narg = narg + 1;
	call cu_$arg_ptr (narg, argp, arglen, code);
	if code ^= 0 then go to start;
	new_data (narg-3) = cv_oct_check_ (argp -> arg, code);
	if code ^= 0 then go to err4;
	go to arg_fetch;

start:
	if narg = 3 then go to err1;
	nwords = narg - 3;

	on linkage_error begin;
	     delete_acl_entries_entry = hcs_$delete_acl_entries;
	     add_acl_entries_entry = hcs_$add_acl_entries;
	     patch_entry = ring_1_patch_$ptr;
	     add_acl_entries_entry = hcs_$add_acl_entries;
	     list_acl_entry = hcs_$list_acl;
	     goto revert_linkage_error;
	     end;
/* set up for installation_tools_ as the "normal" gate  */

	delete_acl_entries_entry = installation_tools_$delete_acl_entries;
	add_acl_entries_entry = installation_tools_$add_acl_entries;
	patch_entry = installation_tools_$patch_ptr;
	add_acl_entries_entry = installation_tools_$add_acl_entries;
	list_acl_entry = installation_tools_$list_acl;
revert_linkage_error:
	 revert linkage_error;
/* get current acl for user so that it can be reset later */

	old_acl.access_name = get_group_id_ ();
	old_acl.modes, old_acl.zero_pad = "0"b;
	old_acl.status_code = 0;

	call list_acl_entry (dir, ename, null, null, addr (old_acl), 1, code);
	if code ^= 0 then go to err3;
	if old_acl.status_code = 0 then do;
	     old_acl_sw = "1"b;
	     current_access = substr (old_acl.modes, 1, 3); /* check to see if i have access */
	     if current_access = "101"b | current_access = "111"b then go to acl_ok;
	end;

/* set up new acl with rew access */

	new_acl.access_name = old_acl.access_name;
	new_acl.modes = "111"b;
	new_acl.zero_pad = "0"b;

	call add_acl_entries_entry (dir, ename, addr (new_acl), 1, code);
	if code = error_table_$argerr then do;
	     code = new_acl.status_code;
	     go to err3;
	end;
	if code ^= 0 then go to err3;
	if new_acl.status_code ^= 0 then do;
	     code = new_acl.status_code;
	     go to err3;
	end;
	acl_sw = "1"b;				/* remember that i set acl */
acl_ok:

	call ring_zero_peek_ (patch_ptr, addr (old_data), nwords, code);
	if code ^= 0 then go to err2;
	do i = 0 to nwords - 1;
	     call ioa_ ("^6o  ^w to ^w", offset+i, old_data (i), new_data (i));
	end;

	call command_query_ (addr (query_info), answer, id, "Type yes if patches are correct.");
	if answer = "no" then go to finish;


	call patch_entry (addr (new_data), patch_ptr, nwords, code);
	if code ^= 0 then go to err3;

finish:
	if acl_sw then if old_acl_sw then do;		/* restore old acl */
		acl_sw = "0"b;

		call add_acl_entries_entry (dir, ename, addr (old_acl), 1, code);
		if code = error_table_$argerr then do;
		     code = old_acl.status_code;
		     go to err3;
		end;
		if code ^= 0 then go to err3;
	     end;
	     else do;				/* delete the acl i added */
		acl_sw = "0"b;
		acl_del_list.access_name = new_acl.access_name;

		call delete_acl_entries_entry (dir, ename, addr (acl_del_list), 1, code);
		if code = error_table_$argerr then do;
		     code = acl_del_list.status_code;
		     go to err3;
		end;
		if code ^= 0 then go to err3;
	     end;

	if sw = name then				/* terminate the segment if we initiated it */
	     call hcs_$terminate_noname (segptr, code);

	return;
err1:	call com_err_ (code, id);
	go to finish;

err2:	call com_err_ (code, id, argp -> arg);
	go to finish;

err3:	call com_err_ (code, id, "^a>^a", dir, ename);
	go to finish;

err4:	call com_err_ (0, id, "Illegal octal number ^a", argp -> arg);
	go to finish;
     end l_patch;
 



		    ring_1_patch_.pl1               11/12/82  1417.3rew 11/12/82  1112.9       36855


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


/* Modified 1/29/75 by Larry Johnson to fix ring number in to_ptr */

ring_1_patch_: proc;

/* External Procedures */

dcl	cu_$level_get entry returns (fixed bin),
	cu_$level_set entry (fixed bin),
	hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)),
	hcs_$initiate entry(char(*) aligned, char(*) aligned, char(*) aligned, fixed bin, fixed bin, ptr, fixed bin(35)),
	hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35)),
	hcs_$terminate_noname entry (ptr, fixed bin (35));

/* External Variables */

dcl	error_table_$argerr ext fixed bin (35),
	error_table_$moderr ext fixed bin (35);

/* Builtin Functions */

dcl	(bit, addr, fixed, null, rel, ptr) builtin;

/* Text References */

dcl	segno fixed bin int static init (0),
	path fixed bin int static init (1);

/* Automatic Variables */

dcl	a_dir char (*),				/* arguments */
	a_ename char (*),
	a_offset fixed bin,
	a_fp ptr,
	a_n fixed bin,
	a_code fixed bin (35),
	a_tp ptr;

dcl	segptr ptr,
	to_ptr ptr,
	from_ptr ptr;

dcl	entry_point fixed bin,
	offset fixed bin,
	n fixed bin,
	save_ring fixed bin;

dcl	max_length fixed bin (18);			/* max size of this segment */

dcl	mode fixed bin (5);

dcl	code fixed bin (35);

dcl	dir char (168) aligned,
	ename char (32) aligned;

/* Based Storage */

dcl	move (n) bit (36) aligned based;

%include its;

/*

*/
pathname: entry (a_dir, a_ename, a_offset, a_fp, a_n, a_code);

	entry_point = path;				/* indicate through which entry point we came */
	dir = a_dir;				/* copy dir name */
	ename = a_ename;				/* copy entry name */
	offset = a_offset;				/* copy offset */

	go to common;

ptr:	entry (a_fp, a_tp, a_n, a_code);

	entry_point = segno;			/* indicate through which entry point we came */
	to_ptr = a_tp;				/* copy pointer to location to be patched */
	addr (to_ptr) -> its.ringno = "001"b;

common:						/* copy arguments common to both entry points */
	from_ptr = a_fp;				/* copy pointer to new data */
	n = a_n;					/* copy number of words to be patched */
	code = 0;					/* clear status code */

	save_ring = cu_$level_get ();			/* save validation level */
	call cu_$level_set (1);			/* set validation level to 1 */

	if entry_point = path then do;		/* if we entered through the pathname entry point */
	     call hcs_$initiate (dir, ename, "", 0, 0, segptr, code);
	     if segptr = null then go to finish;	/* get a pointer to the segment */
	     to_ptr = ptr (segptr, offset);		/* get location to be patched */
	end;

	else segptr = ptr (to_ptr, 0);

	if n <= 0 then go to arg_err;			/* check number of words to be changed */

						/* check exceeding max length of segment */
	call hcs_$get_max_length_seg(from_ptr, max_length, code);
	if code ^= 0 then go to term;

	if fixed(rel(from_ptr), 18) + n > max_length then go to arg_err;

	call hcs_$get_max_length_seg(to_ptr, max_length, code);
	if code ^= 0 then go to term;

	if fixed(rel(to_ptr), 18) + n > max_length then go to arg_err;

	call hcs_$fs_get_mode (segptr, mode, code);	/* check mode */
	if code ^= 0 then go to term;
	if (bit (mode, 5) & "00010"b) = "0"b		/* need write permission */
	then go to access_error;

	to_ptr -> move = from_ptr -> move;		/* make the patch */

term:	if entry_point = path then			/* terminate the segment if we initiated it */
	call hcs_$terminate_noname (segptr, code);

finish:	call cu_$level_set (save_ring);		/* restore the validation level we entered with */
	a_code = code;				/* copy the status code */
	return;

arg_err:	code = error_table_$argerr;
	go to term;

access_error:
	code = error_table_$moderr;
	go to term;

     end ring_1_patch_;
 



		    ring_1_tools_.pl1               10/19/83  0616.7rew 10/19/83  0602.5       78543


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


/* The following procedure is a special entry in ring 1 for use in installing procedures
   in the system libraries. It calls the acl primitive and name manipulation procedures, but first sets the
   validation level to 1 so that procedures can be installed in ring 1 from
   ring 4.

   Originally coded by R. J. Feiertag on January 19, 1971
   last modified by E. Stone 12/71 - changed name from set_acc_control_list_
   modified by Peter B. Kelley 05/73 	- added entry points for new ACL primitives;
   - renamed existing entry points to correspond to
   published documentation. (installation_tools_ gate also changed).
   Modified 01/11/79 by C. D. Tavares to add dir_ring_brackets entry.
   Modified 831014 BIM for delentry_file, expunge acl_add1.
*/

/* format: style2,idind30,indcomtxt */
ring_1_tools_:
     procedure;

	dcl     dir		        char (*);	/* directory of branch whose acl is to be replaced */
	dcl     entry		        char (*);	/* entry name of acl whose acl is to be replaced */
	dcl     code		        fixed bin (35);
						/* file system error code */
	dcl     switch_value	        bit parameter;
						/* for switch stuff */
	dcl     validation_level	        fixed bin;	/* validation level of caller */

	dcl     acl_ptr		        ptr;	/* ptr to new acl structure */
	dcl     delete_acl_ptr	        ptr;	/* ptr to structure containing deletions */
	dcl     dir_acl_ptr		        ptr;	/* as acl_ptr 'cept points to dir_acl structure */
	dcl     acl_count		        fixed bin;	/* no. of acls in structure */
	dcl     area_ptr		        ptr;	/* points to area where acl list is to be */
						/* allocated when listing whole acl  */
	dcl     alloc_ptr		        ptr;	/* set to allocated list in area when listing */
						/* whole acl  */
	dcl     no_sysdaemon_sw	        bit (1) aligned;
						/* if "0"b then *.SysDaemon.* rwa (sma) will */
						/* be appended to replacement list */
	dcl     rbs		        (3) fixed bin (3);
						/* ring brackets for hcs_$set_ring_brackets */
	dcl     dir_rbs		        (2) fixed bin (3);
						/* ring brackets for hcs_$set_dir_ring_brackets */

	dcl     old_name		        char (*);
	dcl     new_name		        char (*);
	dcl     dir2		        char (*);
	dcl     entry2		        char (*);
	dcl     caller		        char (*);
	dcl     err_sw		        bit (1) aligned;

	dcl     cleanup		        condition;

	dcl     copy_names_		        entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned,
				        fixed bin (35));
	dcl     cu_$level_get	        entry (fixed bin);
	dcl     cu_$level_set	        entry (fixed bin);
	dcl     get_ring_		        entry returns (fixed bin);
	dcl     move_names_		        entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned,
				        fixed bin (35));
	dcl     hcs_$add_acl_entries	        entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$add_dir_acl_entries      entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$chname_file	        entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$delentry_file	        entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$delete_acl_entries       entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$delete_dir_acl_entries   entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     hcs_$list_acl	        entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     hcs_$list_dir_acl	        entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     hcs_$replace_acl	        entry (char (*), char (*), ptr, fixed bin, bit (1) aligned,
				        fixed bin (35));
	dcl     hcs_$replace_dir_acl	        entry (char (*), char (*), ptr, fixed bin, bit (1) aligned,
				        fixed bin (35));
	dcl     hcs_$set_ring_brackets        entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
	dcl     hcs_$set_dir_ring_brackets    entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
	dcl     hcs_$set_safety_sw	        entry (char (*), char (*), bit, fixed bin (35));
	dcl     term_		        entry (character (*), character (*), fixed binary (35));


chname_file:
     entry (dir, entry, old_name, new_name, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$chname_file (dir, entry, old_name, new_name, code);
	go to RETURN;

copy_names_:
     entry (dir, entry, dir2, entry2, caller, err_sw, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call copy_names_ (dir, entry, dir2, entry2, caller, err_sw, code);
	go to RETURN;

delentry_file:
     entry (dir, entry, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call term_ (dir, entry, (0));			/* cannot hurt */
	call hcs_$delentry_file (dir, entry, code);
	go to RETURN;

move_names_:
     entry (dir, entry, dir2, entry2, caller, err_sw, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call move_names_ (dir, entry, dir2, entry2, caller, err_sw, code);
	go to RETURN;

list_acl:
     entry (dir, entry, area_ptr, alloc_ptr, acl_ptr, acl_count, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$list_acl (dir, entry, area_ptr, alloc_ptr, acl_ptr, acl_count, code);
	go to RETURN;

add_acl_entries:
     entry (dir, entry, acl_ptr, acl_count, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$add_acl_entries (dir, entry, acl_ptr, acl_count, code);
	go to RETURN;

delete_acl_entries:
     entry (dir, entry, delete_acl_ptr, acl_count, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$delete_acl_entries (dir, entry, delete_acl_ptr, acl_count, code);
	go to RETURN;

replace_acl:
     entry (dir, entry, acl_ptr, acl_count, no_sysdaemon_sw, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$replace_acl (dir, entry, acl_ptr, acl_count, no_sysdaemon_sw, code);
	go to RETURN;

list_dir_acl:
     entry (dir, entry, area_ptr, alloc_ptr, dir_acl_ptr, acl_count, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$list_dir_acl (dir, entry, area_ptr, alloc_ptr, dir_acl_ptr, acl_count, code);
	go to RETURN;

add_dir_acl_entries:
     entry (dir, entry, dir_acl_ptr, acl_count, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$add_dir_acl_entries (dir, entry, dir_acl_ptr, acl_count, code);
	go to RETURN;

delete_dir_acl_entries:
     entry (dir, entry, delete_acl_ptr, acl_count, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$delete_dir_acl_entries (dir, entry, delete_acl_ptr, acl_count, code);
	go to RETURN;

replace_dir_acl:
     entry (dir, entry, dir_acl_ptr, acl_count, no_sysdaemon_sw, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$replace_dir_acl (dir, entry, dir_acl_ptr, acl_count, no_sysdaemon_sw, code);
	go to RETURN;

set_ring_brackets:
     entry (dir, entry, rbs, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$set_ring_brackets (dir, entry, rbs, code);
	go to RETURN;

set_dir_ring_brackets:
     entry (dir, entry, dir_rbs, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$set_dir_ring_brackets (dir, entry, dir_rbs, code);
	go to RETURN;

set_safety_sw:
     entry (dir, entry, switch_value, code);

	validation_level = -1;
	on cleanup call cleanup_validation;
	call setup;
	call hcs_$set_safety_sw (dir, entry, switch_value, code);

/****	   go to RETURN; */

RETURN:
	call cu_$level_set (validation_level);
	return;


setup:
     procedure;

	call cu_$level_get (validation_level);		/* remember caller's validation level */
	call cu_$level_set ((get_ring_ ()));		/* set validation level to current ring */
	return;
     end setup;

cleanup_validation:
     procedure;

	if validation_level ^= -1
	then call cu_$level_set (validation_level);
	validation_level = -1;
	return;
     end cleanup_validation;

     end ring_1_tools_;
 



		    test_archive.pl1                11/12/82  1417.3rew 11/12/82  1113.0       64953


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


test_archive: ta: proc;

/* Command based on archive processing in "bindarchive" command,
   by C Garman, from modifications made to original of
   C Garman by E Stone. */

dcl fix_old bit(1) aligned;

	fix_old = "0"b;		/* Look but don't touch */
	go to startup;

fix_old_archive: foa: entry;	/* Play a few games with contents, on the fly */

	fix_old = "1"b;
	go to startup;

dcl (archive_data_$header_begin,
     archive_data_$ident,
     archive_data_$header_end) char(8) aligned ext;

dcl (error_table_$entlong,
     error_table_$noarg) fixed bin ext;

dcl outnamep ptr,
    arglen fixed bin,
    outname char(arglen) unaligned based(outnamep);

dcl (first bit(1) init("0"b),
     com_name char(16) init("test_archive"),
     (h1, i1, e1) char(8)) aligned int static;	/* copies of archive_data_$--- */

declare 1 archd based aligned,
	2 begin char(8),
	2 name_count char(4),
	2 name char(32),
	2 arc_time char(16),
	2 mode char(4),
	2 seg_time char(20),
	2 bit_count char(8),
	2 end char(8);

dcl (path char(168),
     entarc char(40),
     cur_name char(32),
     type char(8),
     old char(2),
     s char(1),
     c0 char(0)) aligned,
    (i, ibc, ignore, ntharg, nwords, some_old, some_num) fixed bin, 	/* misc numbers */
    code fixed bin(35),
    (pathp, entropy,
     cur_ptr) ptr,
    hdr_length fixed bin int static init(25),
    cur_hdr fixed bin;

dcl (com_err_, ioa_, ioa_$rsnnl) entry options(variable),
    cu_$arg_ptr entry(fixed bin, ptr, fixed bin, fixed bin(35)),
    cv_dec_check_ entry(char(*) aligned, fixed bin(35), fixed bin),
    expand_path_ entry(ptr, fixed bin, ptr, ptr, fixed bin(35)),
    hcs_$initiate_count entry(char(*) aligned, char(*) aligned, char(*) aligned, fixed bin, fixed bin, ptr, fixed bin(35)),
    hcs_$terminate_noname entry(ptr, fixed bin(35));

dcl (addr, char, divide, index, null, ptr, substr) builtin;

/*  */

startup:
	if first = "0"b
	then do;

	     h1 = archive_data_$header_begin;	/* make copies of values in archive_data_ */
	     i1 = archive_data_$ident;
	     e1 = archive_data_$header_end;

	     first = "1"b;

	     end;

	pathp = addr(path);			/* get miscellaneous pointers */
	entropy = addr(entarc);

	ntharg = 0;

arg_loop:
	ntharg = ntharg + 1;

	/* Get name of archive segment. */

	call cu_$arg_ptr(ntharg, outnamep, arglen, code); 	/* get argument */
	if code ^= 0
	then if code = error_table_$noarg
	     then go to abort_args;
	     else go to arg_error;

	if arglen = 0
	then go to arg_loop;

	call expand_path_(outnamep, arglen, pathp, entropy, code);	/* get directory and entry name of argument */
	if code ^= 0
	then do; 
arg_error:
	     call com_err_(code, com_name, outname);
	     go to arg_loop;

	     end;

	substr(entarc, 33, 8) = (8)" ";
	if index(entarc, ".archive ") = 0
	then do;

	     call ioa_$rsnnl("^a.archive", entarc, code, entarc);	/* Add suffix if not provided */
	     if code >= 33			/* Check length of resultant */
	     then do;

		code = error_table_$entlong;
		go to arg_error;

		end;

	     end;

	call hcs_$initiate_count(path, entarc, c0, nwords, 1, cur_ptr, code);
		/* initiate archive segment */

	if cur_ptr = null
	then do;

	     call com_err_(code, com_name, "^R^a>^a^B", path, entarc);
	     go to arg_loop;

	     end;

	call ioa_("^/^a>^a^/", path, entarc); 		/* print name of segment to be tested */

/* Initialize per-archive variables */

	nwords = divide(nwords + 35, 36, 17, 0);	/* convert bit-count to number of words */

	cur_name = "S_T_A_R_T_";
	cur_hdr = 0;

	if nwords <= hdr_length		/* Segment must be at least 26 words long */
	then go to pt_nwords;

	some_old, some_num = 0b;

	do i = 0 by 1 while (cur_hdr < nwords); 	/* loop until end of archive seg found */

	cur_ptr = ptr(cur_ptr, cur_hdr); 		/* get pointer to current archive block */

	old = "  ";				/* Assume new style format (first char is FF) */

	if cur_ptr -> archd.begin ^= i1		/* check validity of archive header */
	then do;					/* Error in archive header */

	     if cur_ptr -> archd.begin = h1
	     then do;

		old = " *";			/* Comment on old-style header (VT) and continue */
		some_old = some_old + 1;
		go to check_end;

		end;

	     type = "ident   ";
arc_err:	     call ioa_("Archive format error(^a) after ""^a"", ""cur_ptr"" = ^p",
		type, cur_name, cur_ptr);

	     go to arg_loop;		/* Look at next arg, leave current archive known */

	     end;

check_end:
	if cur_ptr -> archd.end ^= e1
	then do;

	     type = "fence   ";
	     go to arc_err;

	     end;

	cur_name = cur_ptr -> archd.name;

	call cv_dec_check_(cur_ptr -> archd.bit_count, code, ibc);
				/* get bit-count of i-th component from archive header */
	if code ^= 0
	then call com_err_(0, com_name, "Non-decimal-digit in character # ^d in ""^8a""",
		code, cur_ptr -> archd.bit_count);
	if ibc < 0
	then do;

	     type = "-count  ";
	     go to arc_err;

	     end;

	if substr(cur_ptr -> archd.bit_count, 8, 1) = " "
	then if old = "  "
	     then do;

		old = " #";
		some_num = some_num + 1;

		end;

	call ioa_("^6o^a^-^a", cur_hdr, old, cur_name);

	if fix_old
	then do;

	     if old = " *"			/* Very, very old */
	     then cur_ptr -> archd.begin = i1;

	     if cur_ptr -> archd.name_count ^= "    "
	     then cur_ptr -> archd.name_count = "    ";

	     if char(cur_ptr -> archd.mode, 1) ^= "r"
	     then if index (cur_ptr -> name, ".") ^= 0
		then cur_ptr -> archd.mode = "r wa";
		else cur_ptr -> archd.mode = "re  ";

	     if char(cur_ptr -> archd.arc_time, 4) = "    "
	     then cur_ptr -> archd.arc_time = cur_ptr -> archd.seg_time;

	     if substr(cur_ptr -> archd.bit_count, 8, 1) = " "
	     then cur_ptr -> archd.bit_count = " " || char(cur_ptr -> archd.bit_count, 7);

	     ignore = index(cur_ptr -> archd.name, ".epl");

	     if ignore ^= 0
	     then if substr(cur_ptr -> archd.name, ignore + 4, 3) ^= "bsa"
		then substr(cur_ptr -> archd.name, ignore, 4) = ".pl1";
		else substr(cur_ptr -> archd.name, ignore, 7) = ".alm   ";

	     end;

	cur_hdr = cur_hdr + divide(ibc + 35, 36, 17, 0) + hdr_length;

	end;				/* end of iteration loop for contents of archive file */

	if i = 1
	then s = " ";
	else s = "s";
	call ioa_("^/^6o words, ^d component^a.", cur_hdr, i, s);

	if some_old ^= 0
	then call ioa_("(""*"" indicates very old archive, with VT instead of FF as first character of header!)");

	if some_num ^= 0
	then call ioa_("(""#"" indicates trailing blank in bit-count field)");

	if cur_hdr ^= nwords
	then /* ! */
pt_nwords:
	     call ioa_("""nwords"" = ^o(8), ""cur_hdr"" = ^o after ^p",
		nwords, cur_hdr, cur_ptr);
	else call hcs_$terminate_noname(cur_ptr, code);

	go to arg_loop;

abort_args: /* return */
	call ioa_("");		/* Print out 1 blank line */

end test_archive;
   



		    validate_info_seg.pl1           01/23/89  1234.2rew 01/23/89  1228.9      837729


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

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

validate_info_seg: vis: proc;

/* This command validates the syntax of an info segment.

   Syntax:
	     vis paths {-control_args}
	     [vis path {-control_args}]
   Arguments:

   path
      the pathname of an info seg. The .info suffix is added if necessary.
      The star convention is allowed.

   Control arguments:
   -names, -nm
   -no_names, -nnm (default)
   -severity N, -sv N
      Suppresses error messages of severity less than N.
   -total, -tt
      Prints only the total number of errors or nothing.

   The vis active function must be invoked on a single info segment and
   returns the severity number of the highest severity error encountered.

   Error messages are shown in the first DCL of the program.  The first
   character of each one is its severity. */


/****^  HISTORY COMMENTS:
  1) change(78-12-01,Herbst), approve(), audit(), install():
      Written by S. Herbst.
  2) change(79-10-15,Herbst), approve(), audit(), install():
      Fixed to accept/convert extra paragraphs of standard sections.
  3) change(80-02-25,Herbst), approve(), audit(), install():
      Fixed to diagnose missing :Info: entry lines.
  4) change(80-03-26,Herbst), approve(), audit(), install():
      Max line length changed from 79+NL to 71+NL.
  5) change(80-07-17,Herbst), approve(), audit(), install():
      Changed to print text of nonstandard section titles.
  6) change(81-06-29,Herbst), approve(), audit(), install():
      Changed to convert in place if -of PATH = path, accept any cdtb_ date,
      bugs fixed.
  7) change(82-12-10,Herbst), approve(), audit(), install():
      Fixed long lines bug and -fill on simple header line.
  8) change(83-12-02,Falksenj), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Removed all output capabilities, completely changed message style.
  9) change(85-08-15,Falksenj), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Add CHECK_INFO_TYPE and associate routines + segname checking.
 10) change(85-09-24,Lippard), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Modified by Jim Lippard to not complain about ":Entry:" or ":Info:"
      lines over 71 characters long.
 11) change(86-01-07,Lippard), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Modified to not try to handle addnames on general infos, not consider
      names ending in "_status.info" to be general infos.
 12) change(86-02-13,Lippard), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Modified to count number of infos correctly.
 13) change(86-04-03,Lippard), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Modified to allow multiple short names in header.
 14) change(86-05-13,Lippard), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Modified to require "Syntax" instead of "Usage" for subroutine info
      segs.
 15) change(86-05-16,Lippard), approve(85-11-04,MCR7289),
     audit(86-06-17,Hartogs), install(86-06-17,MR12.0-1076):
      Modified to allow subroutine "Syntax" section to have a blank line
      between the declaration and the call descriptions.
 16) change(86-10-08,Lippard), approve(86-12-01,MCR7581),
     audit(87-03-31,Dickson), install(87-04-01,MR12.1-1019):
      Modified to not put commas at the beginnings of continuation lines.
 17) change(87-01-07,Lippard), approve(87-01-26,MCR7604),
     audit(87-03-31,Dickson), install(87-04-01,MR12.1-1019):
      Modified to complain about more than two blank lines preceding a
      section.
 18) change(88-09-28,Lee), approve(88-11-14,MCR8019), audit(88-11-28,Flegel),
     install(89-01-23,MR12.3-1010):
     phx18806 (Commands 294) - Modified to complain about multiple
     paragraphs separated by single blank lines whose total exceeds 15
     lines.
                                                   END HISTORY COMMENTS */

%page;
/* format: off */
dcl (
/**** SEVERITY 1 messages ****/
     this_form_preferred init ("1This form is preferred:^s^/^13t^a"),
/**** SEVERITY 2 messages ****/
     non_std_title	     init ("2Nonstandard section title^[: ^a^]"),

     paragraph_size	     init ("2Paragraph ^[size (^s^i lines)^;^2s^] exceeds limit of ^i."),

     no_syntax_name	     init ("2Short name ^[""^a"" ^]not used."),

     no_usage_name	     init ("2Name ^[""^a"" ^]not present in Syntax line."),

     end_white_space     init ("2Th^[ese lines end^;is line ends^] in white space"),

     blank_white_space   init ("2Th^[ese blank lines contain^;is blank line contains^] white space"),

     backspace	     init ("2Th^[ese lines contain^;is line contains^] backspace"),
     missing_name	     init ("2Name missing from the segment: ^s^a"),

     extra_name          init ("2Extra name on segment: ^s^a"),

     order_name          init ("2Names out of order on segment."),
/**** SEVERITY 3 messages ****/
     non_printable	     init ("3Th^[ese lines contain^;is line contains^] non-printable characters"),

     lines_too_long	     init ("3These lines of section exceed 71 chars"),

     need_usage	     init ("3This section must be ""Syntax""."),

     need_function	     init ("3This section must be ""Function""."),

     need_command        init ("3This section must be ""Syntax as a command""."),

     not_belong          init ("3This section does not belong here."),

     out_of_sequence     init ("3This section is out of sequence."),

     missing_section     init ("3Missing ^[""^a"" ^]section."),

     too_many	     init ("3Only ^[^s^i^] of these sections allowed."),

     bad_date	     init ("3Unrecognizable date string^[: ^a^]"),

     entry_too_late      init ("3Entry date is later than the info date."),
/**** SEVERITY 4 messages ****/
     missing_info	     init ("4Missing :Info: or :Internal: at beginning of segment.^/"),

     no_entries          init ("4Missing :Entry:."),

     bad_entry           init ("4:Entry: not in a subroutine info."),

     no_hdr_name	     init ("4No name in header line."),

     no_sections	     init ("4No sections in component."),

     need_2_blank_lines  init ("4^[^a^;Section^] not preceded by 2 blank lines."),

     need_ending_NL	     init ("4Segment does not end with a NL."),

     ends_in_NUL	     init ("4Segment ends in^[ ^s^i^] NUL characters."),

     big_header	     init ("4Too many lines^[ (^s^i)^] in header."),
/**** SEVERITY 5 messages ****/
     no_entry	     init ("5Entry not found."),

     nothing_done	     init ("5No processing done."),

     null_segment	     init ("5Segment consists only of ^2s^i NUL characters."),
     zero_segment        init ("5Zero length segment."))

		char (80) var;	/* format: on */ %page;
/* ---------------------------------------------------------------------------

   (START)                                                                                      
      |                                   [S] represents "Scan a section title"                 
   ___v___                                                                                      
  / .gi/  \       GENERAL                                                                       
 / .error/ \ Y       +-----------------+                                                        
<  status/  >------->| section         |                                                        
 \ changes /         |{section ...}    |                                                        
  \_______/          +-----------------+                                                        
      |N                                                                     ("Error")          
     [S]                                                                         |              
      |                                                                          |N             
  ____v____                                             _________            ____|____          
 /         \ Y                                         / Entry-  \ Y        /         \         
< untitled  >--[S]----------------------------------->< points in >-------><  :Entry:  >        
 \_________/                                           \_________/          \_________/         
      |N                                                    |N                   |Y             
      |     An info is prescanned enough to determine       |                    |              
      |     it's type, then a real scan begins.             |                    |              
      |                                                     |      SUBROUTINE    v              
  ____v____                                                 |         +---------------------+   
 /         \ Y                                              v         | Function            |   
< Function  >-------------------------------------------------------->| Syntax              |   
 \_________/                           COMMAND                        |{Arguments}         *|   
      |N                                  +---------------------+     |{Access required}   *|   
      |                                   | Syntax as commamd   |     |{Examples}           |   
  ____v____            _________          |                     |     +---------------------+   
 /Syntax as\ Y        /Syntax as\ N       | Function            |                |              
< a command >--[S]--><an act.fun.>------->|{Arguments}         *|           If came from :Entry:
 \_________/          \_________/        #|{Control args}      *|           go look for another 
      |N                   |Y            #|{CA as a command}   *|                               
      |                    |             #|{CA COMMAND...}     *|  COMMAND/ACTIVE FUNCTION                   
      |                    |              |{Access required}   *|     +---------------------+   
      |                    |              |{Examples}           |     | Syntax as command   |   
      |                    |              +---------------------+     | Syntax as act.fun.  |   
      |                    +----------------------------------------->|                     |   
      |                    |Y          ACTIVE FUNCTION                | Function            |   
  ____v____            ____|____          +---------------------+     |{Arguments}         *|   
 /Syntax as\ Y        /Syntax as\ N       | Syntax as act.fun.  |    #|{Control Args}      *|   
<an act.fun.>--[S]-->< a command >------->|                     |    #|{CA as a command}   *|   
 \_________/          \_________/         | Function            |    #|{CA as an act.func} *|   
      |N                                  |{Arguments}         *|    #|{CA for...}         *|   
      |                                  #|{Control args}      *|     |{Access required}   *|   
      |                                  #|{CA as an act.func} *|     |{Examples}           |   
      |                                  #|{CA for...}         *|     +---------------------+   
      |                                   |{Access required}   *|                               
      |                                   |{Examples}           |                               
      |                                   +---------------------+ (*) These sections can occur  
      |                                                               next in any order:        
      |                                REQUEST                            List of...            
      |                                   +---------------------+         Notes                 
      |                                   | Syntax              |         Notes on...           
  ____v____            _________          |                     |                               
 /         \ Y        /Syntax as\ N       | Function            | (#) Sections can occur as     
<  Syntax   >--[S]--><an act.req.>------->|{Arguments}         *|     a group in any order.     
 \_________/          \_________/        #|{Control args}      *|                               
      |N                   |Y            #|{CA as a request}   *|                               
      |                    |             #|{CA for...}         *|  REQUEST/ACTIVE REQUEST       
      |                    |              |{Access required}   *|     +---------------------+   
      |                    |              |{Examples}           |     | Syntax              |   
      |                    |              +---------------------+     | Syntax as act.req.  |   
      |                    +----------------------------------------->|                     |   
      |                    |Y          ACTIVE REQUEST                 | Function            |   
  ____v____            ____|____          +---------------------+     |{Arguments}         *|   
 /Syntax as\ Y        /         \ N       | Syntax as act.req.  |    #|{Control args}      *|   
<an act.req.>--[S]--><  Syntax   >------->|                     |    #|{CA as a request}   *|   
 \_________/          \_________/         | Function            |    #|{CA as an act.req}  *|   
      |N                                  |{Arguments}         *|    #|{CA for...}         *|   
 ("Not a defined type")                  #|{Control args}      *|     |{Access required}   *|   
      |                                  #|{CA as an act.req}  *|     |{Examples}           |   
      v                                  #|{CA for...}         *|     +---------------------+   
+-----------+                             |{Access required}   *|                               
| sections  |                             |{Examples}           |                               
+-----------+                             +---------------------+                               


---------------------------------------------------------------------------  */
/* In this list, all names which are the full 41 chars long must be an exact */
/*  match to a section name, while the shorter ones only need to match their */
/*  length's worth at the beginning.				       */
dcl std_section	(45) char (41) var int static options (constant) init (
		" 1Access required                        ",
		" 2Arguments                              ",
		" 3Control arguments                      ",
		" 4Control arguments as a command         ",
		" 5Control arguments as a request         ",
		" 6Control arguments as an active function",
		" 7Control arguments as an active request ",
		" 8Control arguments for ",
		" 9Entry points in ",
		"10Examples                               ",
		"11Function                               ",
		"12List of ",
		"13Notes                                  ",
		"14Notes on ",
		"15Syntax                                 ",
		"16Syntax as a command                    ",
		"17Syntax as an active function           ",
		"18Syntax as an active request            ",
		"19Syntax                                 ",
		"20<untitled>                             ",
/**** improper forms follow, they reference proper ones above.	       */
		"17Syntax as active function              ",
		"16Syntax as command                      ",
		"11Purpose                                ",
		" 2Argument ",
		" 2Where                                  ",
		" 3Control argument ",
		"10Example ",
		" 1Access requirement                     ",
		" 1Access requirements                    ",
		"13Note                                   ",
		"17Active function syntax                 ",
		"17Active function usage                  ",
		" 2Active function arguments              ",
		" 2Active function argument               ",
		" 2Arguments as active function           ",
		" 6Active function control arguments      ",
		" 6Active function control argument       ",
		" 6Control arguments as active function   ",
		"16Command syntax                         ",
		"16Command usage                          ",
		" 2Command arguments                      ",
		" 2Command argument                       ",
		" 4Command control arguments              ",
		" 4Command control argument               ",
		" 4Control argument as command            ");


dcl (
    UNKNOWN_TITLE	init (0),
    ACCESS_REQUIRED init (1),
    ARGUMENTS	init (2),
    CONTROL_ARGUMENTS init (3),
    CONTROL_ARGUMENTS_AS_A_COMMAND init (4),
    CONTROL_ARGUMENTS_AS_A_REQUEST init (5),
    CONTROL_ARGUMENTS_AS_AN_ACTIVE_FUNCTION init (6),
    CONTROL_ARGUMENTS_AS_AN_ACTIVE_REQUEST init (7),
    CONTROL_ARGUMENTS_FOR init (8),
    ENTRY_POINTS_IN init (9),
    EXAMPLES	init (10),
    FUNCTION	init (11),
    LIST_OF	init (12),
    NOTES		init (13),
    NOTES_ON	init (14),
    SYNTAX	init (15),
    SYNTAX_AS_A_COMMAND init (16),
    SYNTAX_AS_AN_ACTIVE_FUNCTION init (17),
    SYNTAX_AS_AN_ACTIVE_REQUEST init (18),
    USAGE		init (19),
    UNTITLED	init (20),
    EOF		init (99)
    )		fixed bin int static options (constant);

dcl 1 global, 2 (
	 backspace, bad_date, bad_entry, blank_white_space,
	 end_white_space, ends_in_NUL, entry_too_late, extra_name,
	 lines_too_long, missing_info, missing_name, missing_section,
	 need_2_blank_lines, need_command, need_ending_NL, need_function,
	 need_usage, no_entries, no_entry, no_hdr_name, no_sections,
	 no_syntax_name, no_usage_name, non_printable, non_std_title,
	 not_belong, nothing_done, null_segment, order_name, out_of_sequence,
	 paragraph_size, this_form_preferred, too_many
	 )	fixed bin (18);
/**** This "funny" size of (18) was chosen so the compiler could help	       */
/**** catch improperly called subroutines.			       */

dcl 1 local	like global;

dcl first_section_head char (80) var;


/* additional paragraphs of standard sections */

dcl 1 map		aligned,		/* error map for each type of error */
      2 count	fixed bin,	/* up to hbound (number) */
      2 actual_count fixed bin,
      2 number	(40) fixed bin;	/* line number of each occurrence */

dcl 1 errors	aligned,		/* global for a whole :Info: block or info seg */
      2 backspaces	like map,
      2 badchars	like map,		/* lines with non-printable chars */
      2 endblanks	like map,		/* lines end in white space */
      2 nonblanks	like map,		/* blank lines having white space */
      2 long_lines	like map;		/* lines longer than line_char_limit */

/* CONSTANTS */

dcl ME		char (32) int static options (constant) init ("validate_info_seg");

dcl ((T		init ("1"b),
    F		init (""b)) bit (1),
/****	printable includes BS HT NL and SP			       */
    PRINTABLE	char (98) init ("	
 !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_"
		|| "`abcdefghijklmnopqrstuvwxyz{|}~"),
    LOWER_CASE	char (26) init ("abcdefghijklmnopqrstuvwxyz"),
    UPPER_CASE	char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
				/*    DIGITS	char (10) init ("0123456789"),*/
    HDR_NAME_BREAK	char (4) init (",	) "), /* , HT ) SP */
				/*    IGNORE_CHARS	char (10) init ("	 
{[(,)]}"),			/* HT SP NL {... */
    WHITE_SPACE	char (2) init ("	 "), /* HT SP */
    HT		char (1) init ("	"),
				/*    OH_OH_SIX	char (1) init (""),/* \006 */
    NUL		char (1) init (" "),/* NUL */
    BS		char (1) init (""),	/* backspace */
    SP		char (1) init (" "),
    NL		char (1) init ("
")
    )		int static options (constant);

/**** LIMIT VALUES						       */

dcl (
    line_char_limit init (72),	/* including newline at end	       */
    heading_char_limit init (72),	/* for a section heading	       */
    par_line_limit	init (15)
    )		fixed bin int static options (constant);

/* error info */

dcl (highest_severity, severity_count, severity_limit) fixed bin;
dcl seg_count	fixed bin;
dcl info_count	fixed bin;
dcl 1 error_count,			/* error tabulation by severity      */
      2 (total,			/* # of occurances		       */
      segs,			/* # of segments containing..	       */
      infos,			/* # of infos containing...	       */
      seg,			/* 1- occurred in current segment    */
      info			/* 1- occurred in currend info       */
      )		(5) fixed bin;
dcl err_count	fixed bin;


/* star info */

dcl area		area based (area_ptr);


dcl area_ptr	ptr;
dcl star_index	fixed bin;


/* status info */

dcl 1 status_br	aligned like status_branch;

dcl af_sw		bit (1) aligned;
dcl arg		char (arg_len) based (arg_ptr);
dcl arg_count	fixed bin;
dcl arg_index	fixed bin;
dcl arg_len	fixed bin;
dcl arg_ptr	ptr;
dcl bf_format	char (4);
dcl current_names	(status_branch.nnames) char (32) based (current_names_ptr);
dcl current_names_ptr ptr;
dcl format	char (24);
dcl internal_sw	bit (1) aligned;
dcl path_count	fixed bin;	/* # of paths on command line	       */
dcl return_arg	char (return_len) varying based (return_ptr);
dcl return_len	fixed bin;
dcl return_ptr	ptr;
dcl src_arg	char (168);
dcl src_seg	char (src_len) unaligned based (src_ptr);
dcl src_ptr	ptr;
dcl src_len	fixed bin (24);
dcl src_index	fixed bin (24);
dcl src_bc	fixed bin (24);
dcl src_path	char (201);
dcl src_dname	char (168);
dcl saved_dn	char (168);
dcl src_ename	char (32);
dcl star_en	char (32);
dcl temp_ptr	ptr;
dcl two_paragraph_syntax_sw bit (1) aligned;
dcl div_names_ct	fixed bin;
dcl div_names_ptr	ptr;
dcl div_names_x1	fixed bin;
dcl div_names_x2	fixed bin;
dcl 1 temp	based (temp_ptr),
      2 sort	aligned,		/* array to use with sort_items_     */
        3 n	fixed bin (18),
        3 vector	(1023) ptr unaligned, /* -> a name set		       */
      2 list_ct	fixed bin,	/* # of list elements in use	       */
      2 list	(1023) like div_names;
dcl 1 div_names	(div_names_ct) based (div_names_ptr),
      2 name	char (32),	/* addname, including ".info"	       */
      2 flag	fixed bin;

dcl 1 current,			/* data about info being checked     */
      2 count	fixed bin,	/* # of sections in use	       */
      2 pass	fixed bin,
      2 e		(12),
        3 used	fixed bin,	/* # of uses of this title	       */
        3 minuse	fixed bin,	/* minimum # required	       */
        3 maxuse	fixed bin (24),	/* maximum # allowed	       */
        3 title	fixed bin;	/* text of the title	       */

/* header info */

dcl header_date	char (32);
dcl header_clock	fixed bin (71);
dcl header	char (72) var;	/* text after the date */
dcl header_short_name char (256) var;
dcl header_short_name_temp char (256) var;
dcl names_left_to_add bit (1) aligned;
dcl info_name	char (32) var;
dcl entry_date	char (32);
dcl entry_clock	fixed bin (71);


/* section info */

dcl 1 section_ptr_len aligned,
      2 section_ptr ptr,
      2 section_len fixed bin;
/**** values set by the HEAD routine				       */
dcl section_head	char (40) var;	/* section heading returned	       */
dcl section_id	fixed bin;	/* section head ID		       */
dcl last_section_head char (40) var;
dcl normal_head	char (40) var;	/* normalized section heading	       */
dcl section_head_len fixed bin;	/* number of chars in section head   */
dcl section_line_number fixed bin;	/* number of first line in section   */
dcl section_line_count fixed bin;	/* number of lines in section	       */
dcl section_skip	fixed bin;	/* chars occupied by section heading as given */
dcl section_index	fixed bin;
dcl last_seq	fixed bin;

dcl (blank_char_count, blank_line_count) fixed bin;


/* paragraph info */

dcl par		char (par_len) based (par_ptr);
dcl 1 par_ptr_len	aligned,
      2 par_ptr	ptr,
      2 par_len	fixed bin (24);
dcl par_offset	fixed bin (24);

dcl par_1st_line_len fixed bin;	/* length of 1st line of paragraph */
dcl par_line_number fixed bin;	/* number of first line in paragraph */
dcl par_line_count	fixed bin (24);	/* number of lines in paragraph */
dcl par_unit_line_number fixed bin;     /* number of first line in paragraph unit */
dcl par_unit_line_count fixed bin (24); /* number of lines in paragraph unit */

/* line info */

dcl line		char (line_len) based (line_ptr);
dcl 1 line_ptr_len	aligned,
      2 line_ptr	ptr,
      2 line_len	fixed bin;

dcl line_number	fixed bin;	/* line number in segment */
dcl n_cols	fixed bin;	/* number of character positions in line */
dcl (line_index, special_index) fixed bin (21); /* for counting character positions */


/* switches */

dcl (
    begin_info_sw,			/* starting a new Info	       */
    blank_line_sw,			/* blank line returned by get_line   */
    colon_info_seen_sw,		/* :Info: has been seen	       */
    colon_entry_seen_sw,		/* otherwise, :Entry: has been seen  */
    subroutine_info,		/* This is a subroutine block	       */
    end_info_sw,			/* get_section hit :Info:/:Entry:    */
    entry_info,			/* in a :Entry: block	       */
    general_info,			/* "general info" component	       */
    got_par_sw,			/* a paragraph has been read	       */
    header_shown_sw,		/* header has been displayed	       */
    link_sw,			/* current path is to a link.	       */
    name_sw,			/* -names specified		       */
    non_standard,			/* non-standard section title	       */
    new_segment_sw,			/* starting a new segment	       */
    scanning,			/* 1- just looking, suppress msgs    */
    total_sw)	bit (1) aligned;	/* -total specified		       */

dcl temp_sw	bit (1);

dcl dtem_string	char (32);

dcl (i, j)	fixed bin;

dcl code		fixed bin (35);

dcl error_table_$bad_conversion fixed bin(35) ext static;
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$badstar fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$not_act_fnc fixed bin (35) ext;

dcl complain	automatic entry options (variable);
dcl get_an_info	automatic entry;

dcl active_fnc_err_ entry options (variable);
dcl active_fnc_err_$suppress_name entry options (variable);
dcl check_star_name_$entry entry (char (*), fixed bin (35));
dcl com_err_	entry () options (variable);
dcl com_err_$suppress_name entry options (variable);
dcl convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cv_fstime_	entry (bit (36) aligned) returns (fixed bin (71));
dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$star_dir_list_ entry (char (*), char (*), 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 initiate_file_	entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl pathname_	entry (char (*), char (*)) returns (char (168));
dcl sort_items_$char entry (ptr, fixed bin (24));
dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
dcl (ioa_, ioa_$nnl) entry options (variable);

dcl (addcharno, addr, before, binary, char, charno, convert, divide, fixed,
    hbound, index, lbound, length, ltrim, max, min, mod, null, pointer,
    reverse, rtrim, search, setcharno, string, substr, translate, unspec,
    verify
    )		builtin;

dcl (cleanup, conversion, program_interrupt, size) condition; %page;
/* ------------------------------------------------------------------------- */
/* MAINLINE -- all is controlled from here			       */
/* ------------------------------------------------------------------------- */

/**** Establish the proper command or AF environment		       */
      call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
      if code = error_table_$not_act_fnc
      then do;
         if arg_count = 0
         then do;
usage:	  call com_err_$suppress_name (0, ME, "Usage:  vis paths {-control_args}");
	  return;
         end;
         af_sw = F;
         complain = com_err_;
      end;
      else do;
         if arg_count = 0
         then do;
af_usage:	  call active_fnc_err_$suppress_name (0, ME, "Usage:  [vis paths {-control_args}]");
	  return;
         end;
         af_sw = T;
         complain = active_fnc_err_;
      end;
/**** Begin initialization, Process control args			       */
      name_sw, total_sw = F;
      path_count, highest_severity, severity_limit = 0;
      do arg_index = 1 to arg_count;
         call cu_$arg_ptr (arg_index, arg_ptr, arg_len, (0));
         if substr (arg, 1, length ("-")) = "-"
         then if arg = "-severity" | arg = "-sv"
	    then do;
	       arg_index = arg_index + 1;
	       if arg_index > arg_count
	       then do;
		call complain (0, ME, "No value specified for ^a", arg);
		return;
	       end;
	       call cu_$arg_ptr (arg_index, arg_ptr, arg_len, (0));
	       on conversion,size goto BAD_CONVERSION;
	       severity_limit = convert (severity_limit, arg);
	       revert conversion,size;
	       if severity_limit > hbound (error_count.total, 1)
		  | severity_limit < lbound (error_count.total, 1)
	       then do;
		call complain (0, ME, "^d outside severity range ^d to ^d",
		     severity_limit, lbound (error_count.total, 1),
		     hbound (error_count.total, 1));
		return;
	       end;
	    end;
	    else if arg = "-total" | arg = "-tt"
	    then total_sw = T;
	    else if arg = "-names" | arg = "-nm"
	    then name_sw = T;
	    else if arg = "-no_names" | arg = "-nnm"
	    then name_sw = F;
	    else do;
	       call complain (error_table_$badopt, ME, "^a", arg);
	       return;
	    end;

         else path_count = path_count + 1;
      end;
/**** Check argument consistency				       */
      if (path_count = 0)
      then if af_sw
	 then goto af_usage;
	 else goto usage;
      if af_sw
      then do;
         total_sw = T;
         if (path_count > 1)
         then do;
AF_TOO_MANY:
	  call active_fnc_err_ (0, ME, "Active function does not accept multiple segments.");
	  return;
         end;
      end;
/**** Finish initializing.					       */
      backspaces.actual_count = hbound (backspaces.number, 1);
      badchars.actual_count = hbound (badchars.number, 1);
      endblanks.actual_count = hbound (endblanks.number, 1);
      nonblanks.actual_count = hbound (nonblanks.number, 1);
      long_lines.actual_count = hbound (long_lines.number, 1);
      get_an_info = VALIDATE;		/* make sure it points SOMEWHERE     */
      star_list_branch_ptr, star_list_names_ptr, status_ptr, src_ptr,
	 temp_ptr = null;
      on condition (cleanup) call CLEAN_UP;
      unspec (error_count) = ""b;
      seg_count, info_count = 0;
      info_name = "";
      unspec (global) = ""b;
      call get_temp_segment_ (ME, temp_ptr, code);
      if (code ^= 0)
      then do;
         call complain (code, ME, "Getting temp segment.");
         return;
      end;
      src_ename = star_en;
      if ^db_sw
      then on condition (program_interrupt) goto PI;
      if total_sw & ^af_sw
      then do;
         call ioa_ ("Info types:");
         call ioa_ ("^-"" ?  "" means UNKNOWN format info");
         call ioa_ ("^- ""GEN ""  means GENERAL info");
         call ioa_ ("^- ""COM ""  means COMMAND info");
         call ioa_ ("^- ""AFUN""  means ACTIVE FUNTION info");
         call ioa_ ("^- ""C/AF""  means COMMAND/ACTIVE FUNCTION info");
         call ioa_ ("^- ""REQ ""  means REQUEST info");
         call ioa_ ("^- ""AREQ""  means ACTIVE REQUEST info");
         call ioa_ ("^- ""R/AR""  means REQUEST/ACTIVE REQUEST info");
         call ioa_ ("^- ""SUB+""  means SUBROUTINE w/entries info");
         call ioa_ ("^- ""SUBe""  means SUBROUTINE entry info");
         call ioa_ ("^- ""SUBR""  means SUBROUTINE (no entries) info");
         call ioa_ ("^-"":Info:"" means the segment contains multiple infos.");
         call ioa_ ("
 HIGH #LONG #LONG  info
  SEV  pghs lines  type  INFO/Entry/SEGMENT NAME");
      end;

/**** Process pathnames					       */
      do arg_index = 1 to arg_count;
         call cu_$arg_ptr (arg_index, arg_ptr, arg_len, (0));
         if substr (arg, 1, length ("-")) ^= "-"
         then do;
	  src_arg = arg;
	  call expand_pathname_$add_suffix (src_arg, "info", src_dname, star_en, code);
	  if code ^= 0
	  then do;
BAD_PATH:	     call complain (code, ME, "^a", src_arg);
	     return;
	  end;
	  call PROCESS_STARNAME;
         end;
         else if arg = "-severity" | arg = "-sv"
         then arg_index = arg_index + 1;/* gobble up the associated arg      */
      end;
PI:   if total_sw & ^af_sw
      then do;
/****    Show totals					       */
         call ioa_ ("^/^d Segments, ^d Infos", seg_count, info_count);
         do i = hbound (error_count.total, 1) by -1 to 1;
	  temp_sw = (error_count.total (i) = 0);
	  call ioa_ (
	       "^[  NO^s^;^4d^] severity ^d errors^[ in ^4d segment^[ ^;s^] (^4d info^[s^])",
	       temp_sw, error_count.total (i), i, ^temp_sw,
	       error_count.segs (i), (error_count.segs (i) = 1),
	       error_count.infos (i), (error_count.infos (i) > 1));
         end;
         call ioa_ ("");
      end;

      if af_sw then return_arg = ltrim (char (highest_severity));

RETURN: call CLEAN_UP;
      return;

BAD_CONVERSION:
      call complain (error_table_$bad_conversion, ME, "^a", arg);
      return; %page;
/* ------------------------------------------------------------------------- */
/* Apply the star conventions to the source pathnames,		       */
/* then call VALIDATE for each info seg.			       */
/* ------------------------------------------------------------------------- */

PROCESS_STARNAME: proc;

      status_ptr, star_list_branch_ptr, star_list_names_ptr = null ();
      call check_star_name_$entry (star_en, code);
      if code = error_table_$badstar
      then do;
         call complain (code, ME, "^a", src_arg);
         goto RETURN;
      end;
      if code = 0
      then do;
         src_ename = star_en;
         call VALIDATE;
      end;
      else do;
         area_ptr = get_system_free_area_ ();
         star_select_sw = star_ALL_ENTRIES;
         call hcs_$star_dir_list_ (src_dname, star_en, star_select_sw,
	    area_ptr, star_branch_count, star_link_count, star_list_branch_ptr,
	    star_list_names_ptr, code);
         if code ^= 0
         then do;
	  call complain (code, ME, "^a^[>^]^a", src_dname, src_dname ^= ">", star_en);
	  return;
         end;
         if (star_branch_count > 1) & af_sw
         then goto AF_TOO_MANY;
         saved_dn = src_dname;
         do star_index = 1 to star_branch_count + star_link_count;
	  src_ename = star_list_names (star_dir_list_branch (star_index).nindex);
	  src_dname = saved_dn;
	  call VALIDATE;
         end;
      end;
      call CLEAN_UP$some;

   end PROCESS_STARNAME; %page;
/* ------------------------------------------------------------------------- */
/* Validate a single info segment, printing non-brief information,	       */
/* then printing error messages				       */
/* ------------------------------------------------------------------------- */

VALIDATE: proc;

      src_path = pathname_ (src_dname, src_ename);
      status_area_ptr = get_system_free_area_ ();
      status_ptr = addr (status_br);
      unspec (status_branch) = ""b;
      status_branch.type = Directory;
      call hcs_$status_ (src_dname, src_ename, 1, status_ptr, status_area_ptr, code);

      if code = 0
      then dtem_string = date_time_$format ("date", cv_fstime_ ((status_branch.dtem)), "", "");
      else dtem_string = "";
      link_sw = (status_link.type = Link);
      current_names_ptr = addr (status_entry_names);
      if ^total_sw
      then call ioa_ ("^/^a^[ (LINK)^]", src_path, link_sw);
      call initiate_file_ (src_dname, src_ename, "100"b, src_ptr, src_bc, code); /* Read mode */
      if (code ^= 0)
      then do;
         if code = error_table_$noentry
         then call ERR_MSG3 (local.no_entry, 0, no_entry);
         else do;
	  call complain (code, ME, "^a", src_path);
	  call ERR_MSG3 (local.nothing_done, 0, nothing_done);
         end;
         goto null_file;
      end;

      if ep_sw
      then call ioa_ ("FIL:^( ^a: ^a: ^a:^/^)", current_names);
      seg_count = seg_count + 1;
      new_segment_sw = T;
      colon_info_seen_sw, colon_entry_seen_sw, general_info, entry_info = F;

      nest = 1;
      temp.sort.n, temp.list_ct, line_number = 0;
      src_index = 1;
      src_len = divide (src_bc, 9, 24, 0);
      if (src_len = 0)
      then do;
         call ERR_MSG3 (local.null_segment, 0, zero_segment);
         goto null_file;
      end;
/**** See if there are any trailing NULs (complain if so), strip them off    */
/**** and see if anything left (complain if not).			       */
      nest = verify (reverse (src_seg), NUL) - 1;
      if (nest = -1)
      then do;
         call ERR_MSG (local.null_segment, 0, null_segment, "", src_len, 0);
         goto null_file;
      end;
      if (nest > 0)
      then do;
         call ERR_MSG (local.ends_in_NUL, 0, ends_in_NUL, "", nest, 0);
         src_len = src_len - nest;
      end;
/**** Check for NL at end of segment (complain if none).		       */
      if (substr (src_seg, src_len, 1) ^= NL)
      then call ERR_MSG3 (local.need_ending_NL, 0, need_ending_NL);
      highest_severity, par_line_count = 0;
      par_unit_line_count = 0;
      unspec (errors) = "0"b;
      nest = 1;

      got_par_sw = F;
      header_shown_sw = F;
      if (index (src_seg, "
:Info:") ^= 0) | (index (src_seg, "
:Internal:") ^= 0)
      then do;			/* this is multi-info format	       */
         colon_info_seen_sw = T;
         if (substr (src_seg, 1, 6) ^= ":Info:")
	    & (substr (src_seg, 1, 10) ^= ":Internal:")
         then call ERR_MSG3 (local.missing_info, 0, missing_info);
      end;
      else if (index (src_seg, "
:Entry:") ^= 0)
      then do;
         colon_entry_seen_sw = T;
      end;
      line_number = 0;
      src_index = 1;
      do while (src_index < src_len);	/* go as long as any data is left    */
         call GET_INFO;
      end;
      if ^general_info then call check_addnames();

null_file:
      do sev = 1 to 5;
         error_count.segs (sev) = error_count.segs (sev) + error_count.seg (sev);
         error_count.seg (sev) = 0;
      end;

      if ^total_sw
      then call ioa_ ("^/");
      if src_ptr ^= null
      then call terminate_file_ (src_ptr, (0), TERM_FILE_TERM, (0));
      return; %page;
/* ------------------------------------------------------------------------- */
/* Compare the list of names on the segment with the list of names derived   */
/* from the dividers in the segment.  If they are not the same (including    */
/* order), either change the segment's names (-names) or tell what is wrong  */
/* (-no_names). The names are sorted by longname. Any short names follow a   */
/* longname in the order they occurred in the divider. If no divider exists, */
/* the names are gotten from the header.			       */
/* ------------------------------------------------------------------------- */

check_addnames: proc;

dcl t_ptr		ptr;
dcl t_ct		fixed bin;
dcl a_name	char(32);
dcl done		bit (1) aligned;
dcl error_table_$segnamedup fixed bin(35) ext static;
dcl hcs_$chname_seg entry (ptr, char(*), char(*), fixed bin(35));
dcl order_sw	bit (1) aligned;
dcl used_sw	(status_branch.nnames) bit (1) aligned;

      if (temp.sort.n = 1)
      then do;
         div_names_ptr = temp.sort.vector (1);
         do div_names_ct = 1 to 1000 while (div_names.flag (div_names_ct) ^= 0);
         end;
      end;
      else do;
/****    There's plenty of room in temp, make a sorted array there	       */
         call sort_items_$char (addr (temp.sort), length (temp.list.name (1)));
         div_names_ptr = addr (temp.list (temp.list_ct + 1));
         t_ct = 0;
         div_names_x1, div_names_x2 = 1;
         do while (div_names_x1 <= temp.sort.n);
	  t_ptr = temp.sort.vector (div_names_x1);
	  t_ct = t_ct + 1;
	  div_names.name (t_ct) = t_ptr -> div_names.name (div_names_x2);
	  if (t_ptr -> div_names.flag (div_names_x2) = 0)
	  then do;
	     div_names_x1 = div_names_x1 + 1;
	     div_names_x2 = 1;
	  end;
	  else div_names_x2 = div_names_x2 + 1;
         end;
         div_names_ct = t_ct;
      end;

      unspec (used_sw) = "0"b;
/**** If derived list is the same size as addname list, check equality       */
      if (div_names_ct = status_branch.nnames)
      then do;
         do i = 1 to div_names_ct;
	  if (div_names.name (i) ^= current_names (i))
	  then goto does_not_match;
         end;
         return;			/* AOK			       */

does_not_match:
      end;
      if name_sw
      then do;
/****    Change the set of names to what we want.	Since we are not working  */
/****    ..with extended objects, we are using hcs_$chname_file	       */
         a_name = div_names.name (1);
/****    First make sure the new primary name is there.		       */
         do j = 1 to status_branch.nnames;
	  if (current_names (j) = a_name)
	  then goto already_there;
         end;
/****    Since the needed name is not there, add it		       */
         call hcs_$chname_seg (src_ptr, "", a_name, code);
         if (code ^= 0)
         then if (code ^= error_table_$segnamedup)
         then do;
	  call complain (code, ME, "Trying to add ^a to ^a", a_name, src_path);
	  return;
         end;
already_there:
/****    Next, delete all names except the new primary one.		       */
         do j = 1 to status_branch.nnames;
	  if (current_names (j) ^= a_name)
	  then do;
	     call hcs_$chname_seg (src_ptr, (current_names (j)), "", code);
	     if (code ^= 0)
	     then do;
	        call complain (code, ME, "Trying to delete ^a from ^a",
		 current_names (j), src_path);
	        return;
	     end;
	  end;
         end;
/****    Lastly, add all the needed extra names.			       */
         do i = 2 to div_names_ct;
	  call hcs_$chname_seg (src_ptr, "", div_names.name (i), code);
	  if (code ^= 0)
	  then do;
	     call complain (code, ME, "Trying to add ^a to ^a",
	        div_names.name (i), src_path);
	     return;
	  end;
         end;
         return;
      end;
/**** Tell what is wrong with the addnames.			       */
/****       (No attempt was made here to optimize this searching procedure.) */
      order_sw = T;
/**** Each name in the divider list should be in the addname list.	       */
      do i = 1 to div_names_ct;
         a_name = div_names.name (i);
         done = ""b;
         do j = 1 to status_branch.nnames while (^done);
	  if (current_names (j) = a_name)
	  then do;
	     used_sw (j) = "1"b;
	     done = "1"b;
	  end;
         end;
         if ^done
         then do;
	  order_sw = F;
	  call ERR_MSG (local.missing_name, 00, missing_name,
	     a_name, 0, 0);
         end;
      end;
/**** Each name in the addname list should be in the divider list.	       */
      do j = 1 to status_branch.nnames;
         if ^used_sw (j)
         then do;
	  order_sw = F;
	  call ERR_MSG (local.extra_name, 00, extra_name,
	     (current_names (j)), 0, 0);
         end;
      end;
/**** If all names were accounted for, then the problem is ORDER.	       */
      if order_sw
      then call ERR_MSG3 (local.order_name, 0, order_name);
      return;

   end check_addnames;


dcl sev		fixed bin; %skip (4);
/* ------------------------------------------------------------------------- */
/*			tracing utilities			       */
/* ------------------------------------------------------------------------- */
dcl nest		fixed bin (24) init (1);

PUSH: proc (name);
dcl name		char (24);
      call ioa_ ("^v(: ^)>^a ^i:^i^[ eof^]^[ par^]^[ SCAN^]",
	 nest, name, src_index, src_len, end_info_sw, got_par_sw, scanning);
      nest = nest + 1;
   end PUSH;

POP: proc (name);
dcl name		char (24);
      nest = nest - 1;
      call ioa_ ("^v(: ^)<^a ^i:^i^[ eof^]^[ par^]^[ SCAN^]",
	 nest, name, src_index, src_len, end_info_sw, got_par_sw, scanning);
   end POP; %page;
/* ------------------------------------------------------------------------- */
/* GET_INFO considers an "Info" to be a whole segment, or a portion of a     */
/* segment beginning with either ":Info:" or ":Entry:" and including every-  */
/* thing up to either ":Info:", ":Entry:", or end-of-segment.                */
/* ------------------------------------------------------------------------- */

GET_INFO: proc;
dcl hold_type	entry automatic;
      if tr_sw then call PUSH ("GET_INFO");
      unspec (local) = ""b;
      hold_type = get_an_info;
      get_an_info = CHECK_INFO_TYPE ();
      if (hold_type = MULTSUB_INFO)
	 & (get_an_info ^= ENTRY___INFO)
      then call ERR_MSG3 (local.no_entries, 0, no_entries);
      else if (get_an_info = ENTRY___INFO)
	 & (hold_type ^= ENTRY___INFO)
	 & (hold_type ^= MULTSUB_INFO)
      then call ERR_MSG3 (local.bad_entry, 0, bad_entry);
      div_names_ct = 0;
      div_names_ptr = null ();
      unspec (local) = ""b;
      call get_an_info;		/* process an info block	       */
      if (first_section_head = "<empty info>")
      then call ERR_MSG3 (local.no_sections, 0, no_sections);
      call PRINT_ERR_SUMMARY;
      do sev = 1 to 5;
         error_count.infos (sev) = error_count.infos (sev) + error_count.info (sev);
         error_count.info (sev) = 0;
      end;
      info_name = "";
/**** if there is still more segment to process, back up to the beginning    */
/**** ..of the info divider.					       */
      if (src_index < src_len)
      then do;
         src_index = par_offset;
         line_number = par_line_number - 1;
      end;
      if tr_sw then call POP ("GET_INFO");

   end GET_INFO; %page;
CHECK_INFO_TYPE: proc returns (entry);

dcl hold_src_index	fixed bin;
dcl hold_line_number fixed bin;
dcl result	entry automatic;

      scanning = T;
      subroutine_info = F;
      hold_src_index = src_index;
      hold_line_number = line_number;
      got_par_sw = F;
      call GET_HEADER;		/* scanning		       */
      if general_info
      then result = GENERAL_INFO;
      else if entry_info
      then result = ENTRY___INFO;
      else if colon_entry_seen_sw
      then result = MULTSUB_INFO;
      else do;
         call GET_SECTION;
         if (section_id = UNTITLED)
         then do;
	  call GET_SECTION;
	  if (section_id = ENTRY_POINTS_IN)
	  then result = MULTSUB_INFO;
	  else do;
	     result = SINGSUB_INFO;
	     subroutine_info = T;
	  end;
         end;
         else if (section_id = FUNCTION)
         then do;
	  result = SINGSUB_INFO;
	  subroutine_info = T;
         end;
         else if (section_id = SYNTAX_AS_A_COMMAND)
         then do;
	  call GET_SECTION;
	  if (section_id = SYNTAX_AS_AN_ACTIVE_FUNCTION)
	  then result = COMM_AF_INFO;
	  else result = COMMAND_INFO;
         end;
         else if (section_id = SYNTAX_AS_AN_ACTIVE_FUNCTION)
         then do;
	  call GET_SECTION;
	  if (section_id = SYNTAX_AS_A_COMMAND) | (section_id = SYNTAX)
	  then result = COMM_AF_INFO;
	  else result = ACT_FUN_INFO;
         end;
         else if (section_id = SYNTAX)
         then do;
	  call GET_SECTION;
	  if (section_id = SYNTAX_AS_AN_ACTIVE_REQUEST)
	  then result = REQU_AR_INFO;
	  else if (section_id = SYNTAX_AS_AN_ACTIVE_FUNCTION)
	  then result = COMM_AF_INFO;
	  else result = REQUEST_INFO;
         end;
         else if (section_id = SYNTAX_AS_AN_ACTIVE_REQUEST)
         then do;
	  call GET_SECTION;
	  if (section_id = SYNTAX)
	  then result = REQU_AR_INFO;
	  else result = ACT_REQ_INFO;
         end;
         else result = UNKNOWN_INFO;
      end;
      src_index = hold_src_index;
      line_number = hold_line_number;
      scanning = F;
      got_par_sw = F;
      if db_sw then call ioa_ ("|----------");
      return (result);

   end CHECK_INFO_TYPE; %page;
/* ------------------------------------------------------------------------- */
/* These routines (*_INFO) are designed to make it obvious for each of the   */
/*  Info Types what the allowed sections are, whether optional or required,  */
/*  and what order they must occur in.				       */
/* ------------------------------------------------------------------------- */

/* ------------------------------------------------------------------------- */
/*			COMMAND-only info			       */
/* ------------------------------------------------------------------------- */

COMMAND_INFO: proc;

/**** set the identification for total and complete cases		       */
      bf_format = "COM "; format = "COMMAND";
      if tr_sw then call PUSH ("COMMAND_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (8);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, SYNTAX_AS_A_COMMAND));
L(2): goto L(SEC  ( 2,  1,  1,  2, FUNCTION));
L(3): goto L(SEC  ( 3,  0,  1,  3, ARGUMENTS));
L(4): goto L(SECx ( 4,  0,  1,  4, CONTROL_ARGUMENTS));
L(5): goto L(SECx ( 5,  0,  1,  4, CONTROL_ARGUMENTS_AS_A_COMMAND));
L(6): goto L(SECx ( 6,  0, 99,  4, CONTROL_ARGUMENTS_FOR));
L(7): goto L(SECx ( 7,  0,  1,  7, ACCESS_REQUIRED));
L(8): goto L(SECx ( 8,  0,  1,  8, EXAMPLES));
L(9):	;			/* end-of-info		       */
     				/* format: on		       */

      if tr_sw then call POP ("COMMAND_INFO");

   end COMMAND_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*		      ACTIVE FUNCTION only info		       */
/* ------------------------------------------------------------------------- */

ACT_FUN_INFO: proc;

      bf_format = "AFUN"; format = "ACTIVE FUNTION";
      if tr_sw then call PUSH ("ACT_FUN_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (8);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, SYNTAX_AS_AN_ACTIVE_FUNCTION));
L(2): goto L(SEC  ( 2,  1,  1,  2, FUNCTION));
L(3): goto L(SEC  ( 3,  0,  1,  3, ARGUMENTS));
L(4): goto L(SECx ( 4,  0,  1,  4, CONTROL_ARGUMENTS));
L(5): goto L(SECx ( 5,  0,  1,  4, CONTROL_ARGUMENTS_AS_AN_ACTIVE_FUNCTION));
L(6): goto L(SECx ( 6,  0, 99,  4, CONTROL_ARGUMENTS_FOR));
L(7): goto L(SECx ( 7,  0,  1,  7, ACCESS_REQUIRED));
L(8): goto L(SECx ( 8,  0,  1,  8, EXAMPLES));
L(9):	;			/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("ACT_FUN_INFO");

   end ACT_FUN_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*		    COMMAND & ACTIVE FUNCTION info		       */
/* ------------------------------------------------------------------------- */

COMM_AF_INFO: proc;
      bf_format = "C/AF"; format = "COMMAND/ACTIVE FUNCTION";
      if tr_sw then call PUSH ("COMM_AF_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (10);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, SYNTAX_AS_A_COMMAND));
L(2): goto L(SEC  ( 2,  1,  1,  1, SYNTAX_AS_AN_ACTIVE_FUNCTION));
L(3): goto L(SEC  ( 3,  1,  1,  3, FUNCTION));
L(4): goto L(SEC  ( 4,  0,  1,  4, ARGUMENTS));
L(5): goto L(SECx ( 5,  0,  1,  5, CONTROL_ARGUMENTS));
L(6): goto L(SECx ( 6,  0,  1,  5, CONTROL_ARGUMENTS_AS_A_COMMAND));
L(7): goto L(SECx ( 7,  0,  1,  5, CONTROL_ARGUMENTS_AS_AN_ACTIVE_FUNCTION));
L(8): goto L(SECx ( 8,  0, 99,  5, CONTROL_ARGUMENTS_FOR));
L(9): goto L(SECx ( 9,  0,  1,  9, ACCESS_REQUIRED));
L(10):goto L(SECx (10,  0,  1, 10, EXAMPLES));
L(11):		;		/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("COMM_AF_INFO");

   end COMM_AF_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*			REQUEST only info			       */
/* ------------------------------------------------------------------------- */

REQUEST_INFO: proc;
      bf_format = "REQ "; format = "REQUEST";
      if tr_sw then call PUSH ("REQUEST_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (8);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, SYNTAX));
L(2): goto L(SEC  ( 2,  1,  1,  2, FUNCTION));
L(3): goto L(SEC  ( 3,  0,  1,  3, ARGUMENTS));
L(4): goto L(SECx ( 4,  0,  1,  4, CONTROL_ARGUMENTS));
L(5): goto L(SECx ( 5,  0,  1,  4, CONTROL_ARGUMENTS_AS_A_REQUEST));
L(6): goto L(SECx ( 6,  0, 99,  4, CONTROL_ARGUMENTS_FOR));
L(7): goto L(SECx ( 7,  0,  1,  7, ACCESS_REQUIRED));
L(8): goto L(SECx ( 8,  0,  1,  8, EXAMPLES));
L(9):		;		/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("REQUEST_INFO");

   end REQUEST_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*		       ACTIVE REQUEST only info		       */
/* ------------------------------------------------------------------------- */

ACT_REQ_INFO: proc;
      bf_format = "AREQ"; format = "ACTIVE REQUEST";
      if tr_sw then call PUSH ("ACT_REQ_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (8);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, SYNTAX_AS_AN_ACTIVE_REQUEST));
L(2): goto L(SEC  ( 2,  1,  1,  2, FUNCTION));
L(3): goto L(SEC  ( 3,  0,  1,  3, ARGUMENTS));
L(4): goto L(SECx ( 4,  0,  1,  4, CONTROL_ARGUMENTS));
L(5): goto L(SECx ( 5,  0,  1,  4, CONTROL_ARGUMENTS_AS_AN_ACTIVE_REQUEST));
L(6): goto L(SECx ( 6,  0, 99,  4, CONTROL_ARGUMENTS_FOR));
L(7): goto L(SECx ( 7,  0,  1,  7, ACCESS_REQUIRED));
L(8): goto L(SECx ( 8,  0,  1,  8, EXAMPLES));
L(9):		;		/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("ACT_REQ_INFO");

   end ACT_REQ_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*		    REQUEST & ACTIVE REQUEST info		       */
/* ------------------------------------------------------------------------- */

REQU_AR_INFO: proc;
      bf_format = "R/AR"; format = "REQUEST/ACTIVE REQUEST";
      if tr_sw then call PUSH ("REQU_AR_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (10);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, SYNTAX));
L(2): goto L(SEC  ( 2,  1,  1,  1, SYNTAX_AS_AN_ACTIVE_REQUEST));
L(3): goto L(SEC  ( 3,  1,  1,  3, FUNCTION));
L(4): goto L(SEC  ( 4,  0,  1,  4, ARGUMENTS));
L(5): goto L(SECx ( 5,  0,  1,  5, CONTROL_ARGUMENTS));
L(6): goto L(SECx ( 6,  0,  1,  5, CONTROL_ARGUMENTS_AS_A_REQUEST));
L(7): goto L(SECx ( 7,  0,  1,  5, CONTROL_ARGUMENTS_AS_AN_ACTIVE_REQUEST));
L(8): goto L(SECx ( 8,  0, 99,  5, CONTROL_ARGUMENTS_FOR));
L(9): goto L(SECx ( 9,  0,  1,  9, ACCESS_REQUIRED));
L(10):goto L(SECx (10,  0,  1, 10, EXAMPLES));
L(11):		;		/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("REQU_AR_INFO");

   end REQU_AR_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*		    SUBROUTINE w/multiple entries		       */
/* ------------------------------------------------------------------------- */

MULTSUB_INFO: proc;
      bf_format = "SUB+"; format = "SUBROUTINE w/entries";
      if tr_sw then call PUSH ("MULTSUB_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (2);
/****             seq min max next "title"			       */
P(0):   
P(1): goto P(SEC  ( 1,  1,  1,  1, UNTITLED));
P(2): goto P(SEC  ( 2,  1,  1,  2, ENTRY_POINTS_IN));
P(3):	;			/* end-of-info		       */
      if tr_sw then call POP ("MULTSUB_INFO");
      return;

ENTRY___INFO: entry;
      bf_format = "SUBe"; format = "SUBROUTINE entry";
      if tr_sw then call PUSH ("ENTRY___INFO");
      subroutine_info = T;
      header_shown_sw = F;
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (5);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, FUNCTION));
L(2): goto L(SEC  ( 2,  1,  1,  2, USAGE));
L(3): goto L(SEC  ( 3,  0,  1,  3, ARGUMENTS));
L(4): goto L(SECx ( 4,  0,  1,  4, ACCESS_REQUIRED));
L(5): goto L(SECx ( 5,  0,  1,  5, EXAMPLES));
L(6):		;		/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("ENTRY___INFO");

   end MULTSUB_INFO; %skip (5);
/* ------------------------------------------------------------------------- */
/*		        SUBROUTINE w/one entry		       */
/* ------------------------------------------------------------------------- */

SINGSUB_INFO: proc;
      bf_format = "SUBR"; format = "SUBROUTINE (no entries)";
      if tr_sw then call PUSH ("SINGSUB_INFO");
				/* format: off */
      call GET_HEADER;		/* process first line of info block  */
      call SEC$init (5);
/****             seq min max next "title"			       */
L(0):
L(1): goto L(SEC  ( 1,  1,  1,  1, FUNCTION));
L(2): goto L(SEC  ( 2,  1,  1,  2, USAGE));
L(3): goto L(SEC  ( 3,  0,  1,  3, ARGUMENTS));
L(4): goto L(SECx ( 4,  0,  1,  4, ACCESS_REQUIRED));
L(5): goto L(SECx ( 5,  0,  1,  5, EXAMPLES));
L(6):	;			/* end-of-info		       */
     				/* format: on		       */
      if tr_sw then call POP ("SINGSUB_INFO");

   end SINGSUB_INFO; %skip (3);
/* ------------------------------------------------------------------------- */
/*	         could not figure out what kind this was		       */
/* ------------------------------------------------------------------------- */
UNKNOWN_INFO: proc;
      bf_format = " ?  "; format = "UNKNOWN format";
      goto common;

/* ------------------------------------------------------------------------- */
/*		  GENERAL info - any kind of section		       */
/* ------------------------------------------------------------------------- */

GENERAL_INFO: entry;
      bf_format = "GEN "; format = "GENERAL";
common:
      if tr_sw then call PUSH (format);
      call GET_HEADER;		/* process first line of info block  */
      do while (^end_info_sw);
         call GET_SECTION;
      end;
      if tr_sw then call POP (format);

   end UNKNOWN_INFO; %page;
/* ------------------------------------------------------------------------- */
/* Test for the current section being what is needed. Returns the number of  */
/* the next test to run. SEC just tests for the presence of P_title, while   */
/* SECx also accepts LIST_OF, NOTES, and NOTES_ON.		       */
/* ------------------------------------------------------------------------- */

SEC: proc (P_seq_no, P_min, P_max, P_group_no, P_title) returns (fixed bin);
      extra_sw = ""b;
      goto common;

SECx: entry (P_seq_no, P_min, P_max, P_group_no, P_title) returns (fixed bin);
      extra_sw = "1"b;
      goto common;

dcl (
    P_seq_no	fixed bin,	/* sequence # of this title	       */
    P_min		fixed bin,	/* Minimum # of these allowed	       */
    P_max		fixed bin,	/* Maximum # of these allowed	       */
    P_group_no	fixed bin,	/* group # of this title, when some  */
				/* ..titles occur in any order, they */
				/* ..all have the same group #       */
    P_title	fixed bin		/* title identifier		       */
    )		parameter;

dcl extra_sw	bit (1) aligned;
dcl i		fixed bin;

common:
      if tr_sw then call ioa_ ("  SEC ^4(^3i^) ^i::^a", P_seq_no, P_min, P_max,
	      P_group_no, section_id, std_section (P_title));
/**** fill in item data for later use				       */
      current.title (P_seq_no) = P_title;
      current.minuse (P_seq_no) = P_min;
      current.maxuse (P_seq_no) = P_max;
/**** If no data left, still walk down the list			       */
      if (section_id = EOF)
      then do;
         if (P_seq_no = current.count)
         then do i = 1 to current.count;
	  if (current.used (i) < current.minuse (i))
	  then do;
	     call ERR_MSG (local.missing_section, 00, missing_section,
		substr (std_section (current.title (i)), 3), 0, 0);
	  end;
         end;
         return (P_seq_no + 1);	/* MATCH EOF- keep moving down the   */
				/* ..list and eventually exit it. It */
				/* ..is done this way to make sure   */
				/* ..that current gets all filled in */
      end;
      if (P_title = section_id)
      then do;
         if (P_seq_no < last_seq)
         then call ERR_MSG3 (local.out_of_sequence, 0, out_of_sequence);
         last_seq = P_seq_no;
         current.used (last_seq) = current.used (last_seq) + 1;
         if (current.used (last_seq) > current.maxuse (last_seq))
         then call ERR_MSG (local.too_many, 0, too_many, "", current.maxuse (last_seq), 0);
         if ^end_info_sw
         then call GET_SECTION;
         else section_id = EOF;
         current.pass = 1;
         return (P_group_no);		/* MATCH- continue in same group     */
      end;
/**** no match						       */
      if extra_sw
      then if (section_id = LIST_OF) | (section_id = NOTES) | (section_id = NOTES_ON)
	 then do;
	    if tr_sw then call ioa_ ("  SEC ^4(^3x^) ^i::^a", section_id,
		    std_section (P_title));
next:
	    if ^end_info_sw
	    then call GET_SECTION;
	    else section_id = EOF;
	    current.pass = 1;
	    return (last_seq);	/* MATCH extra- continue in the list */
				/*  where the last match was	       */
	 end;
/**** when we hit the end of the first pass, try again from the top	       */
      if (P_seq_no = current.count)
      then do;
         if (current.pass = 1)
         then do;
	  current.pass = 2;
	  return (1);		/* FAIL- go back to the top	       */
         end;
         if ^non_standard
         then call ERR_MSG3 (local.not_belong, 00, not_belong);
         goto next;
      end;
      return (P_seq_no + 1);		/* FAIL- go on to next test	       */

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

SEC$init: entry (ct);

dcl ct		fixed bin parameter;

      unspec (current) = ""b;
      current.count = ct;
      current.pass = 1;
      last_seq = 0;
      begin_info_sw = T;
      call GET_SECTION;		/* get first section	       */
      return;

   end SEC; %page;
/* ------------------------------------------------------------------------- */
/*	Validate and save the info segment header. Its syntax is:	       */
/*	  {divider} date <SP><SP> long_name{, short_name}...	       */
/* ------------------------------------------------------------------------- */

GET_HEADER: proc;

      if tr_sw then call PUSH ("GET_HEADER");
      call GET_PARAGRAPH (1301,(F));	/* up to first paragraph break (blank line) */

      header_shown_sw, end_info_sw, end_info_sw, internal_sw = F;
      if ^colon_info_seen_sw
      then do;
/**** This is a single-info segment, check its names		       */
         if (index (string (current_names), "changes.info") ^= 0)
	    | (index (string (current_names), ".error.info") ^= 0)
	    | (index (string (current_names), ".gi.info") ^= 0)
	    | (index (string (current_names), "diffs.info") ^= 0)
	    | (index (string (current_names), "differences.info") ^= 0)
	    | (index (string (current_names), "new_features.info") ^= 0)
         then general_info = T;
         call SHOW_HEADER;
      end;
      else do;
/****    This is a multi-info segment. Check out the divider.	       */
         if substr (par, 1, 6) = ":Info:"
         then do;			/* this info seg has entry points    */
	  internal_sw, entry_info = F;
	  call PROCESS_DIVIDER (6);
         end;
         else if substr (par, 1, 10) = ":Internal:"
         then do;			/* this info seg has entry points    */
	  entry_info = F;
	  internal_sw = T;
	  call PROCESS_DIVIDER (10);
         end;
      end;
      if substr (par, 1, 7) = ":Entry:"
      then do;			/* this info seg has entry points    */
         internal_sw, entry_info = T;
         call PROCESS_DIVIDER (7);
      end;
      long_lines.count, backspaces.count,
	 endblanks.count, badchars.count, nonblanks.count = 0;
      last_section_head, section_head = "";
      begin_info_sw = T;
      first_section_head = "<empty info>";
      i = verify (par, WHITE_SPACE);
      j = search (substr (par, i), WHITE_SPACE);
      if j = 0
      then j = par_len - i + 1;
      if entry_info
      then entry_date = substr (par, i, j - 1);
      else header_date = substr (par, i, j - 1);
      i = i + j - 1;
      if substr (par, i, 1) = NL
      then header = "";
      else do;
         i = i + verify (substr (par, i), WHITE_SPACE) - 1;
         j = index (substr (par, i), NL) - 1;
         header = substr (par, i, j);
         i = i + j;
         i = search (header, " ,");
         if i = 0
         then header_short_name = header;
         else do;
	  j = verify (substr (header, i), HDR_NAME_BREAK);
	  header_short_name = substr (header, i + j - 1);
	  header = substr (header, 1, i - 1);
         end;
         if ^scanning & ^internal_sw & ^colon_info_seen_sw & ^general_info
         then do;
	  div_names_ct = div_names_ct + 1;
	  temp.list_ct = temp.list_ct + 1;
	  div_names_ptr = addr (temp.list (temp.list_ct));
	  temp.sort.n = temp.sort.n + 1;
	  temp.sort.vector (temp.sort.n) = div_names_ptr;
	  temp.list.name (temp.list_ct) = header || ".info";
	  temp.list.flag (temp.list_ct) = 1;
	  if ep_sw then call ioa_ ("^3i HDR: <^a> **", temp.list_ct, header);

/* In most cases there will only be one header name and one header short name.
   In the case of some subsystem requests, though, there will be multiple
   short names.  The first of these will be kept in header_short_name and
   considered to be *the* short name for the purpose of checking the Syntax
   line.  The rest will just be additional names. */
	  if (header_short_name ^= header)
	  then do;
	     header_short_name_temp = header_short_name;

	     i = search (header_short_name, " ,");
	     if i ^= 0 then do;
		j = verify (substr (header_short_name, i), HDR_NAME_BREAK);
		header_short_name = substr (header_short_name, 1, i - 1);
	     end;

	     names_left_to_add = T;
	     do while (names_left_to_add);
		i = search (header_short_name_temp, " ,");
		if i ^= 0 then j = verify (substr (header_short_name_temp, i), HDR_NAME_BREAK);
		else names_left_to_add = F;
		div_names_ct = div_names_ct + 1;
		temp.list_ct = temp.list_ct + 1;
		if names_left_to_add then temp.list.name (temp.list_ct) = substr (header_short_name_temp, 1, i - 1) || ".info";
		else temp.list.name (temp.list_ct) = header_short_name_temp || ".info";
		temp.list.flag (temp.list_ct) = 1;
		if ep_sw then call ioa_ ("^3i HDR: <^a>", temp.list_ct, temp.list.name (temp.list_ct));
		header_short_name_temp = substr (header_short_name_temp, i + j - 1);
	     end;
	  end;
	  temp.list.flag (temp.list_ct) = 0;
         end;
      end;
      par_line_count = par_line_count - 1;
      par_unit_line_count = par_unit_line_count - 1;
      if (par_line_count < 1)
      then got_par_sw = F;
      else do;
         got_par_sw = T;
         par_line_number = par_line_number + 1;
         par_ptr = addcharno (par_ptr, i);
         par_len = par_len - i;
      end;

/**** test syntax and semantics of header/entry date fields.	       */
/**** 1) all must be valid					       */
/**** 2) all entry<=header					       */
      if entry_info
      then do;
         call convert_date_to_binary_$relative (entry_date, entry_clock, 0, code);
         if db_sw & (code = 0)
         then call ioa_ ("-Entry: ^a", date_time_$format ("date_time", entry_clock, "", ""));
         if code ^= 0
         then call ERR_MSG (local.bad_date, 0, bad_date, entry_date, 0, 0);
         else if header_date_sw
         then if (header_clock < entry_clock)
	    then call ERR_MSG3 (local.entry_too_late, 0, entry_too_late);
      end;
      else do;
         header_date_sw = "1"b;
         call convert_date_to_binary_$relative (header_date, header_clock, 0, code);
         if db_sw & (code = 0)
         then call ioa_ ("-Header: ^a", date_time_$format ("date_time", header_clock, "", ""));
         if code ^= 0
         then do;
	  call ERR_MSG (local.bad_date, 0, bad_date, header_date, 0, 0);
	  header_date_sw = ""b;	/* don't compare against bad date    */
         end;
      end;
      if header = ""
      then call ERR_MSG3 (local.no_hdr_name, 0, no_hdr_name);

      if entry_info			/* turn "foo" or "bar$foo" into      */
      then do;			/* .."$foo"		       */
         info_name = "$" || substr (info_name, index (info_name, "$") + 1);
      end;
      if tr_sw then call POP ("GET_HEADER");

dcl header_date_sw	bit (1);		/* 1-header_date is valid	       */

   end GET_HEADER; %page;
/* ------------------------------------------------------------------------- */
/* Check out a divider. It's format is:				       */
/*  | :Info:     |						       */
/*  | :Internal: |   name: {name:} ... {NL}			       */
/*  | :Entry:    |						       */
/* ------------------------------------------------------------------------- */

PROCESS_DIVIDER: proc (P_id_len);

dcl P_id_len	fixed bin parm;

dcl id_len	fixed bin;
dcl t_ptr		ptr;
dcl do_names	bit (1);
dcl ch1		char (1);

      do_names = ^scanning & ^internal_sw;
      call SHOW_HEADER;
      if ^scanning then info_count = info_count + 1;
      if (charno (par_ptr) > 2)
      then do;
         t_ptr = addcharno (par_ptr, -3);
         if (substr (t_ptr -> par, 1, 3) ^= "


") | blank_line_count > 2
         then call ERR_MSG (local.need_2_blank_lines, 0, need_2_blank_lines,
	         substr (par, 1, P_id_len), 0, 0);
      end;
      info_name = "";
      general_info = F;
      par_ptr = addcharno (par_ptr, P_id_len);
      par_len = par_len - P_id_len;
      if do_names
      then do;
      end;
NEXT_COLON:
      id_len = index (par, ":");
      if id_len ^= 0
      then do;
         header = ltrim (substr (par, 1, id_len - 1));
         header = rtrim (header);
         if do_names
         then do;
	  div_names_ct = div_names_ct + 1;
	  temp.list_ct = temp.list_ct + 1;
	  if (div_names_ct = 1)
	  then do;
	     div_names_ptr = addr (temp.list (temp.list_ct));
	     temp.sort.n = temp.sort.n + 1;
	     temp.sort.vector (temp.sort.n) = div_names_ptr;
	  end;
	  temp.list.name (temp.list_ct) = header || ".info";
	  temp.list.flag (temp.list_ct) = 1;
	  if ep_sw then call ioa_ ("^3i DIV: <^a>^[ **^]", temp.list_ct, header, (div_names_ct = 1));
         end;
         if (info_name = "")
         then info_name = header;
         header = header || "#";
         if (index (header, ".gi#") ^= 0)
	    | (index (header, ".error#") ^= 0)
	    | (index (header, "status#") ^= 0)
	    | (index (header, "changes#") ^= 0)
	    | (index (header, "diffs#") ^= 0)
	    | (index (header, "differences#") ^= 0)
	    | (index (header, "new_features#") ^= 0)
         then general_info = T;
         ch1 = substr (par, id_len + 1, 1);
         if (ch1 = NL)
         then do;
	  id_len = id_len + 1;
	  par_line_count = par_line_count - 1;
            par_unit_line_count = par_unit_line_count - 1;
	  par_line_number = par_line_number + 1;
            par_unit_line_number = par_unit_line_number + 1;
         end;
         par_ptr = addcharno (par_ptr, id_len);
         par_len = par_len - id_len;
         if (ch1 ^= NL)
         then goto NEXT_COLON;
      end;
      if do_names
      then temp.list.flag (temp.list_ct) = 0;
   end PROCESS_DIVIDER; %skip (3);
SHOW_HEADER: proc;

      if ^total_sw & ^header_shown_sw & ^scanning
      then do;
         header_shown_sw = T;
         call ioa_ ("^/-----------^a info^/LINE: ^i^13t^a", format,
	    par_line_number, substr (par, 1, par_1st_line_len - 1));
         if par_line_count > 1
         then call ioa_ ("^13t^a", before (substr (par, par_1st_line_len + 1), NL));
      end;
   end SHOW_HEADER; %page;
/* ------------------------------------------------------------------------- */
/* Validate the next section, up to a double blank line or section heading.  */
/* ------------------------------------------------------------------------- */

GET_SECTION: proc;

dcl t_ptr		ptr;
dcl done		bit (1);

      if tr_sw then call PUSH ("GET_SECTION");

      call GET_PARAGRAPH (1584,(T));

      section_id = EOF;		/* setup in case nothing else here   */
      if end_info_sw
      then do;
         got_par_sw = T;
         goto exit;			/* do this one first */
      end;

      end_info_sw = F;

      if section_head ^= ""
      then last_section_head = section_head;
      section_head = HEAD (par);
      section_skip = section_head_len;
      section_line_number = par_line_number;
      section_ptr_len = par_ptr_len;
      section_line_count = par_line_count;

      par_unit_line_count = par_line_count;
      par_unit_line_number = par_line_number;

      if (section_head ^= "")
      then do;
         if ^total_sw & (^scanning | db_sw)
         then call ioa_ ("LINE: ^i^13t^a", section_line_number, section_head);

         if (charno (par_ptr) > 2) & ^begin_info_sw
         then do;
	  t_ptr = addcharno (par_ptr, -3);
	  if (substr (t_ptr -> par, 1, 3) ^= "


") | blank_line_count > 2
	  then call ERR_MSG (local.need_2_blank_lines, 0, need_2_blank_lines, "Section", 0, 0);
         end;
      end;
      begin_info_sw = F;

      call NORMALIZE_SECTION_HEAD;

      if (SYNTAX <= section_id) & (section_id <= USAGE)
      then do;
         two_paragraph_syntax_sw = F;
         if ^scanning & ^general_info
         then call PARSE_SYNTAX_SECTION;
         if ^two_paragraph_syntax_sw
         then goto exit;		/* just get 1 paragraph for Syntax:  */
      end;

      done = F;
      do while ((src_index < src_len) & ^done);
         call GET_PARAGRAPH (1635,(T));
         if ((search (par, WHITE_SPACE) = 1)
	    | (index (substr (par, 1, par_1st_line_len), ":") = 0)
	    ) & ^end_info_sw
         then do;
	  section_len = section_len + par_len + blank_char_count;
	  section_line_count = section_line_count + par_line_count + blank_line_count;
         end;
         else done, got_par_sw = T;
      end;

      if general_info
      then goto exit;
      goto rtn (section_id);

rtn (2) /* ARGUMENTS			 */ :

      call CHECK_ARGS_FORMAT;
      goto exit;
rtn (3) /* CONTROL_ARGUMENTS			 */ :
rtn (4) /* CONTROL_ARGUMENTS_AS_A_COMMAND	 */ :
rtn (5) /* CONTROL_ARGUMENTS_AS_A_REQUEST	 */ :
rtn (6) /* CONTROL_ARGUMENTS_AS_AN_ACTIVE_FUNCTION */ :
rtn (7) /* CONTROL_ARGUMENTS_AS_AN_ACTIVE_REQUEST  */ :
rtn (8) /* CONTROL_ARGUMENTS_FOR		 */ :
      call CHECK_CTL_ARGS_FORMAT;
      goto exit;
rtn (9) /* ENTRY_POINTS_IN			 */ :
      goto exit;
rtn (12) /* LIST_OF				 */ :
      call CHECK_LIST_OF;
      goto exit;
rtn (19) /* USAGE				 */ :
      call CHECK_USAGE;
      goto exit;

rtn (0) /* UNKNOWN_TITLE			 */ :
      call ERR_MSG (local.non_std_title, 0, non_std_title, (section_head), 0, 0);
      non_standard = T;

rtn (1) /* ACCESS_REQUIRED			 */ :
rtn (10) /* EXAMPLES			 */ :
rtn (11) /* FUNCTION			 */ :
rtn (13) /* NOTES				 */ :
rtn (14) /* NOTES_ON			 */ :
rtn (15) /* SYNTAX				 */ :
rtn (16) /* SYNTAX_AS_A_COMMAND		 */ :
rtn (17) /* SYNTAX_AS_AN_ACTIVE_FUNCTION	 */ :
rtn (18) /* SYNTAX_AS_AN_ACTIVE_REQUEST		 */ :
rtn (20) /* UNTITLED			 */ :
exit:
      if (first_section_head = "<empty info>")
      then first_section_head = section_head;
      if tr_sw then call POP ("GET_SECTION");


CHECK_CTL_ARGS_FORMAT: CHECK_LIST_OF: CHECK_USAGE:
CHECK_ARGS_FORMAT: proc;

/* For Arguments:, Control arguments:, and List of...: sections, checks format of list:
	name1, name2,
	name3, etc.
	<SP><SP><SP>description
*/

   end CHECK_ARGS_FORMAT;


   end GET_SECTION; %page;
/* ------------------------------------------------------------------------- */
/* Verify the syntax of the Syntax: paragraph, including whether	       */
/* the short name is used in the syntax line.			       */
/* ------------------------------------------------------------------------- */

PARSE_SYNTAX_SECTION: proc;

dcl i		fixed bin;


      if tr_sw then call PUSH ("PARSE_SYNTAX_SECTION");
      i = index (par, header_short_name);
      if (i = 0)
      then if subroutine_info
	 then call ERR_MSG (local.no_usage_name, 0, no_usage_name, (header_short_name), 0, 0);
	 else call ERR_MSG (local.no_syntax_name, 0, no_syntax_name, (header_short_name), 0, 0);

/* Since it is highly likely that a subroutine info will have a blank line
   between the declaration and call descriptions of its syntax section, we
   want to allow a second paragraph if "call" does not appear in the first. */
      if subroutine_info
      then if index (par, "call") = 0
           then two_paragraph_syntax_sw = T;
      if tr_sw then call POP ("PARSE_SYNTAX_SECTION");
   end PARSE_SYNTAX_SECTION; %page;
/* ------------------------------------------------------------------------- */
/* Validate the next paragraph, up to a blank line.		       */
/* (There may already be an unused paragraph waiting.)		       */
/* ------------------------------------------------------------------------- */

GET_PARAGRAPH: proc (ln,par_unit_sw);
dcl ln		fixed bin;	/* this parameter is for debugging   */
				/* only, to indicate which call is   */
				/* being executed		       */
dcl par_unit_sw     bit(1) aligned;     /* handle multiple paragraphs        */
                                        /* delimited by single blank as unit */
      if tr_sw & ^scanning
      then call PUSH ("GET_PARAGRAPH");
      if ^got_par_sw		/* already read-ahead?	       */
      then do;			/* ..No			       */
         if (^par_unit_sw & par_unit_line_count > par_line_limit)
         then do;
	  call ERR_MSG (local.paragraph_size, par_unit_line_number, paragraph_size, "", par_unit_line_count, (par_line_limit));
         end;
         if (src_index >= src_len)
         then do;

            if par_unit_sw & par_unit_line_count > par_line_limit
            then do;
               call ERR_MSG (local.paragraph_size, par_unit_line_number, paragraph_size, "", par_unit_line_count, (par_line_limit));
            end;

	  end_info_sw = T;
	  goto exit;
         end;
         par_1st_line_len = 0;
         blank_line_count, blank_char_count = 0;
         blank_line_sw = (src_index < src_len);
         do while (src_index < src_len & blank_line_sw); /* skip leading blank lines */
	  par_offset = src_index;
	  call GET_LINE;
         end;

         if src_index >= src_len & blank_line_sw
         then do;
				/*	  errors.trailing_blank_lines = ^scanning;*/
	  goto exit;
         end;

         if par_unit_sw then do;
            if blank_line_count > 0
            then do;

               if (par_unit_line_count > par_line_limit)
               then do;
	        call ERR_MSG (local.paragraph_size, par_unit_line_number, paragraph_size, "", par_unit_line_count, (par_line_limit));
               end;

               par_unit_line_count = 1;
               par_unit_line_number = line_number;

            end;

            else
                par_unit_line_count = par_unit_line_count + 2;
         end;

         par_1st_line_len = line_len;
         par_line_number = line_number;
         par_ptr_len = line_ptr_len;
         par_line_count = 1;
         do while (src_index < src_len & ^blank_line_sw);
	  call GET_LINE;
	  if ^blank_line_sw
	  then do;
	     par_len = par_len + line_len;
	     par_line_count = par_line_count + 1;
               par_unit_line_count = par_unit_line_count + 1;
	  end;
         end;
      end;

      if substr (par, 1, 6) = ":Info:"	/* beginning of next :Info: block    */
	 | substr (par, 1, 7) = ":Entry:"
	 | substr (par, 1, 10) = ":Internal:"
      then end_info_sw = T;
      else end_info_sw = F;
exit:
      if db_sw & ^scanning
      then call ioa_ ("^4i)^4i ""^a""(^i)^[ got^]^[ EOF^]", ln, par_line_number,
	      before (substr (par, 1, 15), NL), par_line_count, got_par_sw, end_info_sw);
      got_par_sw = F;

      if tr_sw & ^scanning
      then call POP ("GET_PARAGRAPH");
   end GET_PARAGRAPH; %page;
/* ------------------------------------------------------------------------- */
/* Validate next line, advancing src_index and checking various attributes.  */
/* ------------------------------------------------------------------------- */

GET_LINE: proc;

/**** Set pointer/length of next line.				       */
      line_number = line_number + 1;
      line_ptr = setcharno (src_ptr, src_index - 1);
      line_len = src_len - src_index + 1;
      i = index (line, NL);		/* remove trailing newline */
      if i ^= 0
      then line_len = i;
      src_index = src_index + line_len; /* advance offset into string */
      n_cols = 0;
      if line = NL
      then goto BLANK;
/**** Count character positions in printed line			       */
      line_index, special_index = 1;
      do while (special_index ^= 0);
         special_index = index (substr (line, line_index), HT) - 1;
         if special_index = -1
         then special_index = length (line) - line_index + 1;
         line_index = line_index + special_index;
         n_cols = n_cols + special_index;
         if line_index <= length (line)
         then do;
	  n_cols = n_cols + 10 - mod (n_cols, 10);
	  line_index = line_index + 1;
         end;
      end;
      if (n_cols > line_char_limit)
      then do;
         if (par_line_count > 1) & (substr (line, 1, 6) ^= ":Info:") & (substr (line, 1, 7) ^= ":Entry:")
         then call ERR_LOG (errors.long_lines, line_number);
      end;
      if verify (substr (line, 1, line_len - 1), WHITE_SPACE) = 0
      then do;			/* all blanks? */
         call ERR_LOG (errors.nonblanks, line_number);
BLANK:
         blank_line_sw = T;
         blank_line_count = blank_line_count + 1;
         blank_char_count = blank_char_count + length (line);
         line_ptr = setcharno (src_ptr, src_index - 2);
         line_len = 1;
      end;
      else do;
         if (substr (line, line_len - 1, 1) = HT) | (substr (line, line_len - 1, 1) = SP)
         then call ERR_LOG (errors.endblanks, line_number);
         blank_line_sw = F;
         if index (line, BS) ^= 0
         then call ERR_LOG (errors.backspaces, line_number);
         if verify (line, PRINTABLE) ^= 0
         then call ERR_LOG (errors.badchars, line_number);
      end;
      if db_sw & ^scanning
      then call ioa_ ("^2-**^i-^i^[BL^;^-^a^]", line_number, n_cols,
	      (line_len = 1), substr (line, 1, min (40, max (1, line_len - 1))));

   end GET_LINE; %page;
/* ------------------------------------------------------------------------- */
/* Return the section heading of P_string. This is any string	       */
/*  (<= heading_char_limit chars long) before a colon. Set section_head_len  */
/*  to be the number of chars occupied by heading and colon.	       */
/* ------------------------------------------------------------------------- */

HEAD: proc (P_string) returns (char (40));

dcl P_string	char (*);
dcl i		fixed bin;
dcl j		fixed bin;

      if substr (P_string, 1, 1) = NL | search (P_string, WHITE_SPACE) = 1
      then goto NULL;
      if substr (P_string, 1, 1) = ":"
      then i = 2;			/* to allow for ":Info:" as the heading */
      else i = 1;
      j = search (substr (P_string, i), ":
");
      if j = 0 | j > heading_char_limit + 1 | substr (P_string, i + j - 1, 1) = NL
      then do;
NULL:    section_head_len = 0;
         return ("<untitled>");
      end;
      else do;
         section_head_len = j + i - 1;
         return (ltrim (substr (P_string, i, j - 1)));
      end;

   end HEAD; %page;
/* ------------------------------------------------------------------------- */
/* Reduce a section heading to a standard form, if possible.	       */
/* ------------------------------------------------------------------------- */

NORMALIZE_SECTION_HEAD: proc;

dcl old_len	fixed bin;
dcl section_temp	char (40) var;

      normal_head = section_head;
      section_id = UNKNOWN_TITLE;
      non_standard = F;

      if index (normal_head, BS) ^= 0
      then do;			/* remove underlining */
         do i = 1 to length (normal_head) - 1 while (substr (normal_head, i, 1) ^= " ");
	  if substr (normal_head, i, 2) = BS || "_"
	  then do;
	     normal_head = substr (normal_head, 1, i - 1) || substr (normal_head, i + 1);
	     i = i - 1;
	  end;
         end;
         bsp_sw = T;
      end;
      else bsp_sw = F;

      normal_head = translate (substr (normal_head, 1, 1), UPPER_CASE, LOWER_CASE)
	 || translate (substr (normal_head, 2), LOWER_CASE, UPPER_CASE);
      do section_index = hbound (std_section, 1) by -1 to 1 while
	 (substr (std_section (section_index), 3) ^= substr (normal_head, 1, length (std_section (section_index)) - 2));
      end;
      if (section_index > 0)
      then do;
         section_id = fixed (substr (std_section (section_index), 1, 2));
         old_len = length (std_section (section_index)) - 2;
         section_temp = substr (std_section (section_id), 3);
         if (length (section_temp) < 40)
         then section_temp = section_temp || substr (normal_head, old_len + 1);
         normal_head = section_temp;
         if section_head ^= normal_head
         then do;
	  call ERR_MSG (local.this_form_preferred, 0, this_form_preferred, (normal_head), 0, 0);
	  section_head = normal_head;
         end;
         if (bf_format = "C/AF") & (section_id = SYNTAX)
         then do;
	  call ERR_MSG3 (local.need_command, 0, need_command);
	  section_id = SYNTAX_AS_A_COMMAND;
         end;
         if subroutine_info
         then do;
	  if (SYNTAX <= section_id) & (section_id <= SYNTAX_AS_AN_ACTIVE_REQUEST)
	  then do;
	     call ERR_MSG3 (local.need_usage, 0, need_usage);
	     section_id = USAGE;
	  end;
	  if (section_id = UNTITLED)
	  then do;
	     call ERR_MSG3 (local.need_function, 0, need_function);
	     section_id = FUNCTION;
	  end;
         end;
      end;

dcl bsp_sw	bit (1);

   end NORMALIZE_SECTION_HEAD; %page;
/* ------------------------------------------------------------------------- */
/* ------------------------------------------------------------------------- */

PRINT_ERR_SUMMARY: proc;

      call ERR_PRINT (long_lines, local.lines_too_long, lines_too_long);
      call ERR_PRINT (badchars, local.non_printable, non_printable);
      call ERR_PRINT (nonblanks, local.blank_white_space, blank_white_space);
      call ERR_PRINT (endblanks, local.end_white_space, end_white_space);
      call ERR_PRINT (backspaces, local.backspace, backspace);

      if af_sw then return;

      if total_sw & (highest_severity >= severity_limit)
      then do;
         if (info_name ^= "") & new_segment_sw
         then do;
	  call ioa_ ("^19x:Info: ^a^[ (LINK)^]", src_path, link_sw);
	  new_segment_sw = F;
         end;
         call ioa_ ("^3(^5d ^)  ^4a  ^[^a^[ (LINK)^]^;^2s  ^a^]",
	    highest_severity, local.paragraph_size, local.lines_too_long,
	    bf_format,
	    new_segment_sw, src_path, link_sw, info_name);
         new_segment_sw = F;
      end;
      global = global + local;
      highest_severity = 0;

   end PRINT_ERR_SUMMARY; %page;
/* ------------------------------------------------------------------------- */
/* ------------------------------------------------------------------------- */

ERR_MSG: proc (err_ct, lino, msg, ch_arg, fb_arg1, fb_arg2);
      argct = 6;
      goto common;
ERR_MSG3: entry (err_ct, lino, msg);
      argct = 3;

dcl (err_ct	fixed bin (18),	/* error accumulator	       */
    lino		fixed bin,	/* where it occurred	       */
    msg		char (80) var,	/* text of message		       */
    ch_arg	char (*),		/* character value		       */
    fb_arg1	fixed bin (24),	/* binary value		       */
    fb_arg2	fixed bin (24)	/* another binary value	       */
    )		parm;

dcl argct		fixed bin;
dcl sev		fixed bin;
dcl ch1		char (1);

common:
      if scanning then return;
      err_ct = err_ct + 1;
      ch1 = substr (msg, 1, 1);
      sev = index ("012345", ch1) - 1;
      highest_severity = max (highest_severity, sev);
      error_count.total (sev) = error_count.total (sev) + 1;
      error_count.seg (sev) = 1;
      error_count.info (sev) = 1;
      if total_sw | (sev < severity_limit)
      then return;

      call ioa_$nnl ("Severity ^a", ch1);
      if (lino ^= 0)
      then call ioa_$nnl (", line ^i", lino);
      call ioa_$nnl (". ");
      if (argct = 3)
      then call ioa_ (substr (msg, 2), T);
      else call ioa_ (substr (msg, 2), T, ch_arg, fb_arg1, fb_arg2);

   end ERR_MSG; %page;
/* ------------------------------------------------------------------------- */
/* ------------------------------------------------------------------------- */

ERR_LOG: proc (P_map, P_line_number);

/* This internal procedure adds a line number to the appropriate error array. */

dcl 1 P_map	aligned like map;
dcl P_line_number	fixed bin;

      if (P_map.count = 0)
      then P_map.actual_count = 0;
      P_map.actual_count = P_map.actual_count + 1;
      if P_map.actual_count > hbound (P_map.number, 1)
      then return;
      P_map.count = P_map.count + 1;
      P_map.number (P_map.count) = P_line_number;

   end ERR_LOG; %page;
/* ------------------------------------------------------------------------- */
/* ------------------------------------------------------------------------- */

ERR_PRINT: proc (P_map, P_accum, P_msg);

/* This internal procedure lists the line numbers for a particular error. */

dcl 1 P_map	aligned like map,
    P_accum	fixed bin (18),
    P_msg		char (80) var;

dcl i		fixed bin;
dcl sev		fixed bin;
dcl ch1		char (1);

      if P_map.count = 0
      then return;
      ch1 = substr (P_msg, 1, 1);
      sev = index ("012345", ch1) - 1;
      highest_severity = max (highest_severity, sev);
      error_count.total (sev) = error_count.total (sev) + P_map.actual_count;
      error_count.seg (sev) = 1;
      error_count.info (sev) = 1;
      P_accum = P_accum + P_map.actual_count;

      if total_sw | (sev < severity_limit)
      then return;

      call ioa_$nnl ("Severity ^a. ", ch1);
      severity_count = sev;

      call ioa_$nnl (substr (P_msg, 2), (P_map.count ^= 1));
      call ioa_$nnl (":  ");

      err_count = 2;
      do i = 1 to P_map.count;
         if err_count = 10
         then do;
	  call ioa_$nnl (",^/^10x");
	  err_count = 1;
         end;
         else err_count = err_count + 1;
         if i = 1 | err_count = 1
         then call ioa_$nnl ("^d", P_map.number (i));
         else call ioa_$nnl (",  ^d", P_map.number (i));
      end;
      if P_map.actual_count > P_map.count
      then call ioa_ (",  etc.  (^d in all)", P_map.actual_count);
      else call ioa_ ("");

   end ERR_PRINT;

   end VALIDATE; %page;
CLEAN_UP: proc;

/* ------------------------------------------------------------------------- */
/*		     This is the cleanup handler.		       */
/* ------------------------------------------------------------------------- */

      if src_ptr ^= null ()
      then call terminate_file_ (src_ptr, (0), TERM_FILE_TERM, (0));
      if temp_ptr ^= null ()
      then call release_temp_segment_ (ME, temp_ptr, (0));

CLEAN_UP$some: entry;

/**** allocations from hcs_$status_				       */
      if (status_ptr ^= null ())
      then do;
         if (status_link.type = Link)
         then if (status_link.pathname_relp ^= ""b)
	    then do;
	       free status_pathname in (area);
	       status_link.pathname_relp = ""b;
	    end;
         if (status_branch.names_relp ^= ""b)
         then do;
	  free status_entry_names in (area);
	  status_branch.names_relp = ""b;
         end;
         status_ptr = null ();
      end;
/**** allocations from hcs_$star_dir_list_			       */
      if star_list_names_ptr ^= null	/* this is done first because it     */
      then free star_list_names in (area); /* ...uses the next one.	       */
      if star_list_branch_ptr ^= null
      then free star_dir_list_branch in (area);

   end CLEAN_UP;

dcl db_sw		bit (1) int static init (""b);
dbn: entry; db_sw = "1"b; return;
dbf: entry; db_sw = "0"b; return;

dcl tr_sw		bit (1) int static init (""b);
trn: entry; tr_sw = "1"b; return;
trf: entry; tr_sw = "0"b; return;

dcl ep_sw		bit (1) int static init (""b);
epn: entry; ep_sw = "1"b; return;
epf: entry; ep_sw = "0"b; return;

%page;
%include star_structures;
%page;
%include status_structures;
%page;
%include terminate_file;

   end validate_info_seg;
   



		    vfile_find_bad_nodes.pl1        06/23/83  1242.9rew 06/23/83  1104.1      348867


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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name:  vfile_find_bad_nodes						*/
	/*									*/
	/*      This is a procedure for checking the consistency of the key-containing		*/
	/* components of a vfile_ indexed file.						*/
	/*									*/
	/* Status									*/
	/*									*/
	/* 0) Created:   July, 1981 by  G.C. Dixon					*/
	/* 1) Modified:  May, 1983 by G.C. Dixon to add node_tree checking.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	
vfile_find_bad_nodes:
	proc;

     dcl	Iarg			fixed bin,
	Ibranch			fixed bin,
	Ifn			fixed bin,
	Imode			fixed bin,
	Inode			fixed bin,
	Larg			fixed bin(21),
	Lnode_bit_overlay		fixed bin,
	Lop			fixed bin(21),
	Lread			fixed bin(21),
	Lret			fixed bin(21),
	LINE			char(256),
	Nargs			fixed bin,
	Nbad_nodes		fixed bin,
	Nbad_nodes_in_comp		fixed bin,
	Nkeys			fixed bin(34),
	Nkey_bytes		fixed bin(34),
	Nkey_bytes_in_node		fixed bin,
	Nnon_empty_nodes		fixed bin,
	Parg			ptr,
	Pfn			ptr,
	Pfree_nodes		ptr,
	Piocb			ptr,
	Piocb_node_tree		ptr,
         (Pnode1, Pnode2)		ptr,
	Pnode_array		ptr,
	Pnode_bit_overlay		ptr,
	Pop			ptr,
	Pret			ptr,
	Sattached			bit(1),
	Scommand			bit(1),
	Sinput_switch		bit(1),
	1 Smode			aligned,
	 (2 node_branch,
	  2 key_region,
	  2 key_loc,
	  2 key_overlap,
	  2 key_order,
	  2 node_tree,
	  2 bad_mode_name,
	  2 bad_mode_value)		bit(1) unal,
	Sopened			bit(1),
	Spathname			bit(1),
	Srequest_loop		bit(1),
	Stotal			bit(1),
	1 branch_numb_key		aligned like numb_key,
	code			fixed bin(35),
	comp_num			fixed bin,
	input_switch_name		char(32),
	key			char(256) varying,
	line			char(256) varying,
	mode_string		char(256),	/* This mode string is only used in calls to	*/
						/*   com_err_, so 256 chars is long enough.	*/
	node_bits			bit(4096) unal,
	1 numb_key		aligned,
	  2 comp			fixed bin(17) unal,
	  2 node			fixed bin(18) uns unal,
	pathname			char(168) varying,
	pos_frame (4)		ptr,
	pos_ptr			ptr,
	1 root_numb_key		aligned like numb_key,
	save_numb_key_numb		fixed bin(35),
	temp_comp_num		fixed bin,
	unique			char(15);

     dcl	area			area based(Parea),
	arg			char(Larg) based(Parg),
	branch_numb_key_numb	fixed bin(35) based (addr(branch_numb_key)),
	branch_numb_key_str		char(4) aligned based(addr(branch_numb_key_numb)),
	1 fn			aligned based(Pfn), /* a free node, containing a list of other free	*/
						/*   nodes.				*/
	  2 N			fixed bin,	/* number free nodes listed in this node.	*/
	  2 next_free_node_designator fixed bin(35),	/* record descriptor of next free node list.	*/
	  2 node (0 refer (fn.N))	fixed bin(35),	/* record descriptors of free nodes in this list. */
	1 free_nodes		aligned based(Pfree_nodes),
	  2 N			fixed bin,	/* array of pointers to free nodes or free node 	*/
	  2 node (0 refer (free_nodes.N))
				ptr,		/*   lists.				*/
	node_array (255)		char(4096) aligned based(Pnode_array),
	node_bit_array (4096)	bit(1) unal based (addr(node_bits)),
	node_bit_overlay		bit(Lnode_bit_overlay) based(Pnode_bit_overlay),
	numb_key_numb		fixed bin(35) based(addr(numb_key)),
	numb_key_str		char(4) aligned based(addr(numb_key)),
	op			char(Lop) based(Pop),
	open_descrip		char(100) varying based,
	ret			char(Lret) varying based(Pret),
	root_numb_key_numb		fixed bin(35) aligned based(addr(root_numb_key));

     dcl (char, currentsize, dimension, hbound, index, 
          lbound, ltrim, mod, rtrim)	builtin;

     dcl (cleanup, program_interrupt)	condition;

     dcl  active_fnc_err_		entry() options(variable),
	arg_ptr			entry (fixed bin, ptr, fixed bin(21), fixed bin(35)) variable,
	com_err_			entry() options(variable),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$af_arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$cp			entry (ptr, fixed bin(21), fixed bin(35)),
	delete_$path		entry (char(*), char(*), bit(6), char(*), fixed bin(35)),
	err			entry options(variable) variable,
	get_pdir_			entry() returns(char(168)),
	get_system_free_area_	entry() returns(ptr),
	get_temp_segment_		entry (char(*), ptr, fixed bin(35)),
	ioa_			entry() options(variable),
	ioa_$nnl			entry() options(variable),
	iox_$attach_name		entry (char(*), ptr, char(*), ptr, fixed bin(35)),
	iox_$close		entry (ptr, fixed bin(35)),
	iox_$control		entry (ptr, char(*), ptr, fixed bin(35)),
	iox_$detach_iocb		entry (ptr, fixed bin(35)),
	iox_$destroy_iocb		entry (ptr, fixed bin(35)),
	iox_$get_line		entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
	iox_$look_iocb		entry (char(*), ptr, fixed bin(35)),
	iox_$open			entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
	iox_$position		entry (ptr, fixed bin, fixed bin(21), fixed bin(35)),
	iox_$read_key		entry (ptr, char(256) varying, fixed bin(21), fixed bin(35)),
	mode_string_$get_error	entry (ptr, char(*), fixed bin(35)),
	mode_string_$parse		entry (char(*), ptr, ptr, fixed bin(35)),
	pathname_			entry (char(*), char(*)) returns(char(168)),
	release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
	unique_chars_		entry (bit(*)) returns(char(15));

     dcl (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	HT_SP			char(2) int static options(constant) init("	 "),
	HT_SP_NL			char(3) int static options(constant) init("	 
"),
	Parea			ptr int static init(null),
         (error_table_$bad_mode,
	error_table_$bad_mode_value,
	error_table_$badopt,
	error_table_$inconsistent,
	error_table_$key_duplication,
	error_table_$noarg,
	error_table_$not_attached,
	error_table_$unimplemented_version,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static,
	iox_$user_input		ptr external static,
	proc			char(20) int static options(constant) init("vfile_find_bad_nodes");

	Pfree_nodes = null;				/* Initialize variables for cleanup on unit.	*/
	Piocb = null;
	Piocb_node_tree = null;
	Sattached = FALSE;
	Sopened = FALSE;
	mode_string_info_ptr = null;
	on cleanup call janitor();

	Sinput_switch = FALSE;			/* Initialize variables used to process args.	*/
	Spathname = FALSE;
	input_switch_name = "";
	pathname = "";
	Smode = FALSE;
	Smode.node_branch = TRUE;
	Smode.key_region = TRUE;
	Smode.key_loc = TRUE;

	call cu_$af_return_arg (Nargs, Pret, Lret, code); /* Called as a command, or as an af?		*/
	if code = 0 then do;
	     Scommand = FALSE;
	     Srequest_loop = FALSE;
	     arg_ptr = cu_$af_arg_ptr;
	     err = active_fnc_err_;
	     end;
	else do;
	     Scommand = TRUE;
	     Srequest_loop = TRUE;
	     arg_ptr = cu_$arg_ptr;
	     err = com_err_;
	     end;

	do Iarg = 1 to Nargs;			/* Process arguments.			*/
	     call arg_ptr (Iarg, Parg, Larg, code);

	     if arg = "-input_switch" | arg = "-isw" then do;
		if Spathname then do;
		     call err (error_table_$inconsistent, proc, "^a
Usage:	vfile_find_bad_nodes {pathname}
   or:	vfile_find_bad_nodes -input_switch switch_name", arg);
		     go to FINISH;
		     end;
		Iarg = Iarg + 1;
		if Iarg > Nargs then do;
		     call err (error_table_$noarg, proc, "
^a requires an I/O switch name as its operand.  The switch must be 
attached to the keyed file.  If open, the switch must be opened for
^a or ^a.", arg, iox_modes(Keyed_sequential_input), iox_modes(Keyed_sequential_update));
		     go to FINISH;
		     end;
		call arg_ptr (Iarg, Pop, Lop, code);
		input_switch_name = op;
		Sinput_switch = TRUE;
		end;

	     else if arg = "-request_loop" | arg = "-rql" then
		Srequest_loop = TRUE;

	     else if arg = "-no_request_loop" | arg = "-nrql" then
		Srequest_loop = FALSE;

	     else if arg = "-check" | arg = "-ck" then do;
		Iarg = Iarg + 1;
		if Iarg > Nargs then do;
		     call err (error_table_$noarg, proc, "
^a requires a mode string as its operand.  For a list of modes, type
  help ^a -brief", arg, proc);
		     go to FINISH;
		     end;
		call arg_ptr (Iarg, Pop, Lop, code);
		if Parea = null then
		     Parea = get_system_free_area_();
		call mode_string_$parse (op, Parea, mode_string_info_ptr, code);
		if code ^= 0 then do;
		     call err (code, proc, "^a ^a", arg, op);
		     go to FINISH;
		     end;
		if mode_string_info.version ^= mode_string_info_version_2 then do;
		     call err (error_table_$unimplemented_version, proc, "
Expected version ^d structure from mode_string_$parse, received version ^d.",
			mode_string_info_version_2, mode_string_info.version);
		     go to FINISH;
		     end;
		if mode_string_info.number >= 1 then
		if mode_string_info.modes(1).version ^= mode_value_version_3 then do;
		     call err (error_table_$unimplemented_version, proc, "
Expected version ^d structure from mode_string_$parse, received version ^d.",
			mode_value_version_3, mode_string_info.modes(1).version);
		     go to FINISH;
		     end;
		Smode = FALSE;
		code = 0;
		mode_string_info.modes(*).code = 0;
		do Imode = 1 to mode_string_info.number;
		     if mode_string_info.modes(Imode).boolean_valuep then do;
			if mode_string_info.modes(Imode).mode_name = "node_branch" then
			     Smode.node_branch = mode_string_info.modes(Imode).boolean_value;
			else if mode_string_info.modes(Imode).mode_name = "key_region" then
			     Smode.key_region = mode_string_info.modes(Imode).boolean_value;
			else if mode_string_info.modes(Imode).mode_name = "key_loc" then
			     Smode.key_loc = mode_string_info.modes(Imode).boolean_value;
			else if mode_string_info.modes(Imode).mode_name = "key_overlap" then
			     Smode.key_overlap = mode_string_info.modes(Imode).boolean_value;
			else if mode_string_info.modes(Imode).mode_name = "key_order" then
			     Smode.key_order = mode_string_info.modes(Imode).boolean_value;
			else if mode_string_info.modes(Imode).mode_name = "node_tree" then
			     Smode.node_tree = mode_string_info.modes(Imode).boolean_value;
			else if mode_string_info.modes(Imode).mode_name = "default" then
			     Smode.node_branch,
			     Smode.key_region,
			     Smode.key_loc = mode_string_info.modes(Imode).boolean_value;

			else if mode_string_info.modes(Imode).mode_name = "all" then
			     Smode.node_branch,
			     Smode.key_region,
			     Smode.key_loc,
			     Smode.key_overlap,
			     Smode.key_order,
			     Smode.node_tree = mode_string_info.modes(Imode).boolean_value;
			else do;
			     mode_string_info.modes(Imode).code = error_table_$bad_mode;
			     Smode.bad_mode_name = TRUE;
			     code = error_table_$bad_mode_value;
			     end;
			end;
		     else do;
			mode_string_info.modes(Imode).code = error_table_$bad_mode_value;
			Smode.bad_mode_value = TRUE;
			code = error_table_$bad_mode_value;
			end;
		     end;
		if Smode.bad_mode_name | Smode.bad_mode_value then do;
		     call mode_string_$get_error (mode_string_info_ptr, mode_string, 0);
		     call err (code, proc, "^a^[
Only boolean modes can be given.^]", mode_string, Smode.bad_mode_value & ^Smode.bad_mode_name);
		     go to FINISH;
		     end;
		free mode_string_info in (area);
		mode_string_info_ptr = null;
		end;

	     else if index(arg, "-") = 1 then do;
		call err (error_table_$badopt, proc, "^a
Usage:	vfile_find_bad_nodes {pathname}
   or:	vfile_find_bad_nodes -input_switch switch_name", arg);
		go to FINISH;
		end;

	     else do;
		if Sinput_switch then do;
		     call err (error_table_$inconsistent, proc, "^a
Usage:	vfile_find_bad_nodes {pathname}
   or:	vfile_find_bad_nodes -input_switch switch_name", arg);
		     go to FINISH;
		     end;
		pathname = arg;
		Spathname = TRUE;
		end;
	     end;
	if Spathname | Sinput_switch then;
	else do;
	     call err (error_table_$wrong_no_of_args, proc, "
Usage:	vfile_find_bad_nodes {pathname}
   or:	vfile_find_bad_nodes -input_switch switch_name");
	     go to FINISH;
	     end;


	unique = unique_chars_(""b);
	if Spathname then do;			/* For paths, attach to file in this code.	*/
	     input_switch_name = proc || "." || unique;
	     call iox_$attach_name (input_switch_name, Piocb, "vfile_ " ||
		pathname || " -share 120", null, code);
	     if code ^= 0 then do;
		call err (code, proc, "Attaching to ^a",
		     pathname);
		go to FINISH;
		end;
	     Sattached = TRUE;
	     call iox_$open (Piocb, Keyed_sequential_input, ""b, code);
	     if code ^= 0 then do;
		call err (code, proc, "Opening ^a for ^a.",
		     pathname, iox_modes(Keyed_sequential_input));
		go to FINISH;
		end;
	     Sopened = TRUE;
	     end;

	else do;					/* For I/O switches,			*/
	     call iox_$look_iocb (input_switch_name, Piocb, code);
	     if code ^= 0 then do;			/*   make sure I/O switch exists.		*/
		call err (code, proc, "Finding ^a I/O switch.
Usage:	vfile_find_bad_nodes {pathname}
   or:	vfile_find_bad_nodes -input_switch switch_name",
		     input_switch_name);
		go to FINISH;
		end;
	     if Piocb -> iocb.attach_descrip_ptr = null then do;
		call err (error_table_$not_attached, proc,
		     "
Referencing ^a I/O switch.", input_switch_name);		/*   make sure it is attached to something.	*/
		go to FINISH;
		end;
	     if Piocb -> iocb.open_descrip_ptr = null then do;
		call iox_$open (Piocb, Keyed_sequential_input, ""b, code);
		if code ^= 0 then do;		/*   if not open, open it for ksqi		*/
		     call err (code, proc, "
Opening ^a I/O switch for ^a.", input_switch_name, iox_modes(Keyed_sequential_input));
		     go to FINISH;
		     end;
		Sopened = TRUE;
		end;
	     else do;				/*   if already open, make sure it is for ksqi	*/
		if Piocb -> iocb.open_descrip_ptr -> open_descrip = iox_modes(Keyed_sequential_input) |
		   Piocb -> iocb.open_descrip_ptr -> open_descrip = iox_modes(Keyed_sequential_update) then;
		else do;
		     call err (error_table_$bad_mode, proc, "
^a I/O switch is opened for ^a.  It must be opened for
^a or ^a to use ^a.", input_switch_name,
			Piocb -> iocb.open_descrip_ptr -> open_descrip,
			iox_modes(Keyed_sequential_input),
			iox_modes(Keyed_sequential_update), proc);
		     go to FINISH;
		     end;
		end;
	     end;

	if Smode.node_tree then do;			/* For node_tree checking, create temp vfile_	*/
						/*   in process directory.			*/
	     call iox_$attach_name ("vfbn." || unique, Piocb_node_tree,
		"vfile_ " || pathname_(get_pdir_(), "vfbn." || unique),
		null, code);
	     if code ^= 0 then do;
		call err (code, proc, "
Attempting to attach to temp vfile_ in process dir.");
		go to FINISH;
		end;
	     call iox_$open (Piocb_node_tree, Keyed_sequential_update, ""b, code);
	     if code ^= 0 then do;
		call err (code, proc, "
Attempting to open temp vfile_ in process dir for keyed_sequential_update.");
		go to FINISH;
		end;

	     aki.input_key = TRUE;			/* Initialize structures used to manipulate	*/
	     aki.input_desc = TRUE;			/*   keys in this temp vfile_			*/
	     aki.key_len = 4;

	     gki.input_key = TRUE;
	     gki.input_desc = FALSE;
	     gki.desc_code = 0;
	     gki.current = FALSE;
	     gki.rel_type = 0;
	     gki.head_size = 4;
	     gki.reset_pos = TRUE;
	     gki.pad = FALSE;
	     gki.version = gk_info_version_0;
	     gki.key_len = 4;

	     rki.input_key = TRUE;
	     rki.input_old_desc = TRUE;
	     rki.input_new_desc = TRUE;
	     rki.mbz = FALSE;
	     rki.key_len = 4;
	     end;

	call iox_$read_key (Piocb, key, Lread, code);	/* This call forces initiation of key components. */
	if code ^= 0 then do;
	     call err (code, proc, "
Attempting to read first key ^[of file ^a^s^;on ^s^a I/O switch^].",
		Spathname, pathname, input_switch_name);
	     go to FINISH;
	     end;

	key = "";					/* set variables to access file structures.	*/
	pos_ptr = addr(pos_frame);
	Nbad_nodes = 0;
	indx_cb_ptr = Piocb -> iocb.open_data_ptr;
	f_b_ptr = indx_cb.file_base_ptr;
	if file_base.file_version = 10 then do;
	     call err (0, proc, 
		"This file is in too old a format to check its nodes.");
	     go to FINISH;
	     end;
	is_ptr = indx_cb.index_state_ptr;

	if index_state_block.free_node_designator ^= 0 then do;
	     call get_temp_segment_ (proc, Pfree_nodes, code);
	     if code ^= 0 then do;
		call err (code, proc, "Getting temp segment.");
		go to FINISH;			/* In a temp seg, get a list of the unused nodes  */
		end;				/*   in the index, and avoid doing consistency	*/
	     free_nodes.N = 0;			/*   checks on them, since they may contain data	*/
	     Pfn = is_ptr;				/*   from a previous use which is in an		*/
	     if Pfn = null then go to ABORT_FREE_NODES;	/*   inconsistent state.			*/
	     do while (fn.next_free_node_designator ^= 0);
		Pfn = get_ptr (fn.next_free_node_designator);
		if Pfn = null then go to ABORT_FREE_NODES;
		call ioa_ ("Begin checking free node list (node_ptr = ^p).", Pfn);
		if fn.N < 0 then do;
		     call tell$bad_free_node ("Free node count < 0", 23, Pfn);
		     go to ABORT_FREE_NODES;
		     end;
		if fn.N > 1022 then do;
		     call tell$bad_free_node ("Free node count > 1022", 24, Pfn);
		     go to ABORT_FREE_NODES;
		     end;
		free_nodes.N = free_nodes.N + 1;
		free_nodes.node(free_nodes.N) = Pfn;
		do Ifn = 1 to fn.N;
		     free_nodes.N = free_nodes.N + 1;
		     free_nodes.node(free_nodes.N) = get_ptr(fn.node(Ifn));
		     end;
		end;
	     call ioa_ ("Found ^d undamaged free nodes.  Processing continues.", free_nodes.N);
	     go to END_FREE_NODE_PROCESSING;

ABORT_FREE_NODES:
	     call ioa_ ("Processing of free nodes aborted by this error.
Found ^d undamaged free nodes so far.
Some damaged nodes reported below may actually be undamaged free nodes which
were not located, due to this error.", free_nodes.N);
END_FREE_NODE_PROCESSING:
	     end;

	root_numb_key_numb = file_base.root_node_block.only_branch_in_root;
						/* Remember descriptor of root node for node_tree */
						/*   checking.				*/

	Nnon_empty_nodes = 0;
	Nkeys = 0;
	Nkey_bytes = 0;
	do comp_num = 0,				/* Start with component 0 of the keyed file,	*/
	   index_state_block.index_tail_comp_num repeat comp_table(comp_num).comp_link
	        while (comp_num ^= 0);		/*   and follow chain of key-containing 	*/
	     Pnode_array = seg_ptr_array(comp_num);	/*   components from the comp_table.		*/
	     if comp_num = 0 then Inode = 5;		/* Skip over file_base in component 0.		*/
	     else Inode = 1;			/* For other components, consider pages 1-255	*/

	     call ioa_ ("^/Begin checking component ^d, node:", comp_num);
	     on program_interrupt;			/* Ignore pi unless in request loop.		*/
	     Stotal = FALSE;
	     Nbad_nodes_in_comp = 0;

						/* Note that the following code walks through the */
						/* nodes in each component sequentially, NOT in	*/
						/* tree order.				*/
	     do Inode = Inode to dimension(node_array,1); /* For each potential key-containing node,	*/
		node_ptr = addr(node_array(Inode));	/*   get ptr to node page.  vfile_ has kindly 	*/
						/*   initiated the compoent for us.		*/
		if mod(Inode,25) = 0 then call ioa_$nnl (" ^d", Inode);
						/* Give user a progress indicator every 25 pages. */
		if Pfree_nodes ^= null then do;	/* Avoid checking free nodes.			*/
		     do Ifn = 1 to free_nodes.N while (node_ptr ^= free_nodes.node(Ifn));
			end;
		     if Ifn <= free_nodes.N then go to NEXT_NODE;
		     end;
		if node_block.last_branch_num = 0 then go to NEXT_NODE;
						/* Avoid checking empty nodes.		*/

		Nnon_empty_nodes = Nnon_empty_nodes + 1;
		Nkeys = Nkeys + node_block.last_branch_num - 1;
		Nkey_bytes = Nkey_bytes + 4096 - node_block.low_key_pos + 1 - node_block.scat_space;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* The tests for consistency of each node follow:					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

		if Smode.node_branch then do;
		     if node_block.last_branch_num > 313  then go to FAIL6;
						/* A node can contain at most, 313 1-char keys.	*/
		     if node_block.last_branch_num < 0 then go to FAIL7;
						/* Key count must be positive.		*/
		     end;

		if Smode.key_region then do;
		     if node_block.low_key_pos > 4096  then go to FAIL8;
						/* Keys may not be stored beyond end of page.	*/
		     if node_block.low_key_pos < 4*(currentsize(node_block)-2)  then go to FAIL9;
						/* Keys may not be stored on top of node_block	*/
						/*   structure.				*/
		     if node_block.scat_space > 4096-node_block.low_key_pos+1  then go to FAIL10;
						/* Scattered free key storage space must not be	*/
						/*   larger than key storage region of the node.	*/
		     if node_block.scat_space < 0 then go to FAIL11;
						/*   nor can scattered space be negative.	*/
		     Nkey_bytes_in_node = 0;
		     do Ibranch = 1 to node_block.last_branch_num-1;
			Nkey_bytes_in_node = Nkey_bytes_in_node + node_block.key_length(Ibranch);
			end;			/* Check that scat_space and low_key_pos are	*/
						/*   consistent with all key lengths.		*/
		     if Nkey_bytes_in_node ^= 4096 - node_block.low_key_pos + 1 - node_block.scat_space then
			go to FAIL12;
		     end;

		if Smode.key_loc | Smode.key_order then
		do Ibranch = 1 to node_block.last_branch_num-1;
		     if Smode.key_loc then do;
			if node_block.key_pos(Ibranch) < node_block.low_key_pos  then go to FAIL13;
			if node_block.key_pos(Ibranch)+node_block.key_length(Ibranch)-1  >  4096  then go to FAIL14;
			end;			/* Each key's storage must be in the key storage	*/
						/*   region of the node.			*/

		     if Smode.key_order then do;
			if Ibranch < node_block.last_branch_num - 1 then
			if substr(keys, node_block.key_pos(Ibranch), node_block.key_length(Ibranch)) >
			   substr(keys, node_block.key_pos(Ibranch+1), node_block.key_length(Ibranch+1)) then
			     go to FAIL16;		/* Make sure keys are in ascending ASCII 	*/
			end;			/*   collating sequence in node.		*/
		     end;

		if Smode.key_overlap then do;
		     node_bits = ""b;
		     do Ibranch = 1 to node_block.last_branch_num - 1;
			Pnode_bit_overlay = addr(node_bit_array(node_block.key_pos(Ibranch)));
			Lnode_bit_overlay = node_block.key_length(Ibranch);
			if node_bit_overlay ^= ""b then go to FAIL15;
			node_bit_overlay = ^node_bit_overlay;
			end;			/* Make sure each by of key storage is used for	*/
		     end;				/*   only one key.				*/

		if Smode.node_tree then do;
		     aki.descrip = 0;		/* Add a key to temp vfile_ for each node as it	*/
						/*   is processed.				*/
		     if comp_num = root_numb_key.comp then
		     if (Inode-1)*1024 = root_numb_key.node then do;
			numb_key.comp = -1;		/* Root node has no parent.			*/
			numb_key.node = 0;
			aki.descrip = numb_key_numb;
			end;
		     numb_key.comp = comp_num;
		     numb_key.node = (Inode-1) * 1024;
		     aki.key = numb_key_str;
		     call iox_$control (Piocb_node_tree, "add_key", addr(aki), code);
						/* It is not an error if the key already exists	*/
						/*   since node may have been referenced by 	*/
						/*   sons_ptr of its parent node (checked 	*/
						/*   earlier), and the key would have been created*/
						/*   at that earlier reference.		*/

		     do Ibranch = 1 to node_block.last_branch_num;
						/* Now check all sons_ptrs of this node.	*/
			if node_block.branch(Ibranch) ^= 0 then do;
			     branch_numb_key_numb = node_block.branch(Ibranch);
			     if branch_numb_key_numb = root_numb_key_numb then
				call tell$root_sons_ptr;
						/* Error for sons_ptr to reference root node.	*/
			     else do;
				do temp_comp_num = 0,
				     index_state_block.index_tail_comp_num
				     repeat (comp_table(temp_comp_num).comp_link)
				     while (temp_comp_num ^= 0);
				     if temp_comp_num = branch_numb_key.comp then
					go to SON_OK_SO_FAR;
				     end;
				call tell$non_node_comp_son();
						/* Error for sons_ptr to reference a component	*/
						/*   which contains records rather than key nodes.*/
				go to SKIP_SON;

SON_OK_SO_FAR:			Pnode1 = get_ptr (branch_numb_key_numb);
				if Pfree_nodes ^= null then do;
						/* See if son is a free node.			*/
				     do Ifn = 1 to free_nodes.N while (Pnode1 ^= free_nodes.node(Ifn));
					end;
				     if Ifn <= free_nodes.N then do;
					call tell$free_son();
					go to SKIP_SON;
					end;	/* Error for sons_ptr to reference freed node.	*/
				     end;
				if Pnode1 -> node_block.last_branch_num = 0 then do;
				     call tell$empty_son();
				     go to SKIP_SON;
				     end;		/* Error for sons_ptr to reference an empty node. */

				aki.key = branch_numb_key_str;
						/* Now add key relating this node (parent) to its */
						/*   son.					*/
				aki.descrip = numb_key_numb;
				call iox_$control (Piocb_node_tree, "add_key", addr(aki), code);
				if code = error_table_$key_duplication then do;
				     gki.key = aki.key;
				     call iox_$control (Piocb_node_tree, "get_key", addr(gki), code);
				     if code = 0 then 
				     if gki.descrip ^= 0 then 
					call tell$dup_son_ptr ();
						/* Error if node is son of another parent.	*/
				     else do;	/* If key already exists with zero descriptor,	*/
						/*   that means it was created earlier during	*/
						/*   checking of the sons node.  We'll set the	*/
						/*   key's descriptor to establish parent/son map.*/
					rki.old_descrip = gki.descrip;
					rki.new_descrip = aki.descrip;
					rki.key = aki.key;
					call iox_$control (Piocb_node_tree, "reassign_key",
					     addr(rki), code);
					end;
				     end;
SKIP_SON:				end;
			     end;
			end;
		     end;

		go to NEXT_NODE;			/* All tests passed if we get here.		*/

FAIL6:		call tell ("branch_count > 313", 6);
		go to NEXT_NODE;
		
FAIL7:		call tell ("branch_count < 0", 7);
		go to NEXT_NODE;

FAIL8:		call tell ("start_of_key_region > character position 4096", 8);
		go to NEXT_NODE;
		
FAIL9:		call tell ("start_of_key_region overlays node_block structure", 9);
		go to NEXT_NODE;
		
FAIL10:		call tell ("scattered_free_key_space > 4096-start_of_key_region", 10);
		go to NEXT_NODE;

FAIL11:		call tell ("scattered_free_key_space < 0", 11);
		go to NEXT_NODE;

FAIL12:		call tell ("4096 - start_of_key_region - scattered_free_space ^= sum(key_lengths)", 12);
		go to NEXT_NODE;

FAIL13:		call tell ("Key(" || ltrim(char(Ibranch)) ||
		     ") begins before start_of_key_region", 13);
		go to NEXT_NODE;
		
FAIL14:		call tell ("Key(" || ltrim(char(Ibranch)) ||
		     ") extends beyond end of node", 14);
		go to NEXT_NODE;

FAIL15:		call tell ("Key(" || ltrim(char(Ibranch)) ||
		     ") overlaps storage for other keys in node", 15);
		go to NEXT_NODE;

FAIL16:		call tell ("Key(" || ltrim(char(Ibranch)) || ") > Key(" ||
		     ltrim(char(Ibranch+1)) || ")", 16);
		go to NEXT_NODE;

NEXT_NODE:	end;

	     if Nbad_nodes_in_comp > 0 then		/* Report findings in this component of file.	*/
		call ioa_ ("^/^d bad node^[s^] in comp ^d",
		     Nbad_nodes_in_comp, Nbad_nodes_in_comp^=1, comp_num);
	     end;

	fs_info.info_version = vfs_version_1;
	if Smode.node_tree then do;			/* Now check to be sure that each non-empty	*/
						/*   node but root is son of some parent node.	*/
	     call iox_$control (Piocb_node_tree, "file_status", addr(fs_info), code);
	     call ioa_ ("^/Begin checking references between ^d non-empty tree nodes:",
		fs_info.num_keys);
	     call iox_$position (Piocb_node_tree, -1, 0, code);
	     gki.input_key = FALSE;
	     gki.current = TRUE;
	     call iox_$control (Piocb_node_tree, "get_key", addr(gki), code);
	     Inode = 0;
	     do while (code = 0);
	          Inode = Inode + 1;
	          if mod(Inode,100) = 0 then
		     call ioa_$nnl (" ^d", Inode);
		numb_key_str = gki.key;
		if numb_key_numb = root_numb_key_numb then;
		else if gki.descrip = 0 then 
		     call tell$unreferenced_node();
		call iox_$position (Piocb_node_tree, 0, 1, code);
		if code = 0 then
		     call iox_$control (Piocb_node_tree, "get_key", addr(gki), code);
		end;
	     end;
	call iox_$control (Piocb, "file_status", addr(fs_info), code);
	if Nnon_empty_nodes ^= fs_info.nodes then
	     call tell$bad_node_count_in_header();
	if Nkeys ^= fs_info.num_keys then
	     call tell$bad_key_count_in_header();
	if Nkey_bytes ^= fs_info.key_bytes then
	     call tell$bad_key_byte_count_in_header();

QUIT:	if Nbad_nodes > 0 then			/* Report findings for the entire file.		*/
	     call ioa_ ("^/^d key node^[s were^; was^] damaged.", Nbad_nodes,
	          Nbad_nodes^=1);
	else call ioa_ ("^/No damaged nodes.");
FINISH:	call janitor();
	if ^Scommand then				/* Return true/false when invoked as active fcn.	*/
	     if Nbad_nodes > 0 then
		ret = "true";
	     else ret = "false";
	return;

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


janitor:	proc;

	if Piocb_node_tree ^= null then do;
	     call iox_$close (Piocb_node_tree, code);
	     call iox_$detach_iocb (Piocb_node_tree, code);
	     call iox_$destroy_iocb (Piocb_node_tree, code);
	     call delete_$path (get_pdir_(), "vfbn." || unique, "100100"b, proc, code);
	     end;

	if Piocb ^= null then do;
	     if Sopened then
		call iox_$close (Piocb, code);
	     if Sattached then do;
		call iox_$detach_iocb (Piocb, code);
		call iox_$destroy_iocb (Piocb, code);
		end;
	     end;
	if Pfree_nodes ^= null then
	     call release_temp_segment_ (proc, Pfree_nodes, code);
	if mode_string_info_ptr ^= null then
	     free mode_string_info in (area);

	end janitor;

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


get_ptr:	proc (descriptor) returns(ptr);		/* Given a vfile_ descriptor, this procedure	*/
						/*   returns a corresponding pointer.		*/
    dcl	descriptor		fixed (35);
    dcl	1 desc			like designator_struct aligned based (addr (descriptor));

	if desc.comp_num < lbound(seg_ptr_array,1) then do;
	     call tell$bad_desc ("Bad descriptor ignored", 25, descriptor);
	     return (null);				/* Component number in descriptor must be within	*/
	     end;					/*   bounds of the set_ptr_array in file base.	*/
	if desc.comp_num > hbound(seg_ptr_array,1) then do;
	     call tell$bad_desc ("Descriptor with segno > " || ltrim(char(hbound(seg_ptr_array,1))),
		     26, descriptor);
	     return(null);
	     end;

	return (addr (seg_ptr_array (desc.comp_num) -> seg_array (fixed (desc.offset))));

     end get_ptr;

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


tell:	proc (msg, fail_num);			/* This procedure reports errors on a node-by-node*/
						/*   basis, and managed the request loop.	*/

     dcl	msg			char(*),
	fail_num			fixed bin;
     
	Nbad_nodes = Nbad_nodes + 1;			/* Increment counts and report errors.		*/
	Nbad_nodes_in_comp = Nbad_nodes_in_comp + 1;
	if Stotal then return;
	call ioa_ ("^/ERROR ^d in Comp ^d, node ^d (node_ptr = ^p)
^a
    branch_count = ^d keys
    start_of_key_region = char position ^d
    key_space = ^d chars,
    scattered_free_key_space = ^d chars",
	     fail_num, comp_num, Inode, node_ptr, msg,
	     node_block.last_branch_num, node_block.low_key_pos,
	     4096-node_block.low_key_pos+1, node_block.scat_space);

REQUEST_LOOP:
	if ^Srequest_loop then return;
	on program_interrupt go to INPUT;
INPUT:	call ioa_$nnl ("vfile_find_bad_nodes:  ");
	call iox_$get_line (iox_$user_input, addr(LINE), length(LINE), Lread, code);
	line = ltrim(rtrim(substr(LINE,1,Lread), HT_SP_NL), HT_SP);

	if substr(line,1,2) = ".." then do;
	     substr(line,1,2) = "  ";
	     call cu_$cp (addr(substr(line,1)), length(line), code);
	     go to INPUT;
	     end;
	else if line = "?" then do;
PROMPT:	     call ioa_ ("Respond: quit(q), continue(c), total(tt), ., ?, ..");
	     go to INPUT;
	     end;
	else if line = "q" | line = "quit" then go to QUIT;
	else if line = "c" | line = "continue" then;
	else if line = "tt" | line = "total" then
	     Stotal = TRUE;
	else if line = "." then do;
	     call ioa_ ("vfile_find_bad_nodes 1.0, Referencing ^[file ^a^s^;switch ^s^a^].",
		Spathname, pathname, input_switch_name);
	     go to INPUT;
	     end;
	else do;
	     call ioa_$nnl ("Incorrect response.  ");
	     go to PROMPT;
	     end;
	revert program_interrupt;
	return;

tell$bad_desc:
	entry (msg, fail_num, descriptor);

     dcl	descriptor		fixed bin(35);

	call ioa_ ("^/ERROR ^d in converting record descriptor ^w: ^a",
	     fail_num, descriptor, msg);
	go to REQUEST_LOOP;


tell$bad_free_node:
	entry (msg, fail_num, Pfree_node);

     dcl	Pfree_node		ptr;

	call ioa_ ("^/ERROR ^d in processing free node (node_ptr = ^p): ^a",
	     fail_num, Pfree_node, msg);
	Nbad_nodes = Nbad_nodes + 1;
	go to REQUEST_LOOP;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* The next three error routines simply report errors in the file_base without entering	*/
	/* the request loop.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

tell$bad_key_byte_count_in_header:
	entry();

	call ioa_ ("
ERROR 2, Counted key bytes (^d) ^= file_state_block.total_key_length (^d)
Header of the file (file_base) may have been damaged.",
	     Nkey_bytes, fs_info.key_bytes);
	return;
	

tell$bad_key_count_in_header:
	entry();

	call ioa_ ("
ERROR 3, Counted keys (^d) ^= file_state_block.number_of_keys (^d).
Header of the file (file_base) may have been damaged.",
	     Nkeys, fs_info.num_keys);
	return;


tell$bad_node_count_in_header:
	entry();

	call ioa_ ("
ERROR 1, Counted nodes (^d) ^= index_state_block.number_of_nodes (^d)
Header of the file (file_base) may have been damaged.",
	     Nnon_empty_nodes, fs_info.nodes);
	return;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* The following errors are non-fatal.  Checking of the node containing the error	*/
	/* continues after return from request loop.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

tell$dup_son_ptr:
	entry;

	Nbad_nodes = Nbad_nodes + 1;
	Nbad_nodes_in_comp = Nbad_nodes_in_comp + 1;
	if Stotal then return;
	save_numb_key_numb = numb_key_numb;
	Pnode1 = get_ptr (aki.descrip);
	Pnode2 = get_ptr (gki.descrip);
	call ioa_ ("
ERROR 22 in Comp ^d, node ^d (node_ptr = ^p)", comp_num, Inode, node_ptr);
	numb_key_numb = aki.descrip;
	numb_key.node = divide(numb_key.node, 1024, 18, 0) + 1;
	call ioa_ ("Branch ^d has same sons_ptr (node_block.branch)
            Comp ^d, node ^d (node_ptr = ^p)",  numb_key.comp, numb_key.node, Pnode1);
	numb_key_numb = gki.descrip;
	numb_key.node = divide(numb_key.node, 1024, 18, 0) + 1;
	call ioa_ ("         as Comp ^d, node ^d (node_ptr = ^p)", numb_key.comp, numb_key.node, Pnode2);
	numb_key_numb = save_numb_key_numb;
	go to REQUEST_LOOP;

tell$empty_son:
	entry();

	Nbad_nodes = Nbad_nodes + 1;
	Nbad_nodes_in_comp = Nbad_nodes_in_comp + 1;
	if Stotal then return;
	save_numb_key_numb = numb_key_numb;
	numb_key_numb = gki.descrip;
	numb_key.node = divide(numb_key.node, 1024, 18, 0) + 1;
	Pnode1 = get_ptr (gki.descrip);
	call ioa_ ("
ERROR 18 in Comp ^d, node ^d (node_ptr = ^p)
Branch ^d has sons_ptr (node_block.branch) pointing to an empty node
            Comp ^d, node ^d (node_ptr = ^p)",
	     comp_num, Inode, node_ptr, Ibranch,
	   numb_key.comp, numb_key.node, Pnode1);
	numb_key_numb = save_numb_key_numb;
	go to REQUEST_LOOP;

tell$free_son:
	entry ();

	Nbad_nodes = Nbad_nodes + 1;
	Nbad_nodes_in_comp = Nbad_nodes_in_comp + 1;
	if Stotal then return;
	save_numb_key_numb = numb_key_numb;
	numb_key_numb = gki.descrip;
	numb_key.node = divide(numb_key.node, 1024, 18, 0) + 1;
	Pnode1 = get_ptr (gki.descrip);
	call ioa_ ("
ERROR 19 in Comp ^d, node ^d (node_ptr = ^p)
Branch ^d has sons_ptr (node_block.branch) which is a freed node
	  Comp ^d, node ^d (node_ptr = ^p)",
	     comp_num, Inode, node_ptr, Ibranch, numb_key.comp,
	   numb_key.node, Pnode1);
	numb_key_numb = save_numb_key_numb;
	go to REQUEST_LOOP;


tell$non_node_comp_son:
	entry ();

	Nbad_nodes = Nbad_nodes + 1;
	Nbad_nodes_in_comp = Nbad_nodes_in_comp + 1;
	if Stotal then return;
	save_numb_key_numb = numb_key_numb;
	numb_key_numb = gki.descrip;
	numb_key.node = divide(numb_key.node, 1024, 18, 0) + 1;
	Pnode1 = get_ptr (gki.descrip);
	call ioa_ ("
ERROR 17 in Comp ^d, node ^d (node_ptr = ^p)
Branch ^d has sons_ptr (node_block.branch) pointing to non-node component
            Comp ^d, node ^d (node_ptr = ^p)",
	     comp_num, Inode, node_ptr, Ibranch, numb_key.comp,
	     numb_key.node, Pnode1);
	numb_key_numb = save_numb_key_numb ;
	go to REQUEST_LOOP;

tell$root_sons_ptr:
	entry();

	Nbad_nodes_in_comp = Nbad_nodes_in_comp + 1;
	Nbad_nodes = Nbad_nodes + 1;
	if Stotal then return;
	Pnode1 = get_ptr (branch_numb_key_numb);
	branch_numb_key.node = divide(branch_numb_key.node, 1024, 18, 0) + 1;
	call ioa_ ("
ERROR 20 in Comp ^d, node ^d (node_ptr = ^p)
Branch ^d sons_ptr (node_block.branch) points to root node
            Comp ^d, node ^d (node_ptr = ^p)",
	     comp_num, Inode, node_ptr, Ibranch, branch_numb_key.comp,
	     branch_numb_key.node, Pnode1);
	go to REQUEST_LOOP;


tell$unreferenced_node:
	entry();

	Nbad_nodes = Nbad_nodes + 1;
	if Stotal then return;
	node_ptr = get_ptr (numb_key_numb);
	call ioa_ ("
ERROR 21, Comp ^d, node ^d (node_ptr = ^p) never referenced by 
superior node and it is not the root node.",
	     numb_key.comp, divide(numb_key.node,1024,18,0) + 1, node_ptr);
	go to REQUEST_LOOP;

	end tell;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include ak_info;

    dcl	1 aki			aligned,
	  2 header		like ak_header,
	  2 key			char(4),
	1 gki			aligned,
	  2 header		like gk_header,
	  2 key			char(4),
	1 rki			aligned,
	  2 header		like rk_header,
	  2 key			char(4);

%include mode_string_info;

%include iocb;

%include iox_modes;

%include vfile_indx;

%include vfs_info;

    dcl	1 fs_info			aligned like indx_info,
	info			fixed bin;

	end vfile_find_bad_nodes;


		    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