



		    cref_analyze_.pl1               01/11/83  1527.2rew 01/11/83  1505.8      245916



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


/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */

cref_analyze_: procedure (ename_arg, first_pass);

/* This crossreferencer module digs into object segs and analyzes their
   definitions and links. */

/* Modified 740401 by Paul Green to allow type-6 links
   Modified 750414 by PG to handle type-6 links of form a$
   Much renovated by C. D. Tavares 03/04/76 for environments, 2-pass operation,
   etc.
   Modified by CDT 08/31/76 to use renamed MBZ fields in new linkdcl.incl.pl1
   Modified 09/81 by CDT to track source language suffix.
   Modified November 1982 by CAH to fix bindfile parse.
   Modified January 1983 by BIM to fix bug uncovered by CAH; legal characters
   were rejected in bindfiles.
*/

/* parameters */

dcl  (ename_arg	        char (*),
     first_pass	        bit (1) aligned) parameter;

/* entries */

dcl  com_err_	        entry options (variable),
     cref_filegen_$report_error
		        entry options (variable),
     archive_util_$first_element
		        entry (ptr, fixed bin (35)),
     archive_util_$next_element
		        entry (ptr, fixed bin (35)),
     object_info_$display   entry (ptr, fixed bin (24), ptr, fixed bin (35)),
     decode_definition_$decode_cref
		        entry (ptr, ptr, bit (1) aligned, ptr),
     hcs_$terminate_noname  entry (pointer, fixed bin (35)),
     hcs_$initiate_count    entry (char (*), char (*), char (*),
		        fixed bin (24), fixed bin, ptr, fixed bin (35));

dcl  cref_listman_$get_name entry (pointer) returns (char (32) varying),
     cref_listman_$create_primary_block_char
		        entry (char (*) varying, pointer, pointer, pointer,
		        bit (1) aligned, bit (1) aligned, bit (1) aligned)
		        returns (pointer),
     cref_listman_$predefine_primary_block_char
		        entry (char (*) varying, pointer, pointer,
		        bit (1) aligned, bit (1) aligned, bit (1) aligned)
		        returns (pointer),
     cref_listman_$create_primary_block_acc
		        entry (pointer, pointer, pointer, bit (1) aligned,
		        bit (1) aligned, bit (1) aligned)
		        returns (pointer),
     cref_listman_$create_syn_block
		        entry (char (*) varying, pointer, pointer,
		        bit (1) aligned, pointer),
     cref_listman_$create_environment
		        entry (char (*) varying, bit (1) aligned)
		        returns (pointer),
     cref_listman_$assign_def_block
		        entry (pointer dimension (*), fixed bin, pointer),
     cref_listman_$assign_ref_block
		        entry (pointer dimension (*), fixed bin, pointer),
     cref_listman_$create_include_file_block
		        entry (char (*) varying, bit (72) aligned)
		        returns (pointer),
     cref_listman_$assign_include_file_block
		        entry (pointer dimension (*), fixed bin, pointer);

/* automatic */

dcl  bindfile_char_count    fixed bin (24);

dcl  external_names	        (500) char (32),
     n_external_names       fixed bin;

dcl  1 oi		        aligned like object_info;

dcl  array	        (1000) pointer,
     array_count	        fixed bin,
     offset	        fixed bin (18);

dcl  dirname	        char (168),
     ename	        char (32),
     varying_segname        char (32) varying,
     varying_dir_description
		        char (168) varying,
     component_name	        char (32) varying;

dcl  i		        fixed bin;

dcl  1 arg_structure        aligned,
       2 next_def	        ptr,
       2 last_def	        ptr,
       2 block_ptr	        ptr,
       2 section	        char (4) aligned,
       2 offset	        fixed bin,
       2 entrypoint	        fixed bin,
       2 acc_ptr	        ptr;

dcl  acc_ptr	        ptr,
     linkage_header_ptr     ptr,
     definitions_ptr        ptr,
     seg_ptr	        pointer,
     component_ptr	        pointer,
     nomore	        bit (1) aligned,
     none_found	        bit (1) aligned,
     links_end	        fixed bin (18),
     (link_ptr, type_ptr)   ptr,
     (ltype, dir_idx)       fixed bin (18),
     component_node	        pointer,
     boundseg_node	        pointer,
     dir_node	        pointer,
     code		        fixed bin (35);

dcl  is_external	        bit (1) aligned,
     bitcount	        fixed bin (24);

dcl  (segref_name, defref_name) char (32) varying;

dcl  1 acc_string	        aligned based (acc_ptr),
       2 acclen	        fixed bin (9) unaligned unsigned,
       2 string	        char (acc_string.acclen) unaligned;

/* builtins */

dcl  (addr, addrel, binary,
     divide, empty, hbound,
     index, null, length,
     pointer, reverse, rtrim,
     search, substr, verify) builtin;

dcl  cref_abort_	        condition;

/* external static */

dcl  (error_table_$noalloc,
     error_table_$bad_segment,
     error_table_$noentry)  fixed bin (35) external static;

/* based */

dcl  1 search_dir_struc     aligned based (search_dir_ptr),
       2 make_all_names_external
		        bit (1) aligned,
       2 max_dirs	        fixed bin,
       2 n_dirs	        fixed bin,
       2 item	        (0 refer (search_dir_struc.n_dirs)),
         3 search_dirs      char (168),
         3 search_dir_descriptions
		        char (168) varying;

dcl  search_dir_ptr	        pointer static;

dcl  based_word	        bit (36) aligned based;

dcl  1 archive_header       based (component_ptr) aligned,
       2 pad0	        char (12) unal,
       2 name	        char (32) unal,
       2 pad1	        char (40) unal,
       2 bitcnt	        char (8) unal,
       2 pad2	        char (8) unal,
       2 data	        char (1) unal;

/* include files */

%include object_info;
%include linkdcl;

/* The following include file (source_map) has been copied and modified,
   rather than using the include file because the include file doesn't work
   when source maps occur on odd word boundaries (inside archives) - dtm is
   declared there as fixed bin (71), and gets even-word fetched whether it's
   there or not */

dcl  1 source_map	        aligned based (source_map_p),
       2 version	        fixed bin,
       2 number	        fixed bin,
       2 map	        (0 refer (source_map.number)) aligned,
         3 pathname	        unaligned,
	 4 offset	        bit (18),
	 4 size	        bit (18),
         3 uid	        bit (36),
         3 dtm	        bit (72);

dcl  source_map_p	        pointer,
     source_path_ptr        ptr,
     source_path_len        fixed bin,
     source_path	        char (source_path_len) based (source_path_ptr);
%page;
/* initialize random state variables */

	bindfile_char_count = 0;
	n_external_names = 0;
	oi.version_number = object_info_version_2;
	seg_ptr = null;
	ename = ename_arg;

	none_found = "1"b;


/* Search for this module in all the search directories */

	if search_dir_struc.n_dirs < 1 then do;
		call com_err_ (0, "cref_analyze_",
		     "No search list specified for segment ^a.", ename);
		goto signal_abort;
	     end;

	do dir_idx = 1 to search_dir_struc.n_dirs;

	     varying_segname = rtrim (ename);
	     dirname = search_dirs (dir_idx);

	     call hcs_$initiate_count
		(dirname, ename, "", bitcount, 0, seg_ptr, code);

	     if seg_ptr = null then
		if code = error_table_$noentry then ;	/* well, ok */
		else goto crump;			/* oh oh */

	     else do;				/* we found it */
		     none_found = ""b;
		     varying_dir_description =
			search_dir_descriptions (dir_idx);

		     call process_segment;

		     call hcs_$terminate_noname (seg_ptr, code);

/* Even if found, keep looping to search other dirs unless user said -first */

		     if first_switch then return;
		end;
	end;

	if none_found then
crump:
	     if first_pass then
		call com_err_ (code, "cref_analyze_", ename);

/* We know code is error_table_$noentry at this point.  This is non-fatal */

	return;

returner:
	call hcs_$terminate_noname (seg_ptr, code);
	return;
%page;
process_segment: proc;

	dir_node =
	     cref_listman_$create_environment
	     (varying_dir_description, "1"b);

/* Ignore names of the form "mumble.1"-- this is garbage left by update_seg */

	if length (varying_segname) > length (".1") then
	     if substr (varying_segname,
		length (varying_segname) - 1, 1) = "." then
		if search (substr (varying_segname,
		     length (varying_segname), 1), "0123456789") > 0 then
		     return;

/* Ignore unique names (same reason) */

	if substr (varying_segname, 1, 1) = "!" then return;


/* Now see if the segment we're examining is an archive or standalone.  Process
   each as they deserve. */

	if contains_suffix (varying_segname, ".archive") then do;

		varying_segname =
		     substr (varying_segname, 1,
		     length (varying_segname) - length (".archive"));

/* Check for componented object archives (with names of the form bound_foo_.1,
   bound_foo_.2, etc.  Treat as one archive. */

		i = index (reverse (varying_segname), ".");
		if i > 0 then
		     if verify (reverse (varying_segname), "0123456789")
			= i then
			varying_segname = substr (varying_segname, 1,
			     length (varying_segname) - i);

		if first_pass then
		     call find_bindfile (seg_ptr, varying_segname);

/* The environment of all these components will be the bound segment name and
   the dir description */

		boundseg_node = cref_listman_$create_environment
		     (varying_segname, (bindfile_char_count > 0));

/* Add all synonyms for all components */

		if bindfile_char_count > 0 then call add_bindfile_synonyms;

/* Loop through all components, examining their definitions and links */

		component_ptr = seg_ptr;

		call archive_util_$first_element (component_ptr, code);
		if code ^= 0 then do;
			call com_err_ (code, "cref_analyze_",
			     "Archive format error in ^a.", ename);
			return;
		     end;

		do while (code ^= 1);

/* (which is archive_util_'s clever way of saying it's done) */

		     component_name = rtrim (archive_header.name);

/* Try not to process bindfiles! */

		     if ^contains_suffix (component_name, ".bind") then
			call process_component
			     (component_name, addr (archive_header.data),
			     binary (bitcnt), "1"b);

		     call archive_util_$next_element (component_ptr, code);
		end;
	     end;


/* Otherwise, segment is not an archive. */

	else do;
		boundseg_node = stand_alone_node;

		call process_component
		     (varying_segname, seg_ptr, bitcount, ""b);
	     end;

	return;

     end process_segment;
%page;
process_component: proc (module_name, module_ptr, bitcount, is_archive);

dcl  module_name	        char (*) varying parameter,
     module_ptr	        pointer parameter,
     bitcount	        fixed bin (24) parameter,
     is_archive	        bit (1) aligned parameter;

dcl  hcs_$status_	        entry (char (*), char (*), fixed bin, pointer,
		        pointer, fixed bin (35));

dcl  1 branch_info	        aligned,
       2 type	        bit (2) unaligned,
       2 n_names	        fixed bin (15) unaligned,
       2 names_relp	        bit (18) unaligned,
       2 (dtm, dtu)	        bit (36) unaligned,
       2 mode	        bit (5) unaligned,
       2 pad	        bit (13) unaligned,
       2 records	        fixed bin (17) unaligned;

dcl  name_area	        area (2000);

dcl  names	        (branch_info.n_names) char (32) aligned
		        based (names_ptr),
     names_ptr	        pointer;

dcl  varying_addname        char (32) varying,
     (i, j)	        fixed bin;

dcl  lang_suffix_node       pointer;


/* Get information about object seg. */

	call object_info_$display
	     (module_ptr, bitcount, addr (oi), code);
	if code ^= 0 then do;
		if first_pass then do;
			call cref_filegen_$report_error
			     (code, "cref_analyze_",
			     "^a is non-object.", module_name);
			component_node =
			     cref_listman_$create_primary_block_char
			     (module_name, non_object_node, (dir_node),
			     null, "1"b, "1"b, "1"b); /* do anyway */
		     end;
		return;
	     end;

	if oi.bound then do;

/* A crossref of bound segments is useless, because you can no longer tell
   which outward links are used by which components.  */

		if first_pass then
		     call cref_filegen_$report_error
			(error_table_$bad_segment, "cref_analyze_",
			"^a is bound.", module_name);
		return;
	     end;

	if is_archive then
	     is_external = check_external_name (module_name);
	else is_external = "1"b;

/* Get language suffix if available (some translators like lisp skip it) */

	lang_suffix_node = null;

	if oi.source_map > 0 then do;
		source_map_p = addrel (oi.symbp, oi.source_map);
		source_path_ptr = addrel (oi.symbp,
		     source_map_p -> source_map.offset (1));
		source_path_len =
		     binary (source_map_p -> source_map.size (1));
		i = source_path_len + 2
		     - index (reverse (source_path), ">");
		j = index (substr (source_path, i), ".");
		if j >= 0 then
		     lang_suffix_node = cref_listman_$create_environment
			(substr (source_path, i + j - 1), "0"b);
	     end;

	else source_map_p = null;

/* Enter this name into the Big Book */

	component_node = cref_listman_$create_primary_block_char
	     (module_name, boundseg_node, dir_node, lang_suffix_node,
	     "1"b, first_pass, is_external);


/* Get the info we need on both passes to munch this module */

	linkage_header_ptr = oi.linkp;
	definitions_ptr = oi.defp;

	call decode_definition_$decode_cref
	     (definitions_ptr, addr (arg_structure), nomore,
	     linkage_header_ptr);


	if first_pass then do;

/* On the first pass, we record all necessary synonyms and all existing
   definitions (entrypoints). */

		if ^is_archive then do;

/* Use any added names on the segment as synonyms */

			call hcs_$status_
			     (dirname, ename, 1, addr (branch_info),
			     addr (name_area), code);
			if code ^= 0 then goto crump;

			names_ptr = pointer
			     (addr (name_area), branch_info.names_relp);

/* format: ind3 */

			do i = 1 to branch_info.n_names;
			   if names (i) ^= ename then do;
			         varying_addname = rtrim (names (i));

			         call cref_listman_$create_syn_block
				  (varying_addname, boundseg_node,
				  dir_node, "1"b, component_node);
			      end;
			end;

/* format: revert */

			free names in (name_area);

		     end;


/* Record all external definitions into this object segment. */

		array_count = 0;

		do while (nomore = "0"b);

		     if (section = "text") |
			(section = "link") then do;

			     array_count = array_count + 1;

			     if array_count > hbound (array, 1) then do;
				     explanation = "definitions";
				     goto out_of_space;
				end;

/* Record this definition */
			     array (array_count) =
				cref_listman_$create_primary_block_acc
				(arg_structure.acc_ptr, component_node,
				dir_node, ""b, "1"b, ""b);
			end;

/* Find next definition */

		     call decode_definition_$decode_cref
			(arg_structure.next_def,
			addr (arg_structure), nomore, null);
		end;

		if array_count > 0 then
		     call cref_listman_$assign_def_block
			(array, array_count, component_node);


/* Now get info about include files if requested */

		if (do_include_files & source_map_p ^= null) then do;

			array_count =
			     source_map_p -> source_map.number - 1;

			if array_count > hbound (array, 1) then do;
				explanation = "include files";
				goto out_of_space;
			     end;

/* Start from 2 (1 is the program's own source) */

			do i = 2 to source_map_p -> source_map.number;

			     source_path_ptr = addrel (oi.symbp,
				source_map_p -> source_map.offset (i));
			     source_path_len = binary
				(source_map_p -> source_map.size (i));

/* Strip off dirname */

			     j = source_path_len + 2
				- index (reverse (source_path), ">");

			     array (i - 1) =
				cref_listman_$create_include_file_block
				(substr (source_path, j),
				source_map_p -> source_map.dtm (i));
			end;

			if array_count > 0 then
			     call cref_listman_$assign_include_file_block
				(array, array_count, component_node);

		     end;

		return;
	     end;


	else do;

/* Pass two: record all links denoting outward references from this object
   segment.  */

		array_count = 0;

/* Avoid refugee definitions ("movdef") in linkage section */

		if linkage_header_ptr -> virgin_linkage_header.defs_in_link
		     = "010000"b then
		     links_end = binary (linkage_header_ptr ->
			virgin_linkage_header.def_offset) - 2;

		else links_end = binary (linkage_header_ptr ->
			virgin_linkage_header.linkage_section_lng) - 2;

		do offset =
		     binary (linkage_header_ptr -> header.begin_links)
		     to links_end by 2;

		     link_ptr = addrel (linkage_header_ptr, offset);

/* link.ft2 should be unsnapped link (46 octal) */

		     if link_ptr -> link.ft2 = "46"b3 then do;
			     type_ptr = addrel (definitions_ptr,
				addrel (definitions_ptr, link_ptr ->
				link.exp_ptr) -> exp_word.type_ptr);

			     ltype = binary (type_ptr -> type_pair.type);

			     if ltype < 1 then goto bad_link_type;
			     if ltype > 6 then goto bad_link_type;

/* Get pointer to ACC string with segname in it */

			     acc_ptr = addrel (definitions_ptr,
				type_ptr -> type_pair.seg_ptr);

/* format: comcol40 */

			     goto record_link_segref (ltype);


record_link_segref (1):	         /* myself$ */
record_link_segref (5):	         /* myself$entry */

/* Check for special "*system" link */

			     if binary
				(type_ptr -> type_pair.seg_ptr) = 5
			     then segref_name = "*system";
			     else segref_name = module_name;
			     goto record_link_segref_common;

record_link_segref (3):	         /* segname$ */
record_link_segref (4):	         /* segname$entry */
record_link_segref (6):	         /* either, create-if-not-found */
			     segref_name = acc_string.string;

record_link_segref_common:
			     array_count = array_count + 2;
			     if array_count > hbound (array, 1) then do;
				     explanation = "links";
				     goto out_of_space;
				end;
			     array (array_count - 1) =
				cref_listman_$create_primary_block_char
				(segref_name, boundseg_node, dir_node,
				null, "1"b, ""b, ""b);


/* Get pointer to ACC entryname, if it exists */

			     acc_ptr = addrel (definitions_ptr,
				type_ptr -> type_pair.ext_ptr);

			     goto record_link_defref (ltype);

record_link_defref (6):	         /* either, create-if-not-found */
			     if type_ptr -> type_pair.ext_ptr = ""b then
				goto link_has_no_defname;

			     if acc_ptr -> based_word = ""b then
				goto link_has_no_defname;

record_link_defref (4):	         /* segname$entry */
record_link_defref (5):	         /* myself$entry */
link_has_defname:
			     defref_name = acc_string.string;
			     goto record_link_defref_common;

record_link_defref (1):	         /* myself$ */
record_link_defref (3):	         /* segname$ */
link_has_no_defname:
			     defref_name = segref_name || "$";

record_link_defref_common:
			     array (array_count) =
				cref_listman_$create_primary_block_char
				(defref_name, array (array_count - 1),
				dir_node, null, ""b, ""b, ""b);

			     goto do_next_link;

record_link_segref (2):	         /* obsolete, ITB link */
record_link_defref (2):
bad_link_type:
			     call cref_filegen_$report_error
				(0, "cref_analyze_",
				"Invalid link type ^d found in ""^a""",
				ltype, module_name);
do_next_link:
			end;
		end;

/* format: revert */

		if array_count > 0 then
		     call cref_listman_$assign_ref_block
			(array, array_count, component_node);

		return;
	     end;

     end process_component;
%skip (5);
out_of_space:

