1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /**
19 * \file
20 * \brief Fortran parser module
21 *
22 * contents:
23 *
24 * parser() - parse and semantically analyze one
25 * user subprogram unit.
26 * parse_init() - initialize parsing of new statement.
27 * next_state(state, tkntyp) - look up next state in parse tables.
28 * prettytoken(tkntyp, tknval) - returns string of token
29 */
30
31 #include "ccffinfo.h"
32 #include "gbldefs.h"
33 #include "gramtk.h"
34 #include "gramsm.h"
35 #include "global.h"
36 #include "error.h"
37 #include "symtab.h"
38 #include "semant.h"
39 #include "semstk.h"
40 #include "gramdf.h"
41 #if DEBUG
42 #include "proddf.h"
43 #endif
44 #include "tokdf.h"
45 #include "scan.h"
46
47 #define LOOP while (TRUE)
48 #define NOSTATE ((int)(-1))
49
50 typedef short int PSTACK;
51 static PSTACK *pstack; /* parse stack */
52 static int sst_size = 0; /* current size of parse & semantic stacks */
53 static int cstate; /* current parse state */
54 static int stktop;
55 static INT ctknval; /* 'value' of current token */
56 static int next_state(int, int);
57 static LOGICAL is_declaration(int);
58
59 /* Function pointers indexed by sem.which_pass */
60 static void (*p_semant1[])(int, SST *) = {semant1, semant1};
61 static void (*p_semant2[])(int, SST *) = {NULL, semant2};
62 static void (*p_semant3[])(int, SST *) = {psemant3, semant3};
63 static void (*p_semantio[])(int, SST *) = {psemantio, semantio};
64 static void (*p_semsmp[])(int, SST *) = {psemsmp, semsmp};
65
66 static void _parser(void); /* core parsing function */
67 static char *prettytoken(int, INT);
68
69 void
parser(void)70 parser(void)
71 {
72 static int maxsev;
73 LOGICAL skip_first_pass;
74 ISZ_T save_bss_addr, save_saddr;
75 int save_lineno;
76
77 skip_first_pass = TRUE;
78 if (gbl.internal == 0 && sem.mod_cnt <= 1) {
79 /*
80 * Perform the first pass on a subprogram or all module-contained
81 * contained subprograms. Semantic analysis is not performed on
82 * the executable statements.
83 */
84 skip_first_pass = FALSE;
85 sem.which_pass = 0;
86 reset_internal_subprograms();
87 save_bss_addr = get_bss_addr();
88 save_saddr = gbl.saddr;
89 save_lineno = gbl.lineno;
90 if (!XBIT(120, 0x4000000)) {
91 set_allfiles(0); /* Store file indexes */
92 }
93 fe_init(); /* init the scanner for the first parse */
94 #if DEBUG
95 if (DBGBIT(1, 1) || DBGBIT(2, 1))
96 fprintf(gbl.dbgfil, "----- First Parse -----\n");
97 #endif
98 _parser();
99 maxsev = gbl.maxsev;
100 if (sem.mod_cnt) {
101 /*
102 * Either a module specification or the first module-contained
103 * subprogram was just parsed. If an error occurred, issue the
104 * error summary now.
105 */
106 if (maxsev >= 3)
107 summary(FALSE, FALSE);
108 if (gbl.rutype == RU_BDATA)
109 /*
110 * A module specification part was parsed. Either:
111 * 1. a CONTAINS within the module terminated the first
112 * parse (scan sets scn.end_program_unit to TRUE), or
113 * 2. a module without contained subprograms was parsed.
114 * Now, just produce the module-created blockdata - the second
115 * parse isn't performed.
116 */
117 return;
118 /*
119 * At this point, either:
120 * 1. a module specification part with errors was parsed, or
121 * 2. the first module-contained subprogram was parsed (errors
122 * could have been detected).
123 * Perform the first parse on the remaining contained subprograms,
124 * recording the maximum error level detected for the all of the
125 * contained subprograms.
126 */
127 while (sem.mod_cnt == 1) {
128 reinit();
129 errini();
130 _parser();
131 if (gbl.maxsev > maxsev)
132 maxsev = gbl.maxsev;
133 if (maxsev >= 3 && gbl.currsub)
134 summary(FALSE, FALSE);
135 }
136 }
137 resolve_fwd_refs();
138 set_bss_addr(save_bss_addr);
139 gbl.saddr = save_saddr;
140 gbl.lineno = save_lineno;
141 if (!XBIT(120, 0x4000000)) {
142 set_allfiles(1); /* Retrieve file indexes */
143 }
144 }
145 /*
146 * At this point, we're ready to perform the second parse (includes
147 * executable statements). The second parse is performed on a host
148 * subprogram, an internal subprogram, or module-contained subprogram
149 * if errors were not detected during the first parse.
150 */
151 if (maxsev < 3) {
152 fe_restart();
153 if (!skip_first_pass)
154 reinit();
155 sem.which_pass = 1;
156 p_semant1[1] = semant1;
157 p_semant2[1] = semant2;
158 #if DEBUG
159 if (DBGBIT(1, 1) || DBGBIT(2, 1))
160 fprintf(gbl.dbgfil, "----- Second Parse -----\n");
161 #endif
162 _parser();
163 resolve_fwd_refs();
164 if (gbl.internal || sem.mod_cnt > 1)
165 /*
166 * If we're processing module-contained subprograms, make sure
167 * the scanner is initialized for the next module subprogram.
168 */
169 fe_init();
170 } else if (sem.mod_cnt == 2) {
171 /*
172 * One or more errors were detected in a module subprogram during the
173 * the first parse. Don't perform the second parse on any of the
174 * module subprograms. The ensuing call to parser() will start the
175 * first parse on the statement after the ENDMODULE statement.
176 */
177 end_module();
178 sem.mod_cnt = 0;
179 sem.mod_sym = 0;
180 sem.submod_sym = 0;
181 }
182 }
183
184 static void
_parser(void)185 _parser(void)
186 {
187 int tkntyp, newtop, rednum, get_token(), endflg;
188 int t;
189 int start, end, nstate;
190 int jstart, jend, ptr, i;
191 char *ptoken;
192
193 endflg = 0;
194 sst_size = SST_SIZE;
195 NEW(pstack, PSTACK, sst_size);
196 if (pstack == NULL)
197 error(7, 4, 0, CNULL, CNULL);
198 NEW(sst, SST, sst_size);
199 if (sst == NULL)
200 error(7, 4, 0, CNULL, CNULL);
201
202 /* set funcline to a best guess value in case profiling info is
203 requested for an unnamed program */
204 gbl.funcline = gbl.lineno + 1;
205
206 /* loop once for each statement in subprogram unit: */
207
208 LOOP
209 {
210
211 parse_init();
212
213 /* loop once for each token in current Fortran stmt: */
214
215 tkntyp = get_token(&ctknval); /* first token of a statement */
216
217 if (sem.which_pass == 0) {
218 /*
219 * For the first pass, we want to semantically analyze expressions
220 * only if they occur within a declaration statement. Also, there
221 * are semantic actions shared by the semantic analysis routines
222 * for declaration and executable statements; for the first
223 * pass, we only want these actions to be performed only if they
224 * occur within the declarations statements.
225 */
226 if (is_declaration(tkntyp) ||
227 (tkntyp == TK_GENERIC && sem.type_mode == 2) /* generic tbp */
228 ) {
229 p_semant1[0] = semant1;
230 p_semant2[0] = semant2;
231 } else {
232 p_semant2[0] = psemant2;
233 }
234 gbl.nowarn = FALSE;
235 } else {
236 if (is_declaration(tkntyp)) {
237 /* warnings issued in first pass for declarations */
238 gbl.nowarn = TRUE;
239 } else {
240 gbl.nowarn = FALSE;
241 }
242 }
243
244 LOOP
245 {
246 #if DEBUG
247 if (tkntyp < 1 || tkntyp >= (sizeof(tokname) / sizeof(char *))) {
248 interr("scan error in parser", tkntyp, 3);
249 tkntyp = TK_END;
250 }
251 #endif
252 if (scn.end_program_unit)
253 endflg = 1;
254
255 if (DBGBIT(1, 1)) {
256 fprintf(gbl.dbgfil, "tkntyp: %s tknval: %d", tokname[tkntyp], ctknval);
257 if (tkntyp == TK_IDENT)
258 fprintf(gbl.dbgfil, " (%s)", scn.id.name + ctknval);
259 fprintf(gbl.dbgfil, " lineno: %d \n", gbl.lineno);
260 }
261
262 /*
263 * loop once for each reduction which can be made with tkntyp as
264 * look ahead token (note that a production index may be 0):
265 */
266 LOOP
267 {
268
269 /*
270 * perform binary search on parse tables to determine if a
271 * reduction can be made:
272 */
273 start = fred[cstate];
274 end = fred[cstate + 1] - 1;
275 if (start > end)
276 break; /* no reduction */
277 for (i = start; i <= end; i++) {
278 jstart = lset[nset[i]];
279 jend = lset[nset[i] + 1] - 1;
280 while (jstart <= jend) {
281 ptr = (jstart + jend) >> 1;
282 t = ls[ptr];
283 if (t == tkntyp)
284 goto perform_reduction;
285 if (t < tkntyp)
286 jstart = ptr + 1;
287 else
288 jend = ptr - 1;
289 }
290 }
291 break; /* no reduction found */
292
293 perform_reduction:
294 rednum = prod[i];
295 sem.tkntyp = tkntyp;
296 if (DBGBIT(2, 1))
297 #if DEBUG
298 fprintf(gbl.dbgfil, "%4d %crod(%4d) %s\n",
299 gbl.lineno, sem.which_pass ? 'P' : 'p',
300 rednum, prodstr[rednum]);
301 #else
302 fprintf(gbl.dbgfil, " %cednum: %d\n",
303 sem.which_pass ? 'R' : 'r', rednum);
304 #endif
305
306 /* call appropriate semantic action routine: */
307
308 newtop = stktop - len[rednum] + 1;
309 if (rednum < SEM2)
310 p_semant1[sem.which_pass](rednum, &sst[newtop]);
311 else if (rednum < SEM3)
312 p_semant2[sem.which_pass](rednum, &sst[newtop]);
313 else if (rednum < SEM4)
314 p_semant3[sem.which_pass](rednum, &sst[newtop]);
315 else if (rednum < SEM5)
316 p_semantio[sem.which_pass](rednum, &sst[newtop]);
317 else
318 p_semsmp[sem.which_pass](rednum, &sst[newtop]);
319
320 if (sem.ignore_stmt) {
321 sem.ignore_stmt = FALSE;
322 goto ignore_stmt;
323 }
324
325 /* look for reduce transition: */
326
327 nstate = next_state(pstack[newtop - 1], (int)lhs[rednum]);
328 if (nstate == NOSTATE)
329 goto issue_error;
330 else {
331 cstate = nstate;
332 pstack[newtop] = nstate;
333 stktop = newtop;
334 }
335 } /* end of reduce loop. */
336
337 /* look for a read transition: */
338
339 nstate = next_state(cstate, tkntyp);
340 if (nstate == NOSTATE) {
341 /* tpr 535
342 * the grammar cannot be modified to support complex
343 * constants of the form '( const-expr , const-expr )' but
344 * can modified if a special token is returned for ',' (i.e.,
345 * a "complex comma").
346 * if a syntax error occurs when the current token is a comma,
347 * check if a "complex comma" is legal; if so, continue
348 * by parsing as if we have a complex constant, and semant
349 * will determine if the real & imag parts are constants.
350 */
351 if (tkntyp == TK_COMMA) {
352 nstate = next_state(cstate, TK_CMPLXCOMMA);
353 if (nstate != NOSTATE) {
354 if (DBGBIT(1, 1))
355 fprintf(gbl.dbgfil, ">>> comma changed to complex comma %d\n",
356 gbl.lineno);
357 goto read_trans;
358 }
359 }
360 issue_error:
361
362 ptoken = prettytoken(tkntyp, ctknval);
363 errWithSrc(34, 3, gbl.lineno, ptoken, CNULL, getCurrColumn(), 1, false,
364 getDeduceStr(ptoken));
365 sem.psfunc = FALSE; /* allow no stmt func defs */
366 break;
367 }
368 read_trans:
369 stktop++;
370 if (stktop >= sst_size) {
371 sst_size += SST_SIZE;
372 pstack = (PSTACK *)sccrelal((char *)pstack,
373 ((BIGUINT64)((sst_size) * sizeof(PSTACK))));
374 sst = (SST *)sccrelal((char *)sst, ((BIGUINT64)((sst_size) * sizeof(SST))));
375 assert(pstack != NULL, "parser:stack ovflw", stktop, 4);
376 assert(sst != NULL, "parser:stack ovflw", stktop, 4);
377 }
378 pstack[stktop] = nstate;
379 SST_SYMP(&sst[stktop], ctknval);
380 SST_LINENOP(&sst[stktop], gbl.lineno);
381 SST_COLUMNP(&sst[stktop], getCurrColumn());
382 cstate = nstate;
383
384 if (tkntyp == TK_EOL) {
385 if (endflg == 1)
386 goto parse_done;
387
388 if (!scn.multiple_stmts && gbl.eof_flag ) {
389 if (gbl.empty_contains) {
390 gbl.internal = 0;
391 goto parse_done;
392 }
393
394 errsev(22);
395 sem.mod_cnt = 0;
396 sem.mod_sym = 0;
397 sem.submod_sym = 0;
398 goto parse_done;
399 }
400 break;
401 }
402
403 tkntyp = get_token(&ctknval); /* next token in the statement */
404
405 } /* end foreach token LOOP */
406
407 ignore_stmt:;
408
409 } /* end foreach statement LOOP */
410
411 parse_done:
412 FREE(pstack);
413 FREE(sst);
414 pstack = NULL;
415 sst = NULL;
416 sst_size = 0;
417 }
418
419 /* Initialize parser to begin parsing of next Fortran statement */
420 void
parse_init(void)421 parse_init(void)
422 {
423 pstack[0] = 0;
424 pstack[1] = 1;
425 cstate = 1;
426 stktop = 1;
427
428 scan_reset();
429 }
430
431 /* Return next parse state, given current state and look ahead
432 token. NOSTATE is returned if there is no next state (syntax
433 error).
434 */
435 static int
next_state(int state,int tkntyp)436 next_state(int state, int tkntyp)
437 {
438 int start, end, ptr, t;
439
440 start = ftrn[state];
441 end = ftrn[state + 1] - 1;
442
443 while (start <= end) {
444 ptr = (start + end) >> 1;
445 t = ent[tran[ptr]];
446 if (t == tkntyp)
447 return (tran[ptr]);
448 if (t < tkntyp)
449 start = ptr + 1;
450 else
451 end = ptr - 1;
452 }
453 return (NOSTATE);
454 }
455
456 static char *
prettytoken(int tkntyp,INT tknval)457 prettytoken(int tkntyp, INT tknval)
458 {
459 static char symbuf[132];
460 INT v[2];
461
462 switch (tkntyp) {
463 case TK_EOL:
464 sprintf(symbuf, "end of line");
465 break;
466 case TK_IDENT:
467 case TK_NAMED_CONSTRUCT:
468 sprintf(symbuf, "identifier %s", scn.id.name + tknval);
469 break;
470 case TK_LOGCONST:
471 sprintf(symbuf, "logical constant %s",
472 tknval == SCFTN_TRUE ? ".TRUE." : ".FALSE.");
473 break;
474 case TK_K_LOGCONST:
475 sprintf(symbuf, "logical literal %s", getprint((int)tknval));
476 break;
477 case TK_ICON:
478 sprintf(symbuf, "integer constant %d", tknval);
479 break;
480 case TK_K_ICON:
481 sprintf(symbuf, "integer literal %s", getprint((int)tknval));
482 break;
483 case TK_RCON:
484 strcpy(symbuf, "real constant ");
485 v[0] = tknval;
486 v[1] = 0;
487 cprintf(symbuf + 14, "%.7e", v);
488 break;
489 case TK_DCON:
490 sprintf(symbuf, "doubleprecision constant %s", getprint((int)tknval));
491 break;
492 case TK_CCON:
493 sprintf(symbuf, "complex constant %s", getprint((int)tknval));
494 break;
495 case TK_DCCON:
496 sprintf(symbuf, "doublecomplex constant %s", getprint((int)tknval));
497 break;
498 case TK_HOLLERITH:
499 sprintf(symbuf, "hollerith constant %10.10s",
500 stb.n_base + CONVAL1G(tknval));
501 break;
502 case TK_NONDDEC:
503 sprintf(symbuf, "%s", getprint((int)tknval));
504 break;
505 case TK_NONDEC:
506 sprintf(symbuf, "non-decimal constant %x", tknval);
507 break;
508 case TK_CMPLXCOMMA:
509 sprintf(symbuf, ",");
510 break;
511 case TK_IOLP:
512 case TK_IMPLP:
513 sprintf(symbuf, "(");
514 break;
515 case TK_EQ:
516 if (tknval)
517 sprintf(symbuf, "==");
518 else
519 sprintf(symbuf, "%s", tokname[tkntyp]);
520 break;
521 case TK_GE:
522 if (tknval)
523 sprintf(symbuf, ">=");
524 else
525 sprintf(symbuf, "%s", tokname[tkntyp]);
526 break;
527 case TK_GT:
528 if (tknval)
529 sprintf(symbuf, ">");
530 else
531 sprintf(symbuf, "%s", tokname[tkntyp]);
532 break;
533 case TK_LE:
534 if (tknval)
535 sprintf(symbuf, "<=");
536 else
537 sprintf(symbuf, "%s", tokname[tkntyp]);
538 break;
539 case TK_LT:
540 if (tknval)
541 sprintf(symbuf, "<");
542 else
543 sprintf(symbuf, "%s", tokname[tkntyp]);
544 break;
545 case TK_NE:
546 if (tknval == (('/' << 8) | '='))
547 sprintf(symbuf, "/=");
548 else if (tknval == (('<' << 8) | '>'))
549 sprintf(symbuf, "<>");
550 else
551 sprintf(symbuf, "%s", tokname[tkntyp]);
552 break;
553 case TK_DIMATTR:
554 sprintf(symbuf, "DIMENSION");
555 break;
556 case TK_MP_ATOMIC:
557 sprintf(symbuf, "ATOMIC");
558 break;
559 case TK_MP_BARRIER:
560 sprintf(symbuf, "BARRIER");
561 break;
562 case TK_MP_CANCEL:
563 sprintf(symbuf, "%s", "CANCEL");
564 break;
565 case TK_MP_CRITICAL:
566 sprintf(symbuf, "CRITICAL");
567 break;
568 case TK_MP_DECLAREREDUCTION:
569 sprintf(symbuf, "%s", "DECLAREREDUCTION");
570 break;
571 case TK_MP_DECLARESIMD:
572 sprintf(symbuf, "%s", "DECLARESIMD");
573 break;
574 case TK_MP_DECLARETARGET:
575 sprintf(symbuf, "%s", "DECLARETARGET");
576 break;
577 case TK_MP_DISTPARDO:
578 sprintf(symbuf, "%s", "DISTRIBUTEPARALLELDO");
579 break;
580 case TK_MP_DISTPARDOSIMD:
581 sprintf(symbuf, "%s", "DISTRIBUTEPARALLELDOSIMD");
582 break;
583 case TK_MP_DISTRIBUTE:
584 sprintf(symbuf, "%s", "DISTRIBUTE");
585 break;
586 case TK_MP_DISTSIMD:
587 sprintf(symbuf, "%s", "DISTRIBUTESIMD");
588 break;
589 case TK_MP_DOSIMD:
590 sprintf(symbuf, "%s", "DOSIMD");
591 break;
592 case TK_MP_DOACROSS:
593 sprintf(symbuf, "DOACROSS");
594 break;
595 case TK_MP_ENDCRITICAL:
596 sprintf(symbuf, "ENDCRITICAL");
597 break;
598 case TK_MP_ENDMASTER:
599 sprintf(symbuf, "ENDMASTER");
600 break;
601 case TK_MP_ENDORDERED:
602 sprintf(symbuf, "ENDORDERED");
603 break;
604 case TK_MP_ENDPARALLEL:
605 sprintf(symbuf, "ENDPARALLEL");
606 break;
607 case TK_MP_ENDPARDO:
608 sprintf(symbuf, "ENDPARALLELDO");
609 break;
610 case TK_MP_ENDPARSECTIONS:
611 sprintf(symbuf, "ENDPARALLELSECTIONS");
612 break;
613 case TK_MP_ENDPDO:
614 sprintf(symbuf, "ENDDO");
615 break;
616 case TK_MP_ENDSECTIONS:
617 sprintf(symbuf, "ENDSECTIONS");
618 break;
619 case TK_MP_ENDSINGLE:
620 sprintf(symbuf, "ENDSINGLE");
621 break;
622 case TK_MP_ENDDOSIMD:
623 sprintf(symbuf, "ENDDOSIMD");
624 break;
625 case TK_MP_ENDDISTPARDO:
626 sprintf(symbuf, "%s", "ENDDISTRIBUTEPARALLELDO");
627 break;
628 case TK_MP_ENDDISTPARDOSIMD:
629 sprintf(symbuf, "%s", "ENDDISTRIBUTEPARALELLDOSIMD");
630 break;
631 case TK_MP_ENDDISTRIBUTE:
632 sprintf(symbuf, "%s", "ENDDISTRIBUTE");
633 break;
634 case TK_MP_ENDDISTSIMD:
635 sprintf(symbuf, "%s", "ENDDISTRIBUTESIMD");
636 break;
637 case TK_MP_ENDPARDOSIMD:
638 sprintf(symbuf, "%s", "ENDPARALLELDOSIMD");
639 break;
640 case TK_MP_ENDSIMD:
641 sprintf(symbuf, "%s", "ENDSIMD");
642 break;
643 case TK_MP_ENDTARGET:
644 sprintf(symbuf, "%s", "ENDTARGTARGET");
645 break;
646 case TK_MP_ENDTASK:
647 sprintf(symbuf, "%s", "ENDTASK");
648 break;
649 case TK_MP_ENDTASKLOOP:
650 sprintf(symbuf, "%s", "ENDTASKLOOP");
651 break;
652 case TK_MP_ENDTASKLOOPSIMD:
653 sprintf(symbuf, "%s", "ENDTASKLOOPSIMD");
654 break;
655 case TK_MP_ENDTEAMS:
656 sprintf(symbuf, "%s", "ENDTEAMS");
657 break;
658 case TK_MP_ENDTEAMSDIST:
659 sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTE");
660 break;
661 case TK_MP_ENDTEAMSDISTPARDO:
662 sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTEPARALLELDO");
663 break;
664 case TK_MP_ENDTEAMSDISTPARDOSIMD:
665 sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTEPARALLELDOSIMD");
666 break;
667 case TK_MP_ENDTEAMSDISTSIMD:
668 sprintf(symbuf, "%s", "ENDTEAMSDISTRIBUTESIMD");
669 break;
670 case TK_MP_FLUSH:
671 sprintf(symbuf, "FLUSH");
672 break;
673 case TK_MP_MASTER:
674 sprintf(symbuf, "MASTER");
675 break;
676 case TK_MP_ORDERED:
677 sprintf(symbuf, "ORDERED");
678 break;
679 case TK_MP_PARALLEL:
680 sprintf(symbuf, "PARALLEL");
681 break;
682 case TK_MP_PARDO:
683 sprintf(symbuf, "PARALLELDO");
684 break;
685 case TK_MP_PARSECTIONS:
686 sprintf(symbuf, "PARALLELSECTIONS");
687 break;
688 case TK_MP_PARDOSIMD:
689 sprintf(symbuf, "%s", "PARALLELDOSIMD");
690 break;
691 case TK_MP_PDO:
692 sprintf(symbuf, "DO");
693 break;
694 case TK_MP_SECTION:
695 sprintf(symbuf, "SECTION");
696 break;
697 case TK_MP_SECTIONS:
698 sprintf(symbuf, "SECTIONS");
699 break;
700 case TK_MP_SINGLE:
701 sprintf(symbuf, "SINGLE");
702 break;
703 case TK_MP_SIMD:
704 sprintf(symbuf, "SIMD");
705 break;
706 case TK_MP_TARGET:
707 sprintf(symbuf, "%s", "TARGET");
708 break;
709 case TK_MP_TARGETDATA:
710 sprintf(symbuf, "%s", "TARGETDATA");
711 break;
712 case TK_MP_TARGETENTERDATA:
713 sprintf(symbuf, "%s", "TARGETENTERDATA");
714 break;
715 case TK_MP_TARGETEXITDATA:
716 sprintf(symbuf, "%s", "TARGETEXITDATA");
717 break;
718 case TK_MP_TARGETUPDATE:
719 sprintf(symbuf, "%s", "TARGETUPDATE");
720 break;
721 case TK_MP_TARGPAR:
722 sprintf(symbuf, "%s", "TARGETPAR");
723 break;
724 case TK_MP_TARGPARDO:
725 sprintf(symbuf, "%s", "TARGETPARALLELDO");
726 break;
727 case TK_MP_TARGPARDOSIMD:
728 sprintf(symbuf, "%s", "TARGETPARALLELDOSIMD");
729 break;
730 case TK_MP_TARGPARSIMD:
731 sprintf(symbuf, "%s", "TARGETPARALLELSIMD");
732 break;
733 case TK_MP_TARGSIMD:
734 sprintf(symbuf, "%s", "TARGETSIMD");
735 break;
736 case TK_MP_TARGTEAMS:
737 sprintf(symbuf, "%s", "TARGETTEAMS");
738 break;
739 case TK_MP_TARGTEAMSDIST:
740 sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTE");
741 break;
742 case TK_MP_TARGTEAMSDISTPARDO:
743 sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTEPARALLELDO");
744 break;
745 case TK_MP_TARGTEAMSDISTPARDOSIMD:
746 sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTEPARALLELDOSIMD");
747 break;
748 case TK_MP_TARGTEAMSDISTSIMD:
749 sprintf(symbuf, "%s", "TARGETTEAMSDISTRIBUTESIMD");
750 break;
751 case TK_MP_TASK:
752 sprintf(symbuf, "%s", "TASK");
753 break;
754 case TK_MP_TASKLOOP:
755 sprintf(symbuf, "%s", "TASKLOOP");
756 break;
757 case TK_MP_TASKLOOPSIMD:
758 sprintf(symbuf, "%s", "TASKLOOPSIMD");
759 break;
760 case TK_MP_TEAMS:
761 sprintf(symbuf, "%s", "TEAMS");
762 break;
763 case TK_MP_TEAMSDIST:
764 sprintf(symbuf, "%s", "TEAMSDISTRIBUTE");
765 break;
766 case TK_MP_TEAMSDISTPARDO:
767 sprintf(symbuf, "%s", "TEAMSDISTRIBUTEPARALLELDO");
768 break;
769 case TK_MP_TEAMSDISTPARDOSIMD:
770 sprintf(symbuf, "%s", "TEAMSDISTRIBUTEPARALLELDOSIMD");
771 break;
772 case TK_MP_TEAMSDISTSIMD:
773 sprintf(symbuf, "%s", "TEAMSDISTRIBUTESIMD");
774 break;
775 case TK_MP_THREADPRIVATE:
776 sprintf(symbuf, "THREADPRIVATE");
777 break;
778 default:
779 sprintf(symbuf, "%s", tokname[tkntyp]);
780 break;
781 }
782 return symbuf;
783 }
784
785 static LOGICAL
is_declaration(int tkntyp)786 is_declaration(int tkntyp)
787 {
788 switch (tkntyp) {
789 /*
790 * It would be better if the tokens which can begin a declaration statement
791 * were produced by prstab.
792 */
793 case TK_ENDSTMT:
794 case TK_DIMATTR:
795 case TK_DIRECTIVE:
796 case TK_EMPTYFILE:
797 case TK_ABSTRACT:
798 #ifdef TK_ACCDECL
799 case TK_ACCDECL:
800 #endif
801 case TK_ALIAS:
802 case TK_ALIGN:
803 case TK_ALLOCATABLE:
804 case TK_ASYNCHRONOUS:
805 case TK_ATTRIBUTES:
806 case TK_AUTOMATIC:
807 case TK_BIND:
808 case TK_BLOCKDATA:
809 case TK_BYTE:
810 case TK_CHARACTER:
811 case TK_CLASS:
812 case TK_COMMON:
813 case TK_COMPLEX:
814 case TK_CONTIGUOUS:
815 case TK_DATA:
816 case TK_DIMENSION:
817 case TK_DBLECMPLX:
818 case TK_DBLEPREC:
819 #ifdef TK_DECLARE
820 case TK_DECLARE:
821 #endif
822 case TK_ELEMENTAL:
823 case TK_ENDBLOCKDATA:
824 case TK_ENDENUM:
825 case TK_ENDFUNCTION:
826 case TK_ENDINTERFACE:
827 case TK_ENDMAP:
828 case TK_ENDMODULE:
829 case TK_ENDPROCEDURE:
830 case TK_ENDPROGRAM:
831 case TK_ENDSTRUCTURE:
832 case TK_ENDSUBMODULE:
833 case TK_ENDSUBROUTINE:
834 case TK_ENDTYPE:
835 case TK_ENDUNION:
836 case TK_ENTRY:
837 case TK_ENUM:
838 case TK_ENUMERATOR:
839 case TK_EOL: /* just so is_executable() will produce FALSE */
840 case TK_EQUIV:
841 case TK_EXTERNAL:
842 case TK_FINAL:
843 case TK_FUNCTION:
844 case TK_IGNORE_TKR:
845 case TK_IMPORT:
846 case TK_IMPLICIT:
847 case TK_IMPURE:
848 case TK_INCLUDE:
849 case TK_INTEGER:
850 case TK_INTENT:
851 case TK_INTERFACE:
852 case TK_INTRINSIC:
853 case TK_LOCAL:
854 case TK_LOGICAL:
855 case TK_MAP:
856 case TK_MODULE:
857 case TK_MOVEDESC:
858 case TK_MP_DECLAREREDUCTION:
859 case TK_MP_DECLARESIMD:
860 case TK_MP_DECLARETARGET:
861 case TK_MP_THREADPRIVATE:
862 case TK_NAMELIST:
863 case TK_NCHARACTER:
864 case TK_NON_INTRINSIC:
865 case TK_NOSEQUENCE:
866 case TK_OPTIONAL:
867 case TK_OPTIONS:
868 case TK_PARAMETER:
869 case TK_POINTER:
870 case TK_PRIVATE:
871 case TK_PROCEDURE:
872 case TK_PROGRAM:
873 case TK_PROTECTED:
874 case TK_PUBLIC:
875 case TK_PURE:
876 case TK_REAL:
877 case TK_RECORD:
878 case TK_RECURSIVE:
879 case TK_SAVE:
880 case TK_SEQUENCE:
881 case TK_STATIC:
882 case TK_STRUCTURE:
883 case TK_SUBMODULE:
884 case TK_SUBROUTINE:
885 case TK_TARGET:
886 case TK_TCONTAINS:
887 case TK_TPROCEDURE:
888 case TK_TYPE:
889 case TK_UNION:
890 case TK_USE:
891 case TK_VALUE:
892 case TK_VOLATILE:
893 return TRUE;
894 default:
895 break;
896 }
897 return FALSE;
898 }
899
900 LOGICAL
is_executable(int tkntyp)901 is_executable(int tkntyp)
902 {
903 return !is_declaration(tkntyp);
904 }
905
906 #if DEBUG
907 static FILE *dfile = NULL;
908
909 void
dumpsst(SST * stk)910 dumpsst(SST *stk)
911 {
912 int ast, sptr;
913 dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
914 switch (SST_IDG(stk)) {
915 case S_NULL:
916 fprintf(dfile, "null");
917 break;
918 case S_CONST:
919 fprintf(dfile, "const");
920 break;
921 case S_EXPR:
922 fprintf(dfile, "expr");
923 break;
924 case S_LVALUE:
925 fprintf(dfile, "lvalue");
926 break;
927 case S_LOGEXPR:
928 fprintf(dfile, "logexpr");
929 break;
930 case S_STAR:
931 fprintf(dfile, "star");
932 break;
933 case S_VAL:
934 fprintf(dfile, "val");
935 break;
936 case S_IDENT:
937 fprintf(dfile, "ident");
938 sptr = SST_SYMG(stk);
939 fprintf(dfile, " sptr=%d", sptr);
940 if (sptr > 0 && sptr < stb.stg_avail) {
941 fprintf(dfile, "=%s", SYMNAME(sptr));
942 }
943 break;
944 case S_LABEL:
945 fprintf(dfile, "label");
946 break;
947 case S_STFUNC:
948 fprintf(dfile, "stfunc");
949 break;
950 case S_REF:
951 fprintf(dfile, "ref");
952 break;
953 case S_TRIPLE:
954 fprintf(dfile, "triple");
955 break;
956 case S_KEYWORD:
957 fprintf(dfile, "keyword");
958 break;
959 case S_ACONST:
960 fprintf(dfile, "aconst");
961 break;
962 case S_SCONST:
963 fprintf(dfile, "sconst");
964 break;
965 case S_DERIVED:
966 fprintf(dfile, "derived");
967 break;
968 default:
969 fprintf(dfile, "ID=%d", SST_IDG(stk));
970 }
971 if (SST_PARENG(stk))
972 fprintf(dfile, " paren");
973 if (SST_ALIASG(stk))
974 fprintf(dfile, " alias");
975 ast = SST_ASTG(stk);
976 if (ast) {
977 fprintf(dfile, " ast=%d", ast);
978 if (ast > 0) {
979 fprintf(dfile, "\n");
980 dump_ast_tree(ast);
981 }
982 }
983 fprintf(dfile, "\n");
984 } /* dumpsst */
985
986 void
dumppstack(void)987 dumppstack(void)
988 {
989 int i;
990
991 dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
992 fprintf(dfile, "Semant stack\n");
993 for (i = stktop; i >= 0; --i) {
994 fprintf(dfile, "[%d] ", i);
995 dumpsst(&sst[i]);
996 }
997 } /* dumppstack */
998 #endif
999