1 /* $Id: comcheck.c,v 1.8 2001/08/26 16:24:12 moniot Rel $
2
3 Routines to check common block agreement
4
5 */
6
7 /*
8
9
10 Copyright (c) 2001 by Robert K. Moniot.
11
12 Permission is hereby granted, free of charge, to any person
13 obtaining a copy of this software and associated documentation
14 files (the "Software"), to deal in the Software without
15 restriction, including without limitation the rights to use,
16 copy, modify, merge, publish, distribute, sublicense, and/or
17 sell copies of the Software, and to permit persons to whom the
18 Software is furnished to do so, subject to the following
19 conditions:
20
21 The above copyright notice and this permission notice shall be
22 included in all copies or substantial portions of the
23 Software.
24
25 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
26 KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
27 WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
28 PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
29 COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
30 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
31 OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
32 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
33
34 Acknowledgement: the above permission notice is what is known
35 as the "MIT License."
36 */
37
38 /*
39
40 Shared functions defined:
41
42 check_com_usage() Checks usage status of common blocks & vars
43
44 */
45
46 #include <stdio.h>
47 #include <string.h>
48 #include "ftnchek.h"
49 #include "symtab.h"
50 #include "pgsymtab.h"
51
52 /* Local routines defined. */
53
54 PROTO(PRIVATE void check_nameclash,(void));
55 PROTO(PRIVATE void com_block_usage,( char *name, ComListHeader *cl1 ));
56 PROTO(PRIVATE void com_cmp_lax,( char *name, ComListHeader *c1,
57 ComListHeader *c2 ));
58 PROTO(PRIVATE void com_cmp_strict,( char *name, ComListHeader *c1,
59 ComListHeader *c2 ));
60 PROTO(PRIVATE void com_element_usage,( char *name, ComListHeader *r_cl,
61 ComListElement *r_list, int r_num ));
62 PROTO(PRIVATE void print_marked_com_elts,(ComListElement *r_list, int r_num));
63
64 #ifdef DEBUG_COM_USAGE
65 PROTO(PRIVATE void print_comvar_usage,( ComListHeader *comlist ));
66 #endif
67
68 #define pluralize(n) ((n)==1? "":"s") /* singular/plural suffix for n */
69
70 void
check_comlists(VOID)71 check_comlists(VOID) /* Scans global symbol table for common blocks */
72 {
73 int i;
74 int model_n;
75 ComListHeader *first_list, *model, *clist;
76
77 /* Check for name clashes with subprograms */
78 if(f77_common_subprog_name) {
79 check_nameclash();
80 }
81
82 if(COMCHECK_OFF)
83 return;
84
85 for (i=0; i<glob_symtab_top; i++){
86
87 if (storage_class_of(glob_symtab[i].type) != class_COMMON_BLOCK)
88 continue;
89
90 if((first_list=glob_symtab[i].info.comlist) == NULL){
91 (void)fprintf(list_fd,"\nCommon block %s never defined",
92 glob_symtab[i].name);
93 }
94 else {
95 /* Find instance with most variables to use as model */
96 model=first_list;
97 model_n = first_list->numargs;
98 clist = model;
99 while( (clist=clist->next) != NULL ){
100 if(clist->numargs >= model_n /* if tie, use earlier */
101 /* also if model is from an unvisited library
102 module, take another */
103 || irrelevant(model) ) {
104 model = clist;
105 model_n = clist->numargs;
106 }
107 }
108
109 if( irrelevant(model) )
110 continue; /* skip if irrelevant */
111
112 /* Check consistent SAVEing of block:
113 If SAVEd in one module, must be SAVEd in all.
114 Main prog is an exception: SAVE ignored there. */
115 {
116 ComListHeader *saved_list, *unsaved_list;
117 saved_list = unsaved_list = (ComListHeader *)NULL;
118 clist = first_list;
119 while( clist != NULL ){
120
121 if(!irrelevant(clist) && clist->module->type !=
122 type_byte(class_SUBPROGRAM,type_PROGRAM) ) {
123
124 if(clist->saved)
125 saved_list = clist;
126 else
127 unsaved_list = clist;
128 }
129 clist = clist->next;
130 }
131 if(saved_list != (ComListHeader *)NULL &&
132 unsaved_list != (ComListHeader *)NULL) {
133 cmp_error_count = 0;
134 (void)comcmp_error_head(glob_symtab[i].name,
135 saved_list,
136 "not SAVED consistently");
137 com_error_report(saved_list,"is SAVED");
138 com_error_report(unsaved_list,"is not SAVED");
139 }
140 }
141
142
143 /* Now check agreement of common lists */
144 clist = first_list;
145 while( clist != NULL ){
146 if(clist != model && !irrelevant(clist)) {
147
148 if(comcheck_by_name)
149 com_cmp_strict(glob_symtab[i].name,model,clist);
150 else
151 com_cmp_lax(glob_symtab[i].name,model,clist);
152 }
153 clist = clist->next;
154 }
155 }
156 }
157 } /* check_comlists */
158
159
160 /* Common-list check for comcheck_type or comcheck_length
161 (formerly strictness levels 1 & 2) */
162 PRIVATE void
163 #if HAVE_STDC
com_cmp_lax(char * name,ComListHeader * c1,ComListHeader * c2)164 com_cmp_lax(char *name, ComListHeader *c1, ComListHeader *c2)
165 #else /* K&R style */
166 com_cmp_lax(name,c1,c2)
167 char *name;
168 ComListHeader *c1,*c2;
169 #endif /* HAVE_STDC */
170 {
171 int i1,i2, /* count of common variables in each block */
172 done1,done2, /* true when end of block reached */
173 type1,type2; /* type of variable presently in scan */
174 unsigned long
175 len1,len2, /* length of variable remaining */
176 size1,size2, /* unit size of variable */
177 word1,word2, /* number of "words" scanned */
178 words1,words2, /* number of "words" in block */
179 defsize1,defsize2, /* default size used? */
180 jump; /* number of words to skip next in scan */
181 int byte_oriented=FALSE, /* character vs numeric block */
182 type_clash; /* flag for catching clashes */
183 int n1=c1->numargs,n2=c2->numargs; /* variable count for each block */
184
185 ComListElement *a1=c1->com_list_array, *a2=c2->com_list_array;
186
187 /* Count words in each list */
188 words1=words2=0;
189 for(i1=0; i1<n1; i1++) {
190 size1 = a1[i1].size;
191 if(size1 == size_DEFAULT)
192 size1 = type_size[a1[i1].type];
193 else
194 byte_oriented = TRUE;
195 words1 += array_size(a1[i1].dimen_info)*size1;
196 }
197 for(i2=0; i2<n2; i2++) {
198 size2 = a2[i2].size;
199 if(size2 == size_DEFAULT)
200 size2 = type_size[a2[i2].type];
201 else
202 byte_oriented = TRUE;
203 words2 += array_size(a2[i2].dimen_info)*size2;
204 }
205 /* If not byte oriented, then sizes are all multiples of
206 BpW and can be reported as words according to F77 std. */
207 if(!byte_oriented) {
208 words1 /= BpW;
209 words2 /= BpW;
210 }
211 if(comcheck_length && words1 != words2) {
212 char msg[11+3*sizeof(words1)];
213 cmp_error_count = 0;
214 (void)comcmp_error_head(name,c1,"varying length:");
215 (void)sprintf(msg,"Has %ld %s%s",
216 words1,
217 byte_oriented? "byte":"word",
218 pluralize(words1));
219 com_error_report(c1,msg);
220 (void)sprintf(msg,"Has %ld %s%s",
221 words2,
222 byte_oriented? "byte":"word",
223 pluralize(words2));
224 com_error_report(c2,msg);
225 }
226
227 /* Now check type matches */
228 if(comcheck_type) {
229 done1=done2=FALSE;
230 i1=i2=0;
231 len1=len2=0;
232 word1=word2=1;
233 cmp_error_count=0;
234 for(;;) {
235 if(len1 == 0) { /* move to next variable in list 1 */
236 if(i1 == n1) {
237 done1 = TRUE;
238 }
239 else {
240 type1 = a1[i1].type;
241 size1 = a1[i1].size;
242 defsize1 = (size1 == size_DEFAULT);
243 if(defsize1)
244 size1 = type_size[type1];
245 if(!byte_oriented)
246 size1 /= BpW; /* convert bytes to words */
247 len1 = array_size(a1[i1].dimen_info)*size1;
248 ++i1;
249 }
250 }
251 if(len2 == 0) { /* move to next variable in list 2 */
252 if(i2 == n2) {
253 done2 = TRUE;
254 }
255 else {
256 type2 = a2[i2].type;
257 size2 = a2[i2].size;
258 defsize2 = (size2 == size_DEFAULT);
259 if(defsize2)
260 size2 = type_size[type2];
261 if(!byte_oriented)
262 size2 /= BpW;
263 len2 = array_size(a2[i2].dimen_info)*size2;
264 ++i2;
265 }
266 }
267
268 if(done1 || done2){ /* either list exhausted? */
269 break; /* then stop checking */
270 }
271
272 /* Look for type clash. Allow explicitly sized real to
273 match double of equal size.
274 Allow real to match complex whose parts are of equal size.
275 Within same type category, size diff counts as clash
276 except with char.
277 Also issue warning under -portability or -nowordsize
278 if an explicit size is matched to an implicit size. */
279 type_clash = FALSE;
280 if( (type_category[type1] == type_category[type2]) ) {
281 if( type1 != type_STRING &&
282 (size1 != size2
283 || ((port_mixed_size || local_wordsize==0) &&
284 defsize1 != defsize2))) {
285 type_clash = TRUE;
286 }
287 }
288 else /* different type categories */ {
289 /* Equiv_type matches complex to real */
290 if(equiv_type[type1] != equiv_type[type2]) {
291 type_clash = TRUE;
292 }
293 else {
294 if( type_category[type1] == type_COMPLEX ) {
295 type_clash = (size1 != 2*size2);
296 }
297 else {
298 /* 2nd block has complex */
299 type_clash = (size2 != 2*size1);
300 }
301 /* Give warning anyway if default size
302 is matched to explicit. */
303 if( (port_mixed_size || local_wordsize==0)
304 && defsize1 != defsize2 )
305 type_clash = TRUE;
306 }
307 }
308
309 if(type_clash) {
310 char msg[15+MAX_TYPESPEC+3*sizeof(word1)];
311 if(comcmp_error_head(name,c1,"data type mismatch"))
312 break;
313 (void)sprintf(msg,"%s %ld is type %s",
314 byte_oriented?"Byte":"Word",
315 word1,
316 typespec(type1,!defsize1,(long)size1,FALSE,0L));
317 com_error_report(c1,msg);
318 (void)sprintf(msg,"%s %ld is type %s",
319 byte_oriented?"Byte":"Word",
320 word2,
321 typespec(type2,!defsize2,(long)size2,FALSE,0L));
322 com_error_report(c2,msg);
323 }
324
325 /* Advance along list by largest possible
326 step that does not cross a variable boundary.
327 If matching complex to real, only advance
328 the real part.
329 */
330 jump = len1 < len2? len1: len2; /* min(len1,len2) */
331 len1 -= jump;
332 len2 -= jump;
333 word1 += jump;
334 word2 += jump;
335 }/* end for(;;) */
336 }/* end if(comcheck_type) */
337 }
338
339 /* Common-list check name-by-name (formerly strictness level 3) */
340 PRIVATE void
341 #if HAVE_STDC
com_cmp_strict(char * name,ComListHeader * c1,ComListHeader * c2)342 com_cmp_strict(char *name, ComListHeader *c1, ComListHeader *c2)
343 #else /* K&R style */
344 com_cmp_strict(name,c1,c2)
345 char *name;
346 ComListHeader *c1, *c2;
347 #endif /* HAVE_STDC */
348 {
349 int i;
350 short n,
351 n1 = c1->numargs,
352 n2 = c2->numargs;
353 ComListElement *a1 = c1->com_list_array,
354 *a2 = c2->com_list_array;
355
356 if(comcheck_length) {
357 n = (n1 > n2) ? n2: n1;
358 if(n1 != n2){
359 char msg[15+3*sizeof(n1)];
360 cmp_error_count = 0;
361 (void)comcmp_error_head(name,c1,"varying length:");
362 (void)sprintf(msg,"Has %d variable%s",
363 n1,pluralize(n1));
364 com_error_report(c1,msg);
365 (void)sprintf(msg,"Has %d variable%s",
366 n2,pluralize(n2));
367 com_error_report(c2,msg);
368 }
369 }
370 #ifdef DEBUG_PGSYMTAB
371 if(debug_latest){
372 (void)fprintf(list_fd,"block %s",name);
373 (void)fprintf(list_fd,"\n\t1=in module %s line %u file %s (%s)",
374 c1->module->name,
375 c1->line_num,
376 c1->topfile
377 c1->filename);
378 (void)fprintf(list_fd,"\n\t2=in module %s line %u file %s (%s)",
379 c2->module->name,
380 c2->line_num,
381 c2->topfile,
382 c2->filename);
383 }
384 #endif
385 if(comcheck_type) {
386 cmp_error_count = 0;
387 for (i=0; i<n; i++) {
388 int t1 = datatype_of(a1[i].type),
389 t2 = datatype_of(a2[i].type),
390 s1 = a1[i].size,
391 s2 = a2[i].size,
392 defsize1 = (s1==size_DEFAULT),
393 defsize2 = (s2==size_DEFAULT);
394 /* If -portability, do not translate default sizes so
395 they will never match explicit sizes. */
396 if(!(port_mixed_size || local_wordsize==0)) {
397 if(defsize1)
398 s1 = type_size[t1];
399 if(defsize2)
400 s2 = type_size[t2];
401 }
402
403 if( t1 != t2 || s1 != s2 ) {
404 if(comcmp_error_head(name,c1,"data type mismatch"))
405 break;
406 comvar_error_report(c1,i,"is type");
407 msg_tail(typespec(t1,!defsize1,(long)s1,FALSE,0L));
408 comvar_error_report(c2,i,"is type");
409 msg_tail(typespec(t2,!defsize2,(long)s2,FALSE,0L));
410
411 }/*end if(type or size mismatch)*/
412 }/*end for(i=0; i<n; i++)*/
413 }/* end if(comcheck_type) */
414
415 if(comcheck_dims) {
416 cmp_error_count = 0;
417 for (i=0; i<n; i++){
418 unsigned long d1, d2, s1, s2;
419
420 if((d1=array_dims(a1[i].dimen_info)) !=
421 (d2=array_dims(a2[i].dimen_info))){
422
423 if(comcmp_error_head(name,c1,"array dimen/size mismatch"))
424 break;
425 comvar_error_report(c1,i,"has");
426 msg_tail(ulongtostr((unsigned long)d1));
427 msg_tail(d1 == 1? "dimension": "dimensions");
428 comvar_error_report(c2,i,"has");
429 msg_tail(ulongtostr((unsigned long)d2));
430 msg_tail(d2 == 1? "dimension": "dimensions");
431
432 }/*end if(num dims mismatch)*/
433
434 if((s1=array_size(a1[i].dimen_info)) !=
435 (s2=array_size(a2[i].dimen_info))){
436
437
438 if(comcmp_error_head(name,c1,"array dimen/size mismatch"))
439 break;
440 comvar_error_report(c1,i,"has size");
441 msg_tail(ulongtostr((unsigned long)s1));
442
443 comvar_error_report(c2,i,"has size");
444 msg_tail(ulongtostr((unsigned long)s2));
445
446 }/*end if(array size mismatch)*/
447 }/*end for(i=0; i<n; i++)*/
448 }/*end if(comcheck_dims)*/
449 }/*com_cmp_strict*/
450
451
452 /** Common block and common variable usage checks. Implemented
453 ** by John Quinn, Jan-May 1993. Some modifications made by RKM.
454 **/
455
456
457 void
check_com_usage(VOID)458 check_com_usage(VOID)
459 {
460 int i;
461
462 /* Print common block cross-reference list */
463 if(print_com_xrefs) {
464 com_xref_list();
465 }
466
467 /* Print out usage info */
468 if(usage_com_any) {
469 for(i=0;i<glob_symtab_top;i++){ /* loop thru global table */
470 if (storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK){
471
472 com_block_usage(glob_symtab[i].name,
473 glob_symtab[i].info.comlist );
474 }
475 }
476 }
477 #ifdef DYNAMIC_TABLES
478 (void) cfree(gsymlist);
479 #endif
480 }
481
482 /* Routine to check for common block having same name
483 as subprogram, which is nonstandard. */
484 PRIVATE void
check_nameclash(VOID)485 check_nameclash(VOID)
486 {
487 int i;
488 ArgListHeader *alist;
489 for(i=0;i<HASHSZ;i++) {
490 if(hashtab[i].glob_symtab != NULL &&
491 hashtab[i].com_glob_symtab != NULL) {
492 ComListHeader *clh=hashtab[i].com_glob_symtab->info.comlist;
493 cmp_error_count = 0;
494 (void)comcmp_error_head(hashtab[i].name,clh,
495 "has same name as a subprogram (nonstandard)");
496 com_error_report(clh,"Declared as common block");
497 for(alist=hashtab[i].glob_symtab->info.arglist;alist!=NULL;
498 alist=alist->next) {
499 if(alist->is_defn) {
500 break;
501 }
502 }
503
504 /* if not declared: use first reference */
505 if(alist==NULL) {
506 sub_error_report( hashtab[i].glob_symtab->info.arglist,
507 "Referenced as subprogram");
508 }
509 else {
510 sub_error_report(alist,
511 "Declared as subprogram");
512 }
513 }
514 }
515 }
516
517
518
519 #ifdef DEBUG_COM_USAGE
520
print_comvar_usage(comlist)521 PRIVATE void print_comvar_usage(comlist)
522
523 ComListHeader *comlist;
524 {
525 int i, count;
526 ComListElement *c;
527
528 count = comlist->numargs;
529 c = comlist->com_list_array;
530
531 /* prints out caller module and any_used, any_set flags in CLhead */
532
533 (void)fprintf(list_fd, "\nModule %s any_used %u any_set %u\n",
534 comlist->module->name, comlist->any_used, comlist->any_set);
535
536 if((comlist->any_used || comlist-> any_set||1) ){
537 for (i=0; i<count; i++){
538
539 /* prints out all four flags for each element in array */
540
541 (void)fprintf(list_fd,
542 "\n Element %d (%s) used %u set %u used bf set %u asgnd %u\n"
543 , i+1
544 , c[i].name
545 , c[i].used
546 , c[i].set
547 , c[i].used_before_set
548 , c[i].assigned);
549 } /* end of for */
550
551 } /* end of if */
552 }
553 #endif
554
555 /* Check used, set status of common block. First it looks for
556 whether the block is totally unused, and if so prints a warning
557 and returns. Otherwise, if block is unused by some modules,
558 it says which ones. Meanwhile, it finds the declaration with
559 the most elements to use as reference. If common strictness
560 is 3 (variable by variable) then it OR's the usage flags of
561 each block variable among different declarations, saving the
562 result in reference list. Passes off to com_element_usage
563 to print usage of individual common variables.
564 */
565
566 PRIVATE void
567 #if HAVE_STDC
com_block_usage(char * name,ComListHeader * cl1)568 com_block_usage(char *name, ComListHeader *cl1)
569 #else /* K&R style */
570 com_block_usage(name,cl1)
571 char *name;
572 ComListHeader *cl1;
573 #endif /* HAVE_STDC */
574 {
575 ComListHeader *ref_cl, /* reference decl: has most elements */
576 *cur_cl; /* running cursor thru decls */
577 int j,n,ref_n;
578 int block_any_used, block_any_set;
579 int block_unused_somewhere;
580 ComListElement *ref_list, *c;
581
582 cmp_error_count = 0;
583
584 block_any_used = block_any_set = FALSE;
585 block_unused_somewhere = FALSE;
586 ref_n = cl1->numargs;
587 ref_cl= cl1;
588 cur_cl = cl1;
589 while (cur_cl!=NULL){ /* traverses CLheads */
590 if(! irrelevant(cur_cl) ) {
591
592 if (cur_cl->any_used){ /* stores TRUE if any are TRUE */
593 block_any_used = TRUE;
594 }
595 if (cur_cl->any_set){ /* stores TRUE if any are TRUE */
596 block_any_set = TRUE;
597 }
598 if( ! (cur_cl->any_used || cur_cl->any_set) &&
599 ! cur_cl->module->defined_in_include ) {
600 block_unused_somewhere = TRUE;
601 }
602 /* if any_set and any_used false after this loop block never used */
603
604 if (cur_cl->numargs > ref_n){ /* find largest array */
605 ref_cl = cur_cl;
606 ref_n = cur_cl->numargs;
607 } /* end of if */
608 }/* end if not irrelevant */
609 cur_cl = cur_cl->next;
610 }
611
612 if(irrelevant(ref_cl)) /* Block not declared by modules in calltree */
613 return;
614
615 if(! (block_any_used || block_any_set) ) { /* Totally unused */
616 if(usage_com_block_unused) {
617 cmp_error_count = 0;
618 (void)comcmp_error_head(name,ref_cl,"unused anywhere");
619 }
620 }
621 else {
622 /* If block used somewhere but not everywhere,
623 report it. */
624 if(block_unused_somewhere && usage_com_block_unused) {
625 cmp_error_count = 0;
626 (void)comcmp_error_head(name,ref_cl,
627 "unused in the following modules:");
628
629 cur_cl = cl1;
630 while (cur_cl!=NULL){ /* traverses CLheads */
631 if(! irrelevant(cur_cl) ) {
632 if( ! (cur_cl->any_used || cur_cl->any_set) &&
633 ! cur_cl->module->defined_in_include ) {
634 com_error_report(cur_cl,"Unused");
635 }
636 }
637 cur_cl = cur_cl->next;
638 }
639 }/* end if block_unused_somewhere */
640
641 if(! comcheck_by_name) {
642 /* If not variablewise checking, just
643 give general warnings. */
644 if (!block_any_set){
645 if(usage_com_var_uninitialized) {
646 cmp_error_count = 0;
647 (void)comcmp_error_head(name,ref_cl,
648 "No elements are set, but some are used.");
649 }
650 }
651 if (!block_any_used){
652 if(usage_com_var_set_unused) {
653 cmp_error_count = 0;
654 (void)comcmp_error_head(name,ref_cl,
655 "No elements are used, but some are set.");
656 }
657 }
658 }
659 else { /* strictness == 3 */
660 /* Now go thru the details for each element */
661
662 /* First, malloc up a temporary list and
663 copy ref_cl and its list there so the
664 original is not clobbered (used later in
665 arg usage checks for common aliasing)
666 */
667 ComListHeader *new_ref_cl;
668 ComListElement *new_ref_list;
669 if( (new_ref_cl=(ComListHeader *)calloc(1,sizeof(ComListHeader)))
670 == (ComListHeader *)NULL ||
671 (new_ref_list=(ComListElement *)calloc(ref_cl->numargs,sizeof(ComListElement)))
672 == (ComListElement *)NULL ) {
673 oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
674 "Cannot alloc space for common block ref list");
675 }
676 *new_ref_cl = *ref_cl; /* Copy the header over to temporary */
677
678 ref_list = ref_cl->com_list_array;
679 for(j=0; j<ref_cl->numargs; j++) { /* Copy the array as well */
680 new_ref_list[j] = ref_list[j];
681 }
682 ref_cl = new_ref_cl; /* Now make the temporary the one we use */
683 ref_list = new_ref_list;
684
685 ref_cl->any_used = block_any_used;
686 ref_cl->any_set = block_any_set;
687
688 /* traversing elements in arrays and storing OR'd values in largest array*/
689
690 cur_cl = cl1;
691 while (cur_cl!=NULL){
692 if(! irrelevant(cur_cl) ) {
693 c = cur_cl->com_list_array;
694 n = cur_cl->numargs;
695 for (j=0; j<n; j++){
696 if (c[j].used) {
697 ref_list[j].used = TRUE;
698 }
699 if (c[j].set){
700 ref_list[j].set = TRUE;
701 }
702 if (c[j].used_before_set){
703 ref_list[j].used_before_set = TRUE;
704 }
705 if (c[j].assigned){
706 ref_list[j].assigned = TRUE;
707 }
708 }
709 }
710 cur_cl = cur_cl->next;
711 }
712 com_element_usage(name, ref_cl, ref_list, ref_n);
713
714 /* Free up the temporary ref list */
715 free(new_ref_cl); free(new_ref_list);
716 }
717 }
718 }
719
720 /* Routine to print a list of common-block elements whose
721 marked flag has been set.
722 */
723 PRIVATE void
724 #if HAVE_STDC
print_marked_com_elts(ComListElement * r_list,int r_num)725 print_marked_com_elts(ComListElement *r_list, int r_num)
726 #else /* K&R style */
727 print_marked_com_elts(r_list, r_num)
728 ComListElement *r_list; /* list of elements, some marked */
729 int r_num; /* number of elements in whole list */
730 #endif /* HAVE_STDC */
731 {
732 int i;
733 COLNO_t col;
734 for (i=0,col=78; i<r_num; i++){
735 if (r_list[i].marked){
736 if( (col += 1+(int)strlen(r_list[i].name)) > 78 ) {
737 (void)fprintf(list_fd,"\n ");
738 col = 4+(int)strlen(r_list[i].name);
739 }
740 (void)fprintf(list_fd, " %s",
741 r_list[i].name);
742 }
743 }
744 }
745
746 PRIVATE void
747 #if HAVE_STDC
com_element_usage(char * name,ComListHeader * r_cl,ComListElement * r_list,int r_num)748 com_element_usage(char *name, ComListHeader *r_cl, ComListElement *r_list, int r_num)
749 #else /* K&R style */
750 com_element_usage(name, r_cl, r_list, r_num)
751
752 char *name;
753 ComListHeader *r_cl;
754 ComListElement *r_list;
755 int r_num;
756
757 #endif /* HAVE_STDC */
758 {
759 int i, warnings;
760
761 if (r_cl->any_used || r_cl->any_set){ /* if false block not used */
762
763 if(usage_com_var_uninitialized) {
764 warnings = 0;
765 for (i=0; i<r_num; i++){ /* Count used-not-set cases */
766 if (r_list[i].used && !r_list[i].set){
767 warnings++;
768 r_list[i].marked = TRUE;
769 }
770 else {
771 r_list[i].marked = FALSE;
772 }
773 }
774 if(warnings > 0) {
775 cmp_error_count = 0;
776 (void)comcmp_error_head(name,r_cl,
777 "Elements used but never set:");
778 if(warnings == r_num) {
779 (void)fprintf(list_fd," all");
780 }
781 else {
782 print_marked_com_elts(r_list, r_num);
783 }
784 }
785 }
786
787 if(usage_com_var_set_unused) {
788 warnings = 0;
789 for (i=0; i<r_num; i++){ /* Count set-not-used cases */
790 if (r_list[i].set && !r_list[i].used){
791 warnings++;
792 r_list[i].marked = TRUE;
793 }
794 else {
795 r_list[i].marked = FALSE;
796 }
797 }
798 if(warnings > 0) {
799 cmp_error_count = 0;
800 (void)comcmp_error_head(name,r_cl,
801 "Elements set but never used:");
802 if(warnings == r_num) {
803 (void)fprintf(list_fd," all");
804 }
805 else {
806 print_marked_com_elts(r_list, r_num);
807 }
808 }
809 }
810
811 if(usage_com_var_unused) {
812 warnings = 0;
813 for (i=0; i<r_num; i++){ /* Count not-used, not-set cases */
814 if(!r_list[i].set && !r_list[i].used &&
815 !r_list[i].used_before_set){
816 warnings++;
817 r_list[i].marked = TRUE;
818 }
819 else {
820 r_list[i].marked = FALSE;
821 }
822 }
823 if(warnings > 0) {
824 cmp_error_count = 0;
825 (void)comcmp_error_head(name,r_cl,
826 "Elements never used, never set:");
827 if(warnings == r_num) { /* can't happen but keeps code alike */
828 (void)fprintf(list_fd," all");
829 }
830 else {
831 print_marked_com_elts(r_list, r_num);
832 }
833 }
834 }
835 }
836 else{ /* This cannot be reached if called only when block is used */
837 if(usage_com_block_unused) {
838 cmp_error_count = 0;
839 (void)comcmp_error_head(name,r_cl,
840 "not used.");
841 }
842 } /* any_used and any_set are both false */
843
844
845
846 }
847
848