dcl  explanation	        char (32);

	call com_err_ (error_table_$noalloc, "cref_analyze_",
	     "Internal table overflow while processing ^a in component ^a",
	     explanation, cref_listman_$get_name (component_node));
signal_abort:
	signal cref_abort_;
	goto signal_abort;
%page;
add_bindfile_synonyms: proc;

dcl  name		        char (32) varying;

dcl  token_pos	        fixed bin (21),
     token	        char (32) varying;

dcl  alphabetics	        char (84) static options (constant) initial
		        ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_$0123456789.?/*&^%#@!{}'\|+=-`~"); /* binder and this should take doubled quotes, but since bind dont, we dont have to */

dcl  i		        fixed bin;

dcl  master_node	        pointer;

dcl  is_external	        bit (1) aligned,
     no_synonyms	        bit (1) aligned static;

	if bindfile_char_count = 0 then return;
	if no_synonyms then return;

/* Initialize for token parse */

	token_pos = 1;
	token = "";

/* Scan bindfile until it ends */

/* format: ind3 */

	do while ("1"b);

/* Find next objectname statement */

	   i = index (substr (bindfile, token_pos), "objectname") - 1;

	   if token ^= "objectname" then do;
	         if i < 0 then return;
	         token_pos = token_pos + i + length ("objectname");
	      end;

	   token = get_token ();
	   if token = ":" then do;

/* Record component name */

	         name = get_token ();

	         master_node =
		  cref_listman_$predefine_primary_block_char
		  (name, boundseg_node, dir_node, "1"b, first_pass,
		  check_external_name (name));

	         call flush;			/*  to a ";" */

/* Now search for "synonym:" */

	         token = get_token ();

	         do while (token ^= "objectname");
		  if token ^= "synonym" then call flush;

		  else if get_token () ^= ":" then call flush;

		  else do;

		        token = ",";

		        do while (token = ",");
			 token = get_token ();

			 if all_names_external then
			      is_external = "1"b;

			 else do;
			       do i = 1 to n_external_names
				while (external_names (i)
				^= token);
			       end;

			       if i <= n_external_names then
				  is_external = "1"b;
			       else is_external = ""b;
			    end;

/* Record this synonym */

			 call cref_listman_$create_syn_block
			    (token, boundseg_node, dir_node,
			    is_external, master_node);


			 token = get_token ();	/* "," or ";" */
		        end;

		        if token ^= ";" then do;
			    call com_err_ (0, "cref_analyze_",
			       "Unrecoverable error parsing ^a for ^a",
			       "bindfile", name);
			    goto signal_abort;
			 end;
		     end;

		  token = get_token ();
	         end;
	      end;

	end;

/* format: revert */

return_from_syn_search: return;
%skip (5);
flush: proc;

dcl  i		        fixed bin (21),
     in_comment	        bit (1),
     token	        char (32) varying;

	i = index (substr (bindfile, token_pos), ";");
	if i = 0 then goto return_from_syn_search;

	token_pos = token_pos + i;
	return;

get_token: entry returns (char (32) varying);

