1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 /* ******************************************************
 11    *                                                    *
 12    *                                                    *
 13    * Copyright (c) 1972 by Massachusetts Institute of   *
 14    * Technology and Honeywell Information Systems, Inc. *
 15    *                                                    *
 16    *                                                    *
 17    ****************************************************** */
 18 
 19 include_cross_reference: icref: proc;
 20 
 21 /* procedure to make a crossreference listing for include files */
 22 /* Last modified and converted to v2pl1 by Arlene Scherer February 1973 */
 23 /* Changed to look at new format source archives February 22 1973 */
 24 /* Modified by PG on 740227 to work */
 25 /* Modified by Dennis Sheckler on October 27, 1976 to "know" cds, rd, and ld as suffixes. */
 26 /* Modified by Dennis Sheckler on November 2, 1976 to process mexp source segments correctly. */
 27 
 28 
 29 /* This procedure:
 30 
 31    reads an input driving file given as an argument;
 32 
 33    examines the directory path(s) given in the driving file;
 34 
 35    inspects each source segment whether archived or unarchived;
 36 
 37    performs an include file cross_reference of the segments in the directories given;
 38 
 39    USAGE: icref path-of-driving-file
 40    */
 41 dcl  archive_util_$first_element entry (ptr, fixed bin);
 42 dcl  archive_util_$next_element entry (ptr, fixed bin);
 43 dcl  com_err_ entry options (variable);
 44 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 45 dcl  cv_dec_ entry (char (*) aligned) returns (fixed bin (35));
 46 dcl  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
 47 dcl  get_system_free_area_ entry returns (ptr);
 48 dcl  ioa_ entry options (variable);
 49 dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
 50 dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24), fixed bin (12),
 51      ptr, fixed bin (35));
 52 dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
 53 dcl  hcs_$star_ entry (char (*) aligned, char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
 54 dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
 55 dcl  ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned);
 56 dcl  ios_$detach entry (char (*), char (*), char (*), bit (72) aligned);
 57 dcl  ioa_$ioa_stream entry options (variable);
 58 dcl (tp, p, ap, sp, isegp) ptr;
 59 dcl (areap) ptr init (null);
 60 dcl (eptr, nptr) ptr init (null);
 61 dcl (tc, acode, maxisp, next_path, j, ai, count, isp, sname_len, ename_len, iname_len) fixed bin;
 62 dcl  code fixed bin (35);
 63 dcl (acl, cl) fixed bin (24);
 64 dcl (type, bc, name_offset, nsegs, nchars, strx, inp, inp1, k, i) fixed bin;
 65 dcl (archives_tested, segs_tested, segs_with_includes, number_of_includes, unbound_segs) fixed bin init (0);
 66 dcl (dirname, path) char (168) aligned;
 67 dcl  outname char (168) init ((168) " ");
 68 dcl  stream_name char (12) init ("icref_stream");
 69 dcl  output_name char (11) init ("user_output");
 70 dcl (ename, sname, iname) char (32) aligned;
 71 dcl  first_incl_sw bit (1) aligned init ("0"b);
 72 dcl  not_an_archive bit (1) aligned init ("0"b);            /* switch for unbound source segs */
 73 dcl  status bit (72) aligned;
 74 dcl (c1, c2, c3, c4) char (1) aligned;
 75 dcl  targ char (tc) based (tp);
 76 dcl  btarg char (tc) aligned based (tp);
 77 dcl  string char (262144) based (sp) aligned;
 78 dcl  nl char (1) aligned internal static initial ("
 79 ");
 80 dcl  quote_sign char (1) aligned init ("""");
 81 dcl  hash_char bit (9) init ("000000000"b);
 82 dcl  star_name char (2) static init ("**");
 83 dcl  ctype (6) char (8) aligned static init ("pl1", "alm", "ioc", "fortran", "bcpl", "mexp");
 84 dcl  t3 char (3) aligned,
 85      c char (1) aligned;
 86 
 87 dcl 1 header based (p) aligned,
 88     2 pad0 char (12),
 89     2 name char (32),
 90     2 pad1 char (40),
 91     2 bitcnt char (8);
 92 
 93 dcl 1 cha based,
 94     2 r (0: 1) char (1);
 95 
 96 dcl 1 ch based aligned,
 97     2 a (0: 1) char (1) unal;
 98 
 99 dcl  ht (0:1) fixed bin based (isegp);
100 
101 dcl  enamea (262144) char (32) aligned based;
102 
103 dcl 1 entries (1) based (eptr) aligned,
104     2 type bit (2) unal,
105     2 nname bit (16) unal,
106     2 nindex bit (18) unal;
107 
108 dcl (addr, addrel, divide, fixed, index, null, ptr, substr, unspec) builtin;
109 
110           call cu_$arg_ptr (1, tp, tc, code);               /* get pathname of search file */
111           if code ^= 0 | tc = 0 then do;                    /* none given, print out calling sequence */
112 
113                call com_err_ (code, "icref", "Usage: icref path_of_search_file");
114                return;
115           end;
116 
117           call expand_path_ (tp, tc, addr (dirname), addr (ename), code); /* get expanded form of path name */
118           if code ^= 0 then do;                             /* error in path name */
119                call com_err_ (code, "icref", targ);         /* inform user of mistake */
120                return;
121           end;
122 
123           outname = targ;                                   /* get path name for output segment */
124           call hcs_$initiate_count (dirname, ename, "", cl, 0, p, code); /* get pointer to search file */
125           if p = null
126           then do;
127                call com_err_ (code, "icref", "^a>^a", dirname, ename);
128                return;
129           end;
130 
131           cl = divide (cl, 9, 17, 0);                       /* convert bit count to character count */
132 
133 /* Now initialize the temporary segments, etc. */
134 
135           nchars, nsegs = 0;                                /* initialize metering counters */
136 
137           call hcs_$make_seg ("", "ISEG", "", 01010b, isegp, code); /* get segment in which include data is stored */
138           if isegp = null then do;                          /* trouble */
139                call com_err_ (code, "icref", "Trying to create [pd]>ISEG");
140                return;
141           end;
142                                                             /* set up index for ISEG temporary table and set maximum length */
143           isp = 128;
144 declare  sys_info$max_seg_size external static fixed binary (35);
145 
146           maxisp = sys_info$max_seg_size;
147 
148           if areap = null then areap = get_system_free_area_ (); /* initialize system free area for hcs_$star */
149           next_path = 1;                                    /* initialize index to current path name in search file */
150 PATH_LOOP:
151           if next_path > cl then go to PRINT;               /* done with part 1 when out of pathnames */
152           j = index (substr (p -> string, next_path, cl-next_path+1), nl) - 1; /* get index to last character in path name */
153           if j <= 0 then go to PRINT;                       /* If no path names left, print everything */
154           path = substr (p -> string, next_path, j);        /* copy path name into temporary */
155           next_path = next_path + j + 1;                    /* set index to next path name in search file */
156 
157           call hcs_$star_ (path, star_name, 2, areap, count, eptr, nptr, code); /* get list of branches in the directory */
158           if code ^= 0 then do;                             /* some trouble listing the directory */
159                call com_err_ (code, "icref", path);         /* tell the user about the problem */
160 
161                go to PATH_LOOP;                             /* empty directory.go back for next path */
162           end;
163 
164 
165 
166 
167 /* loop through all segments in this directory. find out if they are archives or unbound;process accordingly */
168           do ai = 1 to count;
169                                                             /* bypass directories and other non-segments */
170                if eptr -> entries (ai).type ^= "01"b then go to NEXT_ARCHIVE;
171                ename = nptr -> enamea (fixed (eptr -> entries (ai).nindex, 18)); /* get the next entry name */
172                call hcs_$initiate_count (path, ename, "", acl, 0, ap, code); /* get pointer to the  segment */
173                if ap = null then do;                        /* some trouble in getting pointer to  segment */
174                     call com_err_ (code, "icref", "^a>^a", path, ename); /* tell user */
175                     go to NEXT_ARCHIVE;                     /* go get the next  segment in the directory */
176                end;
177 
178 /* time to find out what kind of segment it is */
179                ename_len = index (ename, " ") -1;
180                if ename_len = -1 then ename_len = 32;       /* oops, 32 character name */
181                if ename_len <= 8 then go to UNBOUND;        /* not long enough to be an archive */
182                sname = substr (ename, ename_len -1);
183 
184                if substr (ename, ename_len - 7, 8) = ".archive"
185                then do;
186                                                             /* it is an archive file */
187                     call archive_util_$first_element (ap, acode); /* get first segment pointer inside archive file */
188                     if acode = 2 then go to AERROR;         /* archive format error */
189 
190                     if acode = 1
191                     then do;
192                          call ioa_ ("^a>^a is empty and will be ignored.", path, ename);
193                          go to NEXT_ARCHIVE;
194                     end;
195 
196                     if ap = null then go to AERROR;         /* some other problem */
197 
198                     archives_tested = archives_tested+1;
199 FOUND_SEGMENT:
200 
201                     not_an_archive = "0"b;
202 
203 
204                     sname = ap -> header.name;              /* copy segment name into temporary */
205                     sname_len = index (sname, " ") - 1;     /* get length of segment name */
206                     if sname_len = -1
207                     then sname_len = 32;
208                     sp = addrel (ap, 25);                   /* get pointer to the actual data of the segment */
209                     bc = cv_dec_ (ap -> header.bitcnt);     /* get character count */
210                     bc = divide (bc, 9, 17, 0);
211                                                             /* now see if the word "include" appears anywhere in the segment */
212                     j = index (substr (sp -> string, 25, bc), "include");
213 
214                end;                                         /* End of special actions for archive file */
215 
216 
217 /* actions if segment is unbound */
218 
219                else do;
220 UNBOUND:
221 
222                     unbound_segs = unbound_segs + 1;
223                     sname = ename;
224                     sname_len = ename_len;
225                     sp = ap;
226                                                             /* compute character count */
227                     bc = divide (acl, 9, 17, 0);
228 
229 /* see if the word "include" appears anywhere in the segment */
230                     j = index (substr (sp -> string, 1, bc), "include");
231                     not_an_archive = "1"b;
232 
233                end;
234 
235 /* do this for both kinds of segments */
236                segs_tested = segs_tested +1;
237                first_incl_sw = "1"b;
238 
239 /* now see if the index to j was non-zero */
240 
241                if j ^= 0 then do;                           /* Yes, go through include name loop */
242                     t3 = substr (sname, sname_len-2, 3);    /* copy suffix of sname */
243                     if t3 = "pl1" | t3 = "cds" | substr (sname, sname_len-1, 2) = "rd"
244                     then type = 1;                          /* set the suffix type */
245                     else if t3 = "alm" then type = 2;
246                     else if t3 = "ioc" then type = 3;
247                     else if substr (sname, sname_len-6, 7) = "fortran" then type = 4;
248                     else if substr (sname, sname_len-3, 4) = "bcpl" then type = 5;
249                     else if substr (sname, sname_len-3, 4) = "mexp" then type = 6;
250                     else if substr (sname, sname_len-1, 2) = "ld" then do; /* can't contain any include files */
251                          if not_an_archive = "1"b then unbound_segs = unbound_segs -1;
252                          segs_tested = segs_tested -1;
253                          first_incl_sw = "0"b;
254                          go to NEXT_SEGMENT;
255                     end;
256                     else do;                                /* unknown type, error */
257 
258                          call ioa_ ("Unknown segment suffix in ^a.", sname); /* tell user of trouble */
259                          if not_an_archive = "1"b then unbound_segs = unbound_segs -1;
260                          segs_tested = segs_tested -1;
261                          first_incl_sw = "0"b;
262                          go to NEXT_SEGMENT;
263                     end;
264 
265 /* Now put the name in table, but don't use it later if it's not real */
266                     substr (ptr (isegp, isp) -> string, 1, sname_len) = sname;
267                     name_offset = isp;                      /* save index into table */
268                     isp = isp + divide (sname_len+3, 4, 17, 0); /* update to next slot */
269                     nsegs = nsegs+1;
270                     nchars = nchars+bc;
271 
272                     strx = 1;
273 
274 /* when someone gets the time, the standard object segment format now
275    contains a source map of all the source (main + include) segments
276    used to generate the object code.  It would sure be a lot easier
277    to extract that, rather than trying to efficiently parse the source
278    languages.  (pg 740320) */
279 
280 INC_LOOP:
281                     j = index (substr (string, strx, bc-strx+1), "include"); /* search for include in the segment */
282                     if j = 0 then go to NEXT_SEGMENT;
283                     strx = strx + j + 6;
284                     c1 = substr (string, strx, 1);          /* make some checks to see if this include is a real one */
285                     if c1 ^= " " then if c1 ^= "  " then go to INC_LOOP; /* following char must be space or tab */
286                     if strx < 10 then go to OK;             /* beginning of segment */
287                     c1 = sp -> ch.a (strx-10);              /* get character 2-immediately before "include" */
288                     c2 = sp -> ch.a (strx-9);               /* get character immediately before "include" */
289                     if (type = 2) | (type = 3) then do;     /* alm or ioc */
290                          if (c2 = nl) | (c2 = "%") then go to OK; /* ok if preceded by "%" or nl */
291                          if c1 = nl then if c2 = "          " then go to OK; /* ok if preceded by nl-tab */
292                          go to CHECK2;
293                     end;
294                     else if type = 6 then do;               /* mexp */
295                          if c2 = "&" then goto OK;
296                          if c1 = "&" then if c2 = " " | c2 = "        " then goto OK;
297                          goto INC_LOOP;
298                     end;
299                     else do;                                /* pl1, cds, rd, fortran, bcpl */
300                          if (c2 = "%") then go to OK;
301 CHECK2:                  if c1 = "%" then if (c2 = " ") | (c2 = "     ") then go to OK;
302                          go to INC_LOOP;
303                     end;
304 
305 OK:
306                                                             /* Yes but it still might be inside a comment or expression */
307                                                             /* So back up looking for quotes, or comment chars */
308                     if strx < 13 then go to REALLY_OK;      /* except when we're at the beginning */
309 
310                     do j = 1 to 120;
311                          c1 = sp -> ch.a (strx- (9 +j));
312                          c2 = sp -> ch.a (strx- (10 +j));
313                          c3 = sp -> ch.a (strx- (11+j));
314                          c4 = sp -> ch.a (strx- (12+j));
315                          if (c1 = nl) then go to REALLY_OK;
316                          if c1 = "*" then if c2 = "/" then go to INC_LOOP;
317                          if c2 = "/" then if c1 = "*" then go to INC_LOOP; /* end of comment */
318                                                             /* make sure that %INCLUDE not inside of quotes */
319                          if (c1 = quote_sign) then go to INC_LOOP;
320                     end;                                    /* End of loop to try to eliminate comments, etc. */
321 
322 REALLY_OK:
323 
324 /* loop through to bypass blanks and hts */
325                     do j = 1 to 20 while (sp -> ch.a (strx+j-2) = " " | sp -> ch.a (strx+j-2) = "   ");
326                     end;
327                     strx = strx+j-1;                        /* update index into file */
328                     do i = 1 to 24;                         /* search for end of name */
329                          c = substr (string, strx+i-1, 1);  /* get current character */
330                          if c = "       " then go to STOP;
331                          if c = " " then go to STOP;
332                          if c = ";" then go to STOP;
333                          if c = nl then go to STOP;
334                     end;
335                     go to INC_LOOP;                         /* not a real Include statement */
336 STOP:
337 
338 
339 /* Add this to total if first include file for this segment */
340                     if first_incl_sw = "1"b then do;
341                          first_incl_sw = "0"b;
342                          segs_with_includes = segs_with_includes +1;
343                     end;
344 
345                     iname_len = i-1;                        /* set length of include file name */
346                     iname = substr (string, strx, iname_len); /* copy the string into temporary */
347 
348 /* Check for extraneous quote signs in the include name */
349 
350                     if substr (iname, 1, 1) = quote_sign then do; /* May be two quotes */
351                          iname = substr (iname, 2);
352                          iname_len = iname_len -1;
353                     end;
354 
355                     i = index (iname, """");
356                     if i ^= 0 then do;                      /* get rid of quote at end too */
357                          iname = substr (iname, 1, iname_len -1);
358                          iname_len = iname_len -1;
359                     end;
360 
361 
362 /* Now search for the include file name in the structure and enter it if not
363    there. Log the current segment pointed to by this include file */
364 
365                     inp = fixed (unspec (substr (iname, 1, 1)), 9); /* get hash character for search */
366 
367                     do while (ht (inp) ^= 0);               /* see if the name is entered in the table of include file names */
368                          inp1 = ht (inp);                   /* save current thread value */
369                          j = 2;                             /* start compares at second character (first always matches) */
370                          tp = addr (ht (inp1+4));           /* get pointer to string in include entry */
371                          do k = 2 to ht (inp1+2);           /* check each character of the include file name in the table */
372                               if j >= iname_len+1 then go to INSERT; /* match, INSERT the new name */
373                               if substr (iname, j, 1) > tp -> ch.a (k-1) then go to NEXTN; /* no match, go to next entry */
374                               if substr (iname, j, 1) < tp -> ch.a (k-1) then go to INSERT; /* match zzzz */
375                               j = j + 1;                    /* skip to next chacater */
376                          end;
377                               if j = iname_len+1 then if type = ht (inp1+1) then go to EQ; else go to NEXTN;
378                                                             /* found entry if type matches */
379 NEXTN:                   inp = inp1;                        /* loop to next entry in thread */
380                     end;
381 
382 INSERT:
383                     number_of_includes = number_of_includes +1;
384                     ht (isp) = ht (inp);                    /* thread in to next name */
385                     ht (isp+1) = type;                      /* store segment type in new entry */
386                     ht (isp+2) = iname_len;                 /* store length of include name in new entry */
387                     ht (isp+3) = 0;                         /* zero thread of segments for this include file */
388                     ht (inp) = isp;                         /* push next thread to cureently defined entry */
389                     substr (addr (ht (isp+4)) -> string, 1, iname_len) = iname; /* copy include file name */
390                     isp = isp+4+divide (iname_len+3, 4, 17, 0); /* increment free storage pointer */
391 
392 EQ:
393                     inp = ht (inp) + 3;                     /* get thraed of segment for this include file */
394                     do while (ht (inp) ^= 0);               /* go to the end of that thread */
395                          inp = ht (inp);                    /* go indirect to end of thread */
396                     end;
397                     ht (isp) = 0;                           /* zero next thread pointer */
398                     ht (isp+1) = name_offset;               /* fill in pointer to name */
399                     ht (isp+2) = sname_len;                 /* fill in number of characters in segment name */
400                     ht (inp) = isp;                         /* update pointer in inc entry to point to this segment */
401                     isp = isp + 3;                          /* update free storage pointer */
402                     if isp > maxisp then do;                /* watch out for free storage overflow */
403                          call ioa_ ("OUT OF FREE STORAGE CELLS^");
404                          go to PRINT;
405                     end;
406                     go to INC_LOOP;
407                end;                                         /* End of include  loop for this segment */
408 
409 NEXT_SEGMENT:
410                if type = 6 then do;
411                     type = 2;
412                     strx = 1;
413                     goto INC_LOOP;
414                end;
415 
416 /* do this if it was unbound */
417                if not_an_archive = "1"b then do;
418                     not_an_archive = "0"b;
419                end;
420 
421 /* do this if it was an archive_file */
422                else do;
423                     call archive_util_$next_element (ap, acode); /* skip to next segment in the archive file */
424                     if acode = 2 then go to AERROR;         /* Archive format error */
425                     if ap ^= null then go to FOUND_SEGMENT; /* there is another element in this archive, get it */
426                end;
427 NEXT_ARCHIVE:
428                call hcs_$terminate_noname (ap, code);
429           end;                                              /* End of processing all segments in this  archive */
430                                                             /* also end of loop for unbound segments */
431                                                             /* Return  to process next segment or archive */
432                                                             /* Fall through when done with this directory path */
433                                                             /* occurs when ai reaches count */
434 
435           if eptr ^= null then free eptr -> entries;        /* free up storage used by star_ */
436           if nptr ^= null then free nptr -> enamea;
437           go to PATH_LOOP;                                  /* loop back for next path name in search file */
438 
439 AERROR:   call ioa_ ("Archive format error in ^a>^a.", path, ename);
440           go to NEXT_ARCHIVE;
441 ^L
442 /* NOW PRINT OUT ALL THE INFORMATION WE HAVE GATHERED */
443 
444 
445 PRINT:
446           j = index (outname, " ");                         /* get length of path name, for output segment name */
447           substr (outname, j) = ".icrfout";
448           call ios_$attach (stream_name, "file_", outname, "", status); /* make output go into special
449                                                                file */
450           do i = 0 to 127;                                  /* loop through all the buckets in the hash table */
451                inp = i;
452                do while (ht (inp) ^= 0);                    /* loop through all entries in this bucket */
453                     inp1 = ht (inp);                        /* get pointer to next real entry */
454                     tc = ht (inp1+2);                       /* get number of characters in include name */
455                     tp = addr (ht (inp1+4));                /* get pointer to actual name */
456                                                             /* Write out include file name */
457                     call ioa_$ioa_stream (stream_name, "^/^a.incl.^a", btarg, ctype (ht (inp1+1)));
458                     j = ht (inp1+3);                        /* now loop through the trailers for this include file */
459                     do while (j ^= 0);                      /* loop until zero pointer which means no more */
460                          tp = ptr (isegp, ht (j+1));        /* get pointer to this segment name */
461                          tc = ht (j+2);                     /* get length of the segment name */
462                          call ioa_$ioa_stream (stream_name, "   ^a", btarg);
463                          j = ht (j);                        /* chain on to next trailer */
464                     end;
465                     inp = inp1;                             /* chain to next entry */
466                end;
467           end;
468           if nsegs = 0 then call ioa_$ioa_stream (stream_name, "^/^/No segments with includes.");
469           call ioa_$ioa_stream (stream_name, "^|^5/Summary of Include File Cross Reference:^5/");
470           call ioa_$ioa_stream (stream_name, "^/^/^-^-Total number of archives tested:    ^d.", archives_tested);
471           call ioa_$ioa_stream (stream_name, "^/^/^-^-Total  unbound segments tested:     ^d.", unbound_segs);
472           call ioa_$ioa_stream (stream_name, "^/^-^-Total number of segments tested:      ^d.", segs_tested);
473           call ioa_$ioa_stream (stream_name, "^/^-^-Total number of include files:        ^d.", number_of_includes);
474           call ioa_$ioa_stream (stream_name, "^/^-^-Total  segments with include files:   ^d.", segs_with_includes);
475 
476 
477 /* okay to detach the file.We are all finished now */
478 
479           call ios_$detach (stream_name, "", "", status);   /* detach the output file */
480           call hcs_$delentry_seg (isegp, code);             /* delete the temporary data segment */
481      end;