1
2
3
4
5
6
7
8
9
10
11 cross_reference: cref:
12 procedure options (variable);
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30 dcl 1 auto_area_info like area_info aligned automatic;
31
32 dcl eof bit (1) aligned,
33 char_idx fixed bin (21),
34 temp_dir char (168) varying,
35 temp_string char (168),
36 search_dir char (168),
37 token char (200) varying,
38 save_token char (200) varying,
39 master_node pointer,
40 al fixed bin (21),
41 bitcount fixed bin (24),
42 seg_count fixed bin,
43 char_count fixed bin (21),
44 code fixed bin (35),
45 (i, j) fixed bin,
46 n_pathnames fixed bin,
47 given_ll fixed bin,
48 nargs fixed bin,
49 (input_seg_ptr, test_outseg_ptr, output_seg_ptr, err_seg_ptr, msf_fcb_ptr, ap) ptr,
50 cur_dir_description char (168) varying;
51
52 dcl first_pass bit (1) aligned,
53 cur_all_option bit (1) aligned,
54 first_switch bit (1) aligned,
55 do_include_files bit (1) aligned,
56 short_switch bit (1) aligned,
57 brief_switch bit (1) aligned;
58
59 dcl (input_filename, output_filename) char (168),
60 (input_filedir, output_filedir) char (168);
61
62
63
64 dcl (error_table_$noarg,
65 error_table_$inconsistent,
66 error_table_$badopt) fixed bin (35) external static;
67
68 dcl sys_info$max_seg_size ext fixed bin (35) static;
69
70
71
72 dcl (Segs_only fixed bin initial (2),
73 Nondir_segment bit (2) initial ("01"b)) static options (constant);
74
75
76
77 dcl 1 star_structure (seg_count) aligned based (star_struc_ptr),
78 2 type bit (2) unaligned,
79 2 nnames bit (16) unaligned,
80 2 nindex bit (18) unaligned;
81
82 dcl star_struc_ptr pointer;
83
84 dcl star_names (1000) based (star_names_ptr) char (32);
85
86 dcl star_names_ptr pointer;
87
88 dcl system_free_area area based (system_free_ptr),
89 system_free_ptr pointer;
90
91 dcl 1 search_dir_struc aligned based (search_dir_ptr),
92 2 make_all_names_external bit (1) aligned,
93 2 max_dirs fixed bin,
94 2 n_dirs fixed bin,
95 2 item (N_DIRS refer (search_dir_struc.max_dirs)),
96 3 search_dirs char (168),
97 3 search_dir_descriptions char (168) varying;
98
99 dcl N_DIRS fixed bin static options (constant) initial (32),
100 search_dir_ptr pointer;
101 dcl CROSSREF char (8) internal static options (constant) init ("crossref");
102 dcl 1 pathname_struc based (pathname_ptr),
103 2 xxx fixed bin,
104 2 array (nargs refer (xxx)),
105 3 pathname char (168),
106 3 dirname char (168),
107 3 ename char (32),
108 3 dir_description char (168) varying,
109 3 is_starname bit (1),
110 3 all_option bit (1) aligned;
111
112 dcl pathname_ptr pointer;
113
114
115 dcl arg char (al) based (ap);
116
117 %include area_info;
118 %include access_mode_values;
119 %include terminate_file;
120
121
122
123 dcl define_area_ ext entry (pointer, fixed bin (35)),
124 release_area_ ext entry (pointer);
125
126 dcl com_err_ entry options (variable),
127 cref_sort_ ext entry,
128 cref_listman_$init ext entry (ptr),
129 cref_analyze_$init ext entry (bit (1) aligned, bit (1) aligned, pointer),
130 cu_$arg_ptr entry (fixed, ptr, fixed bin (21), fixed bin (35)),
131 cu_$arg_count ext entry (fixed bin),
132 cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
133 expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
134 cref_filegen_$init ext entry (ptr, bit (1) aligned, bit (1) aligned, pointer, fixed bin),
135 cref_filegen_ entry (ptr, ptr),
136 hcs_$delentry_seg entry (ptr, fixed bin (35)),
137 initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24),
138 fixed binary (35)),
139 terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)),
140 absolute_pathname_$add_suffix ext entry (char (*), char (*), char (*), fixed bin (35)),
141 (get_temp_segment_, release_temp_segment_) ext entry (char (*), pointer, fixed bin (35)),
142 hcs_$truncate_seg ext entry (pointer, fixed bin, fixed bin (35)),
143 pathname_ entry (character (*), character (*)) returns(character (168)),
144 cref_analyze_ entry (char (*), bit (1) aligned);
145
146 dcl get_system_free_area_ ext entry returns (pointer);
147
148 dcl hcs_$star_ ext entry (char (*), char (*), fixed bin, pointer, fixed bin, pointer, pointer, fixed bin (35)),
149 check_star_name_$entry ext entry (char (*), fixed bin (35));
150
151 dcl cref_listman_$predefine_primary_block_char ext entry (char (*) varying, pointer, pointer,
152 bit (1) aligned, bit (1) aligned, bit (1) aligned) returns (pointer),
153 cref_listman_$create_syn_block ext entry (char (*) varying, pointer, pointer, bit (1) aligned, pointer);
154
155 dcl msf_manager_$open ext entry (char (*), char (*), pointer, fixed bin (35)),
156 msf_manager_$get_ptr ext entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)),
157 msf_manager_$adjust ext entry (pointer, fixed bin, fixed bin (24), bit (3) aligned, fixed bin (35)),
158 msf_manager_$close ext entry (pointer);
159
160
161
162 dcl (addr, binary, hbound, length, null, rtrim, search, substr, unspec, verify) builtin;
163
164
165
166 dcl (cleanup, cref_abort_) condition;
167
168 ^L
169
170
171
172
173 unspec (auto_area_info) = ""b;
174
175 test_outseg_ptr, err_seg_ptr, auto_area_info.areap, search_dir_ptr,
176 input_seg_ptr, output_seg_ptr, pathname_ptr, star_struc_ptr, star_names_ptr, msf_fcb_ptr = null;
177 input_filename, output_filename = "";
178 cur_all_option = ""b;
179 given_ll = -1;
180
181 system_free_ptr = get_system_free_area_ ();
182 first_switch = ""b;
183 short_switch, do_include_files = ""b;
184 brief_switch = ""b;
185
186 call cu_$arg_count (nargs);
187 if nargs = 0 then do;
188 call com_err_ (error_table_$noarg, "cross_reference", "
189 Basic usage: cross_reference pathname1 ... pathname_n");
190 return;
191 end;
192
193 auto_area_info.version = area_info_version_1;
194 auto_area_info.extend, auto_area_info.no_freeing = "1"b;
195 auto_area_info.size = sys_info$max_seg_size;
196 auto_area_info.owner = "cross_reference";
197
198 call define_area_ (addr (auto_area_info), code);
199 if code ^= 0 then call crump (code, "temp area creation.");
200
201 allocate search_dir_struc in (system_free_area);
202
203 search_dir_struc.make_all_names_external = ""b;
204 search_dir_struc.n_dirs = 0;
205
206 allocate pathname_struc in (system_free_area);
207
208 n_pathnames = 0;
209 cur_dir_description = "";
210
211 do i = 1 to nargs;
212
213 call cu_$arg_ptr (i, ap, al, code);
214
215 if substr (arg, 1, 1) = "-" then do;
216
217 if (arg = "-input_file") | (arg = "-if") then do;
218 if input_filename ^= "" then call crump (error_table_$inconsistent,
219 "Input file may only be specified once.");
220 if i = nargs then call crump (error_table_$noarg,
221 "-input_file must be followed by the name of an input file.");
222
223 i = i + 1;
224 call cu_$arg_ptr (i, ap, al, code);
225 call absolute_pathname_$add_suffix (arg, "crl", input_filename, code);
226 if code ^= 0 then call crump (code, arg);
227 end;
228
229 else if (arg = "-output_file") | (arg = "-of") then do;
230 if output_filename ^= "" then call crump (error_table_$inconsistent,
231 "Output file may only be specified once.");
232 if i = nargs then call crump (error_table_$noarg,
233 "-output_file must be followed by the name of an output file.");
234
235 i = i + 1;
236 call cu_$arg_ptr (i, ap, al, code);
237 call absolute_pathname_$add_suffix (arg, CROSSREF, output_filename, code);
238 if code ^= 0 then call crump (code, arg);
239 end;
240
241 else if arg = "-first" then first_switch = "1"b;
242
243 else if (arg = "-brief" | arg = "-bf") then brief_switch = "1"b;
244
245 else if arg = "-all" then cur_all_option = "1"b;
246
247 else if (arg = "-library" | arg = "-lb") then do;
248 cur_all_option = ""b;
249 i = i + 1;
250 call cu_$arg_ptr (i, ap, al, code);
251 cur_dir_description = arg;
252 end;
253
254 else if (arg = "-include_files" | arg = "-icf") then do_include_files = "1"b;
255
256 else if (arg = "-short" | arg = "-sh") then short_switch = "1"b;
257
258 else if (arg = "-ll" | arg = "-line_length") then do;
259 if i = nargs then call crump (error_table_$noarg,
260 "-ll must be followed by number.");
261
262 i = i + 1;
263 call cu_$arg_ptr (i, ap, al, code);
264 given_ll = cv_dec_check_ (arg, code);
265 if code ^= 0 then call crump (0, arg || " non-numeric.");
266 end;
267
268 else call crump (error_table_$badopt, arg);
269 end;
270
271 else do;
272 n_pathnames = n_pathnames + 1;
273 pathname (n_pathnames) = arg;
274 dir_description (n_pathnames) = cur_dir_description;
275 all_option (i) = cur_all_option;
276 end;
277 end;
278
279
280
281 if input_filename ^= "" then
282 if n_pathnames > 0 then call crump (error_table_$inconsistent,
283 "-input_file cannot be specified with explicit pathnames.");
284 else if cur_dir_description ^= "" then call crump (error_table_$inconsistent, "-input_file and -library");
285
286 if n_pathnames > 0 then
287 if first_switch
288 then call crump (error_table_$inconsistent, "-first meaningless with explicit pathnames.");
289
290
291
292
293 if output_filename = "" then
294 if input_filename = "" then
295 output_filename = "crossref.crossref";
296 else do;
297
298 call expand_pathname_ (input_filename, (""), output_filename, code);
299 if code ^= 0 then call crump (code, output_filename);
300
301 output_filename = rtrim (before (output_filename, ".crl")) || "." ||
302 CROSSREF;
303
304 end;
305
306
307 call get_temp_segment_ ("cross_reference", err_seg_ptr, code);
308 if err_seg_ptr = null then call crump (code, "err segment creation.");
309
310 temp_string = output_filename;
311 call expand_pathname_ (temp_string, output_filedir, output_filename, code);
312 if code ^= 0 then call crump (code, temp_string);
313
314 call msf_manager_$open (output_filedir, output_filename, msf_fcb_ptr, code);
315 if msf_fcb_ptr = null then goto output_seg_err;
316
317 call msf_manager_$get_ptr (msf_fcb_ptr, 0, "1"b , test_outseg_ptr, 0, code);
318
319
320
321 if test_outseg_ptr = null then do;
322 output_seg_err:
323 call com_err_ (code, "cross_reference", "^a.", pathname_ (output_filedir, output_filename));
324 goto err_return;
325 end;
326
327 if code = 0 then output_seg_ptr = test_outseg_ptr;
328
329
330
331 call cref_listman_$init (auto_area_info.areap);
332 call cref_analyze_$init (first_switch, do_include_files, search_dir_ptr);
333 call cref_filegen_$init (err_seg_ptr, brief_switch, short_switch,
334 auto_area_info.areap, given_ll);
335
336
337 on cref_abort_ go to unwind_and_abort;
338 on cleanup call clean_up;
339 ^K
340 if input_filename ^= "" then do;
341
342 temp_string = input_filename;
343 call expand_pathname_ (temp_string, input_filedir, input_filename, code);
344 if code ^= 0 then call crump (code, temp_string);
345
346 call initiate_file_ (input_filedir, input_filename, R_ACCESS, input_seg_ptr, bitcount, code);
347
348 if code ^= 0 then do;
349 if input_seg_ptr ^= null
350 then call terminate_file_ (input_seg_ptr, (0), TERM_FILE_TERM, (0));
351 call com_err_ (code, "cross_reference", "^a", pathname_ (input_filedir, input_filename));
352 goto err_return;
353 end;
354
355 char_count = divide (bitcount, 9, 35, 0);
356
357 do first_pass = "1"b, ""b;
358 char_idx = 1;
359 eof = ""b;
360
361 token = get_token ();
362
363 do while (^eof);
364
365 if (token = "-library" | token = "-lb") then do;
366
367 token = get_token ();
368
369 if token = "-all" then do;
370 cur_all_option = "1"b;
371 token = get_token ();
372 end;
373
374 else cur_all_option = ""b;
375
376 if token ^= ":" then call crump (0,
377 "Unexpected token || """ || token || """ in -library statement.");
378
379 search_dir_struc.make_all_names_external = ""b;
380 search_dir_struc.n_dirs = 0;
381
382 search_dir = get_token ();
383
384 do while (search_dir ^= ";");
385
386 if eof then
387 call crump (0, "Unexpected end-of-file while processing search list; possible missing semicolon in input file.");
388
389 if search_dir = "-wd" then search_dir = "";
390 else if search_dir = "-working_directory" then search_dir = "";
391 cur_dir_description = rest_of_line ();
392 call expand_pathname_ (search_dir, dirname (1), ename (1), code);
393 if code ^= 0 then if first_pass then call com_err_ (code, "cross_reference",
394 "Directory ^a not searched.", search_dir);
395
396 else;
397
398 else do;
399 temp_dir = pathname_ (dirname (1), ename (1));
400
401 search_dir_struc.n_dirs = search_dir_struc.n_dirs + 1;
402
403 if search_dir_struc.n_dirs > hbound (search_dir_struc.item, 1) then do;
404 call com_err_ (0, "cross_reference", "More than ^d search paths specified.", hbound (search_dir_struc.item, 1));
405 signal cref_abort_;
406 end;
407
408 if cur_dir_description ^= "" then
409 search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = cur_dir_description;
410 else search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = temp_dir;
411
412 search_dir_struc.search_dirs (search_dir_struc.n_dirs) = temp_dir;
413
414 search_dir_struc.make_all_names_external = cur_all_option;
415
416 end;
417
418 search_dir = get_token ();
419 end;
420
421 token = get_token ();
422 end;
423
424 if peek_rest_of_line () ^= "" then
425 if first_pass then do;
426
427 save_token = token;
428
429 master_node = cref_listman_$predefine_primary_block_char (token, null, null, "1"b, ""b, "1"b);
430
431 do while (peek_rest_of_line () ^= "");
432 token = get_token ();
433 call cref_listman_$create_syn_block (token, null, null, "1"b, master_node);
434 end;
435
436 token = save_token;
437 end;
438
439 else temp_string = rest_of_line ();
440
441 else call cref_analyze_ ((token), first_pass);
442
443 token = get_token ();
444 end;
445 end;
446 end;
447 ^K
448 else do;
449
450 do i = 1 to n_pathnames;
451 call expand_pathname_ (pathname (i), dirname (i), ename (i), code);
452 if code ^= 0 then call crump (code, pathname (i));
453
454 call check_star_name_$entry (ename (i), code);
455 if code = 0 then is_starname (i) = ""b;
456 else if code < 3 then is_starname (i) = "1"b;
457 else call crump (code, ename (i));
458 end;
459
460 do first_pass = "1"b, ""b;
461
462 do i = 1 to n_pathnames;
463
464 search_dir_struc.make_all_names_external = ""b;
465 search_dir_struc.n_dirs = 0;
466
467 if search_dir_struc.n_dirs > hbound (search_dir_struc.item, 1) then do;
468 call com_err_ (0, "cross_reference", "More than ^d search paths specified.", hbound (search_dir_struc.item, 1));
469 signal cref_abort_;
470 end;
471
472 search_dir_struc.n_dirs = search_dir_struc.n_dirs + 1;
473
474 if dir_description (i) ^= "" then
475 search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = dir_description (i);
476 else search_dir_struc.search_dir_descriptions (search_dir_struc.n_dirs) = rtrim (dirname (i), " ");
477
478 search_dir_struc.search_dirs (search_dir_struc.n_dirs) = dirname (i);
479
480 search_dir_struc.make_all_names_external = all_option (i);
481
482 if is_starname (i) then do;
483
484 call hcs_$star_ (dirname (i), ename (i), Segs_only, system_free_ptr,
485 seg_count, star_struc_ptr, star_names_ptr, code);
486 if code ^= 0 then
487 if first_pass then call com_err_ (code, "cross_reference", "^a. Continuing...",
488 pathname_ (dirname (i), ename (i)));
489
490 else;
491
492 else do;
493 do j = 1 to seg_count;
494
495 if star_structure.type (j) = Nondir_segment
496 then do;
497
498 call cref_analyze_ (star_names (binary (star_structure (j).nindex, 17)),
499 first_pass);
500 end;
501 end;
502
503 free star_names in (system_free_area),
504 star_structure in (system_free_area);
505
506 star_names_ptr, star_struc_ptr = null;
507 end;
508 end;
509
510 else do;
511 call cref_analyze_ (ename (i), first_pass);
512 end;
513 end;
514 end;
515
516 end;
517
518 call cref_sort_;
519
520 output_seg_ptr = test_outseg_ptr;
521 call hcs_$truncate_seg (output_seg_ptr, 0, code);
522 if code ^= 0 then goto output_seg_err;
523
524 call cref_filegen_ (output_seg_ptr, msf_fcb_ptr);
525
526 call msf_manager_$close (msf_fcb_ptr);
527 msf_fcb_ptr = null;
528
529 call terminate_file_ (output_seg_ptr, (0), TERM_FILE_TERM, code);
530 output_seg_ptr = null;
531
532 ^K
533 err_return:
534 call clean_up;
535 return;
536
537 unwind_and_abort:
538 call com_err_ (0, "cross_reference", "Fatal error. Invocation aborted.");
539 call clean_up;
540 return;
541
542 clean_up:
543 procedure;
544
545 if msf_fcb_ptr ^= null then do;
546 call msf_manager_$adjust (msf_fcb_ptr, 0, 0, "110"b, code);
547 if output_seg_ptr ^= null then call hcs_$delentry_seg (output_seg_ptr, code);
548 call msf_manager_$close (msf_fcb_ptr);
549 end;
550 if auto_area_info.areap ^= null then call release_area_ (auto_area_info.areap);
551 if err_seg_ptr ^= null then call release_temp_segment_ ("cross_reference", err_seg_ptr, code);
552 if input_seg_ptr ^= null then call terminate_file_ (input_seg_ptr, (0), TERM_FILE_TERM, (0));
553 if star_struc_ptr ^= null then free star_structure in (system_free_area);
554 if star_names_ptr ^= null then free star_names in (system_free_area);
555 if pathname_ptr ^= null then free pathname_struc in (system_free_area);
556 if search_dir_ptr ^= null then free search_dir_struc in (system_free_area);
557
558 end clean_up;
559
560
561 crump: proc (code, reason);
562
563 dcl code fixed bin (35) parameter,
564 reason char (*) parameter;
565
566 call com_err_ (code, "cross_reference", reason);
567 goto err_return;
568 end crump;
569 ^L
570 get_token: proc returns (char (200) varying);
571
572 dcl token char (200) varying;
573
574 dcl input_seg char (char_count) based (input_seg_ptr);
575
576 dcl separators char (3) static initial ("
577 "),
578 terminators char (2) static initial ("
579 ;"),
580 breaks_and_separators char (5) static initial ("
581 :;");
582
583 dcl i fixed bin (21);
584
585
586 if char_idx > char_count then goto set_eof;
587
588 i = verify (substr (input_seg, char_idx), separators) - 1;
589 if i = -1 then goto set_eof;
590
591 char_idx = char_idx + i;
592
593 i = search (substr (input_seg, char_idx), breaks_and_separators) - 1;
594 if i = -1 then i = char_count - char_idx + 1;
595 else if i = 0 then i = 1;
596
597 token = substr (input_seg, char_idx, i);
598
599 char_idx = char_idx + i;
600
601 if char_idx > char_count then goto set_eof;
602
603 return (token);
604
605 rest_of_line: entry returns (char (200) varying);
606
607 peek_switch = ""b;
608 goto common;
609
610 peek_rest_of_line: entry returns (char (200) varying);
611
612 dcl peek_switch bit (1);
613
614 dcl whitespace char (2) static initial (" ");
615
616 peek_switch = "1"b;
617
618 common:
619 if char_idx > char_count then goto set_eof;
620
621 i = verify (substr (input_seg, char_idx), whitespace) - 1;
622 if i = -1 then goto set_eof;
623
624 char_idx = char_idx + i;
625
626 i = search (substr (input_seg, char_idx), terminators) - 1;
627 if i = -1 then token = substr (input_seg, char_idx);
628 else token = substr (input_seg, char_idx, i);
629
630 if ^peek_switch then char_idx = char_idx + i;
631
632 return (token);
633
634 set_eof:
635 char_idx = char_count + 1;
636 eof = "1"b;
637 return ("");
638
639 end get_token;
640
641 end cross_reference;