1 /* $Id: loccheck.c,v 1.17 2001/11/03 00:55:37 moniot Rel $
2
3 Functions that do local checks on each subprogram.
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_flags() Outputs messages about used-before-set etc.
43 check_mixed_common() checks common for nonportable mixed type
44 find_sixclashes() Finds variables with the same first 6 chars.
45 check_loose_ends() Miscellaneous end-of-subprog checks
46
47 Private functions defined:
48
49 has_nonalnum() True if string has non-alphanumeric char
50
51 */
52
53 #include <stdio.h>
54 #include <ctype.h>
55 #include <string.h>
56 #include "ftnchek.h"
57 #include "symtab.h"
58 #include "plsymtab.h"
59 #include "loccheck.h"
60
61 /* Declarations of local functions */
62
63 PROTO(PRIVATE int has_nonalnum,( char *s ));
64
65 /* Find symbols with nonstd chars _ $ */
66 int
67 #if HAVE_STDC
find_nonalnum_names(Lsymtab ** sym_list)68 find_nonalnum_names(Lsymtab **sym_list)
69 #else /* K&R style */
70 find_nonalnum_names(sym_list)
71 Lsymtab *sym_list[];
72 #endif /* HAVE_STDC */
73 {
74 int i,n;
75 for(i=0,n=0;i<loc_symtab_top;i++) {
76 /* Find all names with nonstd chars, but
77 exclude internal names like %MAIN */
78 if(has_nonalnum(loc_symtab[i].name) &&
79 loc_symtab[i].name[0] != '%') /* exception for internals */
80 sym_list[n++] = &loc_symtab[i];
81 }
82 return n;
83 }
84
85 /* Search thru local symbol table for clashes where identifiers
86 are not unique in 1st six characters. Return value =
87 number of clashes found, with pointers to symbol table
88 entries of clashers in array list. */
89 int
90 #if HAVE_STDC
find_sixclashes(Lsymtab ** list)91 find_sixclashes(Lsymtab **list)
92 #else /* K&R style */
93 find_sixclashes(list)
94 Lsymtab *list[];
95 #endif /* HAVE_STDC */
96 {
97 int i,h, clashes=0;
98 int stg_class;
99 unsigned long hnum;
100
101 for(i=0; i<loc_symtab_top; i++) { /* Scan thru symbol table */
102 stg_class = storage_class_of(loc_symtab[i].type);
103 hnum = hash( loc_symtab[i].name );
104 /* First look for a clash of any kind.
105 (N.B. this loop will never quit if hash
106 table is full, but let's not worry) */
107 while( (h=hnum % HASHSZ), hashtab[h].name != (char *)NULL) {
108 /* Now see if the clashing name is used locally and still
109 clashes at 6 chars. Treat common blocks separately. */
110
111 if((stg_class == class_COMMON_BLOCK &&
112 (
113 hashtab[h].com_loc_symtab != NULL
114 && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
115 && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
116 )
117 ) ||
118 (stg_class != class_COMMON_BLOCK &&
119 (
120 hashtab[h].loc_symtab != NULL
121 && strcmp( hashtab[h].name,loc_symtab[i].name) != 0
122 && strncmp(hashtab[h].name,loc_symtab[i].name,6) == 0
123 )
124 )
125 ) {
126 /* If so, then i'th symbol is a clash */
127
128 list[clashes++] = &loc_symtab[i];
129 break;
130 }
131 else {
132 hnum = rehash(hnum);
133 }
134 }
135 }
136 return clashes;
137 }
138
139
140 void
141 #if HAVE_STDC
check_mixed_common(Lsymtab ** sym_list,int n)142 check_mixed_common(Lsymtab **sym_list, int n)
143 #else /* K&R style */
144 check_mixed_common(sym_list,n)
145 Lsymtab *sym_list[];
146 int n;
147 #endif /* HAVE_STDC */
148 {
149 int i;
150 for(i=0; i<n; i++) {
151 ComListHeader *chead = sym_list[i]->info.comlist;
152 ComListElement *clist;
153 char *mod_name;
154 int j,nvars;
155 int has_char=FALSE,has_nonchar=FALSE;
156 int prev_size = 0;
157 /* initialize to remove lint warning about use before definition */
158 int this_size, this_type;
159
160 if(chead == NULL)
161 continue;
162
163 mod_name = chead->module->name;
164 clist=chead->com_list_array;
165 nvars = chead->numargs;
166
167 for(j=0; j<nvars; j++) {
168
169 /* Check conformity to ANSI rule: no mixing char with other types */
170
171 if( (this_type=datatype_of(clist[j].type)) == type_STRING) {
172 has_char = TRUE;
173 this_size = 1;/* char type size is 1 for alignment purposes */
174 }
175 else { /* other types use declared sizes */
176 has_nonchar = TRUE;
177 if( (this_size=clist[j].size) == size_DEFAULT)
178 this_size = type_size[this_type];
179 }
180 if(has_char && has_nonchar) {
181 if(f77_mixed_common){
182 local_warn_head(mod_name,
183 choose_filename(sym_list[i],file_declared),
184 sym_list[i]->line_declared,
185 (Lsymtab *)NULL, TRUE,
186 "Common block");
187 msg_tail(sym_list[i]->name);
188 msg_tail("has mixed character and non-character variables (nonstandard)");
189 }
190 break;
191 }
192
193 /* Check that variables are in descending order of type size */
194
195 if(j > 0) {
196 if( this_size > prev_size ) {
197 if(port_common_alignment) {
198 local_warn_head(mod_name,
199 choose_filename(sym_list[i],file_declared),
200 sym_list[i]->line_declared,
201 (Lsymtab *)NULL, TRUE,
202 "Common block");
203 msg_tail(sym_list[i]->name);
204 msg_tail("has long data type following short data type (may not be portable)");
205 }
206 break;
207 }
208 }
209 prev_size = this_size;
210 }
211 }
212 }
213
214
215 void
216 #if HAVE_STDC
check_flags(Lsymtab ** list,int n,unsigned int used,unsigned int set,unsigned int ubs,const char * msg,const char * mod_name)217 check_flags(Lsymtab **list, int n, unsigned int used,
218 unsigned int set, unsigned int ubs, const char *msg, const char *mod_name)
219 #else /* K&R style */
220 check_flags(list,n,used,set,ubs,msg,mod_name)
221 Lsymtab *list[];
222 int n;
223 unsigned used,set,ubs;
224 char *msg,*mod_name;
225 #endif /* HAVE_STDC */
226 {
227 int matches=0,col=0,unused_args=0,i,len;
228 unsigned pattern = flag_combo(used,set,ubs);
229
230 for(i=0;i<n;i++) {
231 if( list[i]->common_var ) /* common vars are immune */
232 continue;
233 /* for args, do only 'never used' and
234 then only if -usage=arg-unused given */
235 if( list[i]->argument &&
236 (pattern != flag_combo(0,0,0) || ! usage_arg_unused ) )
237 continue;
238
239 /* skip 'never used' if non-arg and
240 -usage=var-unused not given */
241 if( !(list[i]->argument) &&
242 pattern == flag_combo(0,0,0) && ! usage_var_unused )
243 continue;
244
245 #ifdef ALLOW_INCLUDE
246 /* Skip variables 'declared but not used'
247 and parameters 'set but never used'
248 if defined in include file. */
249
250 if( list[i]->defined_in_include &&
251 ( pattern == flag_combo(0,0,0)
252 || (list[i]->parameter && pattern == flag_combo(0,1,0)) ) )
253 continue;
254 #endif
255 /* function return val: ignore 'set but never used' */
256 if( list[i]->entry_point && pattern == flag_combo(0,1,0) )
257 continue;
258
259 if((unsigned)flag_combo(list[i]->used_flag,list[i]->set_flag,
260 list[i]->used_before_set) == pattern) {
261
262 /* Brief report style gives module name
263 followed by simple list of offenders.
264 */
265 if( brief ) {
266 if(matches++ == 0) {
267 local_warn_head(mod_name,
268 top_filename,
269 NO_LINE_NUM,
270 (Lsymtab *)NULL, FALSE,
271 msg);
272 (void)fprintf(list_fd,"\n");
273 }
274 len = strlen(list[i]->name);
275 col += len = (len <= 10? 10: len) + 9;
276 if(col > 78) {
277 (void)fprintf(list_fd,"\n");
278 col = len;
279 }
280 (void)fprintf(list_fd,"%10s",list[i]->name);
281 /* arg never used: tag with asterisk */
282 (void)fprintf(list_fd,"%-9s",
283 list[i]->argument? (++unused_args,"*") : "" );
284 }/* brief */
285 /* Verbose report style gives file name
286 and line number of each offender.
287 */
288 else {
289 LINENO_t lineno;
290 int inc_index;
291 char *filename;
292 char *tag;
293 char detail[MAXIDSIZE+MAX_TAG_LEN+6]; /* see sprintf below */
294 if( ubs ) {
295 choose_tag(TAG_USED,list[i],&tag,&lineno);
296 inc_index = list[i]->file_used;
297 }
298 else if( set ) {
299 choose_tag(TAG_SET,list[i],&tag,&lineno);
300 inc_index = list[i]->file_set;
301 }
302 else {
303 choose_tag(TAG_DEFN,list[i],&tag,&lineno);
304 inc_index = list[i]->file_declared;
305 }
306
307 if(inc_index >= 0) {
308 filename = incfile_list[inc_index].fname;
309 }
310 else {
311 filename = top_filename;
312 }
313
314 if(matches++ == 0) {
315 local_warn_head(mod_name,
316 filename,
317 lineno,
318 (Lsymtab *)NULL,
319 FALSE,
320 msg);
321 }
322 /* Make detail e.g. "FOO used" */
323 sprintf(detail," %s %s",list[i]->name,tag);
324 local_detail(inc_index,lineno,(char *)NULL,detail);
325
326 /* For used-before-set, say also not set
327 or say where set.
328 */
329 if( ubs ) {
330 if( list[i]->set_flag ) {
331 choose_tag(TAG_SET,list[i],&tag,&lineno);
332 inc_index = list[i]->file_set;
333 sprintf(detail," %s %s",list[i]->name,tag);
334 local_detail(inc_index,lineno,(char *)NULL,detail);
335 }
336 else {
337 msg_tail("; never set");
338 }
339 }
340 if(list[i]->argument) {
341 ++unused_args;
342 msg_tail("(dummy argument)");
343 }
344 }
345
346 matches++;
347 }
348 }
349
350 if(brief && unused_args > 0)
351 (void)fprintf(list_fd,"\n * Dummy argument");
352
353 }
354
355 PRIVATE int
356 #if HAVE_STDC
has_nonalnum(char * s)357 has_nonalnum(char *s) /* Returns TRUE if s contains a $ or _ character
358 and -f77 or -f90 is given. */
359 #else /* K&R style */
360 has_nonalnum(s)
361 char *s;
362 #endif /* HAVE_STDC */
363 {
364 while( *s != '\0' ) {
365 if( !isalnum(*s) ) {
366 if( (*s) == '_' ) {
367 if(f77_underscores)
368 return TRUE;
369 }
370 else { /* treat all non _ same as $ */
371 if(f77_dollarsigns||f90_dollarsigns)
372 return TRUE;
373 }
374 }
375 s++;
376 }
377 return FALSE;
378 }
379
380 void
381 #if HAVE_STDC
check_nonpure(Lsymtab * sym_list[],int n,char * mod_name)382 check_nonpure(Lsymtab* sym_list[], int n, char *mod_name)
383 #else /* K&R style */
384 check_nonpure(sym_list, n, mod_name)
385 Lsymtab* sym_list[];
386 int n;
387 char *mod_name;
388 #endif
389 {
390 int i,
391 com_vars_modified=0, /* count of common variables which are set */
392 args_modified=0; /* count of arguments which are set */
393 for(i=0; i<n; i++) {
394 if( (sym_list[i]->argument || sym_list[i]->common_var)
395 && sym_list[i]->set_flag) {
396 if( (sym_list[i]->argument && !CASCADE_LIMIT(args_modified))
397 || (sym_list[i]->common_var && !CASCADE_LIMIT(com_vars_modified)) )
398 {
399 char *filename = choose_filename(sym_list[i],file_set);
400
401 local_warn_head(mod_name,
402 filename,
403 sym_list[i]->line_set,
404 (Lsymtab *)NULL,
405 TRUE,
406 "Function");
407 if(sym_list[i]->assigned_flag)
408 msg_tail("modifies");
409 else
410 msg_tail("may modify");
411 if(sym_list[i]->argument)
412 msg_tail("argument");
413 else
414 msg_tail("common variable");
415 msg_tail(sym_list[i]->name);
416 }
417 else {
418 break;
419 }
420 }
421 }
422 /* If quit early due to cascade limit, print "etc" */
423
424 if(error_cascade_limit > 0 &&
425 (args_modified > error_cascade_limit
426 || com_vars_modified > error_cascade_limit)) {
427 (void)fprintf(list_fd,"\netc...");
428 }
429 }
430
431 /* This routine catches syntax errors that have to
432 wait till END is seen. At the moment, only looks if
433 CHARACTER*(*) declarations are put on the wrong thing.
434 Has to wait since can use it for ENTRY pt.
435 Also checks if things SAVED that shouldn't be.
436 Also fixes size_is_expression flags if IMPLICIT makes
437 the variable so.
438 */
439 void
440 #if HAVE_STDC
check_loose_ends(int curmodhash)441 check_loose_ends(int curmodhash)
442 #else /* K&R style */
443 check_loose_ends(curmodhash)
444 int curmodhash; /* current_module_hash from fortran.y */
445 #endif /* HAVE_STDC */
446 {
447 int i;
448 for(i=0;i<loc_symtab_top;i++) {
449
450 /* Catch illegal CHARACTER*(*) */
451 if( datatype_of(loc_symtab[i].type) == type_STRING &&
452 loc_symtab[i].size == size_ADJUSTABLE &&
453 !(loc_symtab[i].argument ||
454 loc_symtab[i].parameter ||
455 loc_symtab[i].entry_point) ) {
456 local_err_head(hashtab[curmodhash].name,
457 choose_filename(&loc_symtab[i],file_declared),
458 loc_symtab[i].line_declared,
459 &loc_symtab[i], TRUE,
460 loc_symtab[i].name);
461 msg_tail("cannot be adjustable size");
462 }
463
464 /* Catch unSAVEable SAVE */
465 if(loc_symtab[i].saved &&
466 (loc_symtab[i].common_var ||
467 loc_symtab[i].argument ||
468 loc_symtab[i].external ||
469 loc_symtab[i].parameter ||
470 loc_symtab[i].entry_point) ) {
471 local_err_head(hashtab[curmodhash].name,
472 choose_filename(&loc_symtab[i],file_declared),
473 loc_symtab[i].line_declared,
474 &loc_symtab[i], TRUE,
475 loc_symtab[i].name);
476 msg_tail("cannot be declared in SAVE statement");
477 }
478
479 /* Common block misspelled in SAVE stmt will
480 show up as a SAVEd block with no elements */
481 if(loc_symtab[i].saved &&
482 datatype_of(loc_symtab[i].type) == type_COMMON_BLOCK &&
483 loc_symtab[i].info.comlist == NULL) {
484 if(misc_warn) {
485 local_err_head(hashtab[curmodhash].name,
486 choose_filename(&loc_symtab[i],file_declared),
487 loc_symtab[i].line_declared,
488 &loc_symtab[i], TRUE,
489 loc_symtab[i].name);
490 msg_tail("declared in SAVE statement but no such common block");
491 }
492 }
493
494 /* If IMPLICIT CHARACTER*(expr) is used, then
495 need to fix flag to reflect it. */
496 if(datatype_of(loc_symtab[i].type) == type_UNDECL &&
497 get_size_text(&loc_symtab[i],type_UNDECL) != NULL) {
498 loc_symtab[i].size_is_expression = TRUE;
499 }
500 }
501 }
502