« back to all changes in this revision
Viewing changes to fortran.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Colin Watson
- Date: 2004-03-30 11:56:40 UTC
- Revision ID: james.westby@ubuntu.com-20040330115640-0u2eq56u65zf53il
Tags: upstream-5.5.4
Import upstream version 5.5.4
- files added:
added
removed
fortran.c
1
/*
2
* $Id: fortran.c,v 1.41 2004/03/15 04:17:36 darren Exp $
3
*
4
* Copyright (c) 1998-2003, Darren Hiebert
5
*
6
* This source code is released for free distribution under the terms of the
7
* GNU General Public License.
8
*
9
* This module contains functions for generating tags for Fortran language
10
* files.
11
*/
12
13
/*
14
* INCLUDE FILES
15
*/
16
#include "general.h" /* must always come first */
17
18
#include <string.h>
19
#include <limits.h>
20
#include <ctype.h> /* to define tolower () */
21
#include <setjmp.h>
22
23
#include "debug.h"
24
#include "entry.h"
25
#include "keyword.h"
26
#include "options.h"
27
#include "parse.h"
28
#include "read.h"
29
#include "routines.h"
30
#include "vstring.h"
31
32
/*
33
* MACROS
34
*/
35
#define isident(c) (isalnum(c) || (c) == '_')
36
#define isBlank(c) (boolean) (c == ' ' || c == '\t')
37
#define isType(token,t) (boolean) ((token)->type == (t))
38
#define isKeyword(token,k) (boolean) ((token)->keyword == (k))
39
#define isSecondaryKeyword(token,k) (boolean) ((token)->secondary == NULL ? \
40
FALSE : (token)->secondary->keyword == (k))
41
42
/*
43
* DATA DECLARATIONS
44
*/
45
46
typedef enum eException {
47
ExceptionNone, ExceptionEOF, ExceptionFixedFormat, ExceptionLoop
48
} exception_t;
49
50
/* Used to designate type of line read in fixed source form.
51
*/
52
typedef enum eFortranLineType {
53
LTYPE_UNDETERMINED,
54
LTYPE_INVALID,
55
LTYPE_COMMENT,
56
LTYPE_CONTINUATION,
57
LTYPE_EOF,
58
LTYPE_INITIAL,
59
LTYPE_SHORT
60
} lineType;
61
62
/* Used to specify type of keyword.
63
*/
64
typedef enum eKeywordId {
65
KEYWORD_NONE = -1,
66
KEYWORD_allocatable,
67
KEYWORD_assignment,
68
KEYWORD_automatic,
69
KEYWORD_block,
70
KEYWORD_byte,
71
KEYWORD_cexternal,
72
KEYWORD_cglobal,
73
KEYWORD_character,
74
KEYWORD_common,
75
KEYWORD_complex,
76
KEYWORD_contains,
77
KEYWORD_data,
78
KEYWORD_dimension,
79
KEYWORD_dllexport,
80
KEYWORD_dllimport,
81
KEYWORD_do,
82
KEYWORD_double,
83
KEYWORD_elemental,
84
KEYWORD_end,
85
KEYWORD_entry,
86
KEYWORD_equivalence,
87
KEYWORD_external,
88
KEYWORD_format,
89
KEYWORD_function,
90
KEYWORD_if,
91
KEYWORD_implicit,
92
KEYWORD_include,
93
KEYWORD_inline,
94
KEYWORD_integer,
95
KEYWORD_intent,
96
KEYWORD_interface,
97
KEYWORD_intrinsic,
98
KEYWORD_logical,
99
KEYWORD_map,
100
KEYWORD_module,
101
KEYWORD_namelist,
102
KEYWORD_operator,
103
KEYWORD_optional,
104
KEYWORD_parameter,
105
KEYWORD_pascal,
106
KEYWORD_pexternal,
107
KEYWORD_pglobal,
108
KEYWORD_pointer,
109
KEYWORD_precision,
110
KEYWORD_private,
111
KEYWORD_program,
112
KEYWORD_public,
113
KEYWORD_pure,
114
KEYWORD_real,
115
KEYWORD_record,
116
KEYWORD_recursive,
117
KEYWORD_save,
118
KEYWORD_select,
119
KEYWORD_sequence,
120
KEYWORD_static,
121
KEYWORD_stdcall,
122
KEYWORD_structure,
123
KEYWORD_subroutine,
124
KEYWORD_target,
125
KEYWORD_then,
126
KEYWORD_type,
127
KEYWORD_union,
128
KEYWORD_use,
129
KEYWORD_value,
130
KEYWORD_virtual,
131
KEYWORD_volatile,
132
KEYWORD_where,
133
KEYWORD_while
134
} keywordId;
135
136
/* Used to determine whether keyword is valid for the token language and
137
* what its ID is.
138
*/
139
typedef struct sKeywordDesc {
140
const char *name;
141
keywordId id;
142
} keywordDesc;
143
144
typedef enum eTokenType {
145
TOKEN_UNDEFINED,
146
TOKEN_COMMA,
147
TOKEN_DOUBLE_COLON,
148
TOKEN_IDENTIFIER,
149
TOKEN_KEYWORD,
150
TOKEN_LABEL,
151
TOKEN_NUMERIC,
152
TOKEN_OPERATOR,
153
TOKEN_PAREN_CLOSE,
154
TOKEN_PAREN_OPEN,
155
TOKEN_PERCENT,
156
TOKEN_STATEMENT_END,
157
TOKEN_STRING
158
} tokenType;
159
160
typedef enum eTagType {
161
TAG_UNDEFINED = -1,
162
TAG_BLOCK_DATA,
163
TAG_COMMON_BLOCK,
164
TAG_ENTRY_POINT,
165
TAG_FUNCTION,
166
TAG_INTERFACE,
167
TAG_COMPONENT,
168
TAG_LABEL,
169
TAG_LOCAL,
170
TAG_MODULE,
171
TAG_NAMELIST,
172
TAG_PROGRAM,
173
TAG_SUBROUTINE,
174
TAG_DERIVED_TYPE,
175
TAG_VARIABLE,
176
TAG_COUNT /* must be last */
177
} tagType;
178
179
typedef struct sTokenInfo {
180
tokenType type;
181
keywordId keyword;
182
tagType tag;
183
vString* string;
184
struct sTokenInfo *secondary;
185
unsigned long lineNumber;
186
fpos_t filePosition;
187
} tokenInfo;
188
189
/*
190
* DATA DEFINITIONS
191
*/
192
193
static langType Lang_fortran;
194
static jmp_buf Exception;
195
static int Ungetc;
196
static unsigned int Column;
197
static boolean FreeSourceForm;
198
static boolean ParsingString;
199
static tokenInfo *Parent;
200
201
/* indexed by tagType */
202
static kindOption FortranKinds [] = {
203
{ TRUE, 'b', "block data", "block data"},
204
{ TRUE, 'c', "common", "common blocks"},
205
{ TRUE, 'e', "entry", "entry points"},
206
{ TRUE, 'f', "function", "functions"},
207
{ FALSE, 'i', "interface", "interface contents, generic names, and operators"},
208
{ TRUE, 'k', "component", "type and structure components"},
209
{ TRUE, 'l', "label", "labels"},
210
{ FALSE, 'L', "local", "local, common block, and namelist variables"},
211
{ TRUE, 'm', "module", "modules"},
212
{ TRUE, 'n', "namelist", "namelists"},
213
{ TRUE, 'p', "program", "programs"},
214
{ TRUE, 's', "subroutine", "subroutines"},
215
{ TRUE, 't', "type", "derived types and structures"},
216
{ TRUE, 'v', "variable", "program (global) and module variables"}
217
};
218
219
/* For a definition of Fortran 77 with extensions:
220
* http://scienide.uwaterloo.ca/MIPSpro7/007-2362-004/sgi_html/index.html
221
*
222
* For the Compaq Fortran Reference Manual:
223
* http://h18009.www1.hp.com/fortran/docs/lrm/dflrm.htm
224
*/
225
226
static const keywordDesc FortranKeywordTable [] = {
227
/* keyword keyword ID */
228
{ "allocatable", KEYWORD_allocatable },
229
{ "assignment", KEYWORD_assignment },
230
{ "automatic", KEYWORD_automatic },
231
{ "block", KEYWORD_block },
232
{ "byte", KEYWORD_byte },
233
{ "cexternal", KEYWORD_cexternal },
234
{ "cglobal", KEYWORD_cglobal },
235
{ "character", KEYWORD_character },
236
{ "common", KEYWORD_common },
237
{ "complex", KEYWORD_complex },
238
{ "contains", KEYWORD_contains },
239
{ "data", KEYWORD_data },
240
{ "dimension", KEYWORD_dimension },
241
{ "dll_export", KEYWORD_dllexport },
242
{ "dll_import", KEYWORD_dllimport },
243
{ "do", KEYWORD_do },
244
{ "double", KEYWORD_double },
245
{ "elemental", KEYWORD_elemental },
246
{ "end", KEYWORD_end },
247
{ "entry", KEYWORD_entry },
248
{ "equivalence", KEYWORD_equivalence },
249
{ "external", KEYWORD_external },
250
{ "format", KEYWORD_format },
251
{ "function", KEYWORD_function },
252
{ "if", KEYWORD_if },
253
{ "implicit", KEYWORD_implicit },
254
{ "include", KEYWORD_include },
255
{ "inline", KEYWORD_inline },
256
{ "integer", KEYWORD_integer },
257
{ "intent", KEYWORD_intent },
258
{ "interface", KEYWORD_interface },
259
{ "intrinsic", KEYWORD_intrinsic },
260
{ "logical", KEYWORD_logical },
261
{ "map", KEYWORD_map },
262
{ "module", KEYWORD_module },
263
{ "namelist", KEYWORD_namelist },
264
{ "operator", KEYWORD_operator },
265
{ "optional", KEYWORD_optional },
266
{ "parameter", KEYWORD_parameter },
267
{ "pascal", KEYWORD_pascal },
268
{ "pexternal", KEYWORD_pexternal },
269
{ "pglobal", KEYWORD_pglobal },
270
{ "pointer", KEYWORD_pointer },
271
{ "precision", KEYWORD_precision },
272
{ "private", KEYWORD_private },
273
{ "program", KEYWORD_program },
274
{ "public", KEYWORD_public },
275
{ "pure", KEYWORD_pure },
276
{ "real", KEYWORD_real },
277
{ "record", KEYWORD_record },
278
{ "recursive", KEYWORD_recursive },
279
{ "save", KEYWORD_save },
280
{ "select", KEYWORD_select },
281
{ "sequence", KEYWORD_sequence },
282
{ "static", KEYWORD_static },
283
{ "stdcall", KEYWORD_stdcall },
284
{ "structure", KEYWORD_structure },
285
{ "subroutine", KEYWORD_subroutine },
286
{ "target", KEYWORD_target },
287
{ "then", KEYWORD_then },
288
{ "type", KEYWORD_type },
289
{ "union", KEYWORD_union },
290
{ "use", KEYWORD_use },
291
{ "value", KEYWORD_value },
292
{ "virtual", KEYWORD_virtual },
293
{ "volatile", KEYWORD_volatile },
294
{ "where", KEYWORD_where },
295
{ "while", KEYWORD_while }
296
};
297
298
static struct {
299
unsigned int count;
300
unsigned int max;
301
tokenInfo* list;
302
} Ancestors = { 0, 0, NULL };
303
304
/*
305
* FUNCTION PROTOTYPES
306
*/
307
static void parseStructureStmt (tokenInfo *const token);
308
static void parseUnionStmt (tokenInfo *const token);
309
static void parseDerivedTypeDef (tokenInfo *const token);
310
static void parseFunctionSubprogram (tokenInfo *const token);
311
static void parseSubroutineSubprogram (tokenInfo *const token);
312
313
/*
314
* FUNCTION DEFINITIONS
315
*/
316
317
static void ancestorPush (tokenInfo *const token)
318
{
319
enum { incrementalIncrease = 10 };
320
if (Ancestors.list == NULL)
321
{
322
Assert (Ancestors.max == 0);
323
Ancestors.count = 0;
324
Ancestors.max = incrementalIncrease;
325
Ancestors.list = xMalloc (Ancestors.max, tokenInfo);
326
}
327
else if (Ancestors.count == Ancestors.max)
328
{
329
Ancestors.max += incrementalIncrease;
330
Ancestors.list = xRealloc (Ancestors.list, Ancestors.max, tokenInfo);
331
}
332
Ancestors.list [Ancestors.count] = *token;
333
Ancestors.list [Ancestors.count].string = vStringNewCopy (token->string);
334
Ancestors.count++;
335
}
336
337
static void ancestorPop (void)
338
{
339
Assert (Ancestors.count > 0);
340
--Ancestors.count;
341
vStringDelete (Ancestors.list [Ancestors.count].string);
342
343
Ancestors.list [Ancestors.count].type = TOKEN_UNDEFINED;
344
Ancestors.list [Ancestors.count].keyword = KEYWORD_NONE;
345
Ancestors.list [Ancestors.count].secondary = NULL;
346
Ancestors.list [Ancestors.count].tag = TAG_UNDEFINED;
347
Ancestors.list [Ancestors.count].string = NULL;
348
Ancestors.list [Ancestors.count].lineNumber = 0L;
349
}
350
351
static const tokenInfo* ancestorScope (void)
352
{
353
tokenInfo *result = NULL;
354
unsigned int i;
355
for (i = Ancestors.count ; i > 0 && result == NULL ; --i)
356
{
357
tokenInfo *const token = Ancestors.list + i - 1;
358
if (token->type == TOKEN_IDENTIFIER &&
359
token->tag != TAG_UNDEFINED && token->tag != TAG_INTERFACE)
360
result = token;
361
}
362
return result;
363
}
364
365
static const tokenInfo* ancestorTop (void)
366
{
367
Assert (Ancestors.count > 0);
368
return &Ancestors.list [Ancestors.count - 1];
369
}
370
371
#define ancestorCount() (Ancestors.count)
372
373
static void ancestorClear (void)
374
{
375
while (Ancestors.count > 0)
376
ancestorPop ();
377
if (Ancestors.list != NULL)
378
eFree (Ancestors.list);
379
Ancestors.list = NULL;
380
Ancestors.count = 0;
381
Ancestors.max = 0;
382
}
383
384
static boolean insideInterface (void)
385
{
386
boolean result = FALSE;
387
unsigned int i;
388
for (i = 0 ; i < Ancestors.count && !result ; ++i)
389
{
390
if (Ancestors.list [i].tag == TAG_INTERFACE)
391
result = TRUE;
392
}
393
return result;
394
}
395
396
static void buildFortranKeywordHash (void)
397
{
398
const size_t count = sizeof (FortranKeywordTable) /
399
sizeof (FortranKeywordTable [0]);
400
size_t i;
401
for (i = 0 ; i < count ; ++i)
402
{
403
const keywordDesc* const p = &FortranKeywordTable [i];
404
addKeyword (p->name, Lang_fortran, (int) p->id);
405
}
406
}
407
408
/*
409
* Tag generation functions
410
*/
411
412
static tokenInfo *newToken (void)
413
{
414
tokenInfo *const token = xMalloc (1, tokenInfo);
415
416
token->type = TOKEN_UNDEFINED;
417
token->keyword = KEYWORD_NONE;
418
token->tag = TAG_UNDEFINED;
419
token->string = vStringNew ();
420
token->secondary = NULL;
421
token->lineNumber = getSourceLineNumber ();
422
token->filePosition = getInputFilePosition ();
423
424
return token;
425
}
426
427
static tokenInfo *newTokenFrom (tokenInfo *const token)
428
{
429
tokenInfo *result = newToken ();
430
*result = *token;
431
result->string = vStringNewCopy (token->string);
432
token->secondary = NULL;
433
return result;
434
}
435
436
static void deleteToken (tokenInfo *const token)
437
{
438
if (token != NULL)
439
{
440
vStringDelete (token->string);
441
deleteToken (token->secondary);
442
token->secondary = NULL;
443
eFree (token);
444
}
445
}
446
447
static boolean isFileScope (const tagType type)
448
{
449
return (boolean) (type == TAG_LABEL || type == TAG_LOCAL);
450
}
451
452
static boolean includeTag (const tagType type)
453
{
454
boolean include;
455
Assert (type != TAG_UNDEFINED);
456
include = FortranKinds [(int) type].enabled;
457
if (include && isFileScope (type))
458
include = Option.include.fileScope;
459
return include;
460
}
461
462
static void makeFortranTag (tokenInfo *const token, tagType tag)
463
{
464
token->tag = tag;
465
if (includeTag (token->tag))
466
{
467
const char *const name = vStringValue (token->string);
468
tagEntryInfo e;
469
470
initTagEntry (&e, name);
471
472
if (token->tag == TAG_COMMON_BLOCK)
473
e.lineNumberEntry = (boolean) (Option.locate != EX_PATTERN);
474
475
e.lineNumber = token->lineNumber;
476
e.filePosition = token->filePosition;
477
e.isFileScope = isFileScope (token->tag);
478
e.kindName = FortranKinds [token->tag].name;
479
e.kind = FortranKinds [token->tag].letter;
480
e.truncateLine = (boolean) (token->tag != TAG_LABEL);
481
482
if (ancestorCount () > 0)
483
{
484
const tokenInfo* const scope = ancestorScope ();
485
if (scope != NULL)
486
{
487
e.extensionFields.scope [0] = FortranKinds [scope->tag].name;
488
e.extensionFields.scope [1] = vStringValue (scope->string);
489
}
490
}
491
if (! insideInterface () || includeTag (TAG_INTERFACE))
492
makeTagEntry (&e);
493
}
494
}
495
496
/*
497
* Parsing functions
498
*/
499
500
static int skipLine (void)
501
{
502
int c;
503
504
do
505
c = fileGetc ();
506
while (c != EOF && c != '\n');
507
508
return c;
509
}
510
511
static void makeLabelTag (vString *const label)
512
{
513
tokenInfo *token = newToken ();
514
token->type = TOKEN_LABEL;
515
vStringCopy (token->string, label);
516
makeFortranTag (token, TAG_LABEL);
517
deleteToken (token);
518
}
519
520
static lineType getLineType (void)
521
{
522
static vString *label = NULL;
523
int column = 0;
524
lineType type = LTYPE_UNDETERMINED;
525
526
if (label == NULL)
527
label = vStringNew ();
528
529
do /* read in first 6 "margin" characters */
530
{
531
int c = fileGetc ();
532
533
/* 3.2.1 Comment_Line. A comment line is any line that contains
534
* a C or an asterisk in column 1, or contains only blank characters
535
* in columns 1 through 72. A comment line that contains a C or
536
* an asterisk in column 1 may contain any character capable of
537
* representation in the processor in columns 2 through 72.
538
*/
539
/* EXCEPTION! Some compilers permit '!' as a commment character here.
540
*
541
* Treat # and $ in column 1 as comment to permit preprocessor directives.
542
* Treat D and d in column 1 as comment for HP debug statements.
543
*/
544
if (column == 0 && strchr ("*Cc!#$Dd", c) != NULL)
545
type = LTYPE_COMMENT;
546
else if (c == '\t') /* EXCEPTION! Some compilers permit a tab here */
547
{
548
column = 8;
549
type = LTYPE_INITIAL;
550
}
551
else if (column == 5)
552
{
553
/* 3.2.2 Initial_Line. An initial line is any line that is not
554
* a comment line and contains the character blank or the digit 0
555
* in column 6. Columns 1 through 5 may contain a statement label
556
* (3.4), or each of the columns 1 through 5 must contain the
557
* character blank.
558
*/
559
if (c == ' ' || c == '0')
560
type = LTYPE_INITIAL;
561
562
/* 3.2.3 Continuation_Line. A continuation line is any line that
563
* contains any character of the FORTRAN character set other than
564
* the character blank or the digit 0 in column 6 and contains
565
* only blank characters in columns 1 through 5.
566
*/
567
else if (vStringLength (label) == 0)
568
type = LTYPE_CONTINUATION;
569
else
570
type = LTYPE_INVALID;
571
}
572
else if (c == ' ')
573
;
574
else if (c == EOF)
575
type = LTYPE_EOF;
576
else if (c == '\n')
577
type = LTYPE_SHORT;
578
else if (isdigit (c))
579
vStringPut (label, c);
580
else
581
type = LTYPE_INVALID;
582
583
++column;
584
} while (column < 6 && type == LTYPE_UNDETERMINED);
585
586
Assert (type != LTYPE_UNDETERMINED);
587
588
if (vStringLength (label) > 0)
589
{
590
vStringTerminate (label);
591
makeLabelTag (label);
592
vStringClear (label);
593
}
594
return type;
595
}
596
597
static int getFixedFormChar (void)
598
{
599
boolean newline = FALSE;
600
lineType type;
601
int c = '\0';
602
603
if (Column > 0)
604
{
605
#ifdef STRICT_FIXED_FORM
606
/* EXCEPTION! Some compilers permit more than 72 characters per line.
607
*/
608
if (Column > 71)
609
c = skipLine ();
610
else
611
#endif
612
{
613
c = fileGetc ();
614
++Column;
615
}
616
if (c == '\n')
617
{
618
newline = TRUE; /* need to check for continuation line */
619
Column = 0;
620
}
621
else if (c == '!' && ! ParsingString)
622
{
623
c = skipLine ();
624
newline = TRUE; /* need to check for continuation line */
625
Column = 0;
626
}
627
else if (c == '&') /* check for free source form */
628
{
629
const int c2 = fileGetc ();
630
if (c2 == '\n')
631
longjmp (Exception, (int) ExceptionFixedFormat);
632
else
633
fileUngetc (c2);
634
}
635
}
636
while (Column == 0)
637
{
638
type = getLineType ();
639
switch (type)
640
{
641
case LTYPE_UNDETERMINED:
642
case LTYPE_INVALID:
643
longjmp (Exception, (int) ExceptionFixedFormat);
644
break;
645
646
case LTYPE_SHORT: break;
647
case LTYPE_COMMENT: skipLine (); break;
648
649
case LTYPE_EOF:
650
Column = 6;
651
if (newline)
652
c = '\n';
653
else
654
c = EOF;
655
break;
656
657
case LTYPE_INITIAL:
658
if (newline)
659
{
660
c = '\n';
661
Column = 6;
662
break;
663
}
664
/* fall through to next case */
665
case LTYPE_CONTINUATION:
666
Column = 5;
667
do
668
{
669
c = fileGetc ();
670
++Column;
671
} while (isBlank (c));
672
if (c == '\n')
673
Column = 0;
674
else if (Column > 6)
675
{
676
fileUngetc (c);
677
c = ' ';
678
}
679
break;
680
681
default:
682
Assert ("Unexpected line type" == NULL);
683
}
684
}
685
return c;
686
}
687
688
static int skipToNextLine (void)
689
{
690
int c = skipLine ();
691
if (c != EOF)
692
c = fileGetc ();
693
return c;
694
}
695
696
static int getFreeFormChar (void)
697
{
698
static boolean newline = TRUE;
699
boolean advanceLine = FALSE;
700
int c = fileGetc ();
701
702
/* If the last nonblank, non-comment character of a FORTRAN 90
703
* free-format text line is an ampersand then the next non-comment
704
* line is a continuation line.
705
*/
706
if (c == '&')
707
{
708
do
709
c = fileGetc ();
710
while (isspace (c) && c != '\n');
711
if (c == '\n')
712
{
713
newline = TRUE;
714
advanceLine = TRUE;
715
}
716
else if (c == '!')
717
advanceLine = TRUE;
718
else
719
{
720
fileUngetc (c);
721
c = '&';
722
}
723
}
724
else if (newline && (c == '!' || c == '#'))
725
advanceLine = TRUE;
726
while (advanceLine)
727
{
728
while (isspace (c))
729
c = fileGetc ();
730
if (c == '!' || (newline && c == '#'))
731
{
732
c = skipToNextLine ();
733
newline = TRUE;
734
continue;
735
}
736
if (c == '&')
737
c = fileGetc ();
738
else
739
advanceLine = FALSE;
740
}
741
newline = (boolean) (c == '\n');
742
return c;
743
}
744
745
static int getChar (void)
746
{
747
int c;
748
749
if (Ungetc != '\0')
750
{
751
c = Ungetc;
752
Ungetc = '\0';
753
}
754
else if (FreeSourceForm)
755
c = getFreeFormChar ();
756
else
757
c = getFixedFormChar ();
758
759
return c;
760
}
761
762
static void ungetChar (const int c)
763
{
764
Ungetc = c;
765
}
766
767
/* If a numeric is passed in 'c', this is used as the first digit of the
768
* numeric being parsed.
769
*/
770
static vString *parseInteger (int c)
771
{
772
static vString *string = NULL;
773
774
if (string == NULL)
775
string = vStringNew ();
776
vStringClear (string);
777
778
if (c == '-')
779
{
780
vStringPut (string, c);
781
c = getChar ();
782
}
783
else if (! isdigit (c))
784
c = getChar ();
785
while (c != EOF && isdigit (c))
786
{
787
vStringPut (string, c);
788
c = getChar ();
789
}
790
vStringTerminate (string);
791
792
if (c == '_')
793
{
794
do
795
c = getChar ();
796
while (c != EOF && isalpha (c));
797
}
798
ungetChar (c);
799
800
return string;
801
}
802
803
static vString *parseNumeric (int c)
804
{
805
static vString *string = NULL;
806
807
if (string == NULL)
808
string = vStringNew ();
809
vStringCopy (string, parseInteger (c));
810
811
c = getChar ();
812
if (c == '.')
813
{
814
vStringPut (string, c);
815
vStringCat (string, parseInteger ('\0'));
816
c = getChar ();
817
}
818
if (tolower (c) == 'e')
819
{
820
vStringPut (string, c);
821
vStringCat (string, parseInteger ('\0'));
822
}
823
else
824
ungetChar (c);
825
826
vStringTerminate (string);
827
828
return string;
829
}
830
831
static void parseString (vString *const string, const int delimeter)
832
{
833
const unsigned long inputLineNumber = getInputLineNumber ();
834
int c;
835
ParsingString = TRUE;
836
c = getChar ();
837
while (c != delimeter && c != '\n' && c != EOF)
838
{
839
vStringPut (string, c);
840
c = getChar ();
841
}
842
if (c == '\n' || c == EOF)
843
{
844
verbose ("%s: unterminated character string at line %lu\n",
845
getInputFileName (), inputLineNumber);
846
if (c == EOF)
847
longjmp (Exception, (int) ExceptionEOF);
848
else if (! FreeSourceForm)
849
longjmp (Exception, (int) ExceptionFixedFormat);
850
}
851
vStringTerminate (string);
852
ParsingString = FALSE;
853
}
854
855
/* Read a C identifier beginning with "firstChar" and places it into "name".
856
*/
857
static void parseIdentifier (vString *const string, const int firstChar)
858
{
859
int c = firstChar;
860
861
do
862
{
863
vStringPut (string, c);
864
c = getChar ();
865
} while (isident (c));
866
867
vStringTerminate (string);
868
ungetChar (c); /* unget non-identifier character */
869
}
870
871
/* Analyzes the identifier contained in a statement described by the
872
* statement structure and adjusts the structure according the significance
873
* of the identifier.
874
*/
875
static keywordId analyzeToken (vString *const name)
876
{
877
static vString *keyword = NULL;
878
keywordId id;
879
880
if (keyword == NULL)
881
keyword = vStringNew ();
882
vStringCopyToLower (keyword, name);
883
id = (keywordId) lookupKeyword (vStringValue (keyword), Lang_fortran);
884
885
return id;
886
}
887
888
static void checkForLabel (void)
889
{
890
tokenInfo* token = NULL;
891
int length;
892
int c;
893
894
do
895
c = getChar ();
896
while (isBlank (c));
897
898
for (length = 0 ; isdigit (c) && length < 5 ; ++length)
899
{
900
if (token == NULL)
901
{
902
token = newToken ();
903
token->type = TOKEN_LABEL;
904
}
905
vStringPut (token->string, c);
906
c = getChar ();
907
}
908
if (length > 0)
909
{
910
Assert (token != NULL);
911
vStringTerminate (token->string);
912
makeFortranTag (token, TAG_LABEL);
913
deleteToken (token);
914
}
915
ungetChar (c);
916
}
917
918
static void readIdentifier (tokenInfo *const token, const int c)
919
{
920
parseIdentifier (token->string, c);
921
token->keyword = analyzeToken (token->string);
922
if (! isKeyword (token, KEYWORD_NONE))
923
token->type = TOKEN_KEYWORD;
924
else
925
{
926
token->type = TOKEN_IDENTIFIER;
927
if (strncmp (vStringValue (token->string), "end", 3) == 0)
928
{
929
vString *const sub = vStringNewInit (vStringValue (token->string) + 3);
930
const keywordId kw = analyzeToken (sub);
931
vStringDelete (sub);
932
if (kw != KEYWORD_NONE)
933
{
934
token->secondary = newToken ();
935
token->secondary->type = TOKEN_KEYWORD;
936
token->secondary->keyword = kw;
937
token->keyword = KEYWORD_end;
938
}
939
}
940
}
941
}
942
943
static void readToken (tokenInfo *const token)
944
{
945
int c;
946
947
deleteToken (token->secondary);
948
token->type = TOKEN_UNDEFINED;
949
token->tag = TAG_UNDEFINED;
950
token->keyword = KEYWORD_NONE;
951
token->secondary = NULL;
952
vStringClear (token->string);
953
954
getNextChar:
955
c = getChar ();
956
957
token->lineNumber = getSourceLineNumber ();
958
token->filePosition = getInputFilePosition ();
959
960
switch (c)
961
{
962
case EOF: longjmp (Exception, (int) ExceptionEOF); break;
963
case ' ': goto getNextChar;
964
case '\t': goto getNextChar;
965
case ',': token->type = TOKEN_COMMA; break;
966
case '(': token->type = TOKEN_PAREN_OPEN; break;
967
case ')': token->type = TOKEN_PAREN_CLOSE; break;
968
case '%': token->type = TOKEN_PERCENT; break;
969
970
case '*':
971
case '/':
972
case '+':
973
case '-':
974
case '=':
975
case '<':
976
case '>':
977
{
978
const char *const operatorChars = "*/+=<>";
979
do {
980
vStringPut (token->string, c);
981
c = getChar ();
982
} while (strchr (operatorChars, c) != NULL);
983
ungetChar (c);
984
vStringTerminate (token->string);
985
token->type = TOKEN_OPERATOR;
986
break;
987
}
988
989
case '!':
990
if (FreeSourceForm)
991
{
992
do
993
c = getChar ();
994
while (c != '\n');
995
}
996
else
997
{
998
skipLine ();
999
Column = 0;
1000
}
1001
/* fall through to newline case */
1002
case '\n':
1003
token->type = TOKEN_STATEMENT_END;
1004
if (FreeSourceForm)
1005
checkForLabel ();
1006
break;
1007
1008
case '.':
1009
parseIdentifier (token->string, c);
1010
c = getChar ();
1011
if (c == '.')
1012
{
1013
vStringPut (token->string, c);
1014
vStringTerminate (token->string);
1015
token->type = TOKEN_OPERATOR;
1016
}
1017
else
1018
{
1019
ungetChar (c);
1020
token->type = TOKEN_UNDEFINED;
1021
}
1022
break;
1023
1024
case '"':
1025
case '\'':
1026
parseString (token->string, c);
1027
token->type = TOKEN_STRING;
1028
break;
1029
1030
case ';':
1031
token->type = TOKEN_STATEMENT_END;
1032
break;
1033
1034
case ':':
1035
c = getChar ();
1036
if (c == ':')
1037
token->type = TOKEN_DOUBLE_COLON;
1038
else
1039
{
1040
ungetChar (c);
1041
token->type = TOKEN_UNDEFINED;
1042
}
1043
break;
1044
1045
default:
1046
if (isalpha (c))
1047
readIdentifier (token, c);
1048
else if (isdigit (c))
1049
{
1050
vStringCat (token->string, parseNumeric (c));
1051
token->type = TOKEN_NUMERIC;
1052
}
1053
else
1054
token->type = TOKEN_UNDEFINED;
1055
break;
1056
}
1057
}
1058
1059
static void readSubToken (tokenInfo *const token)
1060
{
1061
if (token->secondary == NULL)
1062
{
1063
token->secondary = newToken ();
1064
readToken (token->secondary);
1065
}
1066
Assert (token->secondary != NULL);
1067
}
1068
1069
/*
1070
* Scanning functions
1071
*/
1072
1073
static void skipToToken (tokenInfo *const token, tokenType type)
1074
{
1075
while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END) &&
1076
!(token->secondary != NULL && isType (token->secondary, TOKEN_STATEMENT_END)))
1077
readToken (token);
1078
}
1079
1080
static void skipPast (tokenInfo *const token, tokenType type)
1081
{
1082
skipToToken (token, type);
1083
if (! isType (token, TOKEN_STATEMENT_END))
1084
readToken (token);
1085
}
1086
1087
static void skipToNextStatement (tokenInfo *const token)
1088
{
1089
do
1090
{
1091
skipToToken (token, TOKEN_STATEMENT_END);
1092
readToken (token);
1093
} while (isType (token, TOKEN_STATEMENT_END));
1094
}
1095
1096
/* skip over parenthesis enclosed contents starting at next token.
1097
* Token is left at the first token following closing parenthesis. If an
1098
* opening parenthesis is not found, `token' is moved to the end of the
1099
* statement.
1100
*/
1101
static void skipOverParens (tokenInfo *const token)
1102
{
1103
int level = 0;
1104
do {
1105
if (isType (token, TOKEN_STATEMENT_END))
1106
break;
1107
else if (isType (token, TOKEN_PAREN_OPEN))
1108
++level;
1109
else if (isType (token, TOKEN_PAREN_CLOSE))
1110
--level;
1111
readToken (token);
1112
} while (level > 0);
1113
}
1114
1115
static boolean isTypeSpec (tokenInfo *const token)
1116
{
1117
boolean result;
1118
switch (token->keyword)
1119
{
1120
case KEYWORD_byte:
1121
case KEYWORD_integer:
1122
case KEYWORD_real:
1123
case KEYWORD_double:
1124
case KEYWORD_complex:
1125
case KEYWORD_character:
1126
case KEYWORD_logical:
1127
case KEYWORD_record:
1128
case KEYWORD_type:
1129
result = TRUE;
1130
break;
1131
default:
1132
result = FALSE;
1133
break;
1134
}
1135
return result;
1136
}
1137
1138
static boolean isSubprogramPrefix (tokenInfo *const token)
1139
{
1140
boolean result;
1141
switch (token->keyword)
1142
{
1143
case KEYWORD_elemental:
1144
case KEYWORD_pure:
1145
case KEYWORD_recursive:
1146
case KEYWORD_stdcall:
1147
result = TRUE;
1148
break;
1149
default:
1150
result = FALSE;
1151
break;
1152
}
1153
return result;
1154
}
1155
1156
/* type-spec
1157
* is INTEGER [kind-selector]
1158
* or REAL [kind-selector] is ( etc. )
1159
* or DOUBLE PRECISION
1160
* or COMPLEX [kind-selector]
1161
* or CHARACTER [kind-selector]
1162
* or LOGICAL [kind-selector]
1163
* or TYPE ( type-name )
1164
*
1165
* Note that INTEGER and REAL may be followed by "*N" where "N" is an integer
1166
*/
1167
static void parseTypeSpec (tokenInfo *const token)
1168
{
1169
/* parse type-spec, leaving `token' at first token following type-spec */
1170
Assert (isTypeSpec (token));
1171
switch (token->keyword)
1172
{
1173
case KEYWORD_character:
1174
/* skip char-selector */
1175
readToken (token);
1176
if (isType (token, TOKEN_OPERATOR) &&
1177
strcmp (vStringValue (token->string), "*") == 0)
1178
readToken (token);
1179
if (isType (token, TOKEN_PAREN_OPEN))
1180
skipOverParens (token);
1181
else if (isType (token, TOKEN_NUMERIC))
1182
readToken (token);
1183
break;
1184
1185
1186
case KEYWORD_byte:
1187
case KEYWORD_complex:
1188
case KEYWORD_integer:
1189
case KEYWORD_logical:
1190
case KEYWORD_real:
1191
readToken (token);
1192
if (isType (token, TOKEN_PAREN_OPEN))
1193
skipOverParens (token); /* skip kind-selector */
1194
if (isType (token, TOKEN_OPERATOR) &&
1195
strcmp (vStringValue (token->string), "*") == 0)
1196
{
1197
readToken (token);
1198
readToken (token);
1199
}
1200
break;
1201
1202
case KEYWORD_double:
1203
readToken (token);
1204
if (isKeyword (token, KEYWORD_complex) ||
1205
isKeyword (token, KEYWORD_precision))
1206
readToken (token);
1207
else
1208
skipToToken (token, TOKEN_STATEMENT_END);
1209
break;
1210
1211
case KEYWORD_record:
1212
readToken (token);
1213
if (isType (token, TOKEN_OPERATOR) &&
1214
strcmp (vStringValue (token->string), "/") == 0)
1215
{
1216
readToken (token); /* skip to structure name */
1217
readToken (token); /* skip to '/' */
1218
readToken (token); /* skip to variable name */
1219
}
1220
break;
1221
1222
case KEYWORD_type:
1223
readToken (token);
1224
if (isType (token, TOKEN_PAREN_OPEN))
1225
skipOverParens (token); /* skip type-name */
1226
else
1227
parseDerivedTypeDef (token);
1228
break;
1229
1230
default:
1231
skipToToken (token, TOKEN_STATEMENT_END);
1232
break;
1233
}
1234
}
1235
1236
static boolean skipStatementIfKeyword (tokenInfo *const token, keywordId keyword)
1237
{
1238
boolean result = FALSE;
1239
if (isKeyword (token, keyword))
1240
{
1241
result = TRUE;
1242
skipToNextStatement (token);
1243
}
1244
return result;
1245
}
1246
1247
/* parse a list of qualifying specifiers, leaving `token' at first token
1248
* following list. Examples of such specifiers are:
1249
* [[, attr-spec] ::]
1250
* [[, component-attr-spec-list] ::]
1251
*
1252
* attr-spec
1253
* is PARAMETER
1254
* or access-spec (is PUBLIC or PRIVATE)
1255
* or ALLOCATABLE
1256
* or DIMENSION ( array-spec )
1257
* or EXTERNAL
1258
* or INTENT ( intent-spec )
1259
* or INTRINSIC
1260
* or OPTIONAL
1261
* or POINTER
1262
* or SAVE
1263
* or TARGET
1264
*
1265
* component-attr-spec
1266
* is POINTER
1267
* or DIMENSION ( component-array-spec )
1268
*/
1269
static void parseQualifierSpecList (tokenInfo *const token)
1270
{
1271
do
1272
{
1273
readToken (token); /* should be an attr-spec */
1274
switch (token->keyword)
1275
{
1276
case KEYWORD_parameter:
1277
case KEYWORD_allocatable:
1278
case KEYWORD_external:
1279
case KEYWORD_intrinsic:
1280
case KEYWORD_optional:
1281
case KEYWORD_private:
1282
case KEYWORD_pointer:
1283
case KEYWORD_public:
1284
case KEYWORD_save:
1285
case KEYWORD_target:
1286
readToken (token);
1287
break;
1288
1289
case KEYWORD_dimension:
1290
case KEYWORD_intent:
1291
readToken (token);
1292
skipOverParens (token);
1293
break;
1294
1295
default: skipToToken (token, TOKEN_STATEMENT_END); break;
1296
}
1297
} while (isType (token, TOKEN_COMMA));
1298
if (! isType (token, TOKEN_DOUBLE_COLON))
1299
skipToToken (token, TOKEN_STATEMENT_END);
1300
}
1301
1302
static tagType variableTagType (void)
1303
{
1304
tagType result = TAG_VARIABLE;
1305
if (ancestorCount () > 0)
1306
{
1307
const tokenInfo* const parent = ancestorTop ();
1308
switch (parent->tag)
1309
{
1310
case TAG_MODULE: result = TAG_VARIABLE; break;
1311
case TAG_DERIVED_TYPE: result = TAG_COMPONENT; break;
1312
case TAG_FUNCTION: result = TAG_LOCAL; break;
1313
case TAG_SUBROUTINE: result = TAG_LOCAL; break;
1314
default: result = TAG_VARIABLE; break;
1315
}
1316
}
1317
return result;
1318
}
1319
1320
static void parseEntityDecl (tokenInfo *const token)
1321
{
1322
Assert (isType (token, TOKEN_IDENTIFIER));
1323
makeFortranTag (token, variableTagType ());
1324
readToken (token);
1325
if (isType (token, TOKEN_PAREN_OPEN))
1326
skipOverParens (token);
1327
if (isType (token, TOKEN_OPERATOR) &&
1328
strcmp (vStringValue (token->string), "*") == 0)
1329
{
1330
readToken (token); /* read char-length */
1331
if (isType (token, TOKEN_PAREN_OPEN))
1332
skipOverParens (token);
1333
else
1334
readToken (token);
1335
}
1336
if (isType (token, TOKEN_OPERATOR))
1337
{
1338
if (strcmp (vStringValue (token->string), "/") == 0)
1339
{ /* skip over initializations of structure field */
1340
readToken (token);
1341
skipPast (token, TOKEN_OPERATOR);
1342
}
1343
else if (strcmp (vStringValue (token->string), "=") == 0)
1344
{
1345
while (! isType (token, TOKEN_COMMA) &&
1346
! isType (token, TOKEN_STATEMENT_END))
1347
{
1348
readToken (token);
1349
if (isType (token, TOKEN_PAREN_OPEN))
1350
skipOverParens (token);
1351
}
1352
}
1353
}
1354
/* token left at either comma or statement end */
1355
}
1356
1357
static void parseEntityDeclList (tokenInfo *const token)
1358
{
1359
if (isType (token, TOKEN_PERCENT))
1360
skipToNextStatement (token);
1361
else while (isType (token, TOKEN_IDENTIFIER) ||
1362
(isType (token, TOKEN_KEYWORD) &&
1363
!isKeyword (token, KEYWORD_function) &&
1364
!isKeyword (token, KEYWORD_subroutine)))
1365
{
1366
/* compilers accept keywoeds as identifiers */
1367
if (isType (token, TOKEN_KEYWORD))
1368
token->type = TOKEN_IDENTIFIER;
1369
parseEntityDecl (token);
1370
if (isType (token, TOKEN_COMMA))
1371
readToken (token);
1372
else if (isType (token, TOKEN_STATEMENT_END))
1373
{
1374
skipToNextStatement (token);
1375
break;
1376
}
1377
}
1378
}
1379
1380
/* type-declaration-stmt is
1381
* type-spec [[, attr-spec] ... ::] entity-decl-list
1382
*/
1383
static void parseTypeDeclarationStmt (tokenInfo *const token)
1384
{
1385
Assert (isTypeSpec (token));
1386
parseTypeSpec (token);
1387
if (!isType (token, TOKEN_STATEMENT_END)) /* if not end of derived type... */
1388
{
1389
if (isType (token, TOKEN_COMMA))
1390
parseQualifierSpecList (token);
1391
if (isType (token, TOKEN_DOUBLE_COLON))
1392
readToken (token);
1393
parseEntityDeclList (token);
1394
}
1395
if (isType (token, TOKEN_STATEMENT_END))
1396
skipToNextStatement (token);
1397
}
1398
1399
/* namelist-stmt is
1400
* NAMELIST /namelist-group-name/ namelist-group-object-list
1401
* [[,]/[namelist-group-name]/ namelist-block-object-list] ...
1402
*
1403
* namelist-group-object is
1404
* variable-name
1405
*
1406
* common-stmt is
1407
* COMMON [/[common-block-name]/] common-block-object-list
1408
* [[,]/[common-block-name]/ common-block-object-list] ...
1409
*
1410
* common-block-object is
1411
* variable-name [ ( explicit-shape-spec-list ) ]
1412
*/
1413
static void parseCommonNamelistStmt (tokenInfo *const token, tagType type)
1414
{
1415
Assert (isKeyword (token, KEYWORD_common) ||
1416
isKeyword (token, KEYWORD_namelist));
1417
readToken (token);
1418
do
1419
{
1420
if (isType (token, TOKEN_OPERATOR) &&
1421
strcmp (vStringValue (token->string), "/") == 0)
1422
{
1423
readToken (token);
1424
if (isType (token, TOKEN_IDENTIFIER))
1425
{
1426
makeFortranTag (token, type);
1427
readToken (token);
1428
}
1429
skipPast (token, TOKEN_OPERATOR);
1430
}
1431
if (isType (token, TOKEN_IDENTIFIER))
1432
makeFortranTag (token, TAG_LOCAL);
1433
readToken (token);
1434
if (isType (token, TOKEN_PAREN_OPEN))
1435
skipOverParens (token); /* skip explicit-shape-spec-list */
1436
if (isType (token, TOKEN_COMMA))
1437
readToken (token);
1438
} while (! isType (token, TOKEN_STATEMENT_END));
1439
skipToNextStatement (token);
1440
}
1441
1442
static void parseFieldDefinition (tokenInfo *const token)
1443
{
1444
if (isTypeSpec (token))
1445
parseTypeDeclarationStmt (token);
1446
else if (isKeyword (token, KEYWORD_structure))
1447
parseStructureStmt (token);
1448
else if (isKeyword (token, KEYWORD_union))
1449
parseUnionStmt (token);
1450
else
1451
skipToNextStatement (token);
1452
}
1453
1454
static void parseMap (tokenInfo *const token)
1455
{
1456
Assert (isKeyword (token, KEYWORD_map));
1457
skipToNextStatement (token);
1458
while (! isKeyword (token, KEYWORD_end))
1459
parseFieldDefinition (token);
1460
readSubToken (token);
1461
Assert (isSecondaryKeyword (token, KEYWORD_map));
1462
skipToNextStatement (token);
1463
}
1464
1465
/* UNION
1466
* MAP
1467
* [field-definition] [field-definition] ...
1468
* END MAP
1469
* MAP
1470
* [field-definition] [field-definition] ...
1471
* END MAP
1472
* [MAP
1473
* [field-definition]
1474
* [field-definition] ...
1475
* END MAP] ...
1476
* END UNION
1477
* *
1478
*
1479
* Typed data declarations (variables or arrays) in structure declarations
1480
* have the form of normal Fortran typed data declarations. Data items with
1481
* different types can be freely intermixed within a structure declaration.
1482
*
1483
* Unnamed fields can be declared in a structure by specifying the pseudo
1484
* name %FILL in place of an actual field name. You can use this mechanism to
1485
* generate empty space in a record for purposes such as alignment.
1486
*
1487
* All mapped field declarations that are made within a UNION declaration
1488
* share a common location within the containing structure. When initializing
1489
* the fields within a UNION, the final initialization value assigned
1490
* overlays any value previously assigned to a field definition that shares
1491
* that field.
1492
*/
1493
static void parseUnionStmt (tokenInfo *const token)
1494
{
1495
Assert (isKeyword (token, KEYWORD_union));
1496
skipToNextStatement (token);
1497
while (isKeyword (token, KEYWORD_map))
1498
parseMap (token);
1499
Assert (isKeyword (token, KEYWORD_end));
1500
readSubToken (token);
1501
Assert (isSecondaryKeyword (token, KEYWORD_union));
1502
skipToNextStatement (token);
1503
}
1504
1505
/* STRUCTURE [/structure-name/] [field-names]
1506
* [field-definition]
1507
* [field-definition] ...
1508
* END STRUCTURE
1509
*
1510
* structure-name
1511
* identifies the structure in a subsequent RECORD statement.
1512
* Substructures can be established within a structure by means of either
1513
* a nested STRUCTURE declaration or a RECORD statement.
1514
*
1515
* field-names
1516
* (for substructure declarations only) one or more names having the
1517
* structure of the substructure being defined.
1518
*
1519
* field-definition
1520
* can be one or more of the following:
1521
*
1522
* Typed data declarations, which can optionally include one or more
1523
* data initialization values.
1524
*
1525
* Substructure declarations (defined by either RECORD statements or
1526
* subsequent STRUCTURE statements).
1527
*
1528
* UNION declarations, which are mapped fields defined by a block of
1529
* statements. The syntax of a UNION declaration is described below.
1530
*
1531
* PARAMETER statements, which do not affect the form of the
1532
* structure.
1533
*/
1534
static void parseStructureStmt (tokenInfo *const token)
1535
{
1536
tokenInfo *name;
1537
Assert (isKeyword (token, KEYWORD_structure));
1538
readToken (token);
1539
if (isType (token, TOKEN_OPERATOR) &&
1540
strcmp (vStringValue (token->string), "/") == 0)
1541
{ /* read structure name */
1542
readToken (token);
1543
if (isType (token, TOKEN_IDENTIFIER))
1544
makeFortranTag (token, TAG_DERIVED_TYPE);
1545
name = newTokenFrom (token);
1546
skipPast (token, TOKEN_OPERATOR);
1547
}
1548
else
1549
{ /* fake out anonymous structure */
1550
name = newToken ();
1551
name->type = TOKEN_IDENTIFIER;
1552
name->tag = TAG_DERIVED_TYPE;
1553
vStringCopyS (name->string, "anonymous");
1554
}
1555
while (isType (token, TOKEN_IDENTIFIER))
1556
{ /* read field names */
1557
makeFortranTag (token, TAG_COMPONENT);
1558
readToken (token);
1559
if (isType (token, TOKEN_COMMA))
1560
readToken (token);
1561
}
1562
skipToNextStatement (token);
1563
ancestorPush (name);
1564
while (! isKeyword (token, KEYWORD_end))
1565
parseFieldDefinition (token);
1566
readSubToken (token);
1567
Assert (isSecondaryKeyword (token, KEYWORD_structure));
1568
skipToNextStatement (token);
1569
ancestorPop ();
1570
deleteToken (name);
1571
}
1572
1573
/* specification-stmt
1574
* is access-stmt (is access-spec [[::] access-id-list)
1575
* or allocatable-stmt (is ALLOCATABLE [::] array-name etc.)
1576
* or common-stmt (is COMMON [ / [common-block-name] /] etc.)
1577
* or data-stmt (is DATA data-stmt-list [[,] data-stmt-set] ...)
1578
* or dimension-stmt (is DIMENSION [::] array-name etc.)
1579
* or equivalence-stmt (is EQUIVALENCE equivalence-set-list)
1580
* or external-stmt (is EXTERNAL etc.)
1581
* or intent-stmt (is INTENT ( intent-spec ) [::] etc.)
1582
* or instrinsic-stmt (is INTRINSIC etc.)
1583
* or namelist-stmt (is NAMELIST / namelist-group-name / etc.)
1584
* or optional-stmt (is OPTIONAL [::] etc.)
1585
* or pointer-stmt (is POINTER [::] object-name etc.)
1586
* or save-stmt (is SAVE etc.)
1587
* or target-stmt (is TARGET [::] object-name etc.)
1588
*
1589
* access-spec is PUBLIC or PRIVATE
1590
*/
1591
static boolean parseSpecificationStmt (tokenInfo *const token)
1592
{
1593
boolean result = TRUE;
1594
switch (token->keyword)
1595
{
1596
case KEYWORD_common:
1597
parseCommonNamelistStmt (token, TAG_COMMON_BLOCK);
1598
break;
1599
1600
case KEYWORD_namelist:
1601
parseCommonNamelistStmt (token, TAG_NAMELIST);
1602
break;
1603
1604
case KEYWORD_structure:
1605
parseStructureStmt (token);
1606
break;
1607
1608
case KEYWORD_allocatable:
1609
case KEYWORD_data:
1610
case KEYWORD_dimension:
1611
case KEYWORD_equivalence:
1612
case KEYWORD_external:
1613
case KEYWORD_intent:
1614
case KEYWORD_intrinsic:
1615
case KEYWORD_optional:
1616
case KEYWORD_pointer:
1617
case KEYWORD_private:
1618
case KEYWORD_public:
1619
case KEYWORD_save:
1620
case KEYWORD_target:
1621
skipToNextStatement (token);
1622
break;
1623
1624
default:
1625
result = FALSE;
1626
break;
1627
}
1628
return result;
1629
}
1630
1631
/* component-def-stmt is
1632
* type-spec [[, component-attr-spec-list] ::] component-decl-list
1633
*
1634
* component-decl is
1635
* component-name [ ( component-array-spec ) ] [ * char-length ]
1636
*/
1637
static void parseComponentDefStmt (tokenInfo *const token)
1638
{
1639
Assert (isTypeSpec (token));
1640
parseTypeSpec (token);
1641
if (isType (token, TOKEN_COMMA))
1642
parseQualifierSpecList (token);
1643
if (isType (token, TOKEN_DOUBLE_COLON))
1644
readToken (token);
1645
parseEntityDeclList (token);
1646
}
1647
1648
/* derived-type-def is
1649
* derived-type-stmt is (TYPE [[, access-spec] ::] type-name
1650
* [private-sequence-stmt] ... (is PRIVATE or SEQUENCE)
1651
* component-def-stmt
1652
* [component-def-stmt] ...
1653
* end-type-stmt
1654
*/
1655
static void parseDerivedTypeDef (tokenInfo *const token)
1656
{
1657
if (isType (token, TOKEN_COMMA))
1658
parseQualifierSpecList (token);
1659
if (isType (token, TOKEN_DOUBLE_COLON))
1660
readToken (token);
1661
if (isType (token, TOKEN_IDENTIFIER))
1662
makeFortranTag (token, TAG_DERIVED_TYPE);
1663
ancestorPush (token);
1664
skipToNextStatement (token);
1665
if (isKeyword (token, KEYWORD_private) ||
1666
isKeyword (token, KEYWORD_sequence))
1667
{
1668
skipToNextStatement (token);
1669
}
1670
while (! isKeyword (token, KEYWORD_end))
1671
{
1672
if (isTypeSpec (token))
1673
parseComponentDefStmt (token);
1674
else
1675
skipToNextStatement (token);
1676
}
1677
readSubToken (token);
1678
Assert (isSecondaryKeyword (token, KEYWORD_type));
1679
skipToToken (token, TOKEN_STATEMENT_END);
1680
ancestorPop ();
1681
}
1682
1683
/* interface-block
1684
* interface-stmt (is INTERFACE [generic-spec])
1685
* [interface-body]
1686
* [module-procedure-stmt] ...
1687
* end-interface-stmt (is END INTERFACE)
1688
*
1689
* generic-spec
1690
* is generic-name
1691
* or OPERATOR ( defined-operator )
1692
* or ASSIGNMENT ( = )
1693
*
1694
* interface-body
1695
* is function-stmt
1696
* [specification-part]
1697
* end-function-stmt
1698
* or subroutine-stmt
1699
* [specification-part]
1700
* end-subroutine-stmt
1701
*
1702
* module-procedure-stmt is
1703
* MODULE PROCEDURE procedure-name-list
1704
*/
1705
static void parseInterfaceBlock (tokenInfo *const token)
1706
{
1707
tokenInfo *name = NULL;
1708
Assert (isKeyword (token, KEYWORD_interface));
1709
readToken (token);
1710
if (isType (token, TOKEN_IDENTIFIER))
1711
{
1712
makeFortranTag (token, TAG_INTERFACE);
1713
name = newTokenFrom (token);
1714
}
1715
else if (isKeyword (token, KEYWORD_assignment) ||
1716
isKeyword (token, KEYWORD_operator))
1717
{
1718
readToken (token);
1719
if (isType (token, TOKEN_PAREN_OPEN))
1720
readToken (token);
1721
if (isType (token, TOKEN_OPERATOR))
1722
{
1723
makeFortranTag (token, TAG_INTERFACE);
1724
name = newTokenFrom (token);
1725
}
1726
}
1727
if (name == NULL)
1728
{
1729
name = newToken ();
1730
name->type = TOKEN_IDENTIFIER;
1731
name->tag = TAG_INTERFACE;
1732
}
1733
ancestorPush (name);
1734
while (! isKeyword (token, KEYWORD_end))
1735
{
1736
switch (token->keyword)
1737
{
1738
case KEYWORD_function: parseFunctionSubprogram (token); break;
1739
case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
1740
1741
default:
1742
if (isSubprogramPrefix (token))
1743
readToken (token);
1744
else if (isTypeSpec (token))
1745
parseTypeSpec (token);
1746
else
1747
skipToNextStatement (token);
1748
break;
1749
}
1750
}
1751
readSubToken (token);
1752
Assert (isSecondaryKeyword (token, KEYWORD_interface));
1753
skipToNextStatement (token);
1754
ancestorPop ();
1755
deleteToken (name);
1756
}
1757
1758
/* entry-stmt is
1759
* ENTRY entry-name [ ( dummy-arg-list ) ]
1760
*/
1761
static void parseEntryStmt (tokenInfo *const token)
1762
{
1763
Assert (isKeyword (token, KEYWORD_entry));
1764
readToken (token);
1765
if (isType (token, TOKEN_IDENTIFIER))
1766
makeFortranTag (token, TAG_ENTRY_POINT);
1767
skipToNextStatement (token);
1768
}
1769
1770
/* stmt-function-stmt is
1771
* function-name ([dummy-arg-name-list]) = scalar-expr
1772
*/
1773
static boolean parseStmtFunctionStmt (tokenInfo *const token)
1774
{
1775
boolean result = FALSE;
1776
Assert (isType (token, TOKEN_IDENTIFIER));
1777
#if 0 /* cannot reliably parse this yet */
1778
makeFortranTag (token, TAG_FUNCTION);
1779
#endif
1780
readToken (token);
1781
if (isType (token, TOKEN_PAREN_OPEN))
1782
{
1783
skipOverParens (token);
1784
result = (boolean) (isType (token, TOKEN_OPERATOR) &&
1785
strcmp (vStringValue (token->string), "=") == 0);
1786
}
1787
skipToNextStatement (token);
1788
return result;
1789
}
1790
1791
static boolean isIgnoredDeclaration (tokenInfo *const token)
1792
{
1793
boolean result;
1794
switch (token->keyword)
1795
{
1796
case KEYWORD_cexternal:
1797
case KEYWORD_cglobal:
1798
case KEYWORD_dllexport:
1799
case KEYWORD_dllimport:
1800
case KEYWORD_external:
1801
case KEYWORD_format:
1802
case KEYWORD_include:
1803
case KEYWORD_inline:
1804
case KEYWORD_parameter:
1805
case KEYWORD_pascal:
1806
case KEYWORD_pexternal:
1807
case KEYWORD_pglobal:
1808
case KEYWORD_static:
1809
case KEYWORD_value:
1810
case KEYWORD_virtual:
1811
case KEYWORD_volatile:
1812
result = TRUE;
1813
break;
1814
1815
default:
1816
result = FALSE;
1817
break;
1818
}
1819
return result;
1820
}
1821
1822
/* declaration-construct
1823
* [derived-type-def]
1824
* [interface-block]
1825
* [type-declaration-stmt]
1826
* [specification-stmt]
1827
* [parameter-stmt] (is PARAMETER ( named-constant-def-list )
1828
* [format-stmt] (is FORMAT format-specification)
1829
* [entry-stmt]
1830
* [stmt-function-stmt]
1831
*/
1832
static boolean parseDeclarationConstruct (tokenInfo *const token)
1833
{
1834
boolean result = TRUE;
1835
switch (token->keyword)
1836
{
1837
case KEYWORD_entry: parseEntryStmt (token); break;
1838
case KEYWORD_interface: parseInterfaceBlock (token); break;
1839
case KEYWORD_stdcall: readToken (token); break;
1840
/* derived type handled by parseTypeDeclarationStmt(); */
1841
1842
case KEYWORD_automatic:
1843
readToken (token);
1844
if (isTypeSpec (token))
1845
parseTypeDeclarationStmt (token);
1846
else
1847
skipToNextStatement (token);
1848
result = TRUE;
1849
break;
1850
1851
default:
1852
if (isIgnoredDeclaration (token))
1853
skipToNextStatement (token);
1854
else if (isTypeSpec (token))
1855
{
1856
parseTypeDeclarationStmt (token);
1857
result = TRUE;
1858
}
1859
else if (isType (token, TOKEN_IDENTIFIER))
1860
result = parseStmtFunctionStmt (token);
1861
else
1862
result = parseSpecificationStmt (token);
1863
break;
1864
}
1865
return result;
1866
}
1867
1868
/* implicit-part-stmt
1869
* is [implicit-stmt] (is IMPLICIT etc.)
1870
* or [parameter-stmt] (is PARAMETER etc.)
1871
* or [format-stmt] (is FORMAT etc.)
1872
* or [entry-stmt] (is ENTRY entry-name etc.)
1873
*/
1874
static boolean parseImplicitPartStmt (tokenInfo *const token)
1875
{
1876
boolean result = TRUE;
1877
switch (token->keyword)
1878
{
1879
case KEYWORD_entry: parseEntryStmt (token); break;
1880
1881
case KEYWORD_implicit:
1882
case KEYWORD_include:
1883
case KEYWORD_parameter:
1884
case KEYWORD_format:
1885
skipToNextStatement (token);
1886
break;
1887
1888
default: result = FALSE; break;
1889
}
1890
return result;
1891
}
1892
1893
/* specification-part is
1894
* [use-stmt] ... (is USE module-name etc.)
1895
* [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt])
1896
* [declaration-construct] ...
1897
*/
1898
static boolean parseSpecificationPart (tokenInfo *const token)
1899
{
1900
boolean result = FALSE;
1901
while (skipStatementIfKeyword (token, KEYWORD_use))
1902
result = TRUE;
1903
while (parseImplicitPartStmt (token))
1904
result = TRUE;
1905
while (parseDeclarationConstruct (token))
1906
result = TRUE;
1907
return result;
1908
}
1909
1910
/* block-data is
1911
* block-data-stmt (is BLOCK DATA [block-data-name]
1912
* [specification-part]
1913
* end-block-data-stmt (is END [BLOCK DATA [block-data-name]])
1914
*/
1915
static void parseBlockData (tokenInfo *const token)
1916
{
1917
Assert (isKeyword (token, KEYWORD_block));
1918
readToken (token);
1919
if (isKeyword (token, KEYWORD_data))
1920
{
1921
readToken (token);
1922
if (isType (token, TOKEN_IDENTIFIER))
1923
makeFortranTag (token, TAG_BLOCK_DATA);
1924
}
1925
ancestorPush (token);
1926
skipToNextStatement (token);
1927
parseSpecificationPart (token);
1928
while (! isKeyword (token, KEYWORD_end))
1929
skipToNextStatement (token);
1930
readSubToken (token);
1931
Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
1932
isSecondaryKeyword (token, KEYWORD_block));
1933
skipToNextStatement (token);
1934
ancestorPop ();
1935
}
1936
1937
/* internal-subprogram-part is
1938
* contains-stmt (is CONTAINS)
1939
* internal-subprogram
1940
* [internal-subprogram] ...
1941
*
1942
* internal-subprogram
1943
* is function-subprogram
1944
* or subroutine-subprogram
1945
*/
1946
static void parseInternalSubprogramPart (tokenInfo *const token)
1947
{
1948
boolean done = FALSE;
1949
if (isKeyword (token, KEYWORD_contains))
1950
skipToNextStatement (token);
1951
do
1952
{
1953
switch (token->keyword)
1954
{
1955
case KEYWORD_function: parseFunctionSubprogram (token); break;
1956
case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
1957
case KEYWORD_end: done = TRUE; break;
1958
1959
default:
1960
if (isSubprogramPrefix (token))
1961
readToken (token);
1962
else if (isTypeSpec (token))
1963
parseTypeSpec (token);
1964
else
1965
readToken (token);
1966
break;
1967
}
1968
} while (! done);
1969
}
1970
1971
/* module is
1972
* mudule-stmt (is MODULE module-name)
1973
* [specification-part]
1974
* [module-subprogram-part]
1975
* end-module-stmt (is END [MODULE [module-name]])
1976
*
1977
* module-subprogram-part
1978
* contains-stmt (is CONTAINS)
1979
* module-subprogram
1980
* [module-subprogram] ...
1981
*
1982
* module-subprogram
1983
* is function-subprogram
1984
* or subroutine-subprogram
1985
*/
1986
static void parseModule (tokenInfo *const token)
1987
{
1988
Assert (isKeyword (token, KEYWORD_module));
1989
readToken (token);
1990
if (isType (token, TOKEN_IDENTIFIER))
1991
makeFortranTag (token, TAG_MODULE);
1992
ancestorPush (token);
1993
skipToNextStatement (token);
1994
parseSpecificationPart (token);
1995
if (isKeyword (token, KEYWORD_contains))
1996
parseInternalSubprogramPart (token);
1997
while (! isKeyword (token, KEYWORD_end))
1998
skipToNextStatement (token);
1999
readSubToken (token);
2000
Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
2001
isSecondaryKeyword (token, KEYWORD_module));
2002
skipToNextStatement (token);
2003
ancestorPop ();
2004
}
2005
2006
/* execution-part
2007
* executable-construct
2008
*
2009
* executable-contstruct is
2010
* execution-part-construct [execution-part-construct]
2011
*
2012
* execution-part-construct
2013
* is executable-construct
2014
* or format-stmt
2015
* or data-stmt
2016
* or entry-stmt
2017
*/
2018
static boolean parseExecutionPart (tokenInfo *const token)
2019
{
2020
boolean result = FALSE;
2021
boolean done = FALSE;
2022
while (! done)
2023
{
2024
switch (token->keyword)
2025
{
2026
default:
2027
if (isSubprogramPrefix (token))
2028
readToken (token);
2029
else
2030
skipToNextStatement (token);
2031
result = TRUE;
2032
break;
2033
2034
case KEYWORD_entry:
2035
parseEntryStmt (token);
2036
result = TRUE;
2037
break;
2038
2039
case KEYWORD_contains:
2040
case KEYWORD_function:
2041
case KEYWORD_subroutine:
2042
done = TRUE;
2043
break;
2044
2045
case KEYWORD_end:
2046
readSubToken (token);
2047
if (isSecondaryKeyword (token, KEYWORD_do) ||
2048
isSecondaryKeyword (token, KEYWORD_if) ||
2049
isSecondaryKeyword (token, KEYWORD_select) ||
2050
isSecondaryKeyword (token, KEYWORD_where))
2051
{
2052
skipToNextStatement (token);
2053
result = TRUE;
2054
}
2055
else
2056
done = TRUE;
2057
break;
2058
}
2059
}
2060
return result;
2061
}
2062
2063
static void parseSubprogram (tokenInfo *const token, const tagType tag)
2064
{
2065
Assert (isKeyword (token, KEYWORD_program) ||
2066
isKeyword (token, KEYWORD_function) ||
2067
isKeyword (token, KEYWORD_subroutine));
2068
readToken (token);
2069
if (isType (token, TOKEN_IDENTIFIER))
2070
makeFortranTag (token, tag);
2071
ancestorPush (token);
2072
skipToNextStatement (token);
2073
parseSpecificationPart (token);
2074
parseExecutionPart (token);
2075
if (isKeyword (token, KEYWORD_contains))
2076
parseInternalSubprogramPart (token);
2077
Assert (isKeyword (token, KEYWORD_end));
2078
readSubToken (token);
2079
Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
2080
isSecondaryKeyword (token, KEYWORD_program) ||
2081
isSecondaryKeyword (token, KEYWORD_function) ||
2082
isSecondaryKeyword (token, KEYWORD_subroutine));
2083
skipToNextStatement (token);
2084
ancestorPop ();
2085
}
2086
2087
2088
/* function-subprogram is
2089
* function-stmt (is [prefix] FUNCTION function-name etc.)
2090
* [specification-part]
2091
* [execution-part]
2092
* [internal-subprogram-part]
2093
* end-function-stmt (is END [FUNCTION [function-name]])
2094
*
2095
* prefix
2096
* is type-spec [RECURSIVE]
2097
* or [RECURSIVE] type-spec
2098
*/
2099
static void parseFunctionSubprogram (tokenInfo *const token)
2100
{
2101
parseSubprogram (token, TAG_FUNCTION);
2102
}
2103
2104
/* subroutine-subprogram is
2105
* subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.)
2106
* [specification-part]
2107
* [execution-part]
2108
* [internal-subprogram-part]
2109
* end-subroutine-stmt (is END [SUBROUTINE [function-name]])
2110
*/
2111
static void parseSubroutineSubprogram (tokenInfo *const token)
2112
{
2113
parseSubprogram (token, TAG_SUBROUTINE);
2114
}
2115
2116
/* main-program is
2117
* [program-stmt] (is PROGRAM program-name)
2118
* [specification-part]
2119
* [execution-part]
2120
* [internal-subprogram-part ]
2121
* end-program-stmt
2122
*/
2123
static void parseMainProgram (tokenInfo *const token)
2124
{
2125
parseSubprogram (token, TAG_PROGRAM);
2126
}
2127
2128
/* program-unit
2129
* is main-program
2130
* or external-subprogram (is function-subprogram or subroutine-subprogram)
2131
* or module
2132
* or block-data
2133
*/
2134
static void parseProgramUnit (tokenInfo *const token)
2135
{
2136
readToken (token);
2137
do
2138
{
2139
if (isType (token, TOKEN_STATEMENT_END))
2140
readToken (token);
2141
else switch (token->keyword)
2142
{
2143
case KEYWORD_block: parseBlockData (token); break;
2144
case KEYWORD_end: skipToNextStatement (token); break;
2145
case KEYWORD_function: parseFunctionSubprogram (token); break;
2146
case KEYWORD_module: parseModule (token); break;
2147
case KEYWORD_program: parseMainProgram (token); break;
2148
case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
2149
2150
default:
2151
if (isSubprogramPrefix (token))
2152
readToken (token);
2153
else
2154
{
2155
boolean one = parseSpecificationPart (token);
2156
boolean two = parseExecutionPart (token);
2157
if (! (one || two))
2158
readToken (token);
2159
}
2160
break;
2161
}
2162
} while (TRUE);
2163
}
2164
2165
static boolean findFortranTags (const unsigned int passCount)
2166
{
2167
tokenInfo *token;
2168
exception_t exception;
2169
boolean retry;
2170
2171
Assert (passCount < 3);
2172
Parent = newToken ();
2173
token = newToken ();
2174
FreeSourceForm = (boolean) (passCount > 1);
2175
Column = 0;
2176
exception = (exception_t) setjmp (Exception);
2177
if (exception == ExceptionEOF)
2178
retry = FALSE;
2179
else if (exception == ExceptionFixedFormat && ! FreeSourceForm)
2180
{
2181
verbose ("%s: not fixed source form; retry as free source form\n",
2182
getInputFileName ());
2183
retry = TRUE;
2184
}
2185
else
2186
{
2187
parseProgramUnit (token);
2188
retry = FALSE;
2189
}
2190
ancestorClear ();
2191
deleteToken (token);
2192
deleteToken (Parent);
2193
2194
return retry;
2195
}
2196
2197
static void initialize (const langType language)
2198
{
2199
Lang_fortran = language;
2200
buildFortranKeywordHash ();
2201
}
2202
2203
extern parserDefinition* FortranParser (void)
2204
{
2205
static const char *const extensions [] = {
2206
"f", "for", "ftn", "f77", "f90", "f95",
2207
#ifndef CASE_INSENSITIVE_FILENAMES
2208
"F", "FOR", "FTN", "F77", "F90", "F95",
2209
#endif
2210
NULL
2211
};
2212
parserDefinition* def = parserNew ("Fortran");
2213
def->kinds = FortranKinds;
2214
def->kindCount = KIND_COUNT (FortranKinds);
2215
def->extensions = extensions;
2216
def->parser2 = findFortranTags;
2217
def->initialize = initialize;
2218
return def;
2219
}
2220
2221
/* vi:set tabstop=8 shiftwidth=4: */
Loggerhead is a web-based interface for Breezy
Version: 2.0.1