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