dcl  separators	        char (3) static initial ("
	 ");					/* NL, tab, SP */

	in_comment = "1"b;

	do while (in_comment);
	     i = verify (substr (bindfile, token_pos), separators) - 1;
	     if i < 0 then goto return_from_syn_search;
	     token_pos = token_pos + i;

	     if substr (bindfile, token_pos, 2) = "/*" then do;
		     i = index (substr (bindfile, token_pos), "*/");
		     if i = 0 then goto return_from_syn_search;
		     token_pos = token_pos + i + 1;
		end;

	     else in_comment = ""b;
	end;

	i = verify (substr (bindfile, token_pos), alphabetics) - 1;
	if i = -1 then i = bindfile_char_count - token_pos + 1;
	else if i = 0 then i = 1;
	token = substr (bindfile, token_pos, i);
	token_pos = token_pos + i;
	return (token);

     end flush;
%skip (5);
find_bindfile: entry (archive_ptr, archive_name);

dcl  archive_ptr	        pointer parameter,
     archive_name	        char (*) varying;

dcl  header_p	        pointer,
     archive_util_$first_disected
		        entry (ptr, ptr, char (32), fixed bin (24),
		        fixed bin (35)),
     archive_util_$disected_element
		        entry (ptr, ptr, char (32), fixed bin (24),
		        fixed bin (35));

dcl  code		        fixed bin (35),
     bitcount	        fixed bin (24),
     component_name	        char (32),
     bindfile_ptr	        pointer static,
     bindfile	        char (bindfile_char_count) based (bindfile_ptr);


	header_p = archive_ptr;
	bindfile_char_count = 0;
	n_external_names = 0;
	no_synonyms = ""b;
	all_names_external = make_all_names_external;

	call archive_util_$first_disected
	     (header_p, bindfile_ptr, component_name, bitcount, code);

/* Find bindfile */

	do while (code = 0);
	     if index (component_name, ".bind") ^= 0 then
		code = 1;
	     else call archive_util_$disected_element
		     (header_p, bindfile_ptr, component_name, bitcount, code);
	end;

	if bindfile_ptr = null then return;

/* Found bindfile.  Examine it. */

	bindfile_char_count = divide (bitcount, 9, 21, 0);

	if index (bindfile, "synonym") = 0 then
	     no_synonyms = "1"b;

	if all_names_external then return;

	token_pos = 1;
	token = "";

	do while (token ^= ":");

/* Makes sure we pick up "Addname:", not just "Addname" */

	     do while (get_token () ^= "Addname");

/* If we run out of bindfile, get_token will do a non-local return anyway */

	     end;

	     token = get_token ();

	     if token = ";" then do;			/* "Addname;" */
		     all_names_external = "1"b;
		     return;
		end;
	end;

/* We have an "Addname:" statement. */

	do while (token ^= ";");
	     n_external_names = n_external_names + 1;
	     if n_external_names > hbound (external_names, 1) then do;
		     call com_err_ (0, "cref_analyze_",
			"More than ^d addnames in bindfile for ^a.",
			n_external_names - 1, archive_name);
		     goto signal_abort;
		end;

	     external_names (n_external_names) = get_token ();
	     token = get_token ();
	end;

	return;
%skip (5);
check_external_name: entry (testname) returns (bit (1) aligned);

dcl  testname	        char (*) varying;

dcl  all_names_external     bit (1) aligned static;

	if all_names_external then return ("1"b);
	if bindfile_char_count = 0 then return (""b);

	do i = 1 to n_external_names;
	     if external_names (i) = testname then return ("1"b);
	end;

	return (""b);
     end add_bindfile_synonyms;
%skip (5);
contains_suffix: proc (name, suffix) returns (bit (1));

dcl  (name	        char (*) varying,
     suffix	        char (*)) parameter;

	if length (name) ^> length (suffix) then
	     return ("0"b);
	if index (name, suffix) ^=
	     length (name) - length (suffix) + 1 then
	     return ("0"b);
	return ("1"b);
     end contains_suffix;
%skip (5);
init: entry (first_switch_arg, include_file_switch_arg, search_dir_ptr_arg);

dcl  (first_switch_arg,
     include_file_switch_arg) bit (1),
     search_dir_ptr_arg     pointer,
     (first_switch,
     do_include_files)      bit (1) aligned static;
dcl  (stand_alone_node,
     non_object_node)       pointer static;


/* If first_sw = "1"b, we stop after finding first occurrence of an entryname
   in any of the search dirs,  If not, we seek ALL occurrences. */

	first_switch = first_switch_arg;

	do_include_files = include_file_switch_arg;
	search_dir_ptr = search_dir_ptr_arg;

	stand_alone_node = cref_listman_$create_environment
	     ("STAND-ALONE", "1"b);
	non_object_node = cref_listman_$create_environment
	     ("NON-OBJECT", "1"b);
	return;

     end cref_analyze_;




		    cref_filegen_.pl1               04/01/85  0811.8rew 03/28/85  0711.7      197010



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


/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5,ind3 */
cref_filegen_: proc (output_seg_ptr_arg, msf_fcb_ptr_arg);

/* This module simply converts all the data in the cross-referencer's
   database into a printable file.

   Completely rewritten 02/03/76 by C. D. Tavares
   Modified 11/19/76 by CDT to allow output to be an MSF.
   Last modified 12/06/80 by CDT to fix bug where random entrypoints of
   non-located modules were being printed without "(?)" after them.
   Modified: 25 March 1985 by G. Palter to fix the bug which causes cref
   to generate a component full of nulls under very rare circumstances.
*/


dcl  output_seg_ptr_arg     pointer parameter,
     msf_fcb_ptr_arg        pointer parameter;

dcl  output_seg_ptr	        pointer,
     msf_fcb_ptr	        pointer;

dcl  output_seg	        char (max_char_count) based (output_seg_ptr),
     max_char_count	        fixed bin (21) initial (sys_info$max_seg_size * 4),
     sys_info$max_seg_size  ext fixed bin (35);

dcl  (char_position,
     line_position,
     last_blackspace)       fixed bin (21),
     cur_component	        fixed bin,
     node		        pointer,
     is_synonym	        bit (1) aligned,
     bucket	        fixed bin;

dcl  (adde, divide, index,
     length, max, mod, null,
     string, substr, unspec) builtin;

dcl  cref_listman_$get_consecutive_segnames
		        entry (pointer, fixed bin) returns (pointer),
     cref_listman_$get_primary_block_long
		        entry (pointer, char (32) varying dimension (*),
		        fixed bin, bit (1) aligned, char (*) varying,
		        char (*) varying),
     cref_listman_$get_defs entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$get_implicit_defs
		        entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$get_name entry (pointer) returns (char (32) varying),
     cref_listman_$get_name_with_suffix
		        entry (pointer) returns (char (32) varying),
     cref_listman_$get_crossrefs
		        entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$get_consecutive_include_files
		        entry (pointer, fixed bin, char (*) varying,
		        bit (72)) returns (pointer),
     cref_listman_$get_include_file_crossrefs
		        entry (pointer, pointer dimension (*), fixed bin);

dcl  include_file_name      char (32) varying,
     date_time_modified     bit (72);

dcl  msf_manager_$get_ptr   entry (pointer, fixed bin, bit (1) aligned,
		        pointer, fixed bin (24), fixed bin (35)),
     msf_manager_$adjust    entry (pointer, fixed bin, fixed bin (24),
		        bit (3) aligned, fixed bin (35)),
     hcs_$truncate_seg      entry (pointer, fixed bin (19), fixed bin (35));

dcl  char_dtm	        char (24);

dcl  date_time_	        entry (bit (72), char (*));

dcl  cref_filegen_$report_error
		        entry options (variable);


dcl  error_table_$no_ext_sym
		        fixed bin (35) static external;

dcl  dir_name	        char (168) varying,
     bound_seg_name	        char (32) varying,
     environment_description
		        char (200) varying;

dcl  (i, j, k)	        fixed bin;

dcl  form_feed	        char (1);

dcl  default_max_line_position
		        fixed bin static options (constant) init (132),
     max_line_position      fixed bin static;

dcl  name_list	        (100) char (32) varying,
     explanation	        char (32) varying,
     n_names	        fixed bin;


dcl  def_array_len	        fixed bin,
     crossref_array_len     fixed bin;

dcl  large_strucp	        pointer static initial (null);

dcl  1 large_struc	        based (large_strucp) aligned,
       2 ndefs	        fixed bin,
       2 def_array	        (NDEFS refer (ndefs)) pointer,
       2 def_ok	        (NDEFS refer (ndefs)) bit (1) unaligned,
       2 crossref_array     (NDEFS refer (ndefs)) pointer,
       2 names	        (NDEFS refer (ndefs)) char (32) varying,
       2 sort_structure     aligned,
         3 n_elements       fixed bin (24),
         3 name_ptrs        (NDEFS refer (ndefs)) ptr unaligned,
       2 index_structure    aligned,
         3 n_elements       fixed bin (24),
         3 indices	        (NDEFS refer (ndefs)) fixed bin (24);

dcl  NDEFS	        fixed bin static initial (2000) options (constant);

dcl  (seg_was_found,
     should_complain)       bit (1) aligned,
     defname	        char (32) varying;

dcl  moby_bar	        char (20) varying static initial ((20)"-");

dcl  (left_margin	        initial (0),
     any_margin	        initial (1000),
     def_margin	        initial (1),
     syn_margin	        initial (30),
     title_margin	        initial (20),
     crossref_margin        initial (20)) fixed bin static;

dcl  bar_margin	        fixed bin,
     interstice	        fixed bin;

dcl  com_err_	        entry options (variable),
     cref_abort_	        condition;

dcl  code		        fixed bin (35);
%page;
      output_seg_ptr = output_seg_ptr_arg;
      msf_fcb_ptr = msf_fcb_ptr_arg;

      char_position = 1;
      cur_component = 0;
      last_blackspace = 1;
      line_position = 1;

      bar_margin = max_line_position - length (moby_bar);
      interstice = max_line_position - 2 * length (moby_bar);

      unspec (form_feed) = "014"b3;

      node = null;
      bucket = 0;

      node = cref_listman_$get_consecutive_segnames (node, bucket);

      do while (node ^= null);

         seg_was_found = ""b;

/* Get all the good dirt about this entry */

         call cref_listman_$get_primary_block_long
	    (node, name_list, n_names, is_synonym, dir_name, bound_seg_name);

         if n_names < 0 then do;
	     explanation = "synonyms";
	     goto out_of_room;
	  end;

         environment_description = "";

         if bound_seg_name = "" then if dir_name = "" then
	     environment_description = "***** NOT FOUND *****";

         if is_synonym then seg_was_found = "1"b;

         if environment_description = "" then do;
	     seg_was_found = "1"b;
	     environment_description = "***** " || bound_seg_name
		|| " in " || dir_name || " *****";
	  end;


         if (^short_switch | seg_was_found) then do;

	     call print_token
		((moby_bar), left_margin, left_margin,
		max_line_position);			/* header */


	     if ^is_synonym then
	        call print_token
		   ((environment_description), any_margin,
		   length (moby_bar) + max (1,
		   divide (interstice -
		   length (environment_description), 2, 17)),
		   max_line_position);

	     call print_token
		((moby_bar), bar_margin, bar_margin, max_line_position);

/* Put out the name of the segment */

	     call print_token
		((name_list (1)), left_margin, left_margin,
		max_line_position);

	     if ^seg_was_found then
	        call print_token (" (?)", max_line_position,
		   left_margin, max_line_position);

	     call print_space;
	     call print_space;

	     if is_synonym then
	        call print_token
		   ("SEE:  " || name_list (2), title_margin,
		   title_margin, max_line_position);

	     else do;

		 if n_names > 1 then do;		/* it has syns */

		       call print_token ("SYNONYM:  ",
			  title_margin, title_margin,
			  max_line_position);

		       do i = 2 to n_names;
			if i > 2 then
			   call print_token (", ", any_margin,
			        syn_margin, max_line_position);
			call print_token ((name_list (i)), any_margin,
			     syn_margin, max_line_position - 2);

/* We don't want a line starting with a comma */
		       end;
		    end;

/* Get the entrypoins of this module */

		 call cref_listman_$get_defs
		      (node, def_array, def_array_len);

		 if def_array_len < 0 then do;
		       explanation = "definitions";
		       goto out_of_room;
		    end;

		 call loop_thru_defs (""b);

/* Now get the defs that should have been there, but weren't */

		 call cref_listman_$get_implicit_defs
		      (node, def_array, def_array_len);

		 if def_array_len < 0 then do;
		       explanation = "implicit definitions";
		       goto out_of_room;
		    end;

		 if def_array_len > 0 then do;
		       string (def_ok) = ""b;
		       if seg_was_found then do;

/* Report that implicit defs were generated for it */

			   should_complain = ""b;

			   do i = 1 to def_array_len;

			      defname = cref_listman_$get_name
				 (def_array (i));

			      if index (defname, "$") =
				 length (defname) then do;

/* links of the form "myself$" are ok; trim the "$" */

				  defname = substr (defname, 1,
				       length (defname) - 1);

				  do j = 1 to n_names while
				       (name_list (j) ^= defname);
				  end;

/* If none of the names matched, complain */

				  if j > n_names then
				     should_complain = "1"b;

				  else def_ok (i) = "1"b;
			         end;

			      else if defname = "symbol_table" then
			         def_ok (i) = "1"b;

			      else should_complain = "1"b;
			   end;

			   if should_complain then

/* Significant error */
			      call cref_filegen_$report_error
				 (error_table_$no_ext_sym,
				 "cref_filegen_",
				 "^a were generated for ^a.",
				 "Implicit definitions",
				 cref_listman_$get_name (node));
			end;
		    end;

		 call loop_thru_defs ("1"b);

	        end;

	     call print_lineskip;
	  end;

         node = cref_listman_$get_consecutive_segnames (node, bucket);
      end;


/* Now list the include files */

      node = null;
      bucket = 0;

      node = cref_listman_$get_consecutive_include_files
	 (node, bucket, include_file_name, date_time_modified);

      if node ^= null then do;

	  call print_formfeed;

	  do while (node ^= null);

	     call print_token
		((moby_bar), left_margin, left_margin, max_line_position);

	     call print_token
		((include_file_name), left_margin, left_margin,
		max_line_position);

	     call print_space;
	     call print_space;

	     call date_time_ (date_time_modified, char_dtm);

	     call print_token
		("***** ", syn_margin, syn_margin, max_line_position);
	     call print_token
		((char_dtm), any_margin, syn_margin, max_line_position);
	     call print_token
		(" *****", any_margin, syn_margin, max_line_position);


	     call cref_listman_$get_include_file_crossrefs
		(node, crossref_array, crossref_array_len);
	     if crossref_array_len < 0 then do;
		 explanation = "include file crossrefs";
		 goto out_of_room;
	        end;

	     do i = 1 to crossref_array_len;
	        if i = 1 then call print_token
		      ("", crossref_margin, crossref_margin,
		      max_line_position);
	        call print_token
		   ((cref_listman_$get_name_with_suffix
		   (crossref_array (i))),
		   any_margin, crossref_margin, max_line_position);
	        call print_tab;
	     end;

	     node = cref_listman_$get_consecutive_include_files
		(node, bucket, include_file_name, date_time_modified);

	     call print_lineskip;
	  end;

	  call print_lineskip;
         end;


/* Now append any waiting error messages to the end of the listing */

      if err_index > 0 then do;

	  call print_formfeed;

	  call put_out_fixedstring
	       (substr (err_messages, 1, err_index));
         end;


      call msf_manager_$adjust
	 (msf_fcb_ptr, cur_component, (char_position - 1) * 9, "111"b, code);
      if code ^= 0 then
         call com_err_
	    (code, "cref_filegen_", "Setting bit count on output file.");

      return;
%skip (5);
out_of_room:
      call com_err_ (0, "cref_filegen_",
	 "Internal table has overflowed.  Too many ^a for ""^a""",
	 explanation, name_list (1));
      signal cref_abort_;
      goto out_of_room;
%page;
loop_thru_defs: proc (defs_are_implicit);

/* This internal subroutine prints the references for each definition, as well
   as printing the definition itself.  */

dcl  defs_are_implicit      bit (1) aligned;

dcl  (i, j)	        fixed bin;

dcl  sort_items_indirect_$varying_char
		        entry (pointer, pointer);


      if def_array_len < 1 then return;

      sort_structure.n_elements, index_structure.n_elements = def_array_len;

      do i = 1 to def_array_len;
         names (i) = cref_listman_$get_name (def_array (i));
         name_ptrs (i) = addr (names (i));
      end;

      if def_array_len > 1 then
         call sort_items_indirect_$varying_char
	    (addr (sort_structure), addr (index_structure));

      else indices (1) = 1;

/* Now print the info about each item */

      do k = 1 to def_array_len;

         i = index_structure.indices (k);

         call print_token
	    ((cref_listman_$get_name (def_array (i))), def_margin,
	    def_margin, max_line_position);

         if defs_are_implicit then
	  if ^def_ok (i) then
	     call print_token
		(" (?)", max_line_position, left_margin,
		max_line_position);
         call print_tab;

         call cref_listman_$get_crossrefs
	    (def_array (i), crossref_array, crossref_array_len);

/* The crossrefs will always be in alphabetical order, because they were
   created via a scan of the database which was performed in alphabetical
   order.  */

         if crossref_array_len < 0 then do;
	     explanation = "cross-references";
	     goto out_of_room;
	  end;

/* Put out the names of all the referencers */

         do j = 1 to crossref_array_len;
	  if j = 1 then call print_token
		("", crossref_margin, crossref_margin, max_line_position);
	  else call print_tab;

	  call print_token
	       (cref_listman_$get_name_with_suffix (crossref_array (j)),
	       any_margin, crossref_margin, max_line_position);
         end;
      end;
   end loop_thru_defs;
%skip (5);
print_token: proc (token, force_column, fold_column, max_column);

/* This internal subroutine places some token into the output file.  The token
   is constrained to appear in a place defined by the other arguments.  Its
   leftmost char cannot appear at any column greater than force_column; if it
   would, it is put on a new line.  The leftmost char of the token cannot
   appear at any column less than fold_column, which is a left-margin
   indicator.  Its rightmost character cannot exceed max_column; if it does,
   it is put on a new line instead.  */

dcl  token	        char (168) varying,

/* If I use (*) I get a non-quick block */

     (force_column, fold_column, max_column) fixed bin;

dcl  token_len	        fixed bin;

dcl  substr	        builtin;

dcl  (tab		        initial ("	"),
     space	        initial (" "),
     nl		        initial ("
")   )		        char (1) varying static;

dcl  (ten_spaces	        char (10) initial ((10)" "),
     thirteen_tabs	        char (13) initial ((13)"	"),
     two_nls	        char (2) varying initial ((2)"
")   )		        static;

dcl  temp		        fixed bin;

      token_len = length (token);

      if line_position > force_column then do;		/* must fold */
	  call backup_to_position (last_blackspace);
	  call put_out ((nl));
	  line_position = 0;
         end;

      if line_position < fold_column then do;
	  temp = divide (fold_column, 10, 17)
	       - divide (line_position, 10, 17);

	  if temp > 0 then do;			/* can use tabs? */
	        call put_out (substr (thirteen_tabs, 1, temp));
	        line_position = 10 * divide (fold_column, 10, 17);
	     end;

	  call put_out (substr (ten_spaces, 1, fold_column - line_position));
	  line_position = fold_column;
         end;

      if token_len + line_position > max_column then do;	/* must fold */
	  call backup_to_position (last_blackspace);
	  call put_out ((nl));

	  if token_len + fold_column > max_column then

/* Too big for line as is, don't fold */
	     line_position = 0;

	  else do;
	        call put_out
		   (substr (thirteen_tabs, 1,
		   divide (fold_column, 10, 17)));
	        call put_out
		   (substr (ten_spaces, 1, mod (fold_column, 10)));
	        line_position = fold_column;
	     end;
         end;

      call put_out (token);
      line_position = line_position + token_len;
      last_blackspace = char_position;
      return;

print_space: entry;

      line_position = line_position + 1;
      if line_position + 1 ^> max_line_position then call put_out ((space));
      return;

print_formfeed: entry;
      call put_out ((form_feed));
      return;

print_lineskip: entry;

      call put_out ((two_nls));
      line_position = 0;
      last_blackspace = char_position;			/* NL's count */
      return;

print_tab: entry;

dcl  new_line_position      fixed bin;

      if line_position > max_line_position then return;

      new_line_position = 10 * (divide (line_position, 10, 17) + 1);
      if new_line_position ^> max_line_position then call put_out ((tab));
      line_position = new_line_position;

      return;
   end print_token;
%skip (5);
put_out: proc (token);

dcl  token	        char (168) varying;

/* If I use (*) I get a non-quick block */

dcl  token_len	        fixed bin;

dcl  chars_left	        fixed bin (21);

      token_len = length (token);
      if token_len = 0 then return;

      chars_left = max_char_count - char_position + 1;

      if token_len >= chars_left then
         call split_across_components ((token), (token_len), chars_left);

      else do;					/* simple case */
	  substr (output_seg, char_position, token_len) = token;
	  char_position = char_position + token_len;
         end;

      return;
   end put_out;

put_out_fixedstring: proc (fixedstring);

dcl  fixedstring	        char (*),
     string_len	        fixed bin (21),
     chars_left	        fixed bin (21);

      string_len = length (fixedstring);
      chars_left = max_char_count - char_position + 1;

      if string_len >= chars_left then
         call split_across_components (fixedstring, string_len, chars_left);

      else do;
	  substr (output_seg, char_position, string_len) = fixedstring;
	  char_position = char_position + string_len;
         end;

      return;
   end put_out_fixedstring;

split_across_components: proc (string, len, chars_left);

dcl  string	        char (*),
     (len, chars_left)      fixed bin (21);

dcl  chars_to_go	        fixed bin (21);

      substr (output_seg, char_position, chars_left) =
	 substr (string, 1, chars_left);		/* all that fits */

      cur_component = cur_component + 1;

      call msf_manager_$get_ptr
	 (msf_fcb_ptr, cur_component, "1"b, output_seg_ptr, 0, code);
      if code ^= 0 then signal cref_abort_;

      char_position = 1;

      chars_to_go = len - chars_left;

      if chars_to_go > 0 then
         substr (output_seg, char_position, chars_to_go) =
	    substr (string, len - chars_to_go + 1, chars_to_go);

      char_position = char_position + chars_to_go;
      return;

   end split_across_components;
%skip (5);
backup_to_position:
   procedure (p_new_position);

dcl  p_new_position	        fixed binary (21) parameter;

      if p_new_position > char_position then do;		/* must backup to previous component */
	  if cur_component = 0 then signal cref_abort_;
	  call hcs_$truncate_seg (output_seg_ptr, 0, (0));
	  cur_component = cur_component - 1;
	  call msf_manager_$get_ptr
	       (msf_fcb_ptr, cur_component, "1"b, output_seg_ptr, 0, code);
	  if code ^= 0 then signal cref_abort_;
         end;

      char_position = p_new_position;

      return;

   end backup_to_position;
%page;
init: entry (err_seg_ptr_arg, brief_arg, short_arg, areap, given_ll);

/* This entry just initializes the error message repository and a few command
   options and allocates some arrays that are too large to keep in automatic
   storage */

dcl  err_seg_ptr_arg        pointer parameter,
     (brief_arg, short_arg) bit (1) aligned parameter,
     areap	        pointer parameter,
     given_ll	        fixed bin parameter;

dcl  cref_area	        area (sys_info$max_seg_size) based (areap);

dcl  (brief_switch,
     short_switch)	        bit (1) aligned static,
     err_seg_ptr	        pointer static;

dcl  1 err_seg	        aligned based (err_seg_ptr),
       2 err_index	        fixed bin (35),
       2 err_messages       char (max_chars) aligned;

dcl  max_chars	        fixed bin (35) static;

      err_seg_ptr = err_seg_ptr_arg;
      short_switch = short_arg;
      brief_switch = brief_arg;
      max_chars = (sys_info$max_seg_size - 1) * 4;

      if given_ll = -1 then max_line_position = default_max_line_position;
      else max_line_position = given_ll;

      err_index = 0;

      allocate large_struc in (cref_area);
      return;
%skip (5);
report_error: entry (errcode, reporter);		/* really is options (variable) */

dcl  errcode	        fixed bin (35) parameter,
     reporter	        char (*) parameter;

dcl  cu_$arg_list_ptr       entry (ptr),
     ioa_$general_rs        entry options (variable),
     ioa_$rs	        entry options (variable),
     cu_$gen_call	        entry (entry, pointer);

dcl  convert_status_code_   entry (fixed bin (35), char (8), char (100)),
     ap		        pointer;

dcl  err_message	        char (100),
     temp_string	        char (168),
     temp_len	        fixed bin;


      if errcode ^= 0 then
         call convert_status_code_ (errcode, "", err_message);
      else err_message = "";

      call cu_$arg_list_ptr (ap);

/* Format the 3rd thru Nth args */

      call ioa_$general_rs (ap, 3, 4, temp_string, 0, "1"b, ""b);

      call ioa_$rs ("^a: ^a  ^a",
	 temp_string, temp_len, reporter, err_message, (temp_string));

      substr (err_messages, err_index + 1, temp_len) =
	 substr (temp_string, 1, temp_len);

      err_index = err_index + temp_len;

      if ^brief_switch then call cu_$gen_call (com_err_, ap);
      return;

   end cref_filegen_;




		    cref_listman_.pl1               11/17/82  1641.2rew 11/17/82  1623.3      314514



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


/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */
cref_listman_: proc;

/* This subroutine handles all the list structuring operations in the
   cross-referencer database.
   Completely redesigned and rewritten by C. D. Tavares
   Modified by CDT 08/30/76 to fix minor chain-ordering bug in include file
   block entry.
   Modified 09/24/79 by CDT to make error message on line 589 more meaningful--
   also global cosmetic change to keep new version of PL/I compiler happy
   (can't declare a like a anymore).
   Modified 11/30/80 by CDT to fix misdeclared parameter.
   Last modified 09/81 by CDT to retain language suffixes
*/

dcl  cref_area_ptr	        pointer static,
     cref_area	        area (sys_info$max_seg_size) based (cref_area_ptr);

dcl  1 cref_database        aligned based (cref_database_ptr),
       2 a_nullp	        pointer unaligned,
       2 nullps	        (7) pointer unaligned,
       2 buckets	        (0:2703) pointer unaligned,
       2 environment_buckets
		        (0:127) pointer unaligned,
       2 include_file_buckets
		        (0:127) pointer unaligned;

dcl  cref_database_ptr      pointer static initial (null);

dcl  1 primary_block        aligned based (primary_block_ptr),
       2 forward_chain      pointer unaligned,
       2 flags	        aligned,
         3 is_segname       bit (1) unaligned,
         3 created_by_ref   bit (1) unaligned,
         3 is_external      bit (1) unaligned,
         3 ref_mismatch_noted
		        bit (1) unaligned,
         3 only_predefined  bit (1) unaligned,
         3 predefined_unused_noted
		        bit (1) unaligned,
       2 bound_seg_node     pointer unaligned,
       2 dir_node	        pointer unaligned,
       2 synonym_forward_chain
		        pointer unaligned,
       2 master_synonym_node
		        pointer unaligned,
       2 definition_node    pointer unaligned,
       2 reference_node     pointer unaligned,
       2 implicit_definition_chain
		        pointer unaligned,
       2 include_file_node  pointer unaligned,
       2 crossref_chain     pointer unaligned,
       2 crossref_chain_end pointer unaligned,
       2 lang_suffix_node   pointer unaligned,
       2 acc_length	        fixed bin (8) unaligned,
       2 name	        char (charlen refer (primary_block.acc_length))
		        unaligned;

dcl  primary_block_ptr      pointer;

dcl  1 attribute_block      aligned based (attribute_ptr),
       2 n_entries	        fixed bin (35),
       2 attribute_nodes    (n_elements refer (n_entries)) pointer unaligned;

dcl  attribute_ptr	        pointer;

dcl  1 include_file_block   aligned based (include_file_ptr),
       2 forward_chain      pointer unaligned,
       2 dtm	        bit (72),
       2 crossref_chain     pointer unaligned,
       2 crossref_chain_end pointer unaligned,
       2 acc_length	        fixed bin (8) unaligned,
       2 name	        char
		        (charlen refer (include_file_block.acc_length))
		        unaligned;

dcl  include_file_ptr       pointer;

dcl  1 string_block	        aligned based (string_ptr),
       2 forward_chain      pointer unaligned,
       2 bindfile_found     bit (1) unaligned,
       2 pad	        bit (8) unaligned,
       2 acc_length	        fixed bin (8) unaligned,
       2 string	        char (charlen refer (string_block.acc_length))
		        unaligned;

dcl  string_ptr	        pointer;

dcl  1 crossref_block       aligned based (crossref_block_ptr),
       2 forward_chain      pointer unaligned,
       2 crossref_node      pointer unaligned;

dcl  crossref_block_ptr     pointer;

dcl  1 implicit_def_block   aligned based (implicit_def_block_ptr),
       2 forward_chain      pointer unaligned,
       2 def_node	        pointer unaligned;

dcl  implicit_def_block_ptr pointer;

dcl  cref_filegen_$report_error
		        entry options (variable),
     sub_err_	        entry options (variable),
     error_table_$namedup   ext fixed bin (35),
     error_table_$noentry   ext fixed bin (35),
     sys_info$max_seg_size  fixed bin (35) external,
     charlen	        fixed bin;

dcl  i		        fixed bin;
%page;
create_primary_block_acc:
     entry (acc_ptr, bound_seg_node, dir_node, is_segname, defining,
	is_external) returns (pointer);

dcl  acc_ptr	        pointer parameter,
     (bound_seg_node,
     dir_node)	        pointer parameter,
     (is_segname,
     defining,
     is_external)	        bit (1) aligned;

dcl  node		        pointer;

dcl  1 based_acc_string     aligned based (acc_ptr),
       2 length	        fixed bin (9) unaligned unsigned,
       2 string	        char (based_acc_string.length) unaligned;

dcl  temp_ptr	        pointer,
     first_block_ptr        pointer,
     bucket	        fixed bin,
     prev_ptr	        pointer;

dcl  (addr, dim, hbound,
     index, length,
     max, null, rank,
     rtrim, substr)	        builtin;


	node = match_or_create_block ((based_acc_string.string),
	     bound_seg_node, dir_node, null, is_segname, defining,
	     ""b, is_external);

	return (node);
%skip (5);
create_primary_block_char:
     entry (char_string, bound_seg_node, dir_node, suffix_node,
	is_segname, defining, is_external) returns (pointer);

dcl  (char_string	        char (*) varying,
     suffix_node	        pointer) parameter;

	node = match_or_create_block ((char_string),
	     bound_seg_node, dir_node, suffix_node, is_segname, defining,
	     ""b, is_external);

	return (node);
%skip (5);
predefine_primary_block_char:
     entry (char_string, bound_seg_node, dir_node, is_segname, defining,
	is_external) returns (pointer);

	node = match_or_create_block ((char_string),
	     bound_seg_node, dir_node, null, is_segname, defining,
	     "1"b, is_external);

	return (node);
%skip (5);
/* format: ind3 */

match_or_create_block: proc (name, bound_seg_node, dir_node, suffix_node,
      is_segname, defining, predefining, is_external)
      returns (pointer);

dcl  name		        char (32) varying parameter,
     (bound_seg_node,
     dir_node,
     suffix_node)	        pointer parameter,
     (is_segname,
     defining,
     predefining,
     is_external)	        bit (1) aligned parameter;

dcl  found	        bit (1) aligned;

dcl  primary_blk_ptr        pointer;

dcl  1 primary_blk	        like primary_block aligned based (primary_blk_ptr);

dcl  already_found	        bit (1) aligned,
     already_found_ptr      pointer;

dcl  node		        pointer;


/* Try to find a block with this name already created. */

      primary_blk_ptr = null;

      call find_block (name, primary_blk_ptr, is_segname, found);

      if found then do;

	  if is_segname then do;

/* The block found must abide by certain rules controlling environment
   matching.  Prepare to see it it does.  Remember where we found the first
   matching block in case none of the rules work out.  */

	        first_block_ptr = primary_blk_ptr;

	        if defining then do;

/* Expect we really wanted to create one.  Before creating, check to see that
   no other external symbol exists in the same directory with the same name.
   Print different error messages depending on whether both names (if found)
   are found in the same bound segment.  (unlikely, but stranger things...) */

		    do while (found);

		       if primary_blk.dir_node = dir_node then do;

/* Claims there's a seg of the same name in the same dir.  Check it out. */

			   if check_dups_in_dir_ok () then
			        return (primary_blk_ptr);
			end;

		       else if primary_blk.dir_node = null &
			     primary_blk.bound_seg_node = null then
			do;

/* This block is a predefined synonym.  Polish it off. */

			   call set_predefined_synonym;
			   return (primary_blk_ptr);
			end;

		       call find_block
			(name, primary_blk_ptr, is_segname, found);
		    end;
		 end;


/* If we're not defining, we're searching. */

	        else do;

/* First rule: Search for name in same bound_seg in same dir.  If found, use
   it.  */

		    do while (found);

		       if primary_blk.bound_seg_node = bound_seg_node
			& primary_blk.dir_node = dir_node then
			  return
			     (find_master_block (primary_blk_ptr));

		       call find_block
			(name, primary_blk_ptr, is_segname, found);
		    end;

/* Second rule: Search for external occurrence of same name in same dir.  If
   found, use.  */

		    found = "1"b;
		    primary_blk_ptr = first_block_ptr;

		    do while (found);

		       if primary_blk.dir_node = dir_node
			& primary_blk.is_external then
			  return
			     (find_master_block (primary_blk_ptr));

		       call find_block
			(name, primary_blk_ptr, is_segname, found);
		    end;

/* Third rule: Search for any external occurrence of segname, and use it.
   Just for safety's sake, continue to check for another match with same
   criteria.  If more than once match does occur, complain, but stick to your
   choice, because it's as good as any.  */

		    already_found = ""b;
		    found = "1"b;
		    primary_blk_ptr = first_block_ptr;

		    do while (found);

		       if primary_blk.is_external then
			  if already_found then do;
			        call cref_filegen_$report_error
				 (error_table_$namedup,
				 "cref_listman_",
				 "References to ^a are ambiguous.",
				 name);

/* Don't print the error message more than once */

			        already_found_ptr ->
				 primary_blk.ref_mismatch_noted
				 = "1"b;

			        return (already_found_ptr);
			     end;

			  else do;
			        if primary_blk.ref_mismatch_noted

/* No use complaining about this one again */

			        then return (find_master_block
				      (primary_blk_ptr));

			        already_found_ptr =
				 find_master_block
				 (primary_blk_ptr);
			        already_found = "1"b;
			     end;

		       call find_block
			(name, primary_blk_ptr, is_segname, found);
		    end;

/* Return the solid match, if we got one */

		    if already_found then return (already_found_ptr);

		 end;
	     end;


/* If it isn't a segname, it's a definition.  Try to match the environments */

	  else do while (found);
	        if primary_blk.bound_seg_node = bound_seg_node then
		   return (primary_blk_ptr);

	        call find_block
		 (name, primary_blk_ptr, is_segname, found);
	     end;

         end;


/* Couldn't find any match.  Time to create a new block. */

      prev_ptr = primary_blk_ptr;

      charlen = length (name);
      allocate primary_blk in (cref_area);

/* Insert name and environmentts */

      primary_blk.name = name;
      primary_blk.lang_suffix_node = suffix_node;
      primary_blk.synonym_forward_chain = null;
      primary_blk.master_synonym_node = null;
      primary_blk.definition_node = null;
      primary_blk.reference_node = null;
      primary_blk.implicit_definition_chain = null;
      primary_blk.include_file_node = null;
      primary_blk.crossref_chain = null;
      primary_blk.crossref_chain_end = null;
      primary_blk.bound_seg_node = bound_seg_node;
      primary_blk.dir_node = dir_node;
      primary_blk.flags.is_segname = is_segname;
      primary_blk.is_external = is_external | ^defining;
      primary_blk.only_predefined = predefining;

/* If we are defining a synonym make sure it doesn't look like a wild ref */

      if (dir_node ^= null & bound_seg_node ^= null) then
	 primary_blk.created_by_ref = ^defining & is_segname;

      call chain_on (prev_ptr, primary_blk_ptr);

      return (primary_blk_ptr);
%page;
check_dups_in_dir_ok: proc returns (bit (1));

/* Why an internal procedure?  To control the damn indenting. */

      if primary_blk.bound_seg_node = bound_seg_node then do;

/* Same module already defined.  What's up? */

	  if (dir_node ^= null | bound_seg_node ^= null) then

/* It's a solid match, not just a don't care match... */

	       if ^predefining then do;

/* ...and we're not predefining it now from a bindfile... */

		   if ^primary_blk.only_predefined then

/* ...and it wasn't formerly predefined by a bindfile-- must be an error */

		        call cref_filegen_$report_error
			 (error_table_$namedup, "cref_listman_",
			 "^a (^a) in ^a", name,
			 bound_seg_node -> string_block.string,
			 dir_node -> string_block.string);

/* In any case, we're defining it NOW, so turn off the predefined bit */

		   else do;
		         primary_blk.only_predefined = ""b;
		         primary_blk.lang_suffix_node = suffix_node;
		      end;
		end;
	  return ("1"b);
         end;

      else if is_external then

/* Aarrgh.  The dirs are the same, but the bound segs are different. */

	 if primary_blk.is_external then
	      call cref_filegen_$report_error
	         (error_table_$namedup, "cref_listman_",
	         "Multiple occurrences of ^a in ^a.",
	         name, dir_node -> string_block.string);

      return ("0"b);

   end check_dups_in_dir_ok;
%skip (5);
set_predefined_synonym: proc;


/* Find the master synonym upon which to work our wiles. */

      if primary_blk.master_synonym_node = null then
	 temp_ptr = primary_blk_ptr;
      else temp_ptr =
	    primary_blk.master_synonym_node;

      node = temp_ptr;				/* anything's OK */

/* Chain through all the synonyms, setting the environments */

      do temp_ptr = temp_ptr repeat (node) while (node ^= null);

         temp_ptr -> primary_blk.dir_node = dir_node;
         temp_ptr -> primary_blk.bound_seg_node = bound_seg_node;

         node = temp_ptr -> primary_blk.synonym_forward_chain;

      end;

      return;

   end set_predefined_synonym;
%skip (5);
find_block: procedure (string, primary_blk_ptr, is_segname, found);

dcl  string	        char (32) varying parameter,
     primary_blk_ptr        pointer parameter,
     found	        bit (1) aligned parameter,
     is_segname	        bit (1) aligned parameter;

dcl  1 primary_blk	        like primary_block aligned based (primary_blk_ptr);

dcl  key		        char (2),
     (high_hash, low_hash)  fixed bin;

dcl  legal_chars	        char (52) static initial
		        ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");

/* These aren't the only legal chars of course, but they are the only chars
   allowed as the first char in a segname or entryname.  */


      found = ""b;

/* If this is a plain old search, hash the string and get to it */

      if primary_blk_ptr = null then do;
(nostrz):	  key = string;
	  high_hash = index (legal_chars, substr (key, 1, 1)) - 1;
	  low_hash = index (legal_chars, substr (key, 2, 1)) - 1;
	  bucket = max (high_hash * length (legal_chars) + low_hash, 0);

/* Set fake prev_ptr to point to bucket chain in case first loop exits */

	  prev_ptr = addr (cref_database.buckets (bucket));

	  if cref_database.buckets (bucket) = null then do;
	        found = ""b;
	        primary_blk_ptr = prev_ptr;
	        return;
	     end;

	  primary_blk_ptr = cref_database.buckets (bucket);
         end;

      else do;
	  if primary_blk.forward_chain = null then return;
	  prev_ptr = primary_blk_ptr;
	  primary_blk_ptr = primary_blk.forward_chain;
         end;


      do primary_blk_ptr = primary_blk_ptr
         repeat (primary_blk.forward_chain);

/* Look for match or at least a good place to add new block */

         if primary_blk.is_segname = is_segname then	/* MUST match */
	    if primary_blk.name = string then do;
		found = "1"b;
		return;
	       end;

/* If we've run too far in alphabetical order, back up and point to good place
   to chain in */

         if primary_blk.name > string then do;
	     primary_blk_ptr = prev_ptr;
	     return;
	  end;

/* End of chain?  Maybe we will want to chain in here later. */

         else if primary_blk.forward_chain = null then return;

         prev_ptr = primary_blk_ptr;			/* loop... */
      end;

   end find_block;
%skip (5);
find_master_block: proc (found_ptr) returns (ptr);

dcl  found_ptr	        pointer;


      if found_ptr -> primary_blk.master_synonym_node = null then
	 return (found_ptr);
      return (found_ptr -> primary_blk.master_synonym_node);

   end find_master_block;
   end match_or_create_block;

/* format: revert */
%page;
create_syn_block: entry (char_string, bound_seg_node, dir_node, is_external,
	master_synonym_node);

dcl  master_synonym_node    pointer;

dcl  master_block_ptr       pointer;


	master_block_ptr = master_synonym_node;

/* Don't syn anything to itself */

	if master_block_ptr -> primary_block.name = char_string then return;

	primary_block_ptr = match_or_create_block
	     ((char_string), bound_seg_node, dir_node, null, "1"b,
	     ^master_block_ptr -> primary_block.created_by_ref, ""b,
	     is_external);

/* Don't do the same syn twice */

	if primary_block.master_synonym_node ^= null then do;
		temp_ptr = primary_block.master_synonym_node;
		call cref_filegen_$report_error (0, "cref_listman_",
		     "^a cannot be made synonymous with ^a;
^-already synonymous to ^a.",
		     char_string, master_block_ptr -> primary_block.name,
		     temp_ptr -> primary_block.name);
		return;
	     end;

/* Patch new block into the forward synonym chain */

	if (primary_block_ptr = null | master_block_ptr = null) then
	     call sub_err_ (0, "cross_reference", "s", null, 0,
		"Inconsistency in synonym chains.");

	primary_block_ptr -> primary_block.synonym_forward_chain =
	     master_block_ptr -> primary_block.synonym_forward_chain;
	master_block_ptr -> primary_block.synonym_forward_chain =
	     primary_block_ptr;

/* Chain master synonym slot to head honcho synonym */

	primary_block_ptr -> primary_block.master_synonym_node =
	     master_synonym_node;

	return;
%skip (5);
create_include_file_block: entry (char_string, date_time_modified)
	returns (pointer);

dcl  date_time_modified     bit (72) parameter;

dcl  satisfied	        bit (1);


/* Hash by first character */

	bucket = rank (substr (char_string, 1, 1));

	satisfied = ""b;

	prev_ptr = addr (cref_database.include_file_buckets (bucket));

/* Try finding an already existing block for this include file */

	if cref_database.include_file_buckets (bucket) ^= null then
	     do include_file_ptr =
		cref_database.include_file_buckets (bucket)
		repeat (include_file_block.forward_chain)
		while (^satisfied);

		if include_file_block.name = char_string then
		     if include_file_block.dtm = date_time_modified then
			return (include_file_ptr);

		     else if include_file_block.dtm > date_time_modified
		     then do;

/* Remember to keep them sorted by dtm */

			     include_file_ptr = prev_ptr;
			     satisfied = "1"b;
			end;

/* If we've passed it in alphabetical order, back up */

		if include_file_block.name > char_string then do;
			include_file_ptr = prev_ptr;
			satisfied = "1"b;
		     end;

/* If we're at the end of the chain, punt */

		else if include_file_block.forward_chain = null then
		     satisfied = "1"b;

		prev_ptr = include_file_ptr;
	     end;

/* Didn't find it; looks like time to create one */

	charlen = length (char_string);
	allocate include_file_block in (cref_area);

	include_file_block.dtm = date_time_modified;
	include_file_block.name = char_string;
	include_file_block.forward_chain = null;
	include_file_block.crossref_chain = null;
	include_file_block.crossref_chain_end = null;

	call chain_on (prev_ptr, include_file_ptr);

	return (include_file_ptr);
%skip (5);
create_environment: entry (description, bindfile_found) returns (pointer);

dcl  description	        char (*) varying parameter,
     bindfile_found	        bit (1) aligned parameter;

	node = make_string (description);
	return (node);
%skip (5);
get_name: entry (node_no) returns (char (32) varying);

dcl  node_no	        pointer parameter;

dcl  temp_string	        char (32) varying;

	primary_block_ptr = node_no;
	temp_string = primary_block.name;
	return (temp_string);


get_name_with_suffix: entry (node_no) returns (char (32) varying);

	primary_block_ptr = node_no;
	temp_string = primary_block.name;
	string_ptr = primary_block.lang_suffix_node;
	if string_ptr ^= null then
	     temp_string = rtrim (temp_string) || string_block.string;
	else temp_string = rtrim (temp_string) || ".?";
	return (temp_string);
%page;
assign_def_block: entry (attribute_array, n_elements, master_node);

dcl  master_node	        pointer parameter,
     attribute_array        (*) pointer parameter,
     n_elements	        fixed bin;

	primary_block_ptr = master_node;

	primary_block.definition_node = assign_attribute_block ();
	return;


assign_ref_block: entry (attribute_array, n_elements, master_node);

	primary_block_ptr = master_node;

	primary_block.reference_node = assign_attribute_block ();
	return;


assign_include_file_block: entry (attribute_array, n_elements, master_node);

	primary_block_ptr = master_node;

	primary_block.include_file_node = assign_attribute_block ();
	return;
%skip (5);
assign_attribute_block: proc returns (pointer);

	if n_elements = 0 then return (null);

	allocate attribute_block in (cref_area);

	do i = 1 to n_elements;
	     attribute_block.attribute_nodes (i) = attribute_array (i);
	end;

	return (attribute_ptr);

     end assign_attribute_block;
%page;
/* format: ind3 */

get_consecutive_segnames: entry (node_arg, bucket_arg) returns (pointer aligned);

dcl  node_arg	        pointer parameter,
     bucket_arg	        fixed bin parameter;


	node = node_arg;

/* If there is no "leftover" node input value, this is the first call to me */

	if node = null then bucket_arg = 0;

/* Otherwise, start search from the next bucket */

	else do;
	      primary_block_ptr = node;
	      node = primary_block_ptr -> primary_block.forward_chain;
	      if node = null then bucket_arg = bucket_arg + 1;
	   end;

/* Chain through buckets to find next block */

	do while ("1"b);

/* Skip dead buckets */

	   do bucket_arg = bucket_arg to hbound (buckets, 1)
	      while (cref_database.buckets (bucket_arg) = null);
	   end;

/* When we run out of buckets, quit */

	   if bucket_arg > hbound (buckets, 1) then return (null);

/* Special initial conditions case */

	   if node = null then
	        node = cref_database.buckets (bucket_arg);

	   primary_block_ptr = node;

	   do primary_block_ptr = primary_block_ptr
	      repeat (node) while (node ^= null);

	      if primary_block.only_predefined then do;
		  if ^primary_block.predefined_unused_noted then do;
		        call cref_filegen_$report_error
			 (0, "cref_listman_",
			 "Warning: Synonyms were defined for ^a,
^-but ^a was not in the search list.",
			 primary_block.name, primary_block.name);
		        primary_block.predefined_unused_noted = "1"b;
		     end;
	         end;


	      else if primary_block.flags.is_segname then do;

/* Got one.  Make sure it's not an internal synonym */

		  if primary_block.is_external then return (node);

/* Of course, if it's internal and NOT a synonym, we still want it */

		  else if primary_block.master_synonym_node = null then
		       return (node);
	         end;

	      node = primary_block.forward_chain;
	   end;

	   bucket_arg = bucket_arg + 1;		/* next bucket */

	end;
%page;
get_consecutive_include_files: entry (node_arg, bucket_arg, char_string, date_time_modified) returns (pointer aligned);


/* This is much the same as the entry above.  See it for comments. */

	node = node_arg;

	if node = null then bucket_arg = 0;

	else do;
	      include_file_ptr = node;
	      node = include_file_ptr -> include_file_block.forward_chain;
	      if node = null then bucket_arg = bucket_arg + 1;
	   end;

	do bucket_arg = bucket_arg to hbound (include_file_buckets, 1)
	   while (cref_database.include_file_buckets (bucket_arg) = null);
	end;

	if bucket_arg > hbound (include_file_buckets, 1) then return (null);

	if node = null then
	     node = cref_database.include_file_buckets (bucket_arg);

	include_file_ptr = node;

	char_string = include_file_block.name;
	date_time_modified = include_file_block.dtm;
	return (node);
%page;
get_refs: entry (node_arg, attribute_array, n_elements);

dcl  (Refs	        initial (1),
     Defs		        initial (2),
     Incls	        initial (3)) internal static fixed bin
		        options (constant);

	call get_attribute_block (Refs);
	return;


get_defs: entry (node_arg, attribute_array, n_elements);

	call get_attribute_block (Defs);
	return;


get_include_files: entry (node_arg, attribute_array, n_elements);

	call get_attribute_block (Incls);
	return;
%skip (5);
get_attribute_block: proc (which_type);

dcl  which_type	        fixed bin;

dcl  which_node	        pointer;


      n_elements = 0;

      primary_block_ptr = node_arg;

/* Don't return refs or include files for synonyms; otherwise find master
   block for this synonym */

      if primary_block.master_synonym_node ^= null then
	 if which_type ^= Defs then return;
	 else primary_block_ptr = primary_block.master_synonym_node;

      if which_type = Refs then
	 which_node = primary_block.reference_node;
      else if which_type = Defs then
	 which_node = primary_block.definition_node;
      else if which_type = Incls then
	 which_node = primary_block.include_file_node;
      else which_node = null;

      if which_node = null then return;

      attribute_ptr = which_node;

      if attribute_block.n_entries > dim (attribute_array, 1) then do;
	  n_elements = -1;
	  return;
         end;

      n_elements = attribute_block.n_entries;

      do i = 1 to n_elements;
         attribute_array (i) = attribute_block.attribute_nodes (i);
      end;

      return;
   end get_attribute_block;
%page;
assign_crossref: entry (node_arg, crossref_node);

dcl  crossref_node	        pointer;

dcl  (Program	        initial (1),
     Include_file	        initial (2)) static options (constant) fixed bin;

	call append_crossref (Program);
	return;



assign_include_file_crossref: entry (node_arg, crossref_node);

	call append_crossref (Include_file);
	return;
%skip (5);
append_crossref: proc (which_type);

dcl  which_type	        fixed bin;

      allocate crossref_block in (cref_area);

      crossref_block.crossref_node = crossref_node;
      crossref_block.forward_chain = null;

      if which_type = Program then do;

	  primary_block_ptr = node_arg;

/* Find master if this is synonym */

	  if primary_block.master_synonym_node ^= null then
	       primary_block_ptr = primary_block.master_synonym_node;

	  if primary_block.crossref_chain = null then	/* start chain */
	       primary_block.crossref_chain = crossref_block_ptr;

	  else do;

/* Spend a little care to keep them in alphabetical order */

	        temp_ptr = primary_block.crossref_chain_end;
	        call chain_on (temp_ptr, crossref_block_ptr);
	     end;

	  primary_block.crossref_chain_end = crossref_block_ptr;
         end;


      else if which_type = Include_file then do;

/* Same comments as above */

	  include_file_ptr = node_arg;

	  if include_file_block.crossref_chain = null then
	       include_file_block.crossref_chain = crossref_block_ptr;

	  else do;
	        temp_ptr = include_file_block.crossref_chain_end;
	        call chain_on (temp_ptr, crossref_block_ptr);
	     end;

	  include_file_block.crossref_chain_end = crossref_block_ptr;
         end;

      return;
   end append_crossref;
%page;
create_implicit_def: entry (node_arg, new_def_node);

dcl  new_def_node	        pointer;


	allocate implicit_def_block in (cref_area);

	implicit_def_block.def_node = new_def_node;
	implicit_def_block.forward_chain = null;

	primary_block_ptr = node_arg;

/* Don't take any wooden synonyms */

	if primary_block.master_synonym_node ^= null then
	     primary_block_ptr = primary_block.master_synonym_node;

	if primary_block.implicit_definition_chain = null then
	     primary_block.implicit_definition_chain =
	        implicit_def_block_ptr;

	else call chain_on
	        (addr (primary_block.implicit_definition_chain),
	        implicit_def_block_ptr);

	return;
%skip (5);
get_primary_block_long: entry (node_arg, name_array, n_names, is_synonym,
        dir_description, bound_segment_name);

dcl  name_array	        char (32) varying dimension (*),
     is_synonym	        bit (1) aligned parameter,
     (dir_description,
     bound_segment_name)    char (*) varying parameter,
     n_names	        fixed bin parameter;


	primary_block_ptr = node_arg;

/* No environments for things that were created by reference (unfound) or
   synonyms */

	if primary_block.created_by_ref then
	     dir_description, bound_segment_name = "";

	else if primary_block.master_synonym_node ^= null then
	     dir_description, bound_segment_name = "";


	else do;
	      string_ptr = primary_block.dir_node;
	      dir_description = string_block.string;

	      string_ptr = primary_block.bound_seg_node;
	      bound_segment_name = string_block.string;
	      if ^string_block.bindfile_found then do;
		  call cref_filegen_$report_error
		     (0, "cref_listman_",
		     "Warning - no bindfile found for ^a.",
		     bound_segment_name);

/* Hack the bindfile-found bit just to shut up multiple error messages */

		  string_block.bindfile_found = "1"b;
	         end;

	      if primary_block.only_predefined then do;
		  call cref_filegen_$report_error
		     (error_table_$noentry, "cref_listman_",
		     "Bindfile for ^a contained nonexistent component ^a",
		     bound_segment_name, primary_block.name);

/* Hack this bit too, same reason */

		  primary_block.only_predefined = ""b;
	         end;
	   end;

	name_array (1) = primary_block.name;
	n_names = 1;

	if primary_block.master_synonym_node ^= null then do;
	      is_synonym = "1"b;
	      primary_block_ptr = primary_block.master_synonym_node;

	      if dim (name_array, 1) < 2 then do;
		  n_names = -1;
		  return;
	         end;

	      n_names = 2;
	      name_array (2) = primary_block.name;
	      return;
	   end;

	else is_synonym = ""b;

	if primary_block.synonym_forward_chain ^= null then do;

	      do n_names = 2 by 1
	         while (primary_block.synonym_forward_chain ^= null);

/* Fill in synonyms */

	         primary_block_ptr = primary_block.synonym_forward_chain;

	         if n_names > dim (name_array, 1) then do;
		     n_names = -1;
		     return;
		  end;

	         name_array (n_names) = primary_block.name;
	      end;

	      n_names = n_names - 1;			/* hack for loop */
	   end;

	return;
%skip (5);
get_implicit_defs: entry (node_arg, attribute_array, n_elements);


/* This is like all the entries above, look up for comments. */

	primary_block_ptr = node_arg;
	n_elements = 0;

	if primary_block.master_synonym_node ^= null then
	     primary_block_ptr = primary_block.master_synonym_node;

	if primary_block.implicit_definition_chain = null then return;

	node = primary_block.implicit_definition_chain;

	do implicit_def_block_ptr = primary_block.implicit_definition_chain
	   repeat (node)
	   while (node ^= null);			/* chain thru, picking up implicit defs */

	   n_elements = n_elements + 1;
	   if n_elements > dim (attribute_array, 1) then do;
	         n_elements = -1;
	         return;
	      end;

	   attribute_array (n_elements) = implicit_def_block.def_node;

	   node = implicit_def_block.forward_chain;
	end;

	return;
%skip (5);
get_crossrefs: entry (node_arg, attribute_array, n_elements);

	call get_crossref_chain (Program);
	return;



get_include_file_crossrefs: entry (node_arg, attribute_array, n_elements);

	call get_crossref_chain (Include_file);
	return;
%skip (5);
get_crossref_chain: proc (which_type);

dcl  which_type	        fixed bin parameter;

      n_elements = 0;

      if which_type = Program then do;
	  primary_block_ptr = node_arg;

	  if primary_block.crossref_chain = null then return;

	  node = primary_block.crossref_chain;
         end;

      else if which_type = Include_file then do;
	  include_file_ptr = node_arg;

	  if include_file_block.crossref_chain = null then return;

	  node = include_file_block.crossref_chain;
         end;

      do crossref_block_ptr = node
         repeat (node) while (node ^= null);

         n_elements = n_elements + 1;
         if n_elements > dim (attribute_array, 1) then do;
	     n_elements = -1;
	     return;
	  end;

         attribute_array (n_elements) = crossref_block.crossref_node;

         node = crossref_block.forward_chain;
      end;

      return;
   end get_crossref_chain;
%page;
init: entry (segp);

dcl  segp		        pointer;


	cref_area_ptr = segp;

	allocate cref_database in (cref_area);

	cref_database.nullps = null;			/* to catch bugs */
	cref_database.a_nullp = null;			/* same here */
	cref_database.buckets = null;
	cref_database.environment_buckets = null;
	cref_database.include_file_buckets = null;
	return;
%page;
chain_on: proc (chain_word_ptr, curr_block_ptr);

/* This internal subroutine causes the chain word at chain_word_ptr to point
   to the block at curr_block_ptr, relinking the chain after chaining the
   curent block in.  */

dcl  (chain_word_ptr, curr_block_ptr) pointer parameter;

dcl  based_pointer	        pointer unaligned based;

      curr_block_ptr -> based_pointer = chain_word_ptr -> based_pointer;
      chain_word_ptr -> based_pointer = curr_block_ptr;
      return;

   end chain_on;
%skip (5);
make_string: proc (string_arg) returns (pointer);

dcl  string_arg	        char (*) varying;

dcl  satisfied	        bit (1) aligned;


      bucket = rank (substr (string_arg, max (1, length (string_arg) - 2), 1));

/* We use the next-to-last char, not first, because using first would cause
   all the "bound_..." to hash into "b", all the dirs to hash into ">", and
   almost nothing anywhere else.  Using last char would mean having a run on
   "_".  */

      satisfied = ""b;

      prev_ptr = addr (cref_database.environment_buckets (bucket));

      if cref_database.environment_buckets (bucket) ^= null then
         do string_ptr = cref_database.environment_buckets (bucket)
	  repeat (string_block.forward_chain)
	  while (^satisfied);

	  if string_block.string = string_arg then do;
	        if bindfile_found then string_block.bindfile_found = "1"b;
	        return (string_ptr);
	     end;

	  if string_block.forward_chain = null then do;
	        satisfied = "1"b;
	        string_ptr = prev_ptr;
	     end;

	  prev_ptr = string_ptr;
         end;

      charlen = length (string_arg);
      allocate string_block in (cref_area);

      string_block.string = string_arg;
      string_block.forward_chain = null;
      string_block.bindfile_found = bindfile_found;

      call chain_on (prev_ptr, string_ptr);

      return (string_ptr);
   end make_string;

     end cref_listman_;




		    cref_sort_.pl1                  11/17/82  1641.2rew 11/17/82  1626.4       39015



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


cref_sort_: procedure;

/* This module performs the actual cross-referencing operation on the database
   previously set up by cref_analyze_.  It loops through
   all the known names, seeing what each calls.  Each module called has a crossref block assigned to
   it giving the node number of the block under consideration, i.e., the calling procedure.
   This completes the real crossreferencing procedure.  A check is made after
   each successful crossreference to make sure that the definition being referenced
   actually existed in the segment being referenced.  If not, we create an implicit definition
   which cref_filegen_ will later mark with an asterisk.
   If there were any include files defined by cref_analyze_, it crossrefs those too.

   Rewritten totally by C. D. Tavares, 02/03/76 */

dcl  node pointer;

dcl  bucket fixed bin;

dcl  cref_listman_$get_consecutive_segnames ext entry (pointer, fixed bin) returns (pointer),
     cref_listman_$get_refs ext entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$assign_crossref ext entry (pointer, pointer),
     cref_listman_$get_defs ext entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$get_implicit_defs ext entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$create_implicit_def ext entry (pointer, pointer);

dcl  cref_listman_$get_include_files ext entry (pointer, pointer dimension (*), fixed bin),
     cref_listman_$assign_include_file_crossref ext entry (pointer, pointer);

dcl (i, j) fixed bin;

dcl (ref_array, def_array, imp_def_array) (1000) pointer,
    (ref_array_len, def_array_len, imp_def_array_len) fixed bin;

dcl  com_err_ ext entry options (variable),
     null builtin,
     cref_abort_ condition;


	bucket = 0;				/* start from the beginning */

	node = cref_listman_$get_consecutive_segnames (null, bucket); /* get the first good node */

	do while (node ^= null);			/* until database exhausted */

	     call cref_listman_$get_refs (node, ref_array, ref_array_len); /* see what it calls */
	     if ref_array_len < 0 then goto out_of_room;	/* let's hope not */

	     do i = 1 to ref_array_len by 2;		/* assign the actual crossrefs */

		call cref_listman_$assign_crossref (ref_array (i+1), node);
						/* plug on "node" as a caller of entrypoint ref_array (i+1) */

		call cref_listman_$get_defs (ref_array (i), def_array, def_array_len);
						/* get the existing defs for the called segment */
		if def_array_len < 0 then goto out_of_room; /* oh well */

		do j = 1 to def_array_len while (def_array (j) ^= ref_array (i+1));
		end;				/* the one "node" called better be defined */

		if j > def_array_len then do;		/* but it's not, must create an implicit def */

		     call cref_listman_$get_implicit_defs (ref_array (i), imp_def_array, imp_def_array_len);
						/* have we already created this implicit def? */
		     if imp_def_array_len < 0 then goto out_of_room;

		     do j = 1 to imp_def_array_len while (imp_def_array (j) ^= ref_array (i+1));
		     end;				/* try to find it there */

		     if j > imp_def_array_len then	/* nope, this is a new non-existent entry */
			call cref_listman_$create_implicit_def (ref_array (i), ref_array (i+1));
		end;
	     end;

	     call cref_listman_$get_include_files (node, ref_array, ref_array_len); /* see if there are any include files */
	     if ref_array_len < 0 then goto out_of_room;

	     do i = 1 to ref_array_len;

		call cref_listman_$assign_include_file_crossref (ref_array (i), node);
	     end;

	     node = cref_listman_$get_consecutive_segnames (node, bucket); /* grab the next one */
	end;

	return;


out_of_room:					/* indigestion of the internal storage */
	call com_err_ (0, "cref_sort_", "Internal data area overflow.");
	signal cref_abort_;				/* let daddy know we lost */

     end cref_sort_;




		    cross_reference.pl1             04/09/85  1531.2r w 04/08/85  1133.3      186624



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


cross_reference: cref:
     procedure options (variable);

/* CROSS_REFERENCE

   Program to make a cross reference listing from object
   segments.

   Modified 741127 by PG for Version II PL/I
   Modified 750411 by PG to handle errors better
   Totally discombobulated to change command syntax by C. D. Tavares, 02/76
   Modified 11/19/76 by CDT to allow output to be an MSF.
   Modified 09/24/78 by CDT to fix a few bugs in input file parsing.
   Modified 10/13/80 by CDT to add -line_length control arg.
   Modified 2/82 BIM for add_suffix.
*/

/* automatic */

dcl 1 auto_area_info like area_info aligned automatic;	/* see include file below */

dcl  eof bit (1) aligned,
     char_idx fixed bin (21),
     temp_dir char (168) varying,
     temp_string char (168),
     search_dir char (168),
     token char (200) varying,
     save_token char (200) varying,
     master_node pointer,
     al fixed bin (21),
     bitcount fixed bin (24),
     seg_count fixed bin,
     char_count fixed bin (21),
     code fixed bin (35),
    (i, j) fixed bin,
     n_pathnames fixed bin,
     given_ll fixed bin,
     nargs fixed bin,
    (input_seg_ptr, test_outseg_ptr, output_seg_ptr, err_seg_ptr, msf_fcb_ptr, ap) ptr,
     cur_dir_description char (168) varying;

dcl  first_pass bit (1) aligned,
     cur_all_option bit (1) aligned,
     first_switch bit (1) aligned,
     do_include_files bit (1) aligned,
     short_switch bit (1) aligned,
     brief_switch bit (1) aligned;

dcl (input_filename, output_filename) char (168),
    (input_filedir, output_filedir) char (168);

/* external static */

dcl (error_table_$noarg,
     error_table_$inconsistent,
     error_table_$badopt) fixed bin (35) external static;

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

/* internal static */

dcl (Segs_only fixed bin initial (2),
     Nondir_segment bit (2) initial ("01"b)) static options (constant);

/* based variables and their pointers */

dcl 1 star_structure (seg_count) aligned based (star_struc_ptr),
    2 type bit (2) unaligned,
    2 nnames bit (16) unaligned,
    2 nindex bit (18) unaligned;

dcl  star_struc_ptr pointer;

dcl  star_names (1000) based (star_names_ptr) char (32);

dcl  star_names_ptr pointer;

dcl  system_free_area area based (system_free_ptr),
     system_free_ptr pointer;

dcl 1 search_dir_struc aligned based (search_dir_ptr),
    2 make_all_names_external bit (1) aligned,
    2 max_dirs fixed bin,
    2 n_dirs fixed bin,
    2 item (N_DIRS refer (search_dir_struc.max_dirs)),
      3 search_dirs char (168),
      3 search_dir_descriptions char (168) varying;

dcl  N_DIRS fixed bin static options (constant) initial (32),
     search_dir_ptr pointer;
dcl  CROSSREF char (8) internal static options (constant) init ("crossref");
dcl 1 pathname_struc based (pathname_ptr),
    2 xxx fixed bin,
    2 array (nargs refer (xxx)),
      3 pathname char (168),
      3 dirname char (168),
      3 ename char (32),
      3 dir_description char (168) varying,
      3 is_starname bit (1),
      3 all_option bit (1) aligned;

dcl  pathname_ptr pointer;


dcl  arg char (al) based (ap);

%include area_info;
%include access_mode_values;
%include terminate_file;

/* entries */

dcl  define_area_ ext entry (pointer, fixed bin (35)),
     release_area_ ext entry (pointer);

dcl  com_err_ entry options (variable),
     cref_sort_ ext entry,
     cref_listman_$init ext entry (ptr),
     cref_analyze_$init ext entry (bit (1) aligned, bit (1) aligned, pointer),
     cu_$arg_ptr entry (fixed, ptr, fixed bin (21), fixed bin (35)),
     cu_$arg_count ext entry (fixed bin),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     cref_filegen_$init ext entry (ptr, bit (1) aligned, bit (1) aligned, pointer, fixed bin),
     cref_filegen_ entry (ptr, ptr),
     hcs_$delentry_seg entry (ptr, fixed bin (35)),
     initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24),
	fixed binary (35)),
     terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)),
     absolute_pathname_$add_suffix ext entry (char (*), char (*), char (*), fixed bin (35)),
    (get_temp_segment_, release_temp_segment_) ext entry (char (*), pointer, fixed bin (35)),
     hcs_$truncate_seg ext entry (pointer, fixed bin, fixed bin (35)),
     pathname_ entry (character (*), character (*)) returns(character (168)),
     cref_analyze_ entry (char (*), bit (1) aligned);

dcl  get_system_free_area_ ext entry returns (pointer);

dcl  hcs_$star_ ext entry (char (*), char (*), fixed bin, pointer, fixed bin, pointer, pointer, fixed bin (35)),
     check_star_name_$entry ext entry (char (*), fixed bin (35));

dcl  cref_listman_$predefine_primary_block_char ext entry (char (*) varying, pointer, pointer,
     bit (1) aligned, bit (1) aligned, bit (1) aligned) returns (pointer),
     cref_listman_$create_syn_block ext entry (char (*) varying, pointer, pointer, bit (1) aligned, pointer);

dcl  msf_manager_$open ext entry (char (*), char (*), pointer, fixed bin (35)),
     msf_manager_$get_ptr ext entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)),
     msf_manager_$adjust ext entry (pointer, fixed bin, fixed bin (24), bit (3) aligned, fixed bin (35)),
     msf_manager_$close ext entry (pointer);

