1 /* $Id: makedcls.c,v 1.15 2003/03/17 23:15:49 moniot Exp $
2
3 Routines for declaration file output
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 /* Originally written by Nelson H.F. Beebe before source text was
39 saved in the symbol table. Rewritten by R. Moniot to make use
40 of said text. */
41
42
43 /*
44 Shared functions defined:
45 make_declarations produces the declarations file
46
47 */
48
49 #include <stdio.h>
50 #include <ctype.h>
51 #include <string.h>
52 #include "ftnchek.h"
53 #include "symtab.h"
54 #include "plsymtab.h"
55
56 extern int free_form; /* for choosing 'C' or '!' as comment char */
57
58 /* Declarations of local functions */
59
60 PROTO(PRIVATE char * base_filename,( char *curr_filename ));
61
62 PROTO(PRIVATE void append_char_to_fragment,( int c ));
63 PROTO(PRIVATE void append_string_to_fragment,( char *s ));
64 PROTO(PRIVATE void append_expr_text_to_fragment,( char *s ));
65
66 PROTO(PRIVATE void maybe_print_module_header,( void ));
67 PROTO(PRIVATE void new_fragment,( void ));
68 PROTO(PRIVATE void print_blanks,( int nblanks ));
69 PROTO(PRIVATE void print_common_decls,( Lsymtab *sym_entry ));
70 PROTO(PRIVATE void print_empty_comment_line,( void ));
71 PROTO(PRIVATE void print_equivalence_decls,( Lsymtab *sym_entry ));
72 PROTO(PRIVATE int count_undeclared_variables,( Lsymtab *sym_entry ));
73 PROTO(PRIVATE void print_list_decls,( Lsymtab *sym_list[], int n, char
74 *header, char *list_type_name ));
75 PROTO(PRIVATE int print_list_name,( char *list_type_name, char *name ));
76 PROTO(PRIVATE void print_declaration_class,( Lsymtab *sym_list[], int n,
77 const char *header ));
78 PROTO(PRIVATE void print_one_list_decls,( Lsymtab *sym_entry, char
79 *list_type_name, char **pheader, int
80 *pnd ));
81 PROTO(PRIVATE void print_parameter_statement,( Lsymtab *symt ));
82 PROTO(PRIVATE void print_selected_declarations,( Lsymtab *sym_list[], int n,
83 int the_type, const char
84 *the_type_name, const char * (*pheader) ));
85 PROTO(PRIVATE int print_typename,( int the_type, const char *the_type_name, int
86 the_size, Lsymtab *symt ));
87 PROTO(PRIVATE int make_sym_list,( Lsymtab *sym_list[], int (*selector)(Lsymtab
88 *sym_entry) ));
89 PROTO(PRIVATE int select_arguments,( Lsymtab *sym_entry ));
90 PROTO(PRIVATE void strip_blanks,(char *s));
91 #if 0 /* not currently used */
92 PROTO(PRIVATE int select_commons,( Lsymtab *sym_entry ));
93 #endif
94 PROTO(PRIVATE int select_externals_by_name,( Lsymtab *sym_entry ));
95 PROTO(PRIVATE int select_externals_by_type,( Lsymtab *sym_entry ));
96 PROTO(PRIVATE int select_intrinsics_by_name,( Lsymtab *sym_entry ));
97 PROTO(PRIVATE int select_intrinsics_by_type,( Lsymtab *sym_entry ));
98 PROTO(PRIVATE int select_locals,( Lsymtab *sym_entry ));
99 PROTO(PRIVATE int select_common_blocks,( Lsymtab *sym_entry ));
100 PROTO(PRIVATE int select_namelists,( Lsymtab *sym_entry ));
101 PROTO(PRIVATE int select_parameters,( Lsymtab *sym_entry ));
102 PROTO(PRIVATE int select_statement_functions,( Lsymtab *sym_entry ));
103 PROTO(PRIVATE int sf3_internal_name,( Lsymtab *sym_entry ));
104
105 PROTO(PRIVATE char * get_dimension_list,( Lsymtab *symt ));
106 PROTO(PRIVATE char * get_parameter_value,( Lsymtab *symt ));
107 PROTO(PRIVATE char * get_size_expression,( Lsymtab *symt ));
108
109
110 #if 0 /* This is how Beebe wrote it */
111 #define ACTUAL_SIZE(p) (((p)->size == 0) ? \
112 std_size[the_type] : (p)->size)
113 #else
114 /* This is what it has to be if IMPLICIT types supported */
115 #define ACTUAL_SIZE(p) (get_size((p),sym_type))
116 #endif
117
118
119 #define DECLARE_ONLY_UNDECLARED() (dcl_only_undeclared)
120 #define DECLARE_COMPACT() (dcl_compact)
121 #define NO_CONTINUATION_LINES() (!(dcl_use_continuations))
122 #define EXCL_SF3_DECLARATIONS() (dcl_excl_sftran3_internal_vars)
123 #define ASTERISK_COMMENT_CHAR() (dcl_asterisk_comment_character)
124 #define FREE_FORM() (dcl_free_form||free_form)
125 #define KEYWORDS_LOWERCASE() (dcl_keywords_lowercase)
126 #define LOWERCASE_COMMENT_CHARACTER() (dcl_lowercase_comment_character)
127 #define VARIABLES_AND_CONSTANTS_LOWERCASE() (dcl_vars_and_consts_lowercase)
128 #define ARRAY_VARS_DIMENSIONED() (!(dcl_no_array_dimensions))
129
130 #define COLUMN_WIDTH 13
131
132 #ifndef PFORT_FIRST_VARIABLE_COLUMN
133 #define PFORT_FIRST_VARIABLE_COLUMN 26 /* to match Extended PFORT Verifier */
134 #endif
135
136 PRIVATE int first_variable_column;
137
138 #define NEXT_COLUMN(column) (first_variable_column + \
139 (((column) - first_variable_column + \
140 COLUMN_WIDTH - 1) / COLUMN_WIDTH)*COLUMN_WIDTH)
141
142 #define isaletter(C) isalpha((int)(C))
143
144 /* define isidletter to allow underscore and/or dollar sign */
145 #define isidletter(C) (isalpha((int)(C)) || (C) == '_' || (C) == '$')
146
147
148 #define makelower(C) (isupper((int)(C)) ? tolower((int)(C)) : (int)(C))
149 #define makeupper(C) (islower((int)(C)) ? toupper((int)(C)) : (int)(C))
150
151 PRIVATE char *begin_module;
152
153 #define MAX_STMT (72 + 19*72 + 1) /* longest Fortran stmt */
154
155 PRIVATE char stmt_fragment[MAX_STMT];
156
157 PRIVATE char comment_char = 'C'; /* default value */
158
159 PRIVATE int std_size[] = /* NB: depends on type_XXX order in symtab.h */
160 {
161 0, /* unknown */
162 4, /* INTEGER*4 */
163 4, /* REAL*4 */
164 8, /* DOUBLE PRECISION == REAL*8 */
165 8, /* COMPLEX*8 */
166 16, /* DOUBLE COMPLEX == COMPLEX*16 */
167 4, /* LOGICAL*4 */
168 1 /* CHARACTER*1 == CHARACTER */
169 };
170
171 PRIVATE int
172 pos_fragment = 0; /* cursor in stmt_fragment buffer */
173
174 PRIVATE int
175 dcl_indent; /* amount to indent declarations */
176
177
178 PRIVATE char *
179 #if HAVE_STDC
base_filename(char * curr_filename)180 base_filename(char *curr_filename)
181 #else /* K&R style */
182 base_filename(curr_filename)
183 char *curr_filename;
184 #endif /* HAVE_STDC */
185
186 {
187 char *path_end=(char *)NULL;
188
189 #ifdef UNIX
190 path_end = strrchr(curr_filename,'/');
191 #endif
192
193 #ifdef VMS
194 path_end = strrchr(curr_filename,']');
195 if( path_end == (char *)NULL )
196 path_end = strrchr(curr_filename,':'); /* for symbolic names */
197 #endif
198
199 #ifdef MSDOS /* look for either \ or / at end. */
200 path_end = strrchr(curr_filename,'\\');
201 if( path_end == (char *)NULL )
202 path_end = strrchr(curr_filename,'/');
203 #endif
204
205 if( path_end == (char *)NULL )
206 path_end = curr_filename;
207 else
208 ++path_end;
209
210 return (path_end);
211 }
212
213
214 PRIVATE void
215 #if HAVE_STDC
append_char_to_fragment(int c)216 append_char_to_fragment(int c)
217 #else /* K&R style */
218 append_char_to_fragment(c)
219 int c;
220 #endif /* HAVE_STDC */
221 {
222 if (pos_fragment < (MAX_STMT - 1))
223 stmt_fragment[pos_fragment++] = c;
224 }
225
226
227 PRIVATE void
228 #if HAVE_STDC
append_string_to_fragment(char * s)229 append_string_to_fragment(char *s)
230 #else /* K&R style */
231 append_string_to_fragment(s)
232 char *s;
233 #endif /* HAVE_STDC */
234 {
235 while (*s)
236 append_char_to_fragment(*s++);
237 }
238
239 /* Appends source text of an expression, up- or
240 down-casing the letters according to pref. */
241 PRIVATE void
242 #if HAVE_STDC
append_expr_text_to_fragment(char * s)243 append_expr_text_to_fragment(char *s)
244 #else /* K&R style */
245 append_expr_text_to_fragment(s)
246 char *s;
247 #endif /* HAVE_STDC */
248 {
249 int quote_char, inside_quote;
250 inside_quote = FALSE;
251 for (; *s; ++s) {
252 if(! inside_quote) {
253 if(*s == '\'' || *s == '"') { /* Start of a quote */
254 inside_quote = TRUE;
255 quote_char = *s;
256 }
257 append_char_to_fragment(VARIABLES_AND_CONSTANTS_LOWERCASE()
258 ? makelower(*s) : makeupper(*s));
259 }
260 else { /* inside quote */
261 if(*s == quote_char) { /* End of quote (quoted quote_char is handled
262 as if consecutive strings) */
263 inside_quote=FALSE;
264 }
265 append_char_to_fragment(*s);
266 }
267 }
268 }
269
270
271 PRIVATE char *
272 #if HAVE_STDC
get_dimension_list(Lsymtab * symt)273 get_dimension_list(Lsymtab *symt)
274 #else /* K&R style */
275 get_dimension_list(symt)
276 Lsymtab *symt;
277 #endif /* HAVE_STDC */
278 {
279 int n, dims;
280
281 /* Get list of array dimensions from symbol table */
282
283 new_fragment();
284
285 append_char_to_fragment('(');
286
287 dims = array_dims(symt->info.array_dim);
288 for (n = 0; n < dims; ++n)
289 {
290 if (n > 0)
291 append_char_to_fragment(',');
292 append_expr_text_to_fragment(symt->src.textvec[n]);
293 }
294
295 append_char_to_fragment(')');
296 append_char_to_fragment('\0');
297
298 return (&stmt_fragment[0]);
299 }
300
301
302
303
304 PRIVATE char *
305 #if HAVE_STDC
get_parameter_value(Lsymtab * symt)306 get_parameter_value(Lsymtab *symt)
307 #else /* K&R style */
308 get_parameter_value(symt)
309 Lsymtab *symt;
310 #endif /* HAVE_STDC */
311 {
312 /* Construct parameter list "(NAME = value)" */
313
314 new_fragment();
315 append_char_to_fragment('(');
316
317 append_expr_text_to_fragment(symt->name);
318
319 append_string_to_fragment(" = ");
320
321 append_expr_text_to_fragment(symt->info.param->src_text);
322
323 append_char_to_fragment(')');
324 append_char_to_fragment('\0');
325 return (&stmt_fragment[0]);
326 }
327
328
329
330 PRIVATE char *
331 #if HAVE_STDC
get_size_expression(Lsymtab * symt)332 get_size_expression(Lsymtab *symt)
333 #else /* K&R style */
334 get_size_expression(symt)
335 Lsymtab *symt;
336 #endif /* HAVE_STDC */
337 {
338 /* Get a CHARACTER size expression from the symbol table */
339
340 new_fragment();
341
342 append_char_to_fragment('*');
343
344 append_expr_text_to_fragment(get_size_text(symt,0));
345
346 append_char_to_fragment('\0');
347
348 return (&stmt_fragment[0]);
349 }
350
351 void
352 #if HAVE_STDC
make_declarations(Lsymtab ** sym_list,char * mod_name)353 make_declarations(Lsymtab **sym_list, char *mod_name)
354 #else /* K&R style */
355 make_declarations(sym_list,mod_name)
356 Lsymtab *sym_list[];
357 char *mod_name;
358 #endif /* HAVE_STDC */
359 {
360 const char *header;
361 char begin[72+1+72+1+2+1];
362 char *base_curr_filename; /* basename of current input file */
363 int len_base_curr_filename;
364
365 if ( ! ANY_DCL_DECLARATIONS() )
366 return;
367
368 base_curr_filename = base_filename(current_filename);
369 len_base_curr_filename = strlen(base_curr_filename);
370
371 /* Establish indentation and comment character
372 for free form or fixed form.
373 */
374 dcl_indent = 6;
375 first_variable_column = PFORT_FIRST_VARIABLE_COLUMN;
376 if (FREE_FORM()) {
377 dcl_indent = DCL_FREEFORM_INDENT;
378 first_variable_column = PFORT_FIRST_VARIABLE_COLUMN-(6-dcl_indent);
379 comment_char = '!';
380 }
381 else if (LOWERCASE_COMMENT_CHARACTER())
382 comment_char = 'c';
383 else if (ASTERISK_COMMENT_CHAR())
384 comment_char = '*';
385 else
386 comment_char = 'C';
387
388 /* In the event there are no declarations to be output, we want
389 the declaration file to be empty, because that reduces the
390 number of files that the user has to deal with. In fact, if it
391 IS empty, it will be deleted on close. Instead of printing the
392 module header comment here, we point a global pointer at it,
393 and then in the print_xxx() functions, print the header before
394 the first declaration that is output.
395
396 We also need to take care not be overwrite the begin[] array,
397 which could happen if the module name or file name are
398 exceptionally long. We therefore take at most 20 characters
399 from the start of the module name, and at most 25 (so the
400 total length of 72 is not surpassed) from the END of the base
401 of the filename, discarding the directory path prefix. */
402
403
404 (void)sprintf(begin,
405 "%c====>Begin Module %-20.20s File %-25.25s\n%c---->Makedcls Options: %-48s\n%c\n",
406 comment_char,
407 mod_name,
408 (len_base_curr_filename > 25) ?
409 (base_curr_filename + len_base_curr_filename - 25) :
410 base_curr_filename,
411 comment_char,
412 EXCL_SF3_DECLARATIONS()?
413 (DECLARE_ONLY_UNDECLARED() ?
414 "Undeclared variables except SFTRAN3 internals" :
415 "All variables except SFTRAN3 internals") :
416 (DECLARE_ONLY_UNDECLARED() ?
417 "Undeclared variables" :
418 "All variables"),
419 comment_char);
420 begin_module = &begin[0];
421
422 print_selected_declarations(sym_list,
423 make_sym_list(sym_list,
424 select_intrinsics_by_name),
425 type_ERROR, "INTRINSIC",
426 (header = "Intrinsic functions", &header));
427 print_declaration_class(sym_list,
428 make_sym_list(sym_list,select_intrinsics_by_type),
429 "Built-in functions");
430
431 print_selected_declarations(sym_list,
432 make_sym_list(sym_list,
433 select_externals_by_name),
434 type_ERROR, "EXTERNAL",
435 (header = "External functions", &header));
436 print_declaration_class(sym_list,
437 make_sym_list(sym_list,select_externals_by_type),
438 (char*)NULL);
439
440 print_declaration_class(sym_list,
441 make_sym_list(sym_list,select_statement_functions),
442 "Statement functions");
443
444 print_declaration_class(sym_list,
445 make_sym_list(sym_list,select_parameters),
446 "Parameter variables");
447
448 print_declaration_class(sym_list,
449 make_sym_list(sym_list,select_arguments),
450 "Argument variables");
451
452 print_declaration_class(sym_list,
453 make_sym_list(sym_list,select_locals),
454 "Local variables");
455
456 print_list_decls(sym_list,
457 make_sym_list(sym_list,select_namelists),
458 "Namelists","NAMELIST");
459
460 /* Common block declarations must be last,
461 for dcl2inc to work correctly.
462 */
463 print_list_decls(sym_list,
464 make_sym_list(sym_list,select_common_blocks),
465 "Common blocks","COMMON");
466
467 if (begin_module == (char*)NULL) /* then need a trailer comment */
468 (void)fprintf(dcl_fd,
469 "%c====>End Module %-20.20s File %-25.25s\n",
470 comment_char,
471 mod_name,
472 (len_base_curr_filename > 25) ?
473 (base_curr_filename + len_base_curr_filename - 25) :
474 base_curr_filename);
475
476 }
477
478
479
480 PRIVATE void
maybe_print_module_header(VOID)481 maybe_print_module_header(VOID)
482 {
483 if (begin_module != (char*)NULL)
484 { /* print module header comment only once */
485 (void)fputs(begin_module, dcl_fd);
486 begin_module = (char*)NULL;
487 }
488 }
489
490
491
492 PRIVATE void
new_fragment(VOID)493 new_fragment(VOID)
494 {
495 pos_fragment = 0;
496 }
497
498
499
500 PRIVATE void
501 #if HAVE_STDC
print_blanks(int nblanks)502 print_blanks(int nblanks)
503 #else /* K&R style */
504 print_blanks(nblanks)
505 int nblanks;
506 #endif /* HAVE_STDC */
507 {
508 for ( ; nblanks > 0; --nblanks)
509 (void)putc(' ',dcl_fd);
510 }
511
512 /* Routine to print namelist and
513 common declarations. */
514
515 PRIVATE void
516 #if HAVE_STDC
print_common_decls(Lsymtab * sym_entry)517 print_common_decls(Lsymtab *sym_entry)
518 /* COMMON block symbol table entry */
519 #else /* K&R style */
520 print_common_decls(sym_entry)
521 Lsymtab *sym_entry; /* COMMON block symbol table entry */
522 #endif /* HAVE_STDC */
523 {
524 int h;
525 int n;
526 Token *t;
527
528 #ifdef DYNAMIC_TABLES /* tables will be mallocked at runtime */
529 static Lsymtab **sym_list=(Lsymtab **)NULL;
530
531 if(sym_list == (Lsymtab **)NULL) { /* Initialize if not done before */
532 if( (sym_list=(Lsymtab **)calloc(LOCSYMTABSZ,sizeof(Lsymtab *)))
533 == (Lsymtab **)NULL) {
534 oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
535 "Cannot malloc space for local symbol list");
536 }
537 }
538 #else
539 Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
540 #endif
541
542 for (n = 0, t = sym_entry->src.toklist->tokenlist;
543 t != NULL;
544 t = t->next_token)
545 {
546 h = t->value.integer;
547 sym_list[n++] = hashtab[h].loc_symtab;
548 }
549
550 if (n > 0)
551 {
552 sort_lsymbols(sym_list,n);
553 print_declaration_class(sym_list, n, "Common variables");
554 }
555 }
556
557
558 PRIVATE void
print_empty_comment_line(VOID)559 print_empty_comment_line(VOID)
560 {
561 (void)putc(comment_char,dcl_fd);
562 (void)putc('\n',dcl_fd);
563 }
564
565
566 PRIVATE void
567 #if HAVE_STDC
print_equivalence_decls(Lsymtab * sym_entry)568 print_equivalence_decls(Lsymtab *sym_entry)
569 /* COMMON block symbol table entry */
570 #else /* K&R style */
571 print_equivalence_decls(sym_entry)
572 Lsymtab *sym_entry; /* COMMON block symbol table entry */
573 #endif /* HAVE_STDC */
574 {
575 int h;
576 int n;
577 Lsymtab *s;
578 Token *t;
579
580 #ifdef DYNAMIC_TABLES /* tables will be mallocked at runtime */
581 static Lsymtab **sym_list=(Lsymtab **)NULL;
582
583 if(sym_list == (Lsymtab **)NULL) { /* Initialize if not done before */
584 if( (sym_list=(Lsymtab **)calloc(LOCSYMTABSZ,sizeof(Lsymtab *)))
585 == (Lsymtab **)NULL) {
586 oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
587 "Cannot malloc space for local symbol list");
588 }
589 }
590 #else
591 Lsymtab *sym_list[LOCSYMTABSZ]; /* temp. list of symtab entries to print */
592 #endif
593
594 for (n = 0, t = sym_entry->src.toklist->tokenlist;
595 t != NULL;
596 t = t->next_token)
597 {
598 h = t->value.integer;
599 for (s = hashtab[h].loc_symtab, s = s->equiv_link;
600 (s != NULL) && (s != hashtab[h].loc_symtab);
601 s = s->equiv_link)
602 sym_list[n++] = s;
603 }
604
605 if (n > 0)
606 {
607 sort_lsymbols(sym_list,n);
608 print_declaration_class(sym_list, n,
609 "Equivalenced common variables");
610 }
611 }
612
613
614 PRIVATE int
615 #if HAVE_STDC
count_undeclared_variables(Lsymtab * sym_entry)616 count_undeclared_variables(Lsymtab *sym_entry)
617 #else /* K&R style */
618 count_undeclared_variables(sym_entry)
619 Lsymtab *sym_entry;
620 #endif /* HAVE_STDC */
621 {
622 int count, h;
623 Token *t;
624 Lsymtab *symt;
625
626 for (count = 0, t = sym_entry->src.toklist->tokenlist;
627 t != NULL;
628 t = t->next_token)
629 { /* Loop over members */
630 h = t->value.integer;
631 symt = hashtab[h].loc_symtab;
632 if (datatype_of(symt->type) == type_UNDECL)
633 count++;
634 }
635 return (count);
636 }
637
638
639 PRIVATE void
640 #if HAVE_STDC
print_list_decls(Lsymtab ** sym_list,int n,char * header,char * list_type_name)641 print_list_decls(Lsymtab **sym_list, int n, char *header, char *list_type_name)
642 #else /* K&R style */
643 print_list_decls(sym_list, n, header, list_type_name)
644 Lsymtab *sym_list[];
645 int n;
646 char *header;
647 char *list_type_name;
648 #endif /* HAVE_STDC */
649 {
650 int i, nd;
651
652 if (DECLARE_ONLY_UNDECLARED() &&
653 (strcmp(list_type_name,"NAMELIST") == 0)) /* These lists are always declared */
654 return;
655
656 nd = 0;
657 for (i=0; i<n; i++)
658 { /* Loop over COMMON or NAMELIST lists */
659 if (sym_list[i]->src.toklist != NULL)
660 {
661 if (strcmp(list_type_name,"COMMON") == 0)
662 { /* then COMMON list */
663 if (!DECLARE_ONLY_UNDECLARED() ||
664 (DECLARE_ONLY_UNDECLARED() &&
665 (count_undeclared_variables(sym_list[i]) > 0)))
666 {
667 print_common_decls(sym_list[i]);
668 if (!DECLARE_ONLY_UNDECLARED())
669 print_one_list_decls(sym_list[i], list_type_name,
670 &header, &nd);
671 print_equivalence_decls(sym_list[i]);
672 }
673 }
674 else /* must be NAMELIST list */
675 print_one_list_decls(sym_list[i], list_type_name, &header, &nd);
676 }
677 }
678
679 if ((nd > 0) && (strcmp(list_type_name,"COMMON") != 0))
680 print_empty_comment_line();
681 }
682 /* routine to print COMMON or NAMELIST
683 name between slashes. */
684 PRIVATE int
685 #if HAVE_STDC
print_list_name(char * list_type_name,char * name)686 print_list_name(char *list_type_name, char *name)
687 #else /* K&R style */
688 print_list_name(list_type_name,name)
689 char *list_type_name;
690 char *name;
691 #endif /* HAVE_STDC */
692 {
693 int column, len;
694 char *p;
695
696 maybe_print_module_header();
697
698 /* Compact mode: COMMON /blknam/
699 Padded mode: COMMON / blknam /
700 */
701 print_blanks(dcl_indent);
702 column = dcl_indent;
703
704 for (p = list_type_name; *p; ++p, ++column)
705 (void)putc(KEYWORDS_LOWERCASE() ? makelower(*p) : makeupper(*p),
706 dcl_fd);
707
708 print_blanks(1);
709 column++;
710
711 (void)putc('/',dcl_fd);
712 column++;
713
714 if (!DECLARE_COMPACT())
715 {
716 print_blanks(1);
717 column++;
718 }
719 len = 0;
720 if (strcmp(name,blank_com_name) != 0) {
721 for (p=name; *p; ++p, ++len)
722 (void)putc(VARIABLES_AND_CONSTANTS_LOWERCASE() ?
723 makelower(*p) : makeupper(*p),dcl_fd);
724 }
725 column += len;
726 if (!DECLARE_COMPACT())
727 {
728 if (len <= 6) /* Max standard length */
729 {
730 print_blanks(7-len); /* Print padding */
731 column += 7-len;
732 }
733 }
734
735 (void)putc('/',dcl_fd);
736 column++;
737
738 if (DECLARE_COMPACT())
739 {
740 print_blanks(1);
741 column++;
742 }
743 else if (column < first_variable_column)
744 {
745 print_blanks(first_variable_column-column);
746 column = first_variable_column;
747 }
748 else if (column == first_variable_column)
749 {
750 print_blanks(1);
751 column++;
752 print_blanks(NEXT_COLUMN(column)-column);
753 column = NEXT_COLUMN(column);
754 }
755 else
756 {
757 print_blanks(NEXT_COLUMN(column)-column);
758 column = NEXT_COLUMN(column);
759 }
760 return column;
761 }
762
763
764 PRIVATE void
765 #if HAVE_STDC
print_declaration_class(Lsymtab ** sym_list,int n,const char * header)766 print_declaration_class(Lsymtab **sym_list, int n, const char *header)
767 #else /* K&R style */
768 print_declaration_class(sym_list, n, header)
769 Lsymtab *sym_list[];
770 int n;
771 char *header;
772 #endif /* HAVE_STDC */
773 {
774 unsigned t;
775 static int types_table[] = /* table defining output declaration order */
776 { /* (alphabetical by type name) */
777 type_STRING,
778 type_COMPLEX,
779 type_DCOMPLEX,
780 type_DP,
781 type_INTEGER,
782 type_LOGICAL,
783 type_REAL,
784 };
785
786 if (n > 0)
787 {
788 for (t = 0; t < sizeof(types_table)/sizeof(types_table[0]); ++t)
789 print_selected_declarations(sym_list, n, types_table[t],
790 (char*)NULL, &header);
791 }
792 }
793
794
795 PRIVATE void
796 #if HAVE_STDC
print_one_list_decls(Lsymtab * sym_entry,char * list_type_name,char ** pheader,int * pnd)797 print_one_list_decls(Lsymtab *sym_entry, char *list_type_name, char **pheader, int *pnd)
798 #else /* K&R style */
799 print_one_list_decls(sym_entry, list_type_name, pheader, pnd)
800 Lsymtab *sym_entry;
801 char *list_type_name;
802 char **pheader;
803 int *pnd;
804 #endif /* HAVE_STDC */
805 {
806 int column, need, next_column, nv;
807 int ncontin;
808 int h;
809 Token *t;
810 Lsymtab *symt;
811 char *p;
812
813 column = 0;
814 ncontin = 0; /* count of continuation lines */
815 nv = 0; /* count of variables in statement */
816 for(t = sym_entry->src.toklist->tokenlist;
817 t != NULL;
818 t = t->next_token)
819 { /* Loop over members */
820 h = t->value.integer;
821 symt = hashtab[h].loc_symtab;
822 if (column == 0) /* at beginning of line, so */
823 { /* we need a type name */
824 maybe_print_module_header();
825 if ((*pheader != (char*)NULL) &&
826 (strcmp(list_type_name,"COMMON") != 0))
827 { /* print header only once */
828 (void)fprintf(dcl_fd,"%c %s\n", comment_char,*pheader);
829 print_empty_comment_line();
830 *pheader = (char*)NULL; /* so we don't print it again */
831 }
832 column = print_list_name(list_type_name,sym_entry->name);
833 nv = 0; /* no variables yet in statement */
834 ncontin = 0;
835 ++(*pnd); /* count declarations produced */
836 }
837 if (DECLARE_COMPACT())
838 next_column = (nv==0?column:column + 2);
839 else
840 next_column = NEXT_COLUMN(nv==0?column:column + 2);
841 need = (int)strlen(symt->name);
842 if ((next_column + need) > 72) /* then must start new line */
843 {
844 if (nv>0 && (strcmp(list_type_name,"COMMON") == 0) &&
845 (NO_CONTINUATION_LINES() || ncontin == (FREE_FORM()?39:19)))
846 {
847 (void)putc('\n',dcl_fd);
848 column = print_list_name(list_type_name,sym_entry->name);
849 nv = 0; /* no variables yet in statement */
850 ncontin = 0;
851 }
852 else
853 {
854 if( FREE_FORM() ) { /* do a free-form continuation */
855 print_blanks(next_column-column);
856 (void)fputs("&\n",dcl_fd);
857 print_blanks(dcl_indent);
858 column = dcl_indent;
859 }
860 else { /* do a fixed-form continuation */
861 (void)putc('\n',dcl_fd);
862 print_blanks(5);
863 (void)putc('x',dcl_fd);
864 column = 6;
865 }
866 if (DECLARE_COMPACT())
867 next_column = (nv==0?column:column + 2);
868 else
869 next_column = NEXT_COLUMN(nv==0?column:column + 2);
870 ++ncontin;
871 }
872 }
873 if (nv > 0) /* multiple variables */
874 {
875 (void)fputs(", ",dcl_fd);
876 print_blanks(next_column - column - 2);
877 column = next_column;
878 }
879 for (p = symt->name; *p; ++p)
880 (void)putc(VARIABLES_AND_CONSTANTS_LOWERCASE() ?
881 makelower(*p) : makeupper(*p),dcl_fd);
882
883 column += need;
884 nv++; /* count variables */
885 }
886 if ((nv > 0) && (strcmp(list_type_name,"COMMON") == 0))
887 {
888 if (column > 0)
889 (void)putc('\n',dcl_fd);
890 print_empty_comment_line();
891 column = 0;
892 }
893 if (column > 0)
894 (void)putc('\n',dcl_fd);
895 }
896
897
898 PRIVATE void
899 #if HAVE_STDC
print_parameter_statement(Lsymtab * symt)900 print_parameter_statement(Lsymtab *symt)
901 #else /* K&R style */
902 print_parameter_statement(symt)
903 Lsymtab *symt;
904 #endif /* HAVE_STDC */
905 {
906 int column;
907 int need;
908 int i;
909
910 column = print_typename(type_ERROR,"PARAMETER",0,symt);
911 need = strlen(get_parameter_value(symt));
912 if ((column + need) > 72) /* then too long to fit on current line */
913 {
914 if( FREE_FORM() ) {
915 (void)fputs(" &\n",dcl_fd);
916 print_blanks(dcl_indent);
917 column = dcl_indent;
918 }
919 else {
920 (void)fputs("\n x",dcl_fd);
921 column = 6;
922 }
923 if ((column + need) > 72)
924 { /* long parameter setting requires line break */
925 for (i = 0; stmt_fragment[i]; ++i)
926 {
927 if (column == 72)
928 {
929 if( FREE_FORM() ) {
930 (void)fputs("&\n",dcl_fd);
931 print_blanks(dcl_indent);
932 (void)putc('&',dcl_fd);
933 column = dcl_indent+1;
934 }
935 else {
936 (void)fputs("\n x",dcl_fd);
937 column = 6;
938 }
939 }
940 (void)putc((int)stmt_fragment[i],dcl_fd);
941 column++;
942 }
943 }
944 else
945 (void)fputs(stmt_fragment,dcl_fd);
946 }
947 else /* fits on current line */
948 (void)fputs(stmt_fragment,dcl_fd);
949 (void)putc('\n',dcl_fd);
950 }
951
952
953 PRIVATE void
954 #if HAVE_STDC
print_selected_declarations(Lsymtab ** sym_list,int n,int the_type,const char * the_type_name,const char * (* pheader))955 print_selected_declarations(Lsymtab **sym_list, int n, int the_type,
956 const char *the_type_name,
957 const char * (*pheader)) /* **pheader is const, *pheader is not */
958 #else /* K&R style */
959 print_selected_declarations(sym_list, n, the_type, the_type_name, pheader)
960 Lsymtab *sym_list[];
961 int n;
962 int the_type;
963 char *the_type_name;
964 char **pheader;
965 #endif /* HAVE_STDC */
966 {
967 int column, i, last_size, need, next_column, nt, nv, ncontin,
968 raw_type, sym_type, sym_size;
969 char *p;
970
971 column = 0;
972 last_size = 0;
973 nt = 0; /* count of type declaration stmts */
974 nv = 0; /* count of variables in statement */
975 for (i = 0; i < n; ++i)
976 { /* loop over variables */
977 raw_type = datatype_of(sym_list[i]->type);
978 if (DECLARE_ONLY_UNDECLARED())
979 {
980 if (raw_type != type_UNDECL)
981 continue; /* want declarations only for undeclared vars */
982 if (sym_list[i]->external) /* and not for explicit EXTERNAL */
983 continue;
984 if (sym_list[i]->intrinsic) /* and not for explicit INTRINSIC */
985 continue;
986 }
987 sym_type = (raw_type == type_UNDECL) ?
988 get_type(sym_list[i]) : datatype_of(sym_list[i]->type);
989
990 if ((the_type != type_ERROR) && (sym_type != the_type))
991 continue;
992
993 sym_size = ACTUAL_SIZE(sym_list[i]);
994 if ((nv > 0) && (sym_size != last_size))
995 { /* have new length modifier, so must start new declaration */
996 (void)putc('\n',dcl_fd);
997 nt++; /* count type declaration statements */
998 column = 0;
999 ncontin = 0;
1000 nv = 0;
1001 }
1002 if (column == 0) /* at beginning of line, so */
1003 { /* we need a type name */
1004 maybe_print_module_header();
1005 if (*pheader != (char*)NULL)
1006 { /* print header only once */
1007 (void)fprintf(dcl_fd,"%c %s\n",comment_char,*pheader);
1008 print_empty_comment_line();
1009 *pheader = (char*)NULL; /* so we don't print it again */
1010 }
1011 column = print_typename(the_type,the_type_name, sym_size,
1012 sym_list[i]);
1013 last_size = sym_size;
1014 nv = 0; /* no variables yet in statement */
1015 ncontin = 0;
1016 }
1017 if (DECLARE_COMPACT())
1018 next_column = (nv==0?column:column + 2);
1019 else
1020 next_column = NEXT_COLUMN(nv==0?column:column + 2);
1021 need = (int)strlen(sym_list[i]->name);
1022
1023 if (sym_list[i]->array_var /* leave space for "(...)" */
1024 && ARRAY_VARS_DIMENSIONED())
1025 need += strlen(get_dimension_list(sym_list[i]));
1026
1027 if ((next_column + need) > 72) /* then must start new declaration */
1028 {
1029 nt++; /* count type declaration statements */
1030 if (nv>0 && (NO_CONTINUATION_LINES() || ncontin == 19))
1031 {
1032 (void)putc('\n',dcl_fd);
1033 column = print_typename(the_type,the_type_name, sym_size,
1034 sym_list[i]);
1035 ncontin = 0;
1036 nv = 0; /* no variables yet in statement */
1037 }
1038 else
1039 {
1040 if( FREE_FORM() ) { /* do a free-form continuation */
1041 print_blanks(next_column-column);
1042 (void)fputs("&\n",dcl_fd);
1043 print_blanks(dcl_indent);
1044 column = dcl_indent;
1045 }
1046 else { /* do a fixed-form continuation */
1047 (void)putc('\n',dcl_fd);
1048 print_blanks(5);
1049 (void)putc('x',dcl_fd);
1050 column = 6;
1051 }
1052 if (DECLARE_COMPACT())
1053 next_column = (nv==0?column:column + 2);
1054 else
1055 next_column = NEXT_COLUMN(nv==0?column:column + 2);
1056 ++ncontin;
1057 }
1058 last_size = sym_size;
1059 }
1060 if (nv > 0) /* multiple variables */
1061 {
1062 (void)fputs(", ",dcl_fd);
1063 print_blanks(next_column - column - 2);
1064 column = next_column;
1065 }
1066 for (p = sym_list[i]->name; *p; ++p)
1067 (void)putc(VARIABLES_AND_CONSTANTS_LOWERCASE() ?
1068 makelower(*p) : makeupper(*p),dcl_fd);
1069 if (sym_list[i]->array_var
1070 && ARRAY_VARS_DIMENSIONED())
1071 (void)fputs(stmt_fragment,dcl_fd);
1072 column += need;
1073 nv++; /* count variables */
1074 if (sym_list[i]->parameter)
1075 {
1076 (void)putc('\n',dcl_fd);
1077 print_parameter_statement(sym_list[i]);
1078 column = 0;
1079 nt++;
1080 nv = 0;
1081 }
1082 }
1083 if (column > 0)
1084 {
1085 (void)putc('\n',dcl_fd);
1086 nt++; /* count type declaration statements */
1087 }
1088 if (nt > 0)
1089 print_empty_comment_line();
1090 }
1091
1092
1093 PRIVATE int
1094 #if HAVE_STDC
print_typename(int the_type,const char * the_type_name,int the_size,Lsymtab * symt)1095 print_typename(int the_type, const char *the_type_name, int the_size, Lsymtab *symt)
1096 /* type_ERROR if typename non-NULL */
1097 /* non-NULL overrides type_table[] use */
1098 #else /* K&R style */
1099 print_typename(the_type,the_type_name,the_size,symt)
1100 int the_type; /* type_ERROR if the_type_name non-NULL */
1101 char *the_type_name; /* non-NULL overrides type_table[] use */
1102 int the_size;
1103 Lsymtab *symt;
1104 #endif /* HAVE_STDC */
1105 { /* return value is last column printed */
1106 int column;
1107 char digits[sizeof("*18446744073709551616")]; /* big enough for 2^64 */
1108 const char *p;
1109 char *size_expression;
1110
1111 maybe_print_module_header();
1112 print_blanks(dcl_indent);
1113 column = dcl_indent;
1114
1115 for (p = (the_type_name == (char*)NULL) ? type_table[the_type] : the_type_name;
1116 *p; ++p, ++column)
1117 (void)putc(KEYWORDS_LOWERCASE() ? makelower(*p) : makeupper(*p),
1118 dcl_fd);
1119 if (symt != NULL) {
1120 if (((symt->size_is_adjustable && (the_type == type_STRING))) ||
1121 (the_size == size_ADJUSTABLE)) /* happens only for CHARACTER*(*) */
1122 {
1123 /* size_is_adjustable overrides the_size because def_parameter() */
1124 /* in symtab.c replaced size_ADJUSTABLE with actual size. */
1125 (void)fputs("*(*)",dcl_fd);
1126 column += 4;
1127 }
1128 else if (symt->size_is_expression && (the_type == type_STRING))
1129 {
1130 size_expression = get_size_expression(symt);
1131 (void)fputs(size_expression,dcl_fd);
1132 column += strlen(size_expression);
1133 }
1134 else if ((the_size > 0) &&
1135 (the_type != type_ERROR) &&
1136 (the_size != std_size[the_type]))
1137 { /* supply length modifier for non-standard type sizes */
1138 (void)sprintf(digits,"*%d",the_size);
1139 (void)fputs(digits,dcl_fd);
1140 column += strlen(digits);
1141 }
1142 }
1143 if (DECLARE_COMPACT())
1144 {
1145 print_blanks(1);
1146 column++;
1147 }
1148 else if (column < first_variable_column)
1149 {
1150 print_blanks(first_variable_column-column);
1151 column = first_variable_column;
1152 }
1153 else if (column == first_variable_column)
1154 {
1155 print_blanks(1);
1156 column++;
1157 print_blanks(NEXT_COLUMN(column)-column);
1158 column = NEXT_COLUMN(column);
1159 }
1160 else
1161 {
1162 print_blanks(NEXT_COLUMN(column)-column);
1163 column = NEXT_COLUMN(column);
1164 }
1165 return (column);
1166 }
1167
1168
1169 PRIVATE int
1170 #if HAVE_STDC
select_arguments(Lsymtab * sym_entry)1171 select_arguments(Lsymtab *sym_entry)
1172 #else /* K&R style */
1173 select_arguments(sym_entry)
1174 Lsymtab *sym_entry;
1175 #endif /* HAVE_STDC */
1176 {
1177 /* return (symbol is a module argument) */
1178 if (sym_entry->declared_external ||
1179 sym_entry->invoked_as_func)
1180 return (0);
1181 else if (sym_entry->argument)
1182 return (1);
1183 else
1184 return (0);
1185 }
1186
1187
1188 #if 0 /* this function not currently used */
1189 PRIVATE int
1190 #if HAVE_STDC
1191 select_commons(Lsymtab *sym_entry)
1192 #else /* K&R style */
1193 select_commons(sym_entry)
1194 Lsymtab *sym_entry;
1195 #endif /* HAVE_STDC */
1196 {
1197 /* return (symbol is in a COMMON block) */
1198 if (sym_entry->common_var)
1199 return (1);
1200 else
1201 return (0);
1202 }
1203 #endif /*0*/
1204
1205
1206 PRIVATE int
1207 #if HAVE_STDC
select_externals_by_name(Lsymtab * sym_entry)1208 select_externals_by_name(Lsymtab *sym_entry)
1209 #else /* K&R style */
1210 select_externals_by_name(sym_entry)
1211 Lsymtab *sym_entry;
1212 #endif /* HAVE_STDC */
1213 {
1214 /* return (symbol is external and must appear in EXTERNAL declaration) */
1215
1216 if (sym_entry->declared_intrinsic) /* must appear first, because symbols */
1217 return (0); /* can be both declared_intrinsic and declared_external*/
1218 /* ??? is this a bug in ftnchek 2.7 ??? */
1219 else if (storage_class_of(sym_entry->type) == class_STMT_FUNCTION)
1220 return (0);
1221 else if (sym_entry->declared_external)
1222 return (1);
1223 else if (sym_entry->declared_intrinsic || sym_entry->intrinsic)
1224 return (0);
1225 else if (sym_entry->invoked_as_func)
1226 return (1);
1227 else
1228 return (0);
1229 }
1230
1231
1232 PRIVATE int
1233 #if HAVE_STDC
select_externals_by_type(Lsymtab * sym_entry)1234 select_externals_by_type(Lsymtab *sym_entry)
1235 #else /* K&R style */
1236 select_externals_by_type(sym_entry)
1237 Lsymtab *sym_entry;
1238 #endif /* HAVE_STDC */
1239 {
1240 /* return (symbol is external and must appear in a type declaration) */
1241 if (storage_class_of(sym_entry->type) == class_STMT_FUNCTION)
1242 return (0);
1243 else if (sym_entry->declared_external)
1244 return (1);
1245 else if (sym_entry->declared_intrinsic)
1246 return (0);
1247 else if (sym_entry->intrinsic)
1248 {
1249 if (datatype_of(sym_entry->type) == type_UNDECL)
1250 { /* user provided no type declaration */
1251 if ((sym_entry->info.intrins_info)->result_type == type_GENERIC)
1252 return (0); /* generics CANNOT have explicit type */
1253 else
1254 return (1); /* not generic, so has explicit type */
1255 }
1256 else /* user supplied an explicit type */
1257 return (1);
1258 }
1259 else if (sym_entry->invoked_as_func)
1260 return (1);
1261 else
1262 return (0);
1263 }
1264
1265
1266 PRIVATE int
1267 #if HAVE_STDC
select_intrinsics_by_name(Lsymtab * sym_entry)1268 select_intrinsics_by_name(Lsymtab *sym_entry)
1269 #else /* K&R style */
1270 select_intrinsics_by_name(sym_entry)
1271 Lsymtab *sym_entry;
1272 #endif /* HAVE_STDC */
1273 {
1274 /* return (symbol is intrinsic and must appear in INTRINSIC declaration) */
1275 if (sym_entry->declared_intrinsic)
1276 return (1);
1277 else
1278 return (0);
1279 }
1280
1281
1282 PRIVATE int
1283 #if HAVE_STDC
select_intrinsics_by_type(Lsymtab * sym_entry)1284 select_intrinsics_by_type(Lsymtab *sym_entry)
1285 #else /* K&R style */
1286 select_intrinsics_by_type(sym_entry)
1287 Lsymtab *sym_entry;
1288 #endif /* HAVE_STDC */
1289 {
1290 /* return (symbol is intrinsic and must appear in a type declaration) */
1291 if (sym_entry->intrinsic &&
1292 ((sym_entry->info.intrins_info)->result_type == type_GENERIC))
1293 return (0);
1294 else
1295 return (select_intrinsics_by_name(sym_entry));
1296 }
1297
1298
1299 PRIVATE int
1300 #if HAVE_STDC
select_locals(Lsymtab * sym_entry)1301 select_locals(Lsymtab *sym_entry)
1302 #else /* K&R style */
1303 select_locals(sym_entry)
1304 Lsymtab *sym_entry;
1305 #endif /* HAVE_STDC */
1306 {
1307 /* return (symbol is a local variable) */
1308
1309 if (EXCL_SF3_DECLARATIONS() && sf3_internal_name(sym_entry))
1310 return (0);
1311 else if (sym_entry->argument ||
1312 sym_entry->common_var ||
1313 sym_entry->declared_external ||
1314 sym_entry->declared_intrinsic ||
1315 sym_entry->entry_point ||
1316 sym_entry->external ||
1317 sym_entry->intrinsic ||
1318 sym_entry->invoked_as_func ||
1319 sym_entry->parameter)
1320 return (0);
1321 else
1322 return (1);
1323 }
1324
1325
1326 PRIVATE int
1327 #if HAVE_STDC
select_common_blocks(Lsymtab * sym_entry)1328 select_common_blocks(Lsymtab *sym_entry)
1329 #else /* K&R style */
1330 select_common_blocks(sym_entry)
1331 Lsymtab *sym_entry;
1332 #endif /* HAVE_STDC */
1333 {
1334 /* return (symbol is a COMMON block name) */
1335 if (storage_class_of(sym_entry->type) == class_COMMON_BLOCK)
1336 return (1);
1337 else
1338 return (0);
1339 }
1340
1341 PRIVATE int
1342 #if HAVE_STDC
select_namelists(Lsymtab * sym_entry)1343 select_namelists(Lsymtab *sym_entry)
1344 #else /* K&R style */
1345 select_namelists(sym_entry)
1346 Lsymtab *sym_entry;
1347 #endif /* HAVE_STDC */
1348 {
1349 /* return (symbol is a NAMELIST name) */
1350 if (storage_class_of(sym_entry->type) == class_NAMELIST)
1351 return (1);
1352 else
1353 return (0);
1354 }
1355
1356 PRIVATE int
1357 #if HAVE_STDC
select_parameters(Lsymtab * sym_entry)1358 select_parameters(Lsymtab *sym_entry)
1359 #else /* K&R style */
1360 select_parameters(sym_entry)
1361 Lsymtab *sym_entry;
1362 #endif /* HAVE_STDC */
1363 {
1364 /* return (symbol is a PARAMETER name) */
1365 if (sym_entry->parameter)
1366 return (1);
1367 else
1368 return (0);
1369 }
1370
1371
1372
1373 PRIVATE int
1374 #if HAVE_STDC
select_statement_functions(Lsymtab * sym_entry)1375 select_statement_functions(Lsymtab *sym_entry)
1376 #else /* K&R style */
1377 select_statement_functions(sym_entry)
1378 Lsymtab *sym_entry;
1379 #endif /* HAVE_STDC */
1380 {
1381 if (storage_class_of(sym_entry->type) == class_STMT_FUNCTION)
1382 return (1);
1383 else
1384 return (0);
1385 }
1386
1387
1388 PRIVATE int
1389 #if HAVE_STDC
sf3_internal_name(Lsymtab * sym_entry)1390 sf3_internal_name(Lsymtab *sym_entry)
1391 #else /* K&R style */
1392 sf3_internal_name(sym_entry)
1393 Lsymtab *sym_entry;
1394 #endif /* HAVE_STDC */
1395 { /* Return (symbol is an SFTRAN3 internal name). */
1396 char *p = sym_entry->name;
1397
1398 /* The SFTRAN3 preprocessor uses internal names of the form NPRddd,
1399 NXdddd, N2dddd, and N3dddd, where d is a decimal digit. */
1400
1401 if ((p[0] != 'N') || (strlen(p) != 6))
1402 return (0);
1403 switch (p[1])
1404 {
1405 case 'P':
1406 if ((p[2] == 'R') && isdigit(p[3]) && isdigit(p[4]) && isdigit(p[5]))
1407 return (1);
1408 else
1409 return (0);
1410
1411 case 'X': /* fall through */
1412 case '2': /* fall through */
1413 case '3':
1414 if (isdigit(p[2]) && isdigit(p[3]) && isdigit(p[4]) && isdigit(p[5]))
1415 return (1);
1416 else
1417 return (0);
1418
1419 default:
1420 return (0);
1421 }
1422 }
1423
1424 PRIVATE int
1425 #if HAVE_STDC
make_sym_list(Lsymtab ** sym_list,int (* selector)(Lsymtab *))1426 make_sym_list(Lsymtab **sym_list, int (*selector) (Lsymtab *))
1427 #else /* K&R style */
1428 make_sym_list(sym_list,selector)
1429 Lsymtab *sym_list[];
1430 PROTO(int (*selector),( Lsymtab *sym_entry ));
1431 #endif /* HAVE_STDC */
1432 {
1433 int i;
1434 int n;
1435
1436 for (i = 0, n = 0; i < loc_symtab_top; ++i)
1437 {
1438 if (selector(&loc_symtab[i]))
1439 sym_list[n++] = &loc_symtab[i];
1440 }
1441 if (n > 0)
1442 {
1443
1444 if (selector == select_parameters) {
1445 /* Free form is not blank-insensitive, so go
1446 thru parameter declarations and remove any
1447 blanks from within numbers.
1448 */
1449 if( FREE_FORM() ) {
1450 for(i=0; i < n; i++) {
1451 if( is_numeric_type(get_type(sym_list[i])) ) {
1452 strip_blanks(sym_list[i]->info.param->src_text);
1453 }
1454 }
1455 }
1456 /* original PARAMETER statement order must be preserved so that
1457 the expressions do not refer to as-yet-undefined parameter names */
1458 sort_parameters(sym_list,n);
1459 }
1460 else
1461 sort_lsymbols(sym_list,n);
1462 }
1463 return (n);
1464 }
1465
1466 /* Routine to remove whitespace from a string */
1467 PRIVATE void
strip_blanks(char * s)1468 strip_blanks(char *s)
1469 {
1470 char *t;
1471 for( t=s; *s != '\0'; s++ ) {
1472 if( !isspace(*s) )
1473 *t++ = *s;
1474 }
1475 *t = '\0';
1476 }
1477
1478