/* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ include_cross_reference: icref: proc; /* procedure to make a crossreference listing for include files */ /* Last modified and converted to v2pl1 by Arlene Scherer February 1973 */ /* Changed to look at new format source archives February 22 1973 */ /* Modified by PG on 740227 to work */ /* Modified by Dennis Sheckler on October 27, 1976 to "know" cds, rd, and ld as suffixes. */ /* Modified by Dennis Sheckler on November 2, 1976 to process mexp source segments correctly. */ /* This procedure: reads an input driving file given as an argument; examines the directory path(s) given in the driving file; inspects each source segment whether archived or unarchived; performs an include file cross_reference of the segments in the directories given; USAGE: icref path-of-driving-file */ dcl archive_util_$first_element entry (ptr, fixed bin); dcl archive_util_$next_element entry (ptr, fixed bin); dcl com_err_ entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_ entry (char (*) aligned) returns (fixed bin (35)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl ioa_ entry options (variable); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24), fixed bin (12), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$star_ entry (char (*) aligned, char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned); dcl ios_$detach entry (char (*), char (*), char (*), bit (72) aligned); dcl ioa_$ioa_stream entry options (variable); dcl (tp, p, ap, sp, isegp) ptr; dcl (areap) ptr init (null); dcl (eptr, nptr) ptr init (null); dcl (tc, acode, maxisp, next_path, j, ai, count, isp, sname_len, ename_len, iname_len) fixed bin; dcl code fixed bin (35); dcl (acl, cl) fixed bin (24); dcl (type, bc, name_offset, nsegs, nchars, strx, inp, inp1, k, i) fixed bin; dcl (archives_tested, segs_tested, segs_with_includes, number_of_includes, unbound_segs) fixed bin init (0); dcl (dirname, path) char (168) aligned; dcl outname char (168) init ((168) " "); dcl stream_name char (12) init ("icref_stream"); dcl output_name char (11) init ("user_output"); dcl (ename, sname, iname) char (32) aligned; dcl first_incl_sw bit (1) aligned init ("0"b); dcl not_an_archive bit (1) aligned init ("0"b); /* switch for unbound source segs */ dcl status bit (72) aligned; dcl (c1, c2, c3, c4) char (1) aligned; dcl targ char (tc) based (tp); dcl btarg char (tc) aligned based (tp); dcl string char (262144) based (sp) aligned; dcl nl char (1) aligned internal static initial (" "); dcl quote_sign char (1) aligned init (""""); dcl hash_char bit (9) init ("000000000"b); dcl star_name char (2) static init ("**"); dcl ctype (6) char (8) aligned static init ("pl1", "alm", "ioc", "fortran", "bcpl", "mexp"); dcl t3 char (3) aligned, c char (1) aligned; dcl 1 header based (p) aligned, 2 pad0 char (12), 2 name char (32), 2 pad1 char (40), 2 bitcnt char (8); dcl 1 cha based, 2 r (0: 1) char (1); dcl 1 ch based aligned, 2 a (0: 1) char (1) unal; dcl ht (0:1) fixed bin based (isegp); dcl enamea (262144) char (32) aligned based; dcl 1 entries (1) based (eptr) aligned, 2 type bit (2) unal, 2 nname bit (16) unal, 2 nindex bit (18) unal; dcl (addr, addrel, divide, fixed, index, null, ptr, substr, unspec) builtin; call cu_$arg_ptr (1, tp, tc, code); /* get pathname of search file */ if code ^= 0 | tc = 0 then do; /* none given, print out calling sequence */ call com_err_ (code, "icref", "Usage: icref path_of_search_file"); return; end; call expand_path_ (tp, tc, addr (dirname), addr (ename), code); /* get expanded form of path name */ if code ^= 0 then do; /* error in path name */ call com_err_ (code, "icref", targ); /* inform user of mistake */ return; end; outname = targ; /* get path name for output segment */ call hcs_$initiate_count (dirname, ename, "", cl, 0, p, code); /* get pointer to search file */ if p = null then do; call com_err_ (code, "icref", "^a>^a", dirname, ename); return; end; cl = divide (cl, 9, 17, 0); /* convert bit count to character count */ /* Now initialize the temporary segments, etc. */ nchars, nsegs = 0; /* initialize metering counters */ call hcs_$make_seg ("", "ISEG", "", 01010b, isegp, code); /* get segment in which include data is stored */ if isegp = null then do; /* trouble */ call com_err_ (code, "icref", "Trying to create [pd]>ISEG"); return; end; /* set up index for ISEG temporary table and set maximum length */ isp = 128; declare sys_info$max_seg_size external static fixed binary (35); maxisp = sys_info$max_seg_size; if areap = null then areap = get_system_free_area_ (); /* initialize system free area for hcs_$star */ next_path = 1; /* initialize index to current path name in search file */ PATH_LOOP: if next_path > cl then go to PRINT; /* done with part 1 when out of pathnames */ j = index (substr (p -> string, next_path, cl-next_path+1), nl) - 1; /* get index to last character in path name */ if j <= 0 then go to PRINT; /* If no path names left, print everything */ path = substr (p -> string, next_path, j); /* copy path name into temporary */ next_path = next_path + j + 1; /* set index to next path name in search file */ call hcs_$star_ (path, star_name, 2, areap, count, eptr, nptr, code); /* get list of branches in the directory */ if code ^= 0 then do; /* some trouble listing the directory */ call com_err_ (code, "icref", path); /* tell the user about the problem */ go to PATH_LOOP; /* empty directory.go back for next path */ end; /* loop through all segments in this directory. find out if they are archives or unbound;process accordingly */ do ai = 1 to count; /* bypass directories and other non-segments */ if eptr -> entries (ai).type ^= "01"b then go to NEXT_ARCHIVE; ename = nptr -> enamea (fixed (eptr -> entries (ai).nindex, 18)); /* get the next entry name */ call hcs_$initiate_count (path, ename, "", acl, 0, ap, code); /* get pointer to the segment */ if ap = null then do; /* some trouble in getting pointer to segment */ call com_err_ (code, "icref", "^a>^a", path, ename); /* tell user */ go to NEXT_ARCHIVE; /* go get the next segment in the directory */ end; /* time to find out what kind of segment it is */ ename_len = index (ename, " ") -1; if ename_len = -1 then ename_len = 32; /* oops, 32 character name */ if ename_len <= 8 then go to UNBOUND; /* not long enough to be an archive */ sname = substr (ename, ename_len -1); if substr (ename, ename_len - 7, 8) = ".archive" then do; /* it is an archive file */ call archive_util_$first_element (ap, acode); /* get first segment pointer inside archive file */ if acode = 2 then go to AERROR; /* archive format error */ if acode = 1 then do; call ioa_ ("^a>^a is empty and will be ignored.", path, ename); go to NEXT_ARCHIVE; end; if ap = null then go to AERROR; /* some other problem */ archives_tested = archives_tested+1; FOUND_SEGMENT: not_an_archive = "0"b; sname = ap -> header.name; /* copy segment name into temporary */ sname_len = index (sname, " ") - 1; /* get length of segment name */ if sname_len = -1 then sname_len = 32; sp = addrel (ap, 25); /* get pointer to the actual data of the segment */ bc = cv_dec_ (ap -> header.bitcnt); /* get character count */ bc = divide (bc, 9, 17, 0); /* now see if the word "include" appears anywhere in the segment */ j = index (substr (sp -> string, 25, bc), "include"); end; /* End of special actions for archive file */ /* actions if segment is unbound */ else do; UNBOUND: unbound_segs = unbound_segs + 1; sname = ename; sname_len = ename_len; sp = ap; /* compute character count */ bc = divide (acl, 9, 17, 0); /* see if the word "include" appears anywhere in the segment */ j = index (substr (sp -> string, 1, bc), "include"); not_an_archive = "1"b; end; /* do this for both kinds of segments */ segs_tested = segs_tested +1; first_incl_sw = "1"b; /* now see if the index to j was non-zero */ if j ^= 0 then do; /* Yes, go through include name loop */ t3 = substr (sname, sname_len-2, 3); /* copy suffix of sname */ if t3 = "pl1" | t3 = "cds" | substr (sname, sname_len-1, 2) = "rd" then type = 1; /* set the suffix type */ else if t3 = "alm" then type = 2; else if t3 = "ioc" then type = 3; else if substr (sname, sname_len-6, 7) = "fortran" then type = 4; else if substr (sname, sname_len-3, 4) = "bcpl" then type = 5; else if substr (sname, sname_len-3, 4) = "mexp" then type = 6; else if substr (sname, sname_len-1, 2) = "ld" then do; /* can't contain any include files */ if not_an_archive = "1"b then unbound_segs = unbound_segs -1; segs_tested = segs_tested -1; first_incl_sw = "0"b; go to NEXT_SEGMENT; end; else do; /* unknown type, error */ call ioa_ ("Unknown segment suffix in ^a.", sname); /* tell user of trouble */ if not_an_archive = "1"b then unbound_segs = unbound_segs -1; segs_tested = segs_tested -1; first_incl_sw = "0"b; go to NEXT_SEGMENT; end; /* Now put the name in table, but don't use it later if it's not real */ substr (ptr (isegp, isp) -> string, 1, sname_len) = sname; name_offset = isp; /* save index into table */ isp = isp + divide (sname_len+3, 4, 17, 0); /* update to next slot */ nsegs = nsegs+1; nchars = nchars+bc; strx = 1; /* when someone gets the time, the standard object segment format now contains a source map of all the source (main + include) segments used to generate the object code. It would sure be a lot easier to extract that, rather than trying to efficiently parse the source languages. (pg 740320) */ INC_LOOP: j = index (substr (string, strx, bc-strx+1), "include"); /* search for include in the segment */ if j = 0 then go to NEXT_SEGMENT; strx = strx + j + 6; c1 = substr (string, strx, 1); /* make some checks to see if this include is a real one */ if c1 ^= " " then if c1 ^= " " then go to INC_LOOP; /* following char must be space or tab */ if strx < 10 then go to OK; /* beginning of segment */ c1 = sp -> ch.a (strx-10); /* get character 2-immediately before "include" */ c2 = sp -> ch.a (strx-9); /* get character immediately before "include" */ if (type = 2) | (type = 3) then do; /* alm or ioc */ if (c2 = nl) | (c2 = "%") then go to OK; /* ok if preceded by "%" or nl */ if c1 = nl then if c2 = " " then go to OK; /* ok if preceded by nl-tab */ go to CHECK2; end; else if type = 6 then do; /* mexp */ if c2 = "&" then goto OK; if c1 = "&" then if c2 = " " | c2 = " " then goto OK; goto INC_LOOP; end; else do; /* pl1, cds, rd, fortran, bcpl */ if (c2 = "%") then go to OK; CHECK2: if c1 = "%" then if (c2 = " ") | (c2 = " ") then go to OK; go to INC_LOOP; end; OK: /* Yes but it still might be inside a comment or expression */ /* So back up looking for quotes, or comment chars */ if strx < 13 then go to REALLY_OK; /* except when we're at the beginning */ do j = 1 to 120; c1 = sp -> ch.a (strx- (9 +j)); c2 = sp -> ch.a (strx- (10 +j)); c3 = sp -> ch.a (strx- (11+j)); c4 = sp -> ch.a (strx- (12+j)); if (c1 = nl) then go to REALLY_OK; if c1 = "*" then if c2 = "/" then go to INC_LOOP; if c2 = "/" then if c1 = "*" then go to INC_LOOP; /* end of comment */ /* make sure that %INCLUDE not inside of quotes */ if (c1 = quote_sign) then go to INC_LOOP; end; /* End of loop to try to eliminate comments, etc. */ REALLY_OK: /* loop through to bypass blanks and hts */ do j = 1 to 20 while (sp -> ch.a (strx+j-2) = " " | sp -> ch.a (strx+j-2) = " "); end; strx = strx+j-1; /* update index into file */ do i = 1 to 24; /* search for end of name */ c = substr (string, strx+i-1, 1); /* get current character */ if c = " " then go to STOP; if c = " " then go to STOP; if c = ";" then go to STOP; if c = nl then go to STOP; end; go to INC_LOOP; /* not a real Include statement */ STOP: /* Add this to total if first include file for this segment */ if first_incl_sw = "1"b then do; first_incl_sw = "0"b; segs_with_includes = segs_with_includes +1; end; iname_len = i-1; /* set length of include file name */ iname = substr (string, strx, iname_len); /* copy the string into temporary */ /* Check for extraneous quote signs in the include name */ if substr (iname, 1, 1) = quote_sign then do; /* May be two quotes */ iname = substr (iname, 2); iname_len = iname_len -1; end; i = index (iname, """"); if i ^= 0 then do; /* get rid of quote at end too */ iname = substr (iname, 1, iname_len -1); iname_len = iname_len -1; end; /* Now search for the include file name in the structure and enter it if not there. Log the current segment pointed to by this include file */ inp = fixed (unspec (substr (iname, 1, 1)), 9); /* get hash character for search */ do while (ht (inp) ^= 0); /* see if the name is entered in the table of include file names */ inp1 = ht (inp); /* save current thread value */ j = 2; /* start compares at second character (first always matches) */ tp = addr (ht (inp1+4)); /* get pointer to string in include entry */ do k = 2 to ht (inp1+2); /* check each character of the include file name in the table */ if j >= iname_len+1 then go to INSERT; /* match, INSERT the new name */ if substr (iname, j, 1) > tp -> ch.a (k-1) then go to NEXTN; /* no match, go to next entry */ if substr (iname, j, 1) < tp -> ch.a (k-1) then go to INSERT; /* match zzzz */ j = j + 1; /* skip to next chacater */ end; if j = iname_len+1 then if type = ht (inp1+1) then go to EQ; else go to NEXTN; /* found entry if type matches */ NEXTN: inp = inp1; /* loop to next entry in thread */ end; INSERT: number_of_includes = number_of_includes +1; ht (isp) = ht (inp); /* thread in to next name */ ht (isp+1) = type; /* store segment type in new entry */ ht (isp+2) = iname_len; /* store length of include name in new entry */ ht (isp+3) = 0; /* zero thread of segments for this include file */ ht (inp) = isp; /* push next thread to cureently defined entry */ substr (addr (ht (isp+4)) -> string, 1, iname_len) = iname; /* copy include file name */ isp = isp+4+divide (iname_len+3, 4, 17, 0); /* increment free storage pointer */ EQ: inp = ht (inp) + 3; /* get thraed of segment for this include file */ do while (ht (inp) ^= 0); /* go to the end of that thread */ inp = ht (inp); /* go indirect to end of thread */ end; ht (isp) = 0; /* zero next thread pointer */ ht (isp+1) = name_offset; /* fill in pointer to name */ ht (isp+2) = sname_len; /* fill in number of characters in segment name */ ht (inp) = isp; /* update pointer in inc entry to point to this segment */ isp = isp + 3; /* update free storage pointer */ if isp > maxisp then do; /* watch out for free storage overflow */ call ioa_ ("OUT OF FREE STORAGE CELLS^"); go to PRINT; end; go to INC_LOOP; end; /* End of include loop for this segment */ NEXT_SEGMENT: if type = 6 then do; type = 2; strx = 1; goto INC_LOOP; end; /* do this if it was unbound */ if not_an_archive = "1"b then do; not_an_archive = "0"b; end; /* do this if it was an archive_file */ else do; call archive_util_$next_element (ap, acode); /* skip to next segment in the archive file */ if acode = 2 then go to AERROR; /* Archive format error */ if ap ^= null then go to FOUND_SEGMENT; /* there is another element in this archive, get it */ end; NEXT_ARCHIVE: call hcs_$terminate_noname (ap, code); end; /* End of processing all segments in this archive */ /* also end of loop for unbound segments */ /* Return to process next segment or archive */ /* Fall through when done with this directory path */ /* occurs when ai reaches count */ if eptr ^= null then free eptr -> entries; /* free up storage used by star_ */ if nptr ^= null then free nptr -> enamea; go to PATH_LOOP; /* loop back for next path name in search file */ AERROR: call ioa_ ("Archive format error in ^a>^a.", path, ename); go to NEXT_ARCHIVE; /* NOW PRINT OUT ALL THE INFORMATION WE HAVE GATHERED */ PRINT: j = index (outname, " "); /* get length of path name, for output segment name */ substr (outname, j) = ".icrfout"; call ios_$attach (stream_name, "file_", outname, "", status); /* make output go into special file */ do i = 0 to 127; /* loop through all the buckets in the hash table */ inp = i; do while (ht (inp) ^= 0); /* loop through all entries in this bucket */ inp1 = ht (inp); /* get pointer to next real entry */ tc = ht (inp1+2); /* get number of characters in include name */ tp = addr (ht (inp1+4)); /* get pointer to actual name */ /* Write out include file name */ call ioa_$ioa_stream (stream_name, "^/^a.incl.^a", btarg, ctype (ht (inp1+1))); j = ht (inp1+3); /* now loop through the trailers for this include file */ do while (j ^= 0); /* loop until zero pointer which means no more */ tp = ptr (isegp, ht (j+1)); /* get pointer to this segment name */ tc = ht (j+2); /* get length of the segment name */ call ioa_$ioa_stream (stream_name, " ^a", btarg); j = ht (j); /* chain on to next trailer */ end; inp = inp1; /* chain to next entry */ end; end; if nsegs = 0 then call ioa_$ioa_stream (stream_name, "^/^/No segments with includes."); call ioa_$ioa_stream (stream_name, "^|^5/Summary of Include File Cross Reference:^5/"); call ioa_$ioa_stream (stream_name, "^/^/^-^-Total number of archives tested: ^d.", archives_tested); call ioa_$ioa_stream (stream_name, "^/^/^-^-Total unbound segments tested: ^d.", unbound_segs); call ioa_$ioa_stream (stream_name, "^/^-^-Total number of segments tested: ^d.", segs_tested); call ioa_$ioa_stream (stream_name, "^/^-^-Total number of include files: ^d.", number_of_includes); call ioa_$ioa_stream (stream_name, "^/^-^-Total segments with include files: ^d.", segs_with_includes); /* okay to detach the file.We are all finished now */ call ios_$detach (stream_name, "", "", status); /* detach the output file */ call hcs_$delentry_seg (isegp, code); /* delete the temporary data segment */ end; */ ----------------------------------------------------------- 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 */