/* builtins */

dcl (addr, binary, hbound, length, null, rtrim, search, substr, unspec, verify) builtin;

/* conditions */

dcl (cleanup, cref_abort_) condition;


/* program */

/* initialize random variables */

	unspec (auto_area_info) = ""b;

	test_outseg_ptr, err_seg_ptr, auto_area_info.areap, search_dir_ptr,
	     input_seg_ptr, output_seg_ptr, pathname_ptr, star_struc_ptr, star_names_ptr, msf_fcb_ptr = null;
	input_filename, output_filename = "";
	cur_all_option = ""b;
	given_ll = -1;

	system_free_ptr = get_system_free_area_ ();
	first_switch = ""b;
	short_switch, do_include_files = ""b;
	brief_switch = ""b;

	call cu_$arg_count (nargs);
	if nargs = 0 then do;			/* if no args */
	     call com_err_ (error_table_$noarg, "cross_reference", "
     Basic usage: cross_reference pathname1 ... pathname_n");
	     return;
	end;

	auto_area_info.version = area_info_version_1;
	auto_area_info.extend, auto_area_info.no_freeing = "1"b; /* currently doesn't work */
	auto_area_info.size = sys_info$max_seg_size;
	auto_area_info.owner = "cross_reference";

	call define_area_ (addr (auto_area_info), code);
	if code ^= 0 then call crump (code, "temp area creation.");

	allocate search_dir_struc in (system_free_area);

	search_dir_struc.make_all_names_external = ""b;
	search_dir_struc.n_dirs = 0;

	allocate pathname_struc in (system_free_area);

	n_pathnames = 0;
	cur_dir_description = "";

	do i = 1 to nargs;

	     call cu_$arg_ptr (i, ap, al, code);

	     if substr (arg, 1, 1) = "-" then do;

		if (arg = "-input_file") | (arg = "-if") then do;
		     if input_filename ^= "" then call crump (error_table_$inconsistent,
			"Input file may only be specified once.");
		     if i = nargs then call crump (error_table_$noarg,
			"-input_file must be followed by the name of an input file.");

		     i = i + 1;
		     call cu_$arg_ptr (i, ap, al, code);
		     call absolute_pathname_$add_suffix (arg, "crl", input_filename, code);
		     if code ^= 0 then call crump (code, arg);
		end;

		else if (arg = "-output_file") | (arg = "-of") then do;
		     if output_filename ^= "" then call crump (error_table_$inconsistent,
			"Output file may only be specified once.");
		     if i = nargs then call crump (error_table_$noarg,
			"-output_file must be followed by the name of an output file.");

		     i = i + 1;
		     call cu_$arg_ptr (i, ap, al, code);
		     call absolute_pathname_$add_suffix (arg, CROSSREF, output_filename, code);
		     if code ^= 0 then call crump (code, arg);
		end;

		else if arg = "-first" then first_switch = "1"b;

		else if (arg = "-brief" | arg = "-bf") then brief_switch = "1"b;

		else if arg = "-all" then cur_all_option = "1"b;

		else if (arg = "-library" | arg = "-lb") then do;
		     cur_all_option = ""b;
		     i = i + 1;
		     call cu_$arg_ptr (i, ap, al, code);
		     cur_dir_description = arg;
		end;

		else if (arg = "-include_files" | arg = "-icf") then do_include_files = "1"b;

		else if (arg = "-short" | arg = "-sh") then short_switch = "1"b;

		else if (arg = "-ll" | arg = "-line_length") then do;
		     if i = nargs then call crump (error_table_$noarg,
			"-ll must be followed by number.");

		     i = i + 1;
		     call cu_$arg_ptr (i, ap, al, code);
		     given_ll = cv_dec_check_ (arg, code);
		     if code ^= 0 then call crump (0, arg || " non-numeric.");
		end;

		else call crump (error_table_$badopt, arg);
	     end;

	     else do;
		n_pathnames = n_pathnames + 1;
		pathname (n_pathnames) = arg;
		dir_description (n_pathnames) = cur_dir_description;
		all_option (i) = cur_all_option;
	     end;
	end;

/* check for wierd and illegal combinations of control args */

	if input_filename ^= "" then
	     if n_pathnames > 0 then call crump (error_table_$inconsistent,
		"-input_file cannot be specified with explicit pathnames.");
	     else if cur_dir_description ^= "" then call crump (error_table_$inconsistent, "-input_file and -library");

	if n_pathnames > 0 then
	     if first_switch
	     then call crump (error_table_$inconsistent, "-first meaningless with explicit pathnames.");


/* Create temp files, etc. */

	if output_filename = "" then
	     if input_filename = "" then
		output_filename = "crossref.crossref";
	     else do;

		call expand_pathname_ (input_filename, (""), output_filename, code);
		if code ^= 0 then call crump (code, output_filename);

		output_filename = rtrim (before (output_filename, ".crl")) || "." ||
		     CROSSREF;

	     end;


	call get_temp_segment_ ("cross_reference", err_seg_ptr, code);
	if err_seg_ptr = null then call crump (code, "err segment creation.");

	temp_string = output_filename;
	call expand_pathname_ (temp_string, output_filedir, output_filename, code);
	if code ^= 0 then call crump (code, temp_string);

	call msf_manager_$open (output_filedir, output_filename, msf_fcb_ptr, code);
	if msf_fcb_ptr = null then goto output_seg_err;

	call msf_manager_$get_ptr (msf_fcb_ptr, /* component */ 0, "1"b /* ok to create */, test_outseg_ptr, 0, code);
						/* initiate it just to see if everything is OK, but NOT
						   using output_seg_ptr so that we don't delete the seg on
						   an error, in case there is already something in it */
	if test_outseg_ptr = null then do;
output_seg_err:
	     call com_err_ (code, "cross_reference", "^a.", pathname_ (output_filedir, output_filename));
	     goto err_return;
	end;

	if code = 0 then output_seg_ptr = test_outseg_ptr;
						/* we really did create it, OK to delete on an err */


	call cref_listman_$init (auto_area_info.areap);
	call cref_analyze_$init (first_switch, do_include_files, search_dir_ptr);
	call cref_filegen_$init (err_seg_ptr, brief_switch, short_switch,
	     auto_area_info.areap, given_ll);


	on cref_abort_ go to unwind_and_abort;		/* handle error case */
	on cleanup call clean_up;			/* and cleanups, too  */
	
	if input_filename ^= "" then do;		/* do the whole thing out of an input file */

	     temp_string = input_filename;
	     call expand_pathname_ (temp_string, input_filedir, input_filename, code);
	     if code ^= 0 then call crump (code, temp_string);

	     call initiate_file_ (input_filedir, input_filename, R_ACCESS, input_seg_ptr, bitcount, code);

	     if code ^= 0 then do;
		if input_seg_ptr ^= null /* zero_length */
		then call terminate_file_ (input_seg_ptr, (0), TERM_FILE_TERM, (0));
		call com_err_ (code, "cross_reference", "^a", pathname_ (input_filedir, input_filename));
		goto err_return;
	     end;

	     char_count = divide (bitcount, 9, 35, 0);

	     do first_pass = "1"b, ""b;
		char_idx = 1;			/* char index into driving file */
		eof = ""b;

		token = get_token ();

		do while (^eof);

		     if (token = "-library" | token = "-lb") then do;

			token = get_token ();

			if token = "-all" then do;
			     cur_all_option = "1"b;
			     token = get_token ();
			end;

			else cur_all_option = ""b;

			if token ^= ":" then call crump (0,
			     "Unexpected token || """ || token || """ in -library statement.");

			search_dir_struc.make_all_names_external = ""b;
			search_dir_struc.n_dirs = 0;

			search_dir = get_token ();

			do while (search_dir ^= ";");

			     if eof then
				call crump (0, "Unexpected end-of-file while processing search list; possible missing semicolon in input file.");

			     if search_dir = "-wd" then search_dir = "";
			     else if search_dir = "-working_directory" then search_dir = "";
			     cur_dir_description = rest_of_line ();
			     call expand_pathname_ (search_dir, dirname (1), ename (1), code);
			     if code ^= 0 then if first_pass then call com_err_ (code, "cross_reference",
				     "Directory ^a not searched.", search_dir);

				else;

			     else do;
				temp_dir = pathname_ (dirname (1), ename (1));

				search_dir_struc.n_dirs = search_dir_struc.n_dirs + 1;

				if search_dir_struc.n_dirs > hbound (search_dir_struc.item, 1) then do;
				     call com_err_ (0, "cross_reference", "More than ^d search paths specified.", hbound (search_dir_struc.item, 1));
				     signal cref_abort_;
				end;

				if cur_dir_description ^= "" then
				     search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = cur_dir_description;
				else search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = temp_dir;

				search_dir_struc.search_dirs (search_dir_struc.n_dirs) = temp_dir;

				search_dir_struc.make_all_names_external = cur_all_option;

			     end;

			     search_dir = get_token ();
			end;

			token = get_token ();
		     end;

		     if peek_rest_of_line () ^= "" then /* this is a synonym definition line */
			if first_pass then do;	/* define syns on first pass only */

			     save_token = token;

			     master_node = cref_listman_$predefine_primary_block_char (token, null, null, "1"b, ""b, "1"b);

			     do while (peek_rest_of_line () ^= "");
				token = get_token ();
				call cref_listman_$create_syn_block (token, null, null, "1"b, master_node);
			     end;

			     token = save_token;
			end;			/* but don't analyze seg, may not be freestanding */

			else temp_string = rest_of_line (); /* throw line away on second pass */

		     else call cref_analyze_ ((token), first_pass); /* one-token line, analyze seg */

		     token = get_token ();
		end;
	     end;
	end;
	
	else do;					/* process by argument list */

	     do i = 1 to n_pathnames;
		call expand_pathname_ (pathname (i), dirname (i), ename (i), code);
		if code ^= 0 then call crump (code, pathname (i));

		call check_star_name_$entry (ename (i), code);
		if code = 0 then is_starname (i) = ""b;
		else if code < 3 then is_starname (i) = "1"b;
		else call crump (code, ename (i));
	     end;

	     do first_pass = "1"b, ""b;

		do i = 1 to n_pathnames;

		     search_dir_struc.make_all_names_external = ""b;
		     search_dir_struc.n_dirs = 0;

		     if search_dir_struc.n_dirs > hbound (search_dir_struc.item, 1) then do;
			call com_err_ (0, "cross_reference", "More than ^d search paths specified.", hbound (search_dir_struc.item, 1));
			signal cref_abort_;
		     end;

		     search_dir_struc.n_dirs = search_dir_struc.n_dirs + 1;

		     if dir_description (i) ^= "" then
			search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = dir_description (i);
		     else search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = rtrim (dirname (i), " ");

		     search_dir_struc.search_dirs (search_dir_struc.n_dirs) = dirname (i);

		     search_dir_struc.make_all_names_external = all_option (i);

		     if is_starname (i) then do;

			call hcs_$star_ (dirname (i), ename (i), Segs_only, system_free_ptr,
			     seg_count, star_struc_ptr, star_names_ptr, code);
			if code ^= 0 then
			     if first_pass then call com_err_ (code, "cross_reference", "^a.  Continuing...",
				pathname_ (dirname (i), ename (i)));

			     else;

			else do;
			     do j = 1 to seg_count;

				if star_structure.type (j) = Nondir_segment
				then do;

				     call cref_analyze_ (star_names (binary (star_structure (j).nindex, 17)),
					first_pass);
				end;
			     end;

			     free star_names in (system_free_area),
				star_structure in (system_free_area);

			     star_names_ptr, star_struc_ptr = null;
			end;
		     end;

		     else do;
			call cref_analyze_ (ename (i), first_pass);
		     end;
		end;
	     end;

	end;

	call cref_sort_;				/* make cross ref lists */

	output_seg_ptr = test_outseg_ptr;		/* now we should delete it if we abort */
	call hcs_$truncate_seg (output_seg_ptr, 0, code); /* This is not the most efficient, but cref_filegen_ may depend on it */
	if code ^= 0 then goto output_seg_err;

	call cref_filegen_ (output_seg_ptr, msf_fcb_ptr); /* create output seg when done */

	call msf_manager_$close (msf_fcb_ptr);
	msf_fcb_ptr = null;

	call terminate_file_ (output_seg_ptr, (0), TERM_FILE_TERM, code);
	output_seg_ptr = null;

	
err_return:
	call clean_up;
	return;

unwind_and_abort:
	call com_err_ (0, "cross_reference", "Fatal error. Invocation aborted.");
	call clean_up;
	return;

clean_up:
	procedure;

	     if msf_fcb_ptr ^= null then do;		/* output seg never successfully finished */
		call msf_manager_$adjust (msf_fcb_ptr, 0, 0, "110"b, code);
		if output_seg_ptr ^= null then call hcs_$delentry_seg (output_seg_ptr, code);
		call msf_manager_$close (msf_fcb_ptr);
	     end;
	     if auto_area_info.areap ^= null then call release_area_ (auto_area_info.areap);
	     if err_seg_ptr ^= null then call release_temp_segment_ ("cross_reference", err_seg_ptr, code);
	     if input_seg_ptr ^= null then call terminate_file_ (input_seg_ptr, (0), TERM_FILE_TERM, (0));
	     if star_struc_ptr ^= null then free star_structure in (system_free_area);
	     if star_names_ptr ^= null then free star_names in (system_free_area);
	     if pathname_ptr ^= null then free pathname_struc in (system_free_area);
	     if search_dir_ptr ^= null then free search_dir_struc in (system_free_area);

	end clean_up;


crump:	proc (code, reason);

dcl  code fixed bin (35) parameter,
     reason char (*) parameter;

	     call com_err_ (code, "cross_reference", reason);
	     goto err_return;
	end crump;

get_token: proc returns (char (200) varying);

dcl  token char (200) varying;

dcl  input_seg char (char_count) based (input_seg_ptr);

dcl  separators char (3) static initial ("
	 "),						/* nl, tab, space */
     terminators char (2) static initial ("
;"),
     breaks_and_separators char (5) static initial ("
	 :;");						/* nl, tab, space, colon, semi */

dcl  i fixed bin (21);


	     if char_idx > char_count then goto set_eof;

	     i = verify (substr (input_seg, char_idx), separators) - 1;
	     if i = -1 then goto set_eof;

	     char_idx = char_idx + i;

	     i = search (substr (input_seg, char_idx), breaks_and_separators) - 1;
	     if i = -1 then i = char_count - char_idx + 1;
	     else if i = 0 then i = 1;

	     token = substr (input_seg, char_idx, i);

	     char_idx = char_idx + i;

	     if char_idx > char_count then goto set_eof;

	     return (token);

rest_of_line:  entry returns (char (200) varying);

	     peek_switch = ""b;
	     goto common;

peek_rest_of_line: entry returns (char (200) varying);

dcl  peek_switch bit (1);

dcl  whitespace char (2) static initial ("	 ");		/* tab, space */

	     peek_switch = "1"b;

common:
	     if char_idx > char_count then goto set_eof;

	     i = verify (substr (input_seg, char_idx), whitespace) - 1;
	     if i = -1 then goto set_eof;

	     char_idx = char_idx + i;

	     i = search (substr (input_seg, char_idx), terminators) - 1;
	     if i = -1 then token = substr (input_seg, char_idx);
	     else token = substr (input_seg, char_idx, i);

	     if ^peek_switch then char_idx = char_idx + i;

	     return (token);

set_eof:
	     char_idx = char_count + 1;
	     eof = "1"b;
	     return ("");

	end get_token;

     end cross_reference;




		    peruse_crossref.pl1             09/15/86  1154.3rew 09/15/86  1153.2      405054



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


/* This program peruses a cross-reference output file, as generated by the
   online crossreference program. It is used to print out entries from the
   crossref in a relatively readable format.

   Modification history:
   08/13/80 W. Olin Sibert
   03/04/81 E. N. Kittlitz - divers alterations.
   04/22/81 E. N. Kittlitz - handle cref* error messages in CREF MSF.
   Fix assumes that all messages are at end of MSF.
   12/31/81 J. Spencer Love - fix search bug, fix long include file names
   bug, minor improvements.
   2/82 BIM for default cref path.
   4 Apr 82, WOS: Modified for active function usage.
   1984-08-26 BIM -brief_errors
   1985-01-03, BIM: fixed leading _ names to work for include files.
*/


/****^  HISTORY COMMENTS:
  1) change(86-08-16,JSLove), approve(86-08-16,MCR7430),
     audit(86-09-12,GDixon), install(86-09-15,MR12.0-1153):
     Added support for synonyms in input file.  Added undocumented -debug
     control argument.
                                                   END HISTORY COMMENTS */


/* format: style2 */

pcref:
peruse_crossref:
     procedure () options (variable);

	dcl     alp		 pointer;
	dcl     code		 fixed bin (35);
	dcl     debug		 bit (3) aligned;
	dcl     nargs		 fixed bin;
	dcl     rs_ptr		 pointer;
	dcl     rs_lth		 fixed bin (21);
	dcl     return_string	 char (rs_lth) based (rs_ptr) varying;
	dcl     complain		 variable entry options (variable);
	dcl     active_function	 bit (1) aligned;
	dcl     brief_sw		 bit (1) aligned;
	dcl     brief_error_sw	 bit (1) aligned;
	dcl     questionable_module	 bit (1) aligned;	/* GLOBAL for communication between process_entry and process_entrypoint. */

	dcl     dname		 char (168);
	dcl     ename		 char (32);
	dcl     bitcount		 fixed bin (24);
	dcl     fs_type		 fixed bin (2);
	dcl     fcb_ptr		 pointer;

	dcl     system_area_ptr	 pointer;
	dcl     system_area		 area based (system_area_ptr);

	dcl     first_entry		 fixed bin;
	dcl     n_entries		 fixed bin;
	dcl     entry_ptr		 pointer;
	dcl     1 entry		 (n_entries) based (entry_ptr),
		2 argno		 fixed bin,
		2 name		 char (36) varying,
		2 ep		 char (36) varying,
		2 non_star_lth	 fixed bin,
		2 include		 bit (1) aligned;

	dcl     n_parts		 fixed bin;
	dcl     1 part		 (64) aligned,	/* "parts" of the cref. Segments and last/first lines */
		2 ptr		 pointer,		/* pointer to beginning of this part */
		2 lth		 fixed bin (21),	/* length in characters */
		2 first		 fixed bin (30),	/* index (from char 1 of part 1) of first char in this part */
		2 last		 fixed bin (30),	/* index of last char in this part */
		2 allocated	 bit (1) aligned;	/* whether this part was allocated, and hence must be freed */

	dcl     active_fnc_err_	 entry options (variable);
	dcl     check_star_name_$entry entry (char (*), fixed bin (35));
	dcl     com_err_		 entry options (variable);
	dcl     cu_$af_return_arg	 entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry (pointer);
	dcl     cu_$arg_ptr_rel	 entry (fixed bin, pointer, fixed bin (21), fixed bin (35), pointer);
	dcl     expand_pathname_$add_suffix
				 entry (character (*), character (*), character (*), character (*),
				 fixed binary (35));
	dcl     get_system_free_area_	 entry () returns (pointer);
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     initiate_file_	 entry (character (*), character (*), bit (*), pointer, fixed binary (24),
				 fixed binary (35));
	dcl     terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));
	dcl     pathname_		 entry (character (*), character (*)) returns (character (168));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$nnl		 entry options (variable);
	dcl     match_star_name_	 entry (char (*), char (*), fixed bin (35));
	dcl     msf_manager_$close	 entry (pointer);
	dcl     msf_manager_$get_ptr	 entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24),
				 fixed bin (35));
	dcl     msf_manager_$open	 entry (char (*), char (*), pointer, fixed bin (35));

	dcl     (
	        error_table_$badopt,
	        error_table_$dirseg,
	        error_table_$noarg,
	        error_table_$not_act_fnc,
	        error_table_$too_many_args
	        )			 fixed bin (35) external static;

	dcl     WHOAMI		 char (32) internal static options (constant) init ("peruse_crossref");
	dcl     DEFAULT_CREF_PATH	 char (168) init (">library_dir_dir>crossref>total.crossref") internal
				 static options (constant);
	dcl     SUFFIX		 char (8) init ("crossref") internal static options (constant);
	dcl     FIRST_CH		 char (63) aligned internal static options (constant)
				 init ("_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789");
	dcl     DASH		 char (1) aligned internal static options (constant) init ("-");
	dcl     SPACE		 char (1) aligned internal static options (constant) init (" ");
	dcl     TWO_SPACES		 char (2) aligned internal static options (constant) init ("  ");
	dcl     TAB		 char (1) aligned internal static options (constant) init ("	");
	dcl     TWO_TABS		 char (2) aligned internal static options (constant)
				 init ("		");
	dcl     NEWLINE		 char (1) aligned internal static options (constant) init ("
");
	dcl     WHITESPACE		 char (3) aligned internal static options (constant) init ("
	 ");					/* NEWLINE, TAB, SPACE */

	dcl     (
	        LESS		 init (1),
	        EQUAL		 init (2),
	        GREATER		 init (3)
	        )			 fixed bin internal static options (constant);

	dcl     (
	        EXACT		 init (1),
	        PARTIAL		 init (2),
	        MISS		 init (3)
	        )			 fixed bin internal static options (constant);

	dcl     (cleanup, logic_error) condition;

	dcl     (addr, after, before, bit, copy, divide, index, length, ltrim, maxlength, min, null, reverse, rtrim,
	        search, substr, unspec, verify)
				 builtin;

%page;
%include access_mode_values;
%page;
%include terminate_file;
%page;
	call cu_$af_return_arg (nargs, rs_ptr, rs_lth, code);

	if (code = 0)
	then do;
		complain = active_fnc_err_;
		return_string = "";
		active_function = "1"b;
	     end;
	else if (code = error_table_$not_act_fnc)
	then do;
		complain = com_err_;
		rs_ptr = null ();
		active_function = "0"b;
	     end;
	else do;
		call com_err_ (code, WHOAMI);
		return;
	     end;

	call cu_$arg_list_ptr (alp);

	system_area_ptr = get_system_free_area_ ();	/* sundry initializations, for cleanup etc. */
	n_parts = 0;
	part.ptr (1) = null ();
	first_entry = 0;
	n_entries = 0;
	dname = "";
	entry_ptr = null ();
	fcb_ptr = null ();

	on condition (cleanup) call clean_up ();

	if nargs < 1
	then do;
USAGE:
		call complain (error_table_$noarg, WHOAMI,
		     "^/Usage:^-^a {crossref_pathname} entrypoint_name(s) {-control_args}", WHOAMI);

MAIN_RETURN:
		call clean_up ();
		return;
	     end;

	call process_args ();

	if n_entries = 0
	then /* must have at least one entrypoint, natch */
	     goto USAGE;

	allocate entry in (system_area) set (entry_ptr);	/* allocate the info array */

	call check_entries ();

	call default_input_file ();

	call hcs_$status_minf (dname, ename, 1b /* chase */, fs_type, bitcount, code);
	if code ^= 0
	then do;
BAD_XREF:
		call complain (code, WHOAMI, "^a", pathname_ (dname, ename));
		goto MAIN_RETURN;
	     end;

	if fs_type = 1
	then /* segment */
	     call initiate_segment ();

	else do;					/* must be an MSF */
		if bitcount = 0
		then do;				/* but it's NOT */
			code = error_table_$dirseg;
			goto BAD_XREF;
		     end;

		call initiate_msf ();
	     end;

	if (debug & "1"b) ^= ""b
	then call print_parts ();

	if (debug & "01"b) = ""b
	then call print_matches ();

	return;
%page;
print_parts:
     proc ();

/* Debugging procedure to list parts of cref file */

	dcl     part_idx		 fixed bin;

	do part_idx = 1 to n_parts;
	     call ioa_ ("Part ^d: ^d chars @ ^p.", part_idx, part.lth (part_idx), part.ptr (part_idx));
	end;

	call ioa_ ("");

	return;
     end print_parts;


print_matches:
     proc ();

/* procedure to print matches found in cref. */

	dcl     line_start		 fixed bin (30);
	dcl     line_ptr		 pointer;
	dcl     line_lth		 fixed bin (21);
	dcl     line		 char (line_lth) based (line_ptr);

	dcl     match		 fixed bin;
	dcl     entry_idx		 fixed bin;
	dcl     search_name		 char (36) varying;
	dcl     exact		 bit (1) aligned;
	dcl     include		 bit (1) aligned;


	do entry_idx = 1 to n_entries;
	     search_name = substr (entry.name (entry_idx), 1, entry.non_star_lth (entry_idx));
	     exact = (length (search_name) = length (entry.name (entry_idx)));
	     include = entry.include (entry_idx);

	     call find_line (search_name, include, exact, line_ptr, line_start, line_lth, match);

	     if (debug & "001"b) ^= ""b
	     then call ioa_ ("^[Exact^;Partial^;No^] match for ""^a"" in ^d char line at char ^d (^p):^/^a", match,
		     entry.name (entry_idx), line_lth, line_start, line_ptr, line);

	     call process_entry (entry_idx, line_start, line_ptr, line_lth);
	end;

	return;
     end print_matches;
%page;
clean_up:
     proc ();

/* cleanup procedure */

	dcl     s1p		 pointer;
	dcl     s1l		 fixed bin (21);
	dcl     s1		 char (s1l) based (s1p);
	dcl     part_idx		 fixed bin;

	if entry_ptr ^= null ()
	then free entry in (system_area);

	if fcb_ptr = null ()
	then do;					/* not an MSF to close */
		if part.ptr (1) ^= null ()
		then /* but there is a segment */
		     call terminate_file_ (part.ptr (1), (0), TERM_FILE_TERM, (0));
	     end;

	else do;					/* otherwise, close the MSF */
		call msf_manager_$close (fcb_ptr);
		do part_idx = 2 to (n_parts - 1) by 2;	/* and free all the strings */
		     s1p = part.ptr (part_idx);
		     s1l = part.lth (part_idx);
		     if part.allocated (part_idx)
		     then free s1 in (system_area);
		end;
	     end;					/* of closing MSF */

	return;
     end clean_up;
%page;
process_args:
     proc ();

/* Simple procedure to process arguments */

	dcl     ap		 pointer;
	dcl     al		 fixed bin (21);
	dcl     arg		 char (al) based (ap);
	dcl     argno		 fixed bin;

	brief_sw, brief_error_sw = "0"b;
	debug = ""b;
	do argno = 1 to nargs;
	     call cu_$arg_ptr_rel (argno, ap, al, (0), alp);

	     if index (arg, "-") = 1
	     then if (^active_function) & ((arg = "-brief") | (arg = "-bf"))
		then brief_sw = "1"b;
		else if (^active_function) & ((arg = "-long") | (arg = "-lg"))
		then brief_sw = "0"b;
		else if arg = "-brief_errors" | arg = "-bfe"
		then brief_error_sw = "1"b;
		else if arg = "-debug" | arg = "-db"
		then do;
			if argno = nargs
			then do;
				call complain (error_table_$noarg, WHOAMI,
				     "^a must be followed by a debug bit mask.", arg);
				goto MAIN_RETURN;
			     end;
			argno = argno + 1;
			call cu_$arg_ptr_rel (argno, ap, al, (0), alp);
			debug = bit (arg, 3);
		     end;
		else if arg = "-long_errors" | arg = "-lgfe"
		then brief_error_sw = "0"b;
		else if (arg = "-pathname") | (arg = "-pn")
		then do;
			if argno = nargs
			then do;
				call complain (error_table_$noarg, WHOAMI,
				     "^a must be followed by a crossreference pathname.", arg);
				goto MAIN_RETURN;
			     end;
			argno = argno + 1;
			call cu_$arg_ptr_rel (argno, ap, al, (0), alp);
			goto PATHNAME;
		     end;

		else do;
			call complain (error_table_$badopt, WHOAMI, "^a", arg);
			goto MAIN_RETURN;
		     end;

	     else if search (arg, "<>") > 0
	     then
PATHNAME:
		do;				/* Looks Like a PATHNAME! */
		     if dname ^= ""			/* Two PATHNAMES? */
		     then do;
			     call complain (error_table_$too_many_args, WHOAMI,
				"Only one crossref pathname is allowed, but ^a appears to be a second pathname.",
				arg);
			     goto MAIN_RETURN;
			end;

		     call expand_pathname_$add_suffix (arg, SUFFIX, dname, ename, code);
		     if code ^= 0
		     then do;
			     call complain (code, WHOAMI, "^a", arg);
			     goto MAIN_RETURN;
			end;
		end;

	     else do;				/* A SEARCH NAME (a search name) */
		     if first_entry = 0
		     then first_entry = argno;
		     n_entries = n_entries + 1;	/* otherwise, remember that we've seen an entrypoint */
		end;

	end;					/* of loop through args */

	return;
     end process_args;
%page;
check_entries:
     proc ();

/* This procedure is used to extract and validate the arguments from the command line
   which specify things to be searched for. */

	dcl     ap		 pointer;
	dcl     al		 fixed bin (21);
	dcl     arg		 char (al) based (ap);
	dcl     argno		 fixed bin;

	dcl     name		 char (36) varying;
	dcl     ep		 char (36) varying;
	dcl     i1		 fixed bin;
	dcl     entry_idx		 fixed bin;

	entry_idx = 0;
	do argno = first_entry to nargs;
	     call cu_$arg_ptr_rel (argno, ap, al, (0), alp);

	     if index (arg, "-") ^= 1 & search (arg, "<>") = 0
	     then do;				/* thats us */
		     entry_idx = entry_idx + 1;	/* get to the next slot */
		     entry.argno (entry_idx) = argno;
		end;
	end;

	do entry_idx = 1 to n_entries;		/* validate the name portions */
	     ep = "";
	     call cu_$arg_ptr_rel (entry.argno (entry_idx), ap, al, (0), alp);

	     name = before (arg, "$");		/* split it in pieces */
	     ep = after (arg, "$");

	     if index (arg, ".incl") = 0
	     then entry.include (entry_idx) = "0"b;
	     else do;
		     entry.include (entry_idx) = "1"b;

		     if length (name) <= 25 & substr (reverse (name), 1, 5) = "lcni."
		     then name = name || ".*";

		     if ep ^= ""
		     then call bad_entry_format ("$ not allowed in include name.");
		end;

	     if length (name) > 32
	     then call bad_entry_format ("Segment name too long.");
	     if length (ep) > 256
	     then call bad_entry_format ("Entrypoint name too long.");

	     entry.name (entry_idx) = name;
	     entry.ep (entry_idx) = ep;

	     call check_star_name_$entry ((name), code);
	     if code > 2
	     then call bad_entry_format ("Invalid star name.");
	     else if code = 2
	     then call bad_entry_format ("Double star not allowed in segment name.");
	     else if code = 1
	     then do;				/* special stuff for hacking star names */
		     i1 = search (name, "*?");	/* find first star-like char -- there is guaranteed to be one */
		     if i1 = 1
		     then /* too complicated to implement this time */
			call bad_entry_format ("Star names may not begin with star.");
		     entry.non_star_lth (entry_idx) = i1 - 1;
						/* length of non-starred portion */
		end;
	     else entry.non_star_lth (entry_idx) = length (name);
						/* otherwise, is whole thing */

	     if length (ep) > 0
	     then do;				/* validate entrypoint name, too */
		     call check_star_name_$entry ((ep), code);
		     if code > 2
		     then call bad_entry_format ("Invalid star name.");
		end;
	end;					/* of validation loop */

	return;					/* end of main code of check_entries */
%page;
bad_entry_format:
     proc (P_message);

	dcl     P_message		 char (*) parameter;

	call cu_$arg_ptr_rel (entry.argno (entry_idx), ap, al, (0), alp);

	call complain (0, WHOAMI, "Invalid search name ^a. ^a", arg, P_message);
	goto MAIN_RETURN;

     end bad_entry_format;

     end check_entries;
%page;
initiate_segment:
     proc ();

/* This procedure is used to initiate a single segment if the xref is not an MSF;
   it creates, effectively, information about a one component MSF. */

	unspec (part (1)) = ""b;

	call initiate_file_ (dname, ename, R_ACCESS, part.ptr (1), bitcount, code);
	if code ^= 0
	then goto BAD_XREF;

	n_parts = 1;

	part.lth (1) = divide (bitcount, 9, 21, 0);
	part.first (1) = 1;				/* first and only component */
	part.last (1) = part.lth (1);			/* last char */
	part.allocated (1) = "0"b;			/* should be terminated, not freed */

	return;
     end initiate_segment;
%page;
initiate_msf:
     proc ();

/* This procedure is used to initiate all the components of an MSF, and then create
   extra "lines" between each component which contain all the characters after (but not
   including) the last newline in component N, followed by all the characters up to and
   including the first newline in component N+1. The starting addresses and lengths of
   each component are then updated appropriately to compensate for the characters
   thus extracted. */

	dcl     (s1p, s2p, s3p)	 pointer;		/* assorted based strings */
	dcl     (s1l, s2l, s3l)	 fixed bin (21);
	dcl     s1		 char (s1l) based (s1p);
	dcl     s2		 char (s2l) based (s2p);
	dcl     s3		 char (s3l) based (s3p);

	dcl     (i1, i2)		 fixed bin (30);
	dcl     part_idx		 fixed bin;
	dcl     component_idx	 fixed bin;


	call msf_manager_$open (dname, ename, fcb_ptr, code);
	if (fcb_ptr = null ()) | (code ^= 0)
	then goto BAD_XREF;

	part_idx = 1;				/* incremented by two each time through */
	do component_idx = 0 by 1;
	     unspec (part (part_idx)) = ""b;		/* initialize */
	     unspec (part (part_idx + 1)) = ""b;
	     part.ptr (part_idx + 1) = null ();

	     call msf_manager_$get_ptr (fcb_ptr, component_idx, "0"b, part.ptr (part_idx), bitcount, code);
	     if part.ptr (part_idx) = null ()
	     then /* last one, probably */
		goto MSF_INITIATED;

	     part.lth (part_idx) = divide (bitcount, 9, 21, 0);
	     n_parts = part_idx;
	     part_idx = part_idx + 2;
	end;

MSF_INITIATED:
	do part_idx = 1 to (n_parts - 2) by 2;		/* now, combine the end and beginning of each segment */
	     s1p = part.ptr (part_idx);		/* into a bare line, so that each part contains only */
	     s1l = part.lth (part_idx);		/* integral lines */
	     i1 = length (s1) - index (reverse (s1), NEWLINE) + 2;
						/* first char after last newline */

	     s2p = part.ptr (part_idx + 2);		/* next segment */
	     s2l = part.lth (part_idx + 2);
	     i2 = index (s2, NEWLINE);		/* first newline */

	     s3l = length (substr (s1, i1)) + length (substr (s2, 1, i2));
						/* length of string to be allocated */
	     allocate s3 in (system_area) set (s3p);	/* -- sum of lengths of line parts */

	     substr (s3, 1, length (substr (s1, i1))) = substr (s1, i1);
						/* and copy in the two pieces */
	     substr (s3, 1 + length (substr (s1, i1))) = substr (s2, 1, i2);

	     part.lth (part_idx) = part.lth (part_idx) - length (substr (s1, i1));
						/* shorten it by amount removed */

	     part.ptr (part_idx + 1) = addr (substr (s3, 1, 1));
						/* remember location of line */
	     part.lth (part_idx + 1) = length (s3);
	     part.allocated (part_idx + 1) = "1"b;

	     part.ptr (part_idx + 2) = addr (substr (s2, i2 + 1));
						/* move the beginning up */
	     part.lth (part_idx + 2) = length (substr (s2, i2 + 1));
						/* and shorten it */
	end;

	part.first (1) = 1;				/* first char of part 1 is 1 */
	do part_idx = 1 to n_parts - 1;		/* now, set the "first" char of each */
	     part.first (part_idx + 1) = part.first (part_idx) + part.lth (part_idx);
	end;

	do part_idx = 1 to n_parts;			/* now set part.last for all the parts */
	     part.last (part_idx) = part.first (part_idx) + part.lth (part_idx) - 1;
	end;

	return;
     end initiate_msf;
%page;
locate_char:
     proc (P_idx, P_part_idx, P_part_offset);

/* This procedure takes a character index (as counted from character one of
   part one) and returns the index of the part which contains it and
   an index into that part. */

	dcl     (
	        P_idx		 fixed bin (30),
	        P_part_idx		 fixed bin,
	        P_part_offset	 fixed bin (21)
	        )			 parameter;

	dcl     idx		 fixed bin;

	do idx = 1 to n_parts;
	     if P_idx >= part.first (idx)
	     then if P_idx <= part.last (idx)
		then do;				/* found it */
			P_part_idx = idx;
			P_part_offset = P_idx - part.first (idx) + 1;
			return;
		     end;
	end;					/* of loop through parts */

	P_part_idx = -1;				/* force a fault if we fall through */
	P_part_offset = -1;

	return;
     end locate_char;
%page;
/* This procedure locates the beginning and end of the text line containing the
   referenced character, and returns a pointer to its first character and the length
   of the line. The line contains a trailing newline, unless the last line of the
   crossreference lacks one and is returned. */

locate_line:
     proc (P_idx, P_line_ptr, P_line_start, P_line_lth);

	dcl     (
	        P_idx		 fixed bin (30),
	        P_line_ptr		 pointer,
	        P_line_start	 fixed bin (30),
	        P_line_lth		 fixed bin (21)
	        )			 parameter;

	dcl     part_ptr		 pointer;
	dcl     part_lth		 fixed bin (21);
	dcl     part		 char (part_lth) based (part_ptr);
	dcl     part_idx		 fixed bin;
	dcl     char_idx		 fixed bin (21);
	dcl     first		 fixed bin (21);
	dcl     lth		 fixed bin (21);

	call locate_char (P_idx, part_idx, char_idx);

	part_ptr = part.ptr (part_idx);
	part_lth = part.lth (part_idx);

	first = index (reverse (substr (part, 1, char_idx)), NEWLINE);
	if first = 0
	then /* no previous newline, start at char 1 */
	     first = 1;
	else first = char_idx - first + 2;

	lth = index (substr (part, first), NEWLINE);
	if lth = 0
	then /* no trailing newline */
	     P_line_lth = length (substr (part, first));
	else P_line_lth = lth;			/* otherwise, include the newline */

	P_line_start = part.first (part_idx) + first - 1; /* the index of the first char */
	P_line_ptr = addr (substr (part, first, 1));

	return;
     end locate_line;
%page;
next_line:
     proc (P_old_line_start, P_old_line_lth, P_new_line_ptr, P_new_line_start, P_new_line_lth);

/* This procedure takes the index of the first character in a line, and returns pointer, start,
   and length for the next line in the file, or a null pointer if there is none. */

	dcl     (
	        P_old_line_start	 fixed bin (30),
	        P_old_line_lth	 fixed bin (21),
	        P_new_line_ptr	 pointer,
	        P_new_line_start	 fixed bin (30),
	        P_new_line_lth	 fixed bin (21)
	        )			 parameter;

	dcl     part_ptr		 pointer;
	dcl     part_lth		 fixed bin (21);
	dcl     part		 char (part_lth) based (part_ptr);
	dcl     part_idx		 fixed bin;
	dcl     char_idx		 fixed bin (21);
	dcl     lth		 fixed bin (21);


	call locate_char (P_old_line_start + P_old_line_lth, part_idx, char_idx);
	if part_idx < 0
	then goto NO_APPROPRIATE_LINE;

	part_ptr = part.ptr (part_idx);
	part_lth = part.lth (part_idx);

	lth = index (substr (part, char_idx), NEWLINE);
	if lth = 0
	then /* no trailing newline */
	     P_new_line_lth = length (substr (part, char_idx));
	else P_new_line_lth = lth;			/* otherwise, include the newline */

	goto RETURN_INDICES;


prev_line:
     entry (P_old_line_start, P_old_line_lth, P_new_line_ptr, P_new_line_start, P_new_line_lth);

	if P_old_line_start - 1 <= 0
	then goto NO_APPROPRIATE_LINE;

	call locate_line (P_old_line_start - 2, P_new_line_ptr, P_new_line_start, P_new_line_lth);

	if "1"b
	then return;

	call locate_char (P_old_line_start - 2, part_idx, char_idx);
	if part_idx < 0
	then goto NO_APPROPRIATE_LINE;

	part_ptr = part.ptr (part_idx);
	part_lth = part.lth (part_idx);

	lth = index (reverse (substr (part, 1, char_idx)), NEWLINE) + 1;
	if lth = 1
	then lth = char_idx + 1;
	else char_idx = char_idx - lth + 3;

	P_new_line_lth = lth;
	goto RETURN_INDICES;


RETURN_INDICES:
	P_new_line_start = part.first (part_idx) + char_idx - 1;
						/* the index of the first char */
	P_new_line_ptr = addr (substr (part, char_idx, 1));

	return;


NO_APPROPRIATE_LINE:
	P_new_line_ptr = null ();
	P_new_line_start = -1;
	P_new_line_lth = -1;
	return;

     end next_line;
%page;
/* This procedure finds the line which either starts with P_string, or the first
   line after that in collating sequence. Collating sequence is strictly ASCII,
   except that anything containing the string ".incl." collates after anything
   that doesn't. The finding is done by binary search. */

find_line:
     proc (P_string, P_include, P_exact, P_line_ptr, P_line_start, P_line_lth, P_matched);

	dcl     (
	        P_string		 char (36) varying,
	        P_include		 bit (1) aligned,
	        P_exact		 bit (1) aligned,
	        P_line_start	 fixed bin (30),
	        P_line_ptr		 pointer,
	        P_line_lth		 fixed bin (21),
	        P_matched		 fixed bin
	        )			 parameter;

	dcl     include		 bit (1) aligned;	/* whether P_string contains ".incl." */
	dcl     str_lth		 fixed bin;
	dcl     backward		 bit (1) aligned;	/* which direction are we scanning */

	dcl     (lb, ub)		 fixed bin (30);	/* bounds for binary search */
	dcl     try		 fixed bin (30);

	dcl     (line_start, try_line_start)
				 fixed bin (30);	/* line we work with */
	dcl     (line_ptr, try_line_ptr)
				 pointer;
	dcl     (line_lth, try_line_lth)
				 fixed bin (21);
	dcl     line		 char (line_lth) based (line_ptr);

	dcl     continue		 bit (1) aligned;
	dcl     comparison		 fixed bin;
	dcl     matched		 fixed bin;

	dcl     last_char		 fixed bin (30);
	dcl     first_char		 fixed bin (30);
%page;
	include = P_include;
	str_lth = length (P_string);

	lb = 1;
	ub = part.last (n_parts);

ITERATE:
	try = divide ((lb + ub), 2, 30, 0);		/* beginning of loop -- see goto at bottom of procedure */

	call locate_line (try, line_ptr, line_start, line_lth);

	try_line_ptr = line_ptr;			/* remember info about this line, in case we must search back */
	try_line_start = line_start;
	try_line_lth = line_lth;

	do while (index (FIRST_CH, substr (line, 1, 1)) = 0);
						/* stop looping at the first non-whitespace */
	     call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
	     if line_ptr = null ()
	     then /* last line */
		goto LOOK_BACK_INSTEAD;
	end;					/* of finding next line with a name on it */

	call compare_line (line, P_string, include, comparison, matched);

	if comparison = EQUAL
	then /* strings are more or less equal. Finish and return */
	     goto EQUAL_MATCH;

	last_char = line_start + line_lth - 1;		/* last char we have "looked" at */

	if comparison = LESS
	then do;					/* if LESS, then search backwards to the previous one */
LOOK_BACK_INSTEAD:
		line_ptr = try_line_ptr;		/* start from the line we ended up trying */
		line_start = try_line_start;
		line_lth = try_line_lth;

		continue = "1"b;
		do while (continue);		/* look at prev line, stop when we hit a good one */
		     call prev_line (line_start, line_lth, line_ptr, line_start, line_lth);
		     if line_ptr = null ()
		     then /* first line */
			goto FINISH_AND_RETURN;

		     if index (FIRST_CH, substr (line, 1, 1)) ^= 0
		     then continue = "0"b;		/* stop looping at the first non-whitespace */
		end;				/* of finding next line with a name on it */

		call compare_line (line, P_string, include, comparison, matched);
						/* see what this line looks like */

		if comparison = EQUAL
		then goto EQUAL_MATCH;

		first_char = line_start;		/* remember the index of the first char we look at */
	     end;					/* of marching backward for "prev" comparison */

	else first_char = try_line_start;		/* remember where we started looking */

	if comparison = LESS
	then /* reset the bounds */
	     ub = first_char;
	else lb = last_char;

	if lb <= ub
	then /* go around and try again */
	     goto ITERATE;				/* Yes, I know it's an evil way to loop, but I think */
	else goto FINISH_AND_RETURN;			/* it's actually somewhat clearer this way than it */
						/* would have been with a do while loop */

EQUAL_MATCH:
	if "1"b
	then do;					/* always scan backwards, just for laughs */
		backward = "1"b;
		continue = "1"b;

EQUAL_MATCH_RESTART:
		do while (continue);
		     if backward
		     then call prev_line (line_start, line_lth, line_ptr, line_start, line_lth);
		     else call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
		     if line_ptr = null ()
		     then if ^backward
			then signal condition (logic_error);
			else do;
				backward = "0"b;
				goto EQUAL_MATCH_RESTART;
			     end;

		     if index (FIRST_CH, substr (line, 1, 1)) ^= 0
		     then do;			/* see if this is a match */
			     call compare_line (line, P_string, include, comparison, matched);
			     if comparison ^= EQUAL
			     then do;		/* stop scan in this direction */
				     if backward
				     then backward = "0"b;
				     else if comparison = LESS
				     then goto FINISH_AND_RETURN;
				end;
			     else if ^backward
			     then /* really set, now */
				if ^P_exact | (matched = EXACT)
				then continue = "0"b;
			end;

		end;				/* of loop to find previous exact match */
	     end;

FINISH_AND_RETURN:
	P_line_ptr = line_ptr;
	P_line_start = line_start;
	P_line_lth = line_lth;
	P_matched = matched;

	return;
     end find_line;
%page;
/* This procedure compares P_string to the first token on P_line, setting P_comparison
   and P_matching appropriately. It is used to determine what direction to search in next,
   and also when to stop looping through lines. This is the procedure where the knowledge
   of the special effects of ".incl." on the collating sequence is embodied. */

compare_line:
     proc (P_line, P_string, P_include, P_comparison, P_matching);

	dcl     (
	        P_line		 char (*),
	        P_string		 char (36) varying,
	        P_include		 bit (1) aligned,
	        P_comparison	 fixed bin,
	        P_matching		 fixed bin
	        )			 parameter;

	dcl     token_lth		 fixed bin;
	dcl     token_ptr		 pointer;
	dcl     token		 char (token_lth) based (token_ptr);

	dcl     test_lth		 fixed bin;

	token_lth = search (P_line, WHITESPACE) - 1;	/* find the first token on the line */
	token_ptr = addr (substr (P_line, 1, 1));
	if token_lth < 0
	then /* no trailing delimiter */
	     token_lth = length (P_line);

	P_matching = MISS;				/* likely this is the case; only set it otherwise if not */

	if index (token, ".incl.") ^= 0
	then do;					/* we have hit an include file line */
		if ^P_include
		then do;				/* but we are not searching for one, so punt */
			P_comparison = LESS;
			return;
		     end;
	     end;

	else if substr (token, token_lth, 1) = ":"
	then do;
		P_comparison = LESS;		/* nasty error message at end of file */
		return;
	     end;

	else do;					/* otherwise, check the opposite */
		if P_include
		then do;				/* include file always after than non-include */
			P_comparison = GREATER;
			return;
		     end;
	     end;

	test_lth = min (length (token), length (P_string));

	if substr (P_string, 1, test_lth) > substr (token, 1, test_lth)
	then P_comparison = GREATER;

	else if substr (P_string, 1, test_lth) < substr (token, 1, test_lth)
	then P_comparison = LESS;

	else if token_lth < length (P_string)
	then /* short token is always greater than string */
	     P_comparison = GREATER;

	else do;					/* they compare equal */
		if length (token) = length (P_string)
		then /* if strings are identical */
		     P_matching = EXACT;
		else P_matching = PARTIAL;

		P_comparison = EQUAL;
	     end;

	return;
     end compare_line;
%page;
/* This procedure prints out formatted information for a single entry. It is given the
   location of the line containins the first reference to the entry. */

process_entry:
     proc (P_entry_idx, P_line_start, P_line_ptr, P_line_lth);

	dcl     (
	        P_entry_idx		 fixed bin,
	        P_line_start	 fixed bin (30),
	        P_line_ptr		 pointer,
	        P_line_lth		 fixed bin (21)
	        )			 parameter;

	dcl     line_start		 fixed bin (30);
	dcl     line_ptr		 pointer;
	dcl     line_lth		 fixed bin (21);
	dcl     line		 char (line_lth) based (line_ptr);

	dcl     name_starname	 char (32);
	dcl     ep_starname		 char (32);
	dcl     name		 char (36) varying;
	dcl     ep		 char (36) varying;

	dcl     n_entrypoints	 fixed bin (17);
	dcl     header_bumf		 char (64) varying;
	dcl     out_str		 char (1000) varying;
	dcl     include		 bit (1) aligned;
	dcl     comparison		 fixed bin (17);
	dcl     matched		 fixed bin (17);
	dcl     ep_scanning		 bit (1) aligned;
	dcl     exact_match		 bit (1) aligned;
	dcl     i1		 fixed bin (21);
	dcl     seg_name		 char (32);
	dcl     synonym		 bit (1) aligned;
	dcl     processing_synonym	 bit (1) aligned;
	dcl     syn_name		 char (32);
	dcl     saved_line_start	 fixed bin (30);
	dcl     saved_line_lth	 fixed bin (21);
	dcl     match		 fixed bin (17);
	dcl     len		 fixed bin (21);
	dcl     pos		 fixed bin (21);


	line_start = P_line_start;
	line_ptr = P_line_ptr;
	line_lth = P_line_lth;

	n_entrypoints = 0;
	out_str = "";
	header_bumf = "FOO!";
	processing_synonym = "0"b;

	name = substr (entry.name (P_entry_idx), 1, entry.non_star_lth (P_entry_idx));
	name_starname = entry.name (P_entry_idx);
	exact_match = (length (name) = length (entry.name (P_entry_idx)));
	include = entry.include (P_entry_idx);
	ep, ep_starname = entry.ep (P_entry_idx);

/* set up to read the ----- bumf line */

TRY_SYNONYM:
	call prev_line (line_start, line_lth, line_ptr, line_start, line_lth);
	ep_scanning = "0"b;				/* no call to look at entrypoint lines yet */

	do while (line_ptr ^= null ());		/* loop through the lines, looking for things to print */

	     if index (FIRST_CH, substr (line, 1, 1)) ^= 0
	     then do;				/* extract segment name */
		     call compare_line (line, name, include, comparison, matched);
						/* is this line interesting? */
		     if comparison ^= EQUAL
		     then /* no longer equal */
			goto FINISHED;		/* the first of these comparisons will always be spurious */
		     else if (matched ^= EXACT) & exact_match
		     then /* we've run out of candidates, even */
			goto FINISHED;

		     ep_scanning, questionable_module, synonym = "0"b;
		     i1 = search (line, WHITESPACE);
		     if i1 = 0
		     then seg_name = line;
		     else do;
			     seg_name = substr (line, 1, i1 - 1);
			     if index (substr (line, i1 + 1), "(?)") ^= 0
			     then questionable_module = "1"b;
			     else if index (substr (line, i1 + 1), "SEE:") ^= 0
			     then synonym = "1"b;
			end;

		     if ^exact_match
		     then do;
			     call match_star_name_ (seg_name, name_starname, code);
			     if code ^= 0
			     then goto NEXT_LINE;	/* it doesn't match -- ignore it */
			end;

		     if include
		     then call process_include ();	/* well, is it ? */
		     else if synonym
		     then do;
			     if processing_synonym
			     then do;
				     call complain (0, WHOAMI, "Nested synonym ^a.", name);
				     goto MAIN_RETURN;
				end;
			     saved_line_start = line_start;
			     saved_line_lth = line_lth;
			     syn_name = seg_name;
			     name, name_starname =
				ltrim (rtrim (after (substr (line, i1 + 1), ":"), WHITESPACE), WHITESPACE);
			     call find_line (name, "0"b, "1"b, line_ptr, line_start, line_lth, match);
			     if (debug & "001"b) ^= ""b
			     then call ioa_ ("^[Exact^;Partial^;No^] match for synonym ^a line[^d,^d]@^p:^/^a",
				     match, name, line_start, line_lth, line_ptr, line);
			     exact_match, processing_synonym = "1"b;
			     goto TRY_SYNONYM;
			end;
		     else do;
			     if processing_synonym
			     then seg_name = syn_name;
			     ep_scanning = "1"b;
NEXT_LINE:
			     call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
			end;			/* skip the segname line */
		end;

	     else if ep_scanning & substr (line, 1, 1) = SPACE
	     then do;				/* see if it's an entrypoint name */
		     if index (FIRST_CH, substr (line, 2, 1)) ^= 0
		     then call process_entrypoint ();
		     else call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
		end;

	     else do;
		     if ^include & (substr (line, 1, 1) = DASH)
		     then do;			/* must be dat ole debbil --- bumf line */
			     pos = index (line, "***** ") + 6;
			     if pos > 6
			     then do;
				     len = index (substr (line, pos), " *****") - 1;
				     if len > 0 then header_bumf = substr (line, pos, len);
				end;
			end;
		     call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
		end;
	end;					/* otherwise, just skip it */

FINISHED:
	if processing_synonym
	then do;
		processing_synonym = "0"b;
		name = substr (entry.name (P_entry_idx), 1, entry.non_star_lth (P_entry_idx));
		name_starname = entry.name (P_entry_idx);
		exact_match = (length (name) = length (entry.name (P_entry_idx)));
		line_start = saved_line_start;
		line_lth = saved_line_lth;
		goto NEXT_LINE;
	     end;

	if n_entrypoints = 0			/* found nothing there */
	then if ^brief_error_sw
	     then call complain (0, WHOAMI, "Not found: ^a^[$^a^]^/", name_starname, (ep_starname ^= ""), ep_starname);
	     else ;
	else if ^active_function
	then call ioa_$nnl ("^a", out_str);		/* all done */

	return;					/* end of code for process_entry */
%page;
process_entrypoint:
     proc ();

/* This procedure (internal to process_entry) collects information about a single entrypoint. */

	dcl     (idx, jdx)		 fixed bin (21);
	dcl     ep_name		 char (32);
	dcl     caller_name		 char (32) varying;

	dcl     first_on_line	 bit (1) aligned;
	dcl     questionable_entry	 bit (1) aligned;
	dcl     header_output	 bit (1) aligned;
	dcl     obj_name		 char (72) varying;
	dcl     line_size		 fixed bin (17);
	dcl     MAX_LINE_SIZE	 fixed bin internal static options (constant) init (72);


	idx = search (substr (line, 2), WHITESPACE);
	ep_name = substr (line, 2, idx - 1);		/* extract the entrypoint name */
	idx = 1 + idx;

	if ep_starname ^= ""
	then do;					/* see if we should print this one */
		call match_star_name_ ((ep_name), ep_starname, code);
		if code ^= 0
		then do;				/* it doesn't match -- ignore it */
			call next_line (line_start, line_lth, line_ptr, line_start, line_lth);
			return;			/* get to the beginning of the next line */
		     end;				/* and return to let it get inspected */
	     end;

	questionable_entry = "0"b;
	jdx = index (substr (line, idx), "(?)");
	if jdx > 0
	then do;
		idx = idx + jdx + 3;
		questionable_entry = ^questionable_module;
	     end;

	n_entrypoints = n_entrypoints + 1;

	if (ep_name = seg_name)
	then /* figure out what to call this */
	     obj_name = rtrim (seg_name);
	else if (ep_name = "")
	then obj_name = rtrim (seg_name) || "$";
	else obj_name = rtrim (seg_name) || "$" || rtrim (ep_name);

	line_size = MAX_LINE_SIZE + 1;		/* force "overflow" for first time through */
	header_output = "0"b;			/* whether we've commented on this entry yet */

GET_NEXT_TOKEN:
	if ^active_function
	then /* If we're gonna be printing this, see if it's too big */
	     if (length (out_str) + 200 > maxlength (out_str))
	     then do;				/* time to flush the buffer */
		     call ioa_$nnl ("^a", out_str);
		     out_str = "";
		end;

	if idx >= line_lth
	then do;					/* get the next line */
GET_TO_NEXT_LINE:
		call next_line (line_start, line_lth, line_ptr, line_start, line_lth);

		if (substr (line, 1, min (2, length (line))) ^= TWO_SPACES) & (substr (line, 1, 1) ^= TAB)
		then do;
			if active_function
			then return;		/* Not gonna say anything */

			if ^header_output
			then do;			/* whether we have said anything about this entry */
				if brief_sw
				then return;
				out_str = out_str || "No references to ";
				out_str = out_str || obj_name;
				out_str = out_str || " (";
				out_str = out_str || header_bumf;
				out_str = out_str || ")";
			     end;

			out_str = out_str || NEWLINE; /* finish it with two newlines */
			out_str = out_str || NEWLINE; /* watch cretinous pl1 concatenation implementation */
			return;			/* and return for the next entrypoint */
		     end;

		idx = 1;				/* start at the beginning */
	     end;

	jdx = verify (substr (line, idx), WHITESPACE);
	if jdx = 0
	then goto GET_TO_NEXT_LINE;

	idx = idx + jdx - 1;			/* first non-white char */
	jdx = search (substr (line, idx), WHITESPACE) - 1;
	if jdx < 0
	then jdx = length (substr (line, idx));

	caller_name = substr (line, idx, jdx);

	if active_function
	then do;					/* Just add to the return string, and go back for more */
		if length (return_string) > 0
		then return_string = return_string || " ";
		return_string = return_string || caller_name;
		idx = idx + jdx;
		goto GET_NEXT_TOKEN;
	     end;

	if line_size + 2 + length (caller_name) > MAX_LINE_SIZE
	then do;
		if ^header_output
		then do;
			out_str = out_str || "References to ";
			out_str = out_str || obj_name;
			out_str = out_str || ":  (";
			out_str = out_str || header_bumf;
			out_str = out_str || ")";
			if questionable_entry
			then out_str = out_str || " ** Not Found **";
			out_str = out_str || NEWLINE;
			out_str = out_str || copy (SPACE, 4);

			header_output = "1"b;
		     end;

		else do;
			out_str = out_str || ",";
			out_str = out_str || NEWLINE;
			out_str = out_str || copy (SPACE, 4);
		     end;

		line_size = 4;
	     end;

	else if ^first_on_line
	then do;
		out_str = out_str || ", ";
		line_size = line_size + 2;
	     end;

	out_str = out_str || caller_name;
	line_size = line_size + length (caller_name);
	first_on_line = "0"b;

	idx = idx + jdx;				/* get on to next token */
	goto GET_NEXT_TOKEN;

     end process_entrypoint;
%page;
process_include:
     proc ();

/* This procedure (internal to process_entry) collects information about a single include file. */

	dcl     (idx, jdx)		 fixed bin (21);
	dcl     caller_name		 char (32) varying;
	dcl     first_on_line	 bit (1) aligned;
	dcl     header_output	 bit (1) aligned;
	dcl     incl_name		 char (32) varying;
	dcl     incl_dtcm		 char (40) varying;
	dcl     line_size		 fixed bin (17);
	dcl     MAX_LINE_SIZE	 fixed bin internal static options (constant) init (72);


	n_entrypoints = n_entrypoints + 1;
	incl_name = rtrim (seg_name);

	if index (line, "*****") = 0
	then call next_line (line_start, line_lth, line_ptr, line_start, line_lth);

	incl_dtcm = substr (line, index (line, "***** ") + 6);
	incl_dtcm = substr (incl_dtcm, 1, length (incl_dtcm) - 7);

	idx = line_lth;				/* force next_line */
	line_size = MAX_LINE_SIZE + 1;		/* force "overflow" for first time through */
	header_output = "0"b;			/* whether we've commented on this entry yet */

GET_NEXT_TOKEN:
	if ^active_function
	then /* If we're gonna be printing this, see if it's too big */
	     if (length (out_str) + 200 > maxlength (out_str))
	     then do;				/* time to flush the buffer */
		     call ioa_$nnl ("^a", out_str);
		     out_str = "";
		end;

	if idx >= line_lth
	then do;					/* get the next line */
GET_TO_NEXT_LINE:
		call next_line (line_start, line_lth, line_ptr, line_start, line_lth);

		if (substr (line, 1, 2) ^= TWO_TABS)
		then if header_output
		     then do;			/* whether we have said anything about this include incarnation */
			     if active_function
			     then return;		/* Not gonna say anything */

			     out_str = out_str || NEWLINE;
						/* add one newline for now */
			     out_str = out_str || NEWLINE;
						/* and another for later */
			     return;		/* and return for the next entrypoint */
			end;

		idx = 1;				/* start at the beginning */
	     end;

	jdx = verify (substr (line, idx), WHITESPACE);
	if jdx = 0
	then goto GET_TO_NEXT_LINE;

	idx = idx + jdx - 1;			/* first non-white char */
	jdx = search (substr (line, idx), WHITESPACE) - 1;
	if jdx < 0
	then jdx = length (substr (line, idx));

	caller_name = substr (line, idx, jdx);

	if active_function
	then do;					/* Just add to the return string, and go back for more */
		if length (return_string) > 0
		then return_string = return_string || " ";
		return_string = return_string || caller_name;
		idx = idx + jdx;
		header_output = "1"b;		/* Force above logic to terminate properly */
		goto GET_NEXT_TOKEN;
	     end;

	if line_size + 2 + length (caller_name) > MAX_LINE_SIZE
	then do;
		if ^header_output
		then do;
			out_str = out_str || "References to ";
			out_str = out_str || incl_name;
			out_str = out_str || ":  (";
			out_str = out_str || incl_dtcm;
			out_str = out_str || ")";
			out_str = out_str || NEWLINE;
			out_str = out_str || copy (SPACE, 4);

			header_output = "1"b;
		     end;

		else do;
			out_str = out_str || ",";
			out_str = out_str || NEWLINE;
			out_str = out_str || copy (SPACE, 4);
		     end;

		line_size = 4;
	     end;

	else if ^first_on_line
	then do;
		out_str = out_str || ", ";
		line_size = line_size + 2;
	     end;

	out_str = out_str || caller_name;
	line_size = line_size + length (caller_name);
	first_on_line = "0"b;

	idx = idx + jdx;				/* get on to next token */
	goto GET_NEXT_TOKEN;

     end process_include;

     end process_entry;
%page;
default_input_file:
     procedure;

	if dname ^= ""
	then return;
	ename = "";

	call expand_pathname_$add_suffix (DEFAULT_CREF_PATH, SUFFIX, dname, ename, code);
	if code ^= 0
	then do;
		call complain (code, WHOAMI, "Bad default path ^a.", DEFAULT_CREF_PATH);
		goto MAIN_RETURN;
	     end;

     end default_input_file;

     end peruse_crossref;





		    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
