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 scan.c
20
21 \brief This file contains the compiler's scanner (lexical analyzer) module.
22 */
23
24 #include "gbldefs.h"
25 #include "global.h"
26 #include "symtab.h"
27 #include "dtypeutl.h"
28 #include "gramtk.h"
29 #include "error.h"
30 #include "semant.h"
31 #include "semstk.h"
32 #include "scan.h"
33 #include "ast.h"
34 #include "ccffinfo.h"
35 #include "fih.h"
36 #include "dinit.h"
37
38 /* functions defined in this file: */
39
40 extern void fe_restore_state(void);
41
42 static void set_input_form(LOGICAL);
43 static void get_stmt(void);
44 static void line_directive(void);
45 static void get_fn(void);
46 static int otodi(char *, int, INT *);
47 static int htodi(char *, int, INT *);
48 static int hex_to_i(int);
49 static int btodi(char *, int, INT *);
50 static int read_card(void);
51 static void write_card(void);
52 static int check_pgi_pragma(char *);
53 static int check_pragma(char *);
54 static int ic_strncmp(char *, char *);
55 static LOGICAL is_lineblank(char *);
56 static void crunch(void);
57 static int classify_smp(void);
58 static int classify_dec(void);
59 static int classify_pragma(void);
60 static int classify_pgi_pragma(void);
61 static int classify_ac_type(void);
62 static int classify_pgi_dir(void);
63 static int classify_kernel_pragma(void);
64 static void alpha(void);
65 static int get_id_name(char *, int);
66 static LOGICAL is_keyword(char *, int, char *);
67 static int cmp(char *, char *, int *);
68 static int is_ident(char *);
69 static int is_digit_string(char *);
70 static int get_kind_id(char *);
71 static INT get_kind_value(int);
72 static int get_cstring(char *, int *);
73 static int get_fmtstr(char *);
74 static void get_number(int);
75 static void get_nondec(int);
76 static int get_prefixed_int(int);
77 static void check_ccon(void);
78 static void do_dot(void);
79 static void push_include(char *);
80 static void put_astfil(int, char *, LOGICAL);
81 static void put_lineno(int);
82 static void put_include(int, int);
83 static void realloc_stmtb(void);
84 static void ff_check_stmtb(void);
85 static void check_continuation(int);
86 static LOGICAL is_next_char(char *, int);
87 static int double_type(char *, int *);
88 void add_headerfile(char *, int, int);
89
90 /* external declarations */
91
92 extern void parse_init(void);
93 extern void p_pragma(char *, int); /* directives */
94 extern LOGICAL fpp_;
95
96 #undef OPENMP
97 #undef SGIMP
98 #define OPENMP (flg.smp && !XBIT(69, 1))
99 #define SGIMP (flg.smp && !XBIT(69, 2))
100
101 /* define various scanner maximum values:
102 - maximum number of lines per statement (number of continuations + 1)
103 - maximum number of columns allowed in a card
104 - maximum include nesting depth
105 - longest free form line allowed (fixed form is usually 72 or 132)
106 - maximum length allowed for include file pathname
107 */
108
109 /* for KANJI, the 2 following limits are effectively halved */
110 #define MAX_COLS 1000
111 #define CARDB_SIZE (MAX_COLS + 6)
112
113 #define INIT_LPS 21
114 #define MAX_IDEPTH 20
115 #define MAX_PATHNAME_LEN 4096
116
117 /* define pseudo-characters - integer values equivalent
118 to non-printing characters are used: */
119
120 #define CH_STRING 31
121 #define CH_HOLLERITH 30
122 #define CH_O 29
123 #define CH_X 28
124 #define CH_IMPLP 27
125 #define CH_NULLSTR 26
126 #define CH_KSTRING 25 /* kanji string - NC'...' */
127 #define CH_PRAGMA 24
128 #define CH_IOLP 23
129 #define CH_B 22
130 #define CH_IMPRP 21
131 #define CH_UNDERSCORE 20
132 #define CH_FMTSTR 19
133
134 /* define card types returned by read_card: */
135
136 #define CT_NONE 0
137 #define CT_INITIAL 1
138 #define CT_END 2
139 #define CT_CONTINUATION 3
140 #define CT_SMP 4
141 #define CT_DEC 5
142 #define CT_COMMENT 6
143 #define CT_EOF 7
144 #define CT_DIRECTIVE 8
145 #define CT_LINE 9
146 #define CT_PRAGMA 10
147 #define CT_FIXED 11
148 #define CT_FREE 12
149 #define CT_MEM 13
150 /* parsed pragma: */
151 #define CT_PPRAGMA 14
152 #define CT_ACC 15
153 #define CT_KERNEL 16
154 #define CT_PGI 17
155
156 /* define sentinel types returned by read_card: */
157
158 #define SL_NONE 0
159 #define SL_HPF 1
160 #define SL_OMP 2
161 #define SL_SGI 3
162 #define SL_MEM 4
163 #define SL_PGI 6
164 #define SL_KERNEL 7
165
166 /* BIND keyword allowed in function declaration: use these states
167 to allow for this
168 */
169 #define B_NONE 0
170 #define B_FUNC_FOUND 1
171 #define B_RPAREN_FOUND 2
172 #define B_RESULT_FOUND 3
173 #define B_RESULT_RPAREN_FOUND 4
174
175 #define ERROR_STOP() \
176 { \
177 tkntyp = TK_ERRORSTOP; \
178 idlen += 5; \
179 }
180
181 static int bind_state = B_NONE;
182
183 /* define data local to Scanner module: */
184
185 static FILE *curr_fd; /* file descriptor for current input file */
186
187 static int incl_level; /* current include level. starts at 0. */
188 static int incl_stacksz; /* current size of include stack */
189
190 typedef struct { /* include-stack contents: */
191 FILE *fd;
192 int lineno;
193 int findex;
194 char *fname;
195 LOGICAL list_now;
196 int card_type; /* type of "look-ahead" card, CT_NONE if NA */
197 int sentinel; /* sentinel of 'card_type'. Value is one of
198 * SL_NONE, SL_OMP, etc. */
199 char *first_char; /* pointer to first character in look ahead */
200 LOGICAL eof_flag; /* current eof flag */
201 LOGICAL is_freeform; /* current fixed-/free- form state */
202 char cardb[CARDB_SIZE]; /* contents of look ahead */
203 } ISTACK;
204
205 static ISTACK *incl_stack = NULL;
206
207 static int hdr_level; /* current include level. starts at 0. */
208 static int hdr_stacksz; /* current size of include stack */
209
210 typedef struct { /* include-stack contents: */
211 int lineno;
212 int findex;
213 char *fname;
214 } HDRSTACK;
215
216 static HDRSTACK *hdr_stack = NULL;
217
218 static int curr_line; /* current source input file line number */
219 static LOGICAL first_line; /* line is first line read */
220 static char cardb[CARDB_SIZE]; /* buffer containing last card read
221 * in. text terminated by newline
222 * character. */
223 static char save_extend_ch; /* char overwritten @ pos flg.extend_source */
224 static LOGICAL list_now; /* TRUE if source lines currently being
225 * written */
226 static char printbuff[CARDB_SIZE]; /* holds card if generating listing */
227 static char *first_char; /* pointer into cardb to first character of
228 * the card following label field. Typically
229 * points to 7th char, but may point earlier
230 * if tabs or "&" in column 1 used. */
231 static int card_type; /* type of card currently in cardb. Value is
232 * one of CT_INITIAL, CT_END, etc. */
233 static int sentinel; /* sentinel of 'card_type'. Value is one of
234 * SL_NONE, SL_OMP, etc. */
235 static char *stmtb; /* buffer containing current Fortran stmt
236 * terminated by NULL. */
237 static char *stmtbefore = NULL; /* 'stmtb' before crunch */
238 static char *stmtbafter = NULL; /* 'stmtb' after crunch */
239 static short *last_char = NULL; /* position in stmb of the last char for each
240 * line */
241 static int card_count; /* number of cards making up the current stmt */
242 static int max_card; /* maximum number of cards read in for any
243 * Fortran stmt */
244 static char *currc; /* pointer into stmtb to current position */
245 static char *eos; /* pointer into stmtb of last character */
246 static int leadCount; /* number of leading spaces in current statement */
247 static int currCol; /* If > 0, represents source column of current token */
248
249 static char *tkbuf = NULL; /* buffer used when tokens are read from file
250 * during _read_token(). */
251 static int tkbuf_sz; /* size of tkbuf */
252
253 static int directive_sz; /* size of the directive string buffer */
254 static int options_sz; /* size of the options string buffer */
255
256 static LOGICAL scnerrfg, /* lexical error found in this statement */
257 exp_comma, /* exposed (unparenthesized) comma in stmt */
258 exp_equal, /* exposed equal sign in current stmt */
259 exp_ptr_assign, /* exposed pointer assign ('=>') in stmt */
260 exp_attr, /* exposed attribute syntax (::) in stmt */
261 follow_attr, /* this is after the attribute (::) in stmt */
262 exp_ac, /* this is after the attribute ((/) in stmt */
263 exp_dtvlist, /* this is after the attribute DT( or DT'..'( */
264 ionly; /* integer constants only - no real */
265
266 static LOGICAL par1_attr; /* '::' enclosed within single level parens */
267
268 static LOGICAL is_smp; /* current statement is an SMP directive */
269 static LOGICAL is_sgi; /* current statement is an sgi SMP directive
270 * (is_smp is set as well).
271 */
272 static LOGICAL is_dec; /* current statement is a DEC directive */
273 static LOGICAL is_mem; /* current statement is a mem directive */
274 static LOGICAL is_ppragma; /* current statement is a parsed pragma/directive */
275 static LOGICAL is_pgi; /* current statement is a pgi directive */
276 static bool is_doconcurrent; /* current statement is a do concurrent stmt */
277 static LOGICAL is_kernel; /* current statement is a parsed kernel directive */
278 static LOGICAL long_pragma_candidate; /* current statement may be a
279 * long directive/pragma */
280 static int scmode; /* scan mode - used to interpret alpha tokens
281 * Possible states and values are: */
282 #define SCM_FIRST 1
283 #define SCM_IDENT 2
284 #define SCM_FORMAT 3
285 #define SCM_IMPLICIT 4
286 #define SCM_FUNCTION 5
287 #define SCM_IO 6
288 #define SCM_TO 7
289 #define SCM_IF 8
290 #define SCM_DOLAB 9
291 #define SCM_GOTO 10
292 #define SCM_DONEXT 11
293 #define SCM_LOCALITY 12
294 #define SCM_ALLOC 13
295 #define SCM_ID_ATTR 14
296 #define SCM_NEXTIDENT 15 /* next exposed id is as if it begins a statement */
297 #define SCM_INTERFACE 16
298 #define SCM_OPERATOR 17 /* next id (presumably enclosed in '.'s) is a
299 * user-defined or named intrinsic operator */
300 #define SCM_LOOKFOR_OPERATOR 18 /* next id may be word 'operator' */
301 #define SCM_PAR 19
302 #define SCM_ACCEL 20
303 #define SCM_BIND 21 /* next id is keyword bind */
304 #define SCM_PROCEDURE 22
305 #define SCM_KERNEL 23
306 #define SCM_GENERIC 24
307 #define SCM_TYPEIS 25
308 #define SCM_DEFINED_IO 26
309 #define SCM_CHEVRON 27
310
311 static int par_depth; /* current parentheses nesting depth */
312 static LOGICAL past_equal; /* set if past the equal sign */
313 static LOGICAL reset_past_equal; /* set if past_equal must be reset */
314 static int acb_depth; /* current 'array constructor begin' depth */
315 static int tkntyp; /* token to be returned by get_token. Value
316 * is one of the terminal symbols (TK_XXX) of
317 * the grammar. */
318 static INT tknval; /* additional info on token returned also to
319 * parser. */
320 static int body_len; /* number of characters in statement portion
321 * of card - either 67 or 127
322 * (flg.extend_source - 5) */
323 static LOGICAL no_crunch; /* compiler directives (pragmas) can't be
324 * crunched */
325 static LOGICAL in_include; /* TRUE when statement in get_stmt() is read
326 * from an include file. */
327 static int kind_id; /* ST_PARAM if kind parammeter found by
328 * get_kind_id() */
329 static LOGICAL seen_implp; /* TRUE if the left paren surrounding the
330 * IMPLICIT range was seen */
331 static LOGICAL is_freeform; /* source form is freeform */
332 static LOGICAL sig_blanks; /* blanks are significant */
333
334 /* free form handling */
335
336 static void ff_get_stmt(void);
337 static void ff_prescan(void);
338 static void ff_chk_pragma(char *);
339 static void ff_get_noncomment(char *);
340 static int ff_read_card(void);
341 static int ff_get_label(char *);
342
343 static struct {
344 char *cavail;
345 char *outptr; /* last previous char put into crunched stmt */
346 char *amper_ptr;
347 int last_char; /* last char position of current card */
348 } ff_state;
349
350 /* switchable fixed or free form handling */
351
352 static void (*p_get_stmt)(void) = get_stmt;
353 static int (*p_read_card)(void) = read_card;
354
355 /* switchable get_token */
356
357 static int _get_token(INT *);
358 static void ill_char(int);
359 static void _write_token(int, INT);
360 static int _read_token(INT *);
361 static int (*p_get_token[])(INT *) = {_get_token, _read_token};
362
363 #include "kwddf.h"
364
365 static void init_ktable(KTABLE *);
366 static int keyword(char *, KTABLE *, int *, LOGICAL);
367 static int keyword_idx; /* index of KWORD entry found by keyword() */
368
369 /* Macro to NULL terminate a substring to error module */
370
371 #define CERROR(a, b, c, d, e, f) \
372 { \
373 char tmp; \
374 tmp = *e; \
375 *e = 0; \
376 error(a, b, c, d, f); \
377 *e = tmp; \
378 }
379
380 /** \brief Initialize Scanner. This routine is called once at the beginning
381 of execution.
382 \param fd file descriptor for main input source file
383 */
384 void
scan_init(FILE * fd)385 scan_init(FILE *fd)
386 {
387 /*
388 * for each set of keywords, determine the first and last keywords
389 * beginning with a given letter.
390 */
391 init_ktable(&normalkw);
392 init_ktable(&logicalkw);
393 init_ktable(&iokw);
394 init_ktable(&formatkw);
395 init_ktable(¶llelkw);
396 init_ktable(&parbegkw);
397 init_ktable(&deckw);
398 init_ktable(&pragma_kw);
399 init_ktable(&ppragma_kw);
400 init_ktable(&kernel_kw);
401 init_ktable(&pgi_kw);
402
403 if (XBIT(49, 0x1040000)) {
404 /* T3D/T3E or C90 Cray targets */
405 ctable['@'] |= _CS; /* allowed in an identifier */
406 ctable['L'] |= _HO; /* left-justified, zero-filled Hollerith */
407 ctable['R'] |= _HO; /* right-justified, zero-filled Hollerith */
408 ctable['l'] |= _HO; /* left-justified, zero-filled Hollerith */
409 ctable['r'] |= _HO; /* right-justified, zero-filled Hollerith */
410 }
411 curr_fd = fd;
412 curr_line = 0;
413 first_line = TRUE;
414 in_include = FALSE;
415 gbl.eof_flag = FALSE;
416 body_len = flg.extend_source - 5;
417 /*
418 * Initially, create enough space for 21 lines (1 for the initial card,
419 * 19 continuations, and an extra card to delay first reallocation until
420 * after the 20th card is read). Note that for each line, we never copy
421 * more than 'MAX_COLS-1' characters into the statement -- read_card()
422 * always locates a position after the first (cardb[0]) position.
423 * read_card() also terminates a line with respect to the number of columns
424 * allowed in a line (flg.extend_source)
425 * More space is created as needed in get_stmt.
426 */
427 max_card = INIT_LPS;
428 stmtbefore = sccalloc((BIGUINT64)(max_card * (MAX_COLS - 1) + 1));
429 if (stmtbefore == NULL)
430 error(7, 4, 0, CNULL, CNULL);
431 stmtbafter = sccalloc((BIGUINT64)(max_card * (MAX_COLS - 1) + 1));
432 if (stmtbafter == NULL)
433 error(7, 4, 0, CNULL, CNULL);
434 stmtb = stmtbefore;
435 last_char = (short *)sccalloc((BIGUINT64)(max_card * sizeof(short)));
436 if (last_char == NULL)
437 error(7, 4, 0, CNULL, CNULL);
438
439 incl_level = 0;
440 hdr_level = 0;
441 incl_stacksz = 2;
442 hdr_stacksz = 2;
443 NEW(incl_stack, ISTACK, incl_stacksz);
444 NEW(hdr_stack, HDRSTACK, hdr_stacksz);
445
446 /* trigger get_stmt call first time get_token is called: */
447
448 currc = NULL;
449 leadCount = 0;
450 currCol = 0;
451
452 #if DEBUG
453 if (DBGBIT(4, 1024)) {
454 if ((astb.astfil = fopen("foobar", "w+")) == NULL)
455 errfatal(5);
456 } else
457 #endif
458 if ((astb.astfil = tmpf("b")) == NULL)
459 errfatal(5);
460
461 put_astfil(FR_SRC, gbl.file_name, TRUE);
462
463 set_input_form(flg.freeform); /* sets is_freeform */
464
465 /* initiate one-card look ahead: */
466
467 list_now = flg.list;
468 card_type = (*p_read_card)();
469 directive_sz = CARDB_SIZE;
470 NEW(scn.directive, char, directive_sz);
471 options_sz = CARDB_SIZE;
472 NEW(scn.options, char, options_sz);
473 tkbuf_sz = CARDB_SIZE << 3;
474 NEW(tkbuf, char, tkbuf_sz);
475 scn.id.size = 1024;
476 NEW(scn.id.name, char, scn.id.size);
477 scn.id.avl = 0;
478 }
479
480 /** \brief Lexical or syntactical error found, so re-initialize the Scanner
481 so that next Fortran statement will be processed.
482 */
483 void
scan_reset(void)484 scan_reset(void)
485 {
486 currc = NULL;
487 leadCount = 0;
488 currCol = 0;
489 scn.end_program_unit = FALSE;
490 }
491
492 /** \brief Compilation is finished - deallocate storage, close files, etc.
493 */
494 void
scan_fini(void)495 scan_fini(void)
496 {
497 if (stmtbefore)
498 FREE(stmtbefore);
499 if (stmtbafter)
500 FREE(stmtbafter);
501 if (last_char)
502 FREE(last_char);
503 if (incl_stack)
504 FREE(incl_stack);
505 FREE(scn.directive);
506 FREE(scn.options);
507 if (tkbuf)
508 FREE(tkbuf);
509 FREE(scn.id.name);
510 if (astb.astfil)
511 fclose(astb.astfil);
512 }
513
514 /*
515 * Dynamically switch the form of the input
516 */
517 static void
set_input_form(LOGICAL free)518 set_input_form(LOGICAL free)
519 {
520 if (free) {
521 /*printf("switching to free @ %d\n", curr_line);*/
522 p_get_stmt = ff_get_stmt;
523 p_read_card = ff_read_card;
524 is_freeform = TRUE;
525 } else {
526 /*printf("switching to fixed @ %d\n", curr_line);*/
527 p_get_stmt = get_stmt;
528 p_read_card = read_card;
529 is_freeform = FALSE;
530 }
531 }
532
533 int
get_token(INT * tknv)534 get_token(INT *tknv)
535 {
536 return p_get_token[sem.which_pass](tknv);
537 }
538
539
540 /*
541 * Extracts next token and returns it to Parser. Reads in new
542 * Fortran statement if necessary. Does some syntactic checking.
543 */
544 static int
_get_token(INT * tknv)545 _get_token(INT *tknv)
546 {
547 static int lparen;
548 tknval = 0;
549
550 retry:
551 if (currc == NULL) {
552 scnerrfg = FALSE;
553 put_astfil(FR_STMT, NULL, FALSE);
554 stmtb = stmtbefore;
555 if (!scn.multiple_stmts) {
556 (*p_get_stmt)();
557 }
558 if (no_crunch) {
559 no_crunch = FALSE;
560 currc = stmtb;
561 sig_blanks = FALSE;
562 } else {
563 crunch();
564 stmtb = stmtbafter;
565 if (scnerrfg) {
566 parse_init();
567 goto retry;
568 }
569 scn.id.avl = 0;
570 currc = stmtb;
571 scmode = SCM_FIRST;
572 ionly = FALSE;
573 par_depth = 0;
574 past_equal = FALSE;
575 reset_past_equal = TRUE;
576 acb_depth = 0;
577 bind_state = B_NONE;
578 if (is_smp) {
579 if (classify_smp() == 0) {
580 currc = NULL;
581 goto retry;
582 }
583 goto ret_token;
584 }
585 if (is_dec) {
586 if (classify_dec() == 0) {
587 currc = NULL;
588 goto retry;
589 }
590 goto ret_token;
591 }
592 if (is_mem) {
593 if (classify_pragma() == 0) {
594 currc = NULL;
595 goto retry;
596 }
597 goto ret_token;
598 }
599 if (is_ppragma) {
600 if (classify_pgi_pragma() == 0) {
601 currc = NULL;
602 goto retry;
603 }
604 goto ret_token;
605 }
606 if (is_pgi) {
607 if (classify_pgi_dir() == 0) {
608 currc = NULL;
609 goto retry;
610 }
611 goto ret_token;
612 }
613 if (is_kernel) {
614 if (classify_kernel_pragma() == 0) {
615 currc = NULL;
616 goto retry;
617 }
618 goto ret_token;
619 }
620 }
621 }
622
623 again:
624 switch (*currc++) {
625
626 case ' ':
627 goto again;
628
629 case ';': /* statement separator; set flag and ... */
630 scn.multiple_stmts = TRUE;
631 case '!': /* inline comment character .. treat like end
632 * of line character ....... */
633 case '\n': /* return end of statement token: */
634 currc = NULL;
635 tkntyp = TK_EOL;
636 goto ret_token;
637
638 case 'a':
639 case 'b':
640 case 'c':
641 case 'd':
642 case 'e':
643 case 'f':
644 case 'g':
645 case 'h':
646 case 'i':
647 case 'j':
648 case 'k':
649 case 'l':
650 case 'm':
651 case 'n':
652 case 'o':
653 case 'p':
654 case 'q':
655 case 'r':
656 case 's':
657 case 't':
658 case 'u':
659 case 'v':
660 case 'w':
661 case 'x':
662 case 'y':
663 case 'z':
664 case 'A':
665 case 'B':
666 case 'C':
667 case 'D':
668 case 'E':
669 case 'F':
670 case 'G':
671 case 'H':
672 case 'I':
673 case 'J':
674 case 'K':
675 case 'L':
676 case 'M':
677 case 'N':
678 case 'O':
679 case 'P':
680 case 'Q':
681 case 'R':
682 case 'S':
683 case 'T':
684 case 'U':
685 case 'V':
686 case 'W':
687 case 'X':
688 case 'Y':
689 case 'Z':
690 case '_':
691 case '$':
692 if ((scmode == SCM_IDENT) && (bind_state == B_RESULT_RPAREN_FOUND)) {
693 scmode = SCM_FIRST;
694 }
695 alpha();
696 break;
697
698 case '1':
699 case '2':
700 case '3':
701 case '4':
702 case '5':
703 case '6':
704 case '7':
705 case '8':
706 case '9':
707 case '0':
708 currc--;
709 get_number(0);
710 break;
711
712 case CH_X:
713 get_nondec(16);
714 break;
715
716 case CH_O:
717 get_nondec(8);
718 break;
719
720 case CH_B:
721 get_nondec(2);
722 break;
723
724 case '#':
725 if (get_prefixed_int(16)) {
726 ill_char('#');
727 goto retry;
728 }
729 break;
730
731 case '%': /* %loc or %fill tokens expected,
732 else error */
733 if (is_ident(currc) == 3 && strncmp(currc, "loc", 3) == 0) {
734 currc += 3;
735 tkntyp = TK_LOC;
736 goto ret_token;
737 }
738 if (INSIDE_STRUCT && is_ident(currc) == 4 &&
739 strncmp(currc, "fill", 4) == 0) {
740 currc += 4;
741 tkntyp = TK_FILL;
742 goto ret_token;
743 }
744 tkntyp = TK_PERCENT;
745 goto ret_token;
746
747 case '&':
748 tkntyp = TK_AMPERSAND;
749 goto ret_token;
750
751 case '(': /* check for complex constant, else just
752 * paren: */
753 if (*currc == '/') {
754 if (par_depth == 0 && !past_equal && scmode != SCM_FORMAT &&
755 scmode != SCM_PAR) {
756 /* (/.../) can only occur inside () or on RHS */
757 /* scmode = SCM_OPERATOR; */
758 } else if (scmode != SCM_FORMAT && scmode != SCM_OPERATOR &&
759 scmode != SCM_PAR) {
760 par_depth++;
761 acb_depth++;
762 currc++;
763 tkntyp = TK_ACB;
764 if (classify_ac_type()) {
765 exp_ac = 1;
766 lparen = 0;
767 }
768 goto ret_token;
769 }
770 lparen = 0;
771 } else {
772 if (tkntyp == TK_DT || exp_dtvlist == 1) {
773 exp_dtvlist = 1;
774 tkntyp = TK_DLP;
775 par_depth++;
776 goto ret_token;
777 }
778 lparen = 1;
779 }
780 check_ccon();
781 break;
782
783 case '[':
784 tkntyp = TK_ACB;
785 if (classify_ac_type()) {
786 exp_ac = 1;
787 }
788 lparen = 0;
789 acb_depth++;
790 goto ret_token;
791 case ']':
792 tkntyp = TK_ACE;
793 acb_depth--;
794 goto ret_token;
795
796 case ')': /* return right paren */
797 par_depth--;
798 if (par_depth == 0) {
799 if (scmode == SCM_IO)
800 scmode = SCM_IDENT;
801 else if (scmode == SCM_NEXTIDENT)
802 scmode = SCM_FIRST;
803 else if (follow_attr)
804 scmode = SCM_LOOKFOR_OPERATOR;
805 else if (is_doconcurrent)
806 scmode = SCM_LOCALITY;
807 }
808 tkntyp = TK_RPAREN;
809 if (bind_state == B_FUNC_FOUND) {
810 bind_state = B_RPAREN_FOUND;
811 } else if (bind_state == B_RESULT_FOUND) {
812 bind_state = B_RESULT_RPAREN_FOUND;
813 }
814 if (exp_dtvlist) {
815 exp_dtvlist = 0;
816 } else {
817 lparen = 0;
818 }
819 goto ret_token;
820
821 case '*': /* return * or ** token: */
822 if (*currc == '*') {
823 currc++;
824 tkntyp = TK_EXPON;
825 } else
826 tkntyp = TK_STAR;
827 goto ret_token;
828
829 case '+': /* return plus token: */
830 tkntyp = TK_PLUS;
831 goto ret_token;
832 case ',': /* return comma token: */
833 if (par_depth == 0) {
834 /* exposed comma seen */
835 if (reset_past_equal)
836 past_equal = FALSE;
837 if (scmode == SCM_ID_ATTR)
838 /* if expecting an id within the context of ::, next id is
839 * an attributed keyword
840 */
841 scmode = SCM_FIRST;
842 else if (follow_attr)
843 scmode = SCM_LOOKFOR_OPERATOR;
844 }
845 if ((scmode == SCM_IDENT) && (bind_state == B_RPAREN_FOUND)) {
846 scmode = SCM_FIRST;
847 }
848 tkntyp = TK_COMMA;
849 goto ret_token;
850
851 case '-': /* return minus sign token: */
852 tkntyp = TK_MINUS;
853 goto ret_token;
854
855 case '.': /* return keyword enclosed in dots, real
856 * constant, or just dot token: */
857 do_dot();
858 break;
859 case '/': /* slash, concatenate, or not equal token: */
860 if (scmode != SCM_FORMAT) {
861 if (*currc == '/') {
862 currc++;
863 tkntyp = TK_CONCAT;
864 goto ret_token;
865 }
866 if (acb_depth && *currc == ')' && scmode != SCM_OPERATOR) {
867 par_depth--;
868 acb_depth--;
869 currc++;
870 tkntyp = TK_ACE;
871 goto ret_token;
872 }
873 }
874 if (*currc == '=') {
875 currc++;
876 tkntyp = TK_NE;
877 tknval = ('/' << 8) | '=';
878 } else
879 tkntyp = TK_SLASH;
880 goto ret_token;
881
882 case ':': /* return colon or coloncolon token: */
883 if (*currc == ':') {
884 if (acb_depth > 0 && exp_ac && !lparen) {
885 currc++;
886 tkntyp = TK_COLONCOLON;
887 exp_ac = 0;
888 ionly = false;
889 goto ret_token;
890 }
891 if (par_depth == 0 && exp_attr) {
892 currc++;
893 tkntyp = TK_COLONCOLON;
894 exp_attr = false;
895 follow_attr = true;
896 if (scmode != SCM_GENERIC)
897 scmode = SCM_LOOKFOR_OPERATOR;
898 goto ret_token;
899 }
900 if (par1_attr && par_depth == 1 &&
901 (scmode == SCM_ALLOC || is_doconcurrent || scn.stmtyp == TK_FORALL)) {
902 currc++;
903 tkntyp = TK_COLONCOLON;
904 ionly = false;
905 par1_attr = false;
906 goto ret_token;
907 }
908 }
909 tkntyp = TK_COLON;
910 if (scn.stmtyp == TK_USE) {
911 scmode = SCM_LOOKFOR_OPERATOR;
912 follow_attr = true;
913 }
914 goto ret_token;
915
916 case '=': /* return equals sign or eq compar. token */
917 if (*currc == '=') {
918 currc++;
919 tkntyp = TK_EQ;
920 tknval = ('=' << 8) | '=';
921 } else if (*currc == '>') {
922 currc++;
923 tkntyp = TK_RENAME;
924 past_equal = TRUE;
925 } else {
926 tkntyp = TK_EQUALS;
927 past_equal = TRUE;
928 }
929 goto ret_token;
930
931 case '<': /* less than or less than or equal */
932 if (*currc == '=') {
933 currc++;
934 tkntyp = TK_LE;
935 tknval = ('<' << 8) | '=';
936 } else if (*currc == '>') {
937 if (flg.standard)
938 error(170, 2, gbl.lineno, "<> should be /=", CNULL);
939 currc++;
940 tkntyp = TK_NE;
941 tknval = ('<' << 8) | '>';
942 }
943 else {
944 tkntyp = TK_LT;
945 tknval = '<';
946 }
947 goto ret_token;
948
949 case '>': /* greater than or greater than or equal */
950 if (*currc == '=') {
951 currc++;
952 tkntyp = TK_GE;
953 tknval = ('>' << 8) | '=';
954 }
955 else {
956 tkntyp = TK_GT;
957 tknval = '>';
958 }
959 goto ret_token;
960
961 #undef MKC
962 #undef MERGE
963 #define MKC(cp) ((*(cp)) & 0xFF)
964 #define MERGE(cp) \
965 ((MKC(cp) << 24) | (MKC(cp + 1) << 16) | (MKC(cp + 2) << 8) | (MKC(cp + 3)))
966 case CH_HOLLERITH:
967 tknval = MERGE(currc);
968 currc += 4;
969 tkntyp = TK_HOLLERITH;
970 goto ret_token;
971 case CH_STRING:
972 tknval = MERGE(currc);
973 currc += 4;
974 if (*currc == '(' && tkntyp == TK_DT) {
975 exp_dtvlist = 1;
976 }
977 tkntyp = TK_STRING;
978 goto ret_token;
979 case CH_NULLSTR:
980 tknval = getstring("", 0);
981 tkntyp = TK_STRING;
982 goto ret_token;
983 case CH_KSTRING:
984 tknval = MERGE(currc);
985 currc += 4;
986 tkntyp = TK_KSTRING;
987 goto ret_token;
988 case CH_FMTSTR:
989 tknval = MERGE(currc);
990 currc += 4;
991 tkntyp = TK_FMTSTR;
992 goto ret_token;
993
994 case CH_PRAGMA:
995 /* go off and finish the processing of the compiler directive.
996 * when done, need to get the next statement.
997 */
998 {
999 /* null terminate line */
1000 char *p;
1001 p = currc;
1002 while (*p != '\n')
1003 p++;
1004 *p = '\0';
1005 }
1006 put_astfil(FR_PRAGMA, currc, TRUE);
1007 if (XBIT(49, 0x1040000) && strncmp(currc, "cray", 4) == 0) {
1008 int len;
1009 /* T3D/T3E or C90 Cray targets */
1010 len = strlen(currc + 4) + 6;
1011 NEED(len, scn.directive, char, directive_sz, len + CARDB_SIZE);
1012 strncpy(scn.directive, "CDIR$", 5);
1013 strcpy(scn.directive + 5, currc + 4);
1014 *--currc = '\n'; /* next token is TK_EOL */
1015 tkntyp = TK_DIRECTIVE;
1016 goto ret_token;
1017 }
1018 currc = NULL;
1019 goto retry;
1020
1021 case CH_IOLP:
1022 par_depth++;
1023 tkntyp = TK_IOLP; /* add as case in _rd_token() */
1024 goto ret_token;
1025
1026 case CH_IMPLP:
1027 par_depth++;
1028 seen_implp = TRUE;
1029 tkntyp = TK_IMPLP; /* add as case in _rd_token() */
1030 goto ret_token;
1031
1032 case CH_IMPRP:
1033 par_depth--;
1034 seen_implp = FALSE;
1035 tkntyp = TK_RPAREN; /* add as case in _rd_token() */
1036 if (bind_state == B_FUNC_FOUND) {
1037 bind_state = B_RPAREN_FOUND;
1038 }
1039 goto ret_token;
1040
1041 case CH_UNDERSCORE:
1042 tkntyp = TK_UNDERSCORE;
1043 goto ret_token;
1044
1045 default: /* illegal character - ignore it: */
1046 ill_char(*(currc - 1));
1047 goto retry;
1048 }
1049
1050 if (scnerrfg) {
1051 parse_init();
1052 goto retry;
1053 }
1054 ret_token:
1055 *tknv = tknval;
1056 _write_token(tkntyp, tknval);
1057 return (tkntyp);
1058 }
1059
1060 static void
ill_char(int ch)1061 ill_char(int ch)
1062 {
1063 char ctmp[5];
1064 int c = ch & 0xFF;
1065
1066 if (c < ' ' || c > '~')
1067 sprintf(ctmp, "%2X", c);
1068 else {
1069 ctmp[0] = c;
1070 ctmp[1] = '\0';
1071 }
1072 error(25, 2, gbl.lineno, ctmp, CNULL);
1073 }
1074
1075 /* read one Fortran statement, including up continuations
1076 into stmtb. Process directive lines if encountered. Skip past
1077 comment lines. Handle end of files. Extract labels from initial lines.
1078 Write lines to source listing.
1079 */
1080 static void
get_stmt(void)1081 get_stmt(void)
1082 {
1083 char *p;
1084 char *cavail; /* available space ptr into stmtb */
1085 int c, outp;
1086 LOGICAL endflg; /* this stmt is an END statement */
1087 char lbuff[8]; /* temporarily holds label name */
1088 int in_linedir = 0;
1089 int lineno;
1090
1091 endflg = FALSE;
1092 card_count = 0;
1093 cavail = &stmtb[0];
1094 scn.is_hpf = FALSE;
1095 is_smp = FALSE;
1096 is_sgi = FALSE;
1097 is_dec = FALSE;
1098 is_mem = FALSE;
1099 is_ppragma = FALSE;
1100 is_kernel = FALSE;
1101 is_doconcurrent = false;
1102 is_pgi = FALSE;
1103
1104 do {
1105 again:
1106 switch (card_type) {
1107 case CT_END:
1108 endflg = TRUE;
1109 goto initial_card;
1110 case CT_DEC:
1111 is_dec = TRUE;
1112 goto initial_card;
1113 case CT_MEM:
1114 is_mem = TRUE;
1115 goto initial_card;
1116 case CT_PPRAGMA:
1117 is_ppragma = TRUE;
1118 goto initial_card;
1119 case CT_PGI:
1120 is_pgi = TRUE;
1121 goto initial_card;
1122 case CT_KERNEL:
1123 is_kernel = TRUE;
1124 goto initial_card;
1125 case CT_SMP:
1126 is_smp = TRUE;
1127 is_sgi = sentinel == SL_SGI;
1128 /* fall thru */
1129 case CT_INITIAL:
1130 initial_card:
1131 gbl.in_include = in_include;
1132 put_astfil(curr_line, &printbuff[8], TRUE);
1133 if (card_count == 0) {
1134 if (hdr_level == 0)
1135 fihb.currfindex = gbl.findex = 1;
1136 else
1137 fihb.currfindex = gbl.findex = hdr_stack[hdr_level - 1].findex;
1138 gbl.curr_file = FIH_FULLNAME(gbl.findex);
1139 }
1140 card_count = 1;
1141 put_lineno(curr_line);
1142
1143 p = first_char;
1144 while ((*cavail++ = *p++) != '\n')
1145 ;
1146 cavail--; /* delete trailing '\n' */
1147 /* may need to pad line out to 72 chars (less 1st 6): */
1148 c = p - first_char;
1149 if (XBIT(125, 4))
1150 c = kanji_len((unsigned char *)first_char, c);
1151 while (c < body_len) {
1152 *cavail++ = ' ';
1153 c++;
1154 }
1155 last_char[0] = cavail - stmtb - 1; /* locate last character of
1156 * this line
1157 */
1158
1159 /* process label field: */
1160
1161 outp = 2;
1162 if (sentinel != SL_SGI) {
1163 for (p = cardb; p < first_char - 1; p++) {
1164 c = *p & 0xff;
1165 if (!isblank(c)) {
1166 if (isdig(c))
1167 lbuff[outp++] = c;
1168 else {
1169 error(18, 3, curr_line, "field", CNULL);
1170 break;
1171 }
1172 }
1173 }
1174 }
1175
1176 scn.currlab = 0;
1177 if (outp != 2) {
1178 atoxi(&lbuff[2], &scn.labno, outp - 2, 10);
1179 if (scn.labno == 0)
1180 error(18, 2, curr_line, "0", "- label field ignored");
1181 else {
1182 int lab_sptr = getsymf(".L%05ld", (long)scn.labno);
1183 scn.currlab = declref(lab_sptr, ST_LABEL, 'd');
1184 if (DEFDG(scn.currlab))
1185 errlabel(97, 3, curr_line, SYMNAME(lab_sptr), CNULL);
1186 /* linked list of labels for internal subprograms */
1187 if (sem.which_pass == 0 && gbl.internal > 1 &&
1188 SYMLKG(scn.currlab) == NOSYM) {
1189 SYMLKP(scn.currlab, sem.flabels);
1190 sem.flabels = scn.currlab;
1191 }
1192 }
1193 }
1194 break;
1195
1196 case CT_CONTINUATION:
1197 check_continuation(curr_line);
1198 put_astfil(curr_line, &printbuff[8], TRUE);
1199 if (card_count == 0) {
1200 error(19, 3, curr_line, CNULL, CNULL);
1201 break;
1202 }
1203 if (++card_count >= max_card) {
1204 int chars_used;
1205 chars_used = cavail - stmtb;
1206 realloc_stmtb();
1207 cavail = stmtb + chars_used;
1208 if (stmtb == NULL)
1209 error(7, 4, 0, CNULL, CNULL);
1210 }
1211 if (flg.standard && card_count == 257)
1212 error(170, 2, curr_line, "more than 255 continuations", CNULL);
1213
1214 p = first_char;
1215 while ((*cavail++ = *p++) != '\n')
1216 ;
1217 --cavail; /* delete trailing '\n' */
1218 /* may need to pad line out to 72 chars (less 1st 6): */
1219 c = p - first_char;
1220 if (XBIT(125, 4))
1221 c = kanji_len((unsigned char *)first_char, c);
1222 while (c < body_len) {
1223 *cavail++ = ' ';
1224 c++;
1225 }
1226
1227 /* locate the last character position for this line */
1228
1229 last_char[card_count - 1] = cavail - stmtb - 1;
1230
1231 break;
1232
1233 case CT_COMMENT:
1234 put_astfil(curr_line, &printbuff[8], TRUE);
1235 break;
1236
1237 case CT_EOF:
1238 /* pop include */
1239 if (incl_level > 0) {
1240 char *save_filenm;
1241
1242 incl_level--;
1243 if (incl_stack[incl_level].is_freeform) {
1244 set_input_form(TRUE);
1245 incl_level++;
1246 ff_get_stmt();
1247 return;
1248 }
1249 save_filenm = gbl.curr_file;
1250 curr_fd = incl_stack[incl_level].fd;
1251 gbl.findex = incl_stack[incl_level].findex;
1252 curr_line = incl_stack[incl_level].lineno;
1253 gbl.curr_file = incl_stack[incl_level].fname;
1254 list_now = incl_stack[incl_level].list_now;
1255 gbl.eof_flag = incl_stack[incl_level].eof_flag;
1256 if (curr_line == 1)
1257 add_headerfile(gbl.curr_file, curr_line + 1, 0);
1258 else
1259 add_headerfile(gbl.curr_file, curr_line, 0);
1260
1261 put_include(FR_E_INCL, gbl.findex);
1262
1263 card_type = incl_stack[incl_level].card_type;
1264 sentinel = incl_stack[incl_level].sentinel;
1265 if (card_type != CT_NONE) {
1266 first_char = incl_stack[incl_level].first_char;
1267 BCOPY(cardb, incl_stack[incl_level].cardb, char, CARDB_SIZE);
1268 if (card_type != CT_DIRECTIVE)
1269 write_card();
1270 if (card_type == CT_EOF && incl_level == 0) {
1271 if (gbl.currsub || sem.mod_sym) {
1272 gbl.curr_file = save_filenm;
1273 sem.mod_cnt = 0;
1274 sem.mod_sym = 0;
1275 sem.submod_sym = 0;
1276 errsev(22);
1277 }
1278 finish();
1279 }
1280 } else
1281 card_type = read_card();
1282 if (incl_level == 0)
1283 in_include = FALSE;
1284 if (card_type == CT_EOF && incl_level <= 0)
1285 errsev(22);
1286 else
1287 goto again;
1288 }
1289 /* terminate compilation: */
1290 if (sem.mod_sym) {
1291 errsev(22);
1292 sem.mod_cnt = 0;
1293 sem.mod_sym = 0;
1294 sem.submod_sym = 0;
1295 }
1296 finish();
1297
1298 case CT_DIRECTIVE:
1299 put_astfil(curr_line, &printbuff[8], TRUE);
1300 put_lineno(curr_line);
1301 /* convert upper case letters to lower: */
1302 for (p = &cardb[1]; (c = *p) != ' ' && c != '\n'; ++p)
1303 if (c >= 'A' && c <= 'Z')
1304 *p = tolower(c);
1305 if (strncmp(&cardb[1], "list", 4) == 0)
1306 list_now = flg.list;
1307 else if (strncmp(&cardb[1], "nolist", 6) == 0)
1308 list_now = FALSE;
1309 else if (strncmp(&cardb[1], "eject", 5) == 0) {
1310 if (list_now)
1311 list_page();
1312 } else if (strncmp(&cardb[1], "insert", 6) == 0)
1313 push_include(&cardb[8]);
1314 else /* unrecognized directive: */
1315 errsev(20);
1316 break;
1317
1318 case CT_LINE:
1319 lineno = gbl.lineno;
1320 line_directive();
1321 card_type = CT_COMMENT;
1322
1323 break;
1324
1325 case CT_PRAGMA:
1326 scn.currlab = 0;
1327 put_astfil(curr_line, &printbuff[8], TRUE);
1328 no_crunch = TRUE;
1329 if (card_count == 0) {
1330 if (hdr_level == 0)
1331 fihb.currfindex = gbl.findex = 1;
1332 else
1333 fihb.currfindex = gbl.findex = hdr_stack[hdr_level - 1].findex;
1334 gbl.curr_file = FIH_FULLNAME(gbl.findex);
1335 }
1336 card_count = 1;
1337 put_lineno(curr_line);
1338 p = first_char;
1339 *cavail++ = CH_PRAGMA;
1340 while ((*cavail++ = *p++) != '\n')
1341 ;
1342 cavail--; /* delete trailing '\n' */
1343 last_char[0] = cavail - stmtb - 1; /* locate last character of
1344 * this line
1345 */
1346 card_type = CT_INITIAL; /* trick rest of processing */
1347 break;
1348
1349 case CT_FIXED:
1350 put_astfil(curr_line, &printbuff[8], TRUE);
1351 set_input_form(FALSE);
1352 card_type = CT_COMMENT;
1353 break;
1354
1355 case CT_FREE:
1356 set_input_form(TRUE);
1357 card_type = CT_COMMENT;
1358 ff_get_stmt();
1359 return;
1360
1361 default:
1362 interr("get_stmt: bad ctype", card_type, 4);
1363 }
1364 /* start new listing page if at END, then read new card: */
1365
1366 if (flg.list && card_type <= CT_COMMENT) {
1367 if (list_now)
1368 list_line(printbuff);
1369 }
1370 #if DEBUG
1371 if (DBGBIT(4, 2))
1372 fprintf(gbl.dbgfil, "line(%4d) %s", curr_line, cardb);
1373 #endif
1374 card_type = read_card();
1375 if (endflg) {
1376 if (card_type == CT_CONTINUATION)
1377 endflg = FALSE;
1378 else if (flg.list)
1379 list_page();
1380 }
1381
1382 } while (!endflg &&
1383 (cavail == stmtb || card_type == CT_CONTINUATION ||
1384 card_type == CT_COMMENT || card_type == CT_LINE /* tpr 533 */
1385 ));
1386 *cavail = '\n';
1387 if (scn.currlab) {
1388 put_astfil(FR_LABEL, NULL, FALSE);
1389 put_astfil(scn.labno, NULL, FALSE);
1390 }
1391 }
1392
1393 void
add_headerfile(char * fname_buff,int cl,int includedir)1394 add_headerfile(char *fname_buff, int cl, int includedir)
1395 {
1396 if (!XBIT(120, 0x4000000)) {
1397 if (hdr_level == 0) {
1398 NEED(hdr_level + 1, hdr_stack, HDRSTACK, hdr_stacksz, hdr_level + 3);
1399
1400 /* need to add original source file first */
1401 if (in_include) {
1402 gbl.findex = hdr_stack[hdr_level].findex = 1;
1403 fihb.currfindex = gbl.findex;
1404 FIH_PARENT(hdr_stack[hdr_level].findex) = 0;
1405 hdr_stack[hdr_level].lineno = 1;
1406 hdr_stack[hdr_level].fname = FIH_FULLNAME(gbl.findex);
1407 hdr_level++;
1408 } else {
1409 /* original source file */
1410 if (strcmp(FIH_FULLNAME(1), fname_buff) == 0) {
1411 gbl.findex = hdr_stack[hdr_level].findex = 1;
1412 } else {
1413 gbl.findex = hdr_stack[hdr_level].findex =
1414 addfile(fname_buff, 0, 0, 1, gbl.lineno, 1, hdr_level);
1415 }
1416 fihb.currfindex = gbl.findex;
1417 FIH_PARENT(hdr_stack[hdr_level].findex) = 0;
1418 hdr_stack[hdr_level].lineno = 1;
1419 hdr_stack[hdr_level].fname = FIH_FULLNAME(gbl.findex);
1420 put_include(FR_B_HDR, hdr_stack[hdr_level].findex);
1421 hdr_level++;
1422 return;
1423 }
1424 }
1425 if (strcmp(fname_buff, hdr_stack[hdr_level - 1].fname) == 0) {
1426
1427 ; /* same file */
1428 } else if (hdr_level > 1 &&
1429 strcmp(fname_buff, hdr_stack[hdr_level - 2].fname) == 0 &&
1430 cl != 1) {
1431 /* must not do hdr_level == 0, it is original source file. */
1432 hdr_level--;
1433 put_include(FR_E_HDR, hdr_stack[hdr_level - 1].findex);
1434 /* make sure hdr_level never gets back down to 0 */
1435 if (hdr_level == 0)
1436 ++hdr_level;
1437 } else {
1438 NEED(hdr_level + 1, hdr_stack, HDRSTACK, hdr_stacksz, hdr_level + 3);
1439 hdr_stack[hdr_level].findex =
1440 addfile(fname_buff, 0, 0, 1, includedir ? curr_line : gbl.lineno,
1441 cl - 1, hdr_level);
1442 hdr_stack[hdr_level].lineno = cl;
1443 hdr_stack[hdr_level].fname = FIH_FULLNAME(hdr_stack[hdr_level].findex);
1444 FIH_PARENT(hdr_stack[hdr_level].findex) = hdr_stack[hdr_level - 1].findex;
1445 put_include(FR_B_HDR, hdr_stack[hdr_level].findex);
1446 hdr_level++;
1447 }
1448 }
1449 }
1450
1451 static void
line_directive(void)1452 line_directive(void)
1453 {
1454 static char fname_buff[CARDB_SIZE];
1455 char *p;
1456 char *to;
1457 int cl;
1458 char *tmp_ptr;
1459
1460 /*
1461 * The syntax of a line directive is:
1462 * #<c><line #>[<d>][<file name>]
1463 * where:
1464 * # appears in column 1,
1465 * <c> is one or more blank characters, a '-', or '+',
1466 * <d> is one or more blank characters,
1467 * <file name> is a quoted string.
1468 * If <file name> is not quoted string, it's assumed to be commentary.
1469 */
1470
1471 /* preprocessor communicates to the scanner where or not the
1472 * ensuing line(s) came from an include file.
1473 */
1474 if (cardb[1] == '-') {
1475 in_include = FALSE;
1476 cardb[1] = ' ';
1477 } else if (cardb[1] == '+') {
1478 in_include = TRUE;
1479 cardb[1] = ' ';
1480 }
1481 write_card();
1482 put_astfil(curr_line, &printbuff[8], TRUE);
1483 if (!isblank(cardb[1]))
1484 goto ill_line;
1485 p = cardb + 2;
1486 while (isblank(*p)) /* skip blank characters */
1487 ++p;
1488 if (!isdig(*p))
1489 goto ill_line;
1490 cl = 0;
1491 for (; isdig(*p); ++p)
1492 cl = (10 * cl) + (*p - '0');
1493 while (isblank(*p)) /* skip blank characters */
1494 ++p;
1495 if (*p == '"') {
1496 cardb[CARDB_SIZE - 1] = '"'; /* limit length of file name */
1497 to = fname_buff;
1498 while (*++p != '"') {
1499 if (*p == '\n')
1500 goto ill_line;
1501 *to++ = *p;
1502 }
1503 if (to == fname_buff) /* check for empty string */
1504 *to++ = ' ';
1505 *to = '\0';
1506 add_headerfile(fname_buff, cl, 1);
1507 }
1508
1509 curr_line = cl - 1;
1510 return;
1511 ill_line:
1512 tmp_ptr = gbl.curr_file;
1513 if (hdr_level)
1514 gbl.curr_file = hdr_stack[hdr_level - 1].fname;
1515 error(21, 3, curr_line, CNULL, CNULL);
1516 gbl.curr_file = tmp_ptr;
1517 }
1518
1519 static void
get_fn(void)1520 get_fn(void)
1521 {
1522 /*
1523 * This is a hack to get the name of the file that was preprocessed
1524 * and saved to a file which is now being compiled. We want the name
1525 * of the original file to show up as the file being debugged.
1526 *
1527 * The expected syntax of the line directive in this situation is:
1528 * #<c><line #>[<d>][<file name>]
1529 * where:
1530 * # appears in column 1,
1531 * <c> a blank
1532 * <line #> 1
1533 * <d> is a blank.
1534 * <file name> is a quoted string.
1535 */
1536 char *p;
1537 int len;
1538 int i;
1539
1540 if (XBIT(120, 0x40000))
1541 return;
1542 if (cardb[1] != ' ' || cardb[2] != '1' || cardb[3] != ' ')
1543 return;
1544 p = &cardb[4];
1545 if (*p == '"') {
1546 while (*++p != '"') {
1547 if (*p == '\0' || *p == '\n')
1548 return;
1549 }
1550 len = p - &cardb[5];
1551 if (len <= 0)
1552 return;
1553 gbl.fn = (char *)getitem(8, len + 1);
1554 strncpy(gbl.fn, &cardb[5], len);
1555 gbl.fn[len] = '\0';
1556 }
1557 }
1558
1559 static char *
_readln(int mx_len,LOGICAL len_err)1560 _readln(int mx_len, LOGICAL len_err)
1561 {
1562 int c;
1563 int i;
1564 char *p, *q;
1565
1566 long_pragma_candidate = FALSE;
1567 if ((c = getc(curr_fd)) == EOF) {
1568 if (incl_level == 0) {
1569 gbl.eof_flag = TRUE;
1570 }
1571 fclose(curr_fd);
1572 return NULL;
1573 }
1574 curr_line++;
1575 i = 0;
1576 p = cardb - 1;
1577 while (c != '\n') {
1578 i++;
1579 if (i > mx_len) {
1580 if (len_err) {
1581 for (q = cardb; isblank(*q) && q < p; ++q)
1582 ;
1583 if (flg.standard || *q != '!')
1584 /* Flag non-comments; flag any statement under -Mstandard. */
1585 error(285, 3, curr_line, CNULL, CNULL);
1586 else
1587 /* Comments might be pragmas; set up to check those later. */
1588 long_pragma_candidate = TRUE;
1589 }
1590 /* skip to the end-of-line */
1591 while (1) {
1592 c = getc(curr_fd);
1593 if (c == '\n' || c == EOF)
1594 break;
1595 }
1596 break;
1597 }
1598 *++p = c;
1599 c = getc(curr_fd);
1600 if (c == EOF) {
1601 /* this can't be the first character of the line; this case
1602 * is detected as end-of-file (see above).
1603 */
1604 break;
1605 }
1606 }
1607 p[1] = '\n';
1608 p[2] = '\0';
1609 return p; /* last position */
1610 }
1611
1612 /* read one input line into cardb, and determine its type
1613 (card_type) and determine first character following the
1614 label field (first_char).
1615 */
1616 static int
read_card(void)1617 read_card(void)
1618 {
1619 int c;
1620 int i;
1621 char *p; /* pointer into cardb */
1622 LOGICAL tab_seen;
1623 int ct_init;
1624 char *tmp_ptr;
1625
1626 assert(!gbl.eof_flag, "read_card:err", gbl.eof_flag, 4);
1627 sentinel = SL_NONE;
1628
1629 p = _readln(CARDB_SIZE - 2, FALSE);
1630 if (p == NULL)
1631 return CT_EOF;
1632
1633 ct_init = CT_INITIAL; /* initial card type */
1634 if (*cardb == '#') {
1635 if (first_line && !fpp_) {
1636 get_fn();
1637 }
1638 first_line = FALSE;
1639 return CT_LINE;
1640 }
1641 first_line = FALSE;
1642 save_extend_ch = cardb[flg.extend_source]; /* just in case it's needed */
1643 cardb[flg.extend_source] = '\n'; /* ensure that newline char marks end
1644 * of buff */
1645 c = cardb[0];
1646 if (c == '%')
1647 return CT_DIRECTIVE;
1648 if (c == '$') /* APFTN64 style of directives */
1649 return CT_DIRECTIVE;
1650 write_card();
1651 first_char = &cardb[6]; /* default first character of stmt */
1652 if (c == 'c' || c == 'C' || c == '*' || c == '!') {
1653 /* possible compiler directive. these directives begin with (upper
1654 * or lower case):
1655 * c$pragma
1656 * cpgi$ cvd$ cdir$ !cdir
1657 * to check for a directive, all that's done is to copy at most N
1658 * characters after the leading 'c', where N is the max length of
1659 * the allowable prefixes, converting to lower case if necessary.
1660 * if the prefix matches one of the above, a special card type
1661 * is returned. NOTE: can't process the directive now since
1662 * this card represents the read-ahead ---- NEED to ensure that
1663 * semantic actions are performed.
1664 */
1665 #define MAX_DIRLEN 4
1666 char b[MAX_DIRLEN + 1], cc;
1667
1668 /* sun's c$pragma is separate from those whose prefixes end with $ */
1669 if (cardb[1] == '$' && (cardb[2] == 'P' || cardb[2] == 'p') &&
1670 (cardb[3] == 'R' || cardb[3] == 'r') &&
1671 (cardb[4] == 'A' || cardb[4] == 'a') &&
1672 (cardb[5] == 'G' || cardb[5] == 'g') &&
1673 (cardb[6] == 'M' || cardb[6] == 'm') &&
1674 (cardb[7] == 'A' || cardb[7] == 'a')) {
1675 /*
1676 * communicate to p_pragma() that this is a sun directive.
1677 * do so by prepending the substring beginning with the
1678 * first character after "pragma" with "sun".
1679 */
1680 first_char = &cardb[5];
1681 strncpy(first_char, "sun", 3);
1682 return (CT_PRAGMA);
1683 }
1684
1685 if (OPENMP && /* c$smp, c$omp - smp directive sentinel */
1686 cardb[1] == '$' && (cardb[2] == 'S' || cardb[2] == 's' ||
1687 cardb[2] == 'O' || cardb[2] == 'o') &&
1688 (cardb[3] == 'M' || cardb[3] == 'm') &&
1689 (cardb[4] == 'P' || cardb[4] == 'p')) {
1690 strncpy(cardb, " ", 5);
1691 ct_init = CT_SMP; /* change initial card type */
1692 sentinel = SL_OMP;
1693 goto bl_firstchar;
1694 }
1695 /* SGI c$doacross, c$& */
1696 if (SGIMP && cardb[1] == '$' && (cardb[2] == 'D' || cardb[2] == 'd') &&
1697 (cardb[3] == 'O' || cardb[3] == 'o') &&
1698 (cardb[4] == 'A' || cardb[4] == 'a') &&
1699 (cardb[5] == 'C' || cardb[5] == 'c') &&
1700 (cardb[6] == 'R' || cardb[6] == 'r') &&
1701 (cardb[7] == 'O' || cardb[7] == 'o') &&
1702 (cardb[8] == 'S' || cardb[8] == 's') &&
1703 (cardb[9] == 'S' || cardb[9] == 's')) {
1704 sentinel = SL_SGI;
1705 first_char = &cardb[2];
1706 return CT_SMP;
1707 }
1708 if (SGIMP && cardb[1] == '$' && cardb[2] == '&') {
1709 if (!is_sgi)
1710 /* current statement is not an SGI smp statement; just
1711 * treat as a comment.
1712 */
1713 return CT_COMMENT;
1714 sentinel = SL_SGI;
1715 first_char = &cardb[3];
1716 return CT_CONTINUATION;
1717 }
1718 /* OpenMP conditional compilation sentinels */
1719 if (OPENMP && cardb[1] == '$' && (iswhite(cardb[2]) || isdigit(cardb[2]))) {
1720 c = cardb[0] = cardb[1] = ' ';
1721 goto bl_firstchar;
1722 }
1723 /* Miscellaneous directives which are parsed */
1724 if (XBIT(59, 0x4) && /* c$mem - mem directive sentinel */
1725 cardb[1] == '$' && (cardb[2] == 'M' || cardb[2] == 'm') &&
1726 (cardb[3] == 'E' || cardb[3] == 'e') &&
1727 (cardb[4] == 'M' || cardb[4] == 'm')) {
1728 strncpy(cardb, " ", 5);
1729 ct_init = CT_MEM; /* change initial card type */
1730 sentinel = SL_MEM;
1731 goto bl_firstchar;
1732 }
1733 if (XBIT_PCAST && /* c$pgi - alternate pgi accelerator directive sentinel */
1734 cardb[1] == '$' && (cardb[2] == 'P' || cardb[2] == 'p') &&
1735 (cardb[3] == 'G' || cardb[3] == 'g') &&
1736 (cardb[4] == 'I' || cardb[4] == 'i')) {
1737 strncpy(cardb, " ", 5);
1738 ct_init = CT_PGI; /* change initial card type */
1739 sentinel = SL_PGI;
1740 goto bl_firstchar;
1741 }
1742 if (XBIT(137, 1) && /* c$cuf - cuda kernel directive sentinel */
1743 cardb[1] == '$' && (cardb[2] == 'C' || cardb[2] == 'c') &&
1744 (cardb[3] == 'U' || cardb[3] == 'u') &&
1745 (cardb[4] == 'F' || cardb[4] == 'f')) {
1746 strncpy(cardb, " ", 5);
1747 ct_init = CT_KERNEL; /* change initial card type */
1748 sentinel = SL_KERNEL;
1749 goto bl_firstchar;
1750 }
1751 if (XBIT(137, 1) && /* !@cuf - cuda kernel conditional compilation */
1752 cardb[1] == '@' && (cardb[2] == 'C' || cardb[2] == 'c') &&
1753 (cardb[3] == 'U' || cardb[3] == 'u') &&
1754 (cardb[4] == 'F' || cardb[4] == 'f') && iswhite(cardb[5])) {
1755 strncpy(cardb, " ", 5);
1756 goto bl_firstchar;
1757 }
1758
1759 i = 1;
1760 p = b;
1761 while (TRUE) {
1762 cc = cardb[i];
1763 if (cc >= 'A' && cc <= 'Z')
1764 *p = tolower(cc);
1765 else
1766 *p = cc;
1767 p++;
1768 if (i >= MAX_DIRLEN || cc == '$' || cc == '\n')
1769 break;
1770 i++;
1771 }
1772 if (cc == '$') {
1773 *p = '\0';
1774 if (strncmp(b, "pgi$", 4) == 0 || strncmp(b, "vd$", 3) == 0) {
1775 /* for these directives, point to first character after the
1776 * '$'.
1777 */
1778 first_char = &cardb[i + 1];
1779 if (check_pgi_pragma(first_char) == CT_PPRAGMA) {
1780 strncpy(cardb, " ", 4);
1781 if (b[0] == 'p')
1782 cardb[4] = ' ';
1783 return CT_PPRAGMA;
1784 }
1785 return CT_PRAGMA;
1786 }
1787 if (strncmp(b, "dir$", 4) == 0) {
1788 /*
1789 * communicate to p_pragma() that this is a cray directive.
1790 * do so by prepending the substring beginning with the
1791 * first character after the '$' with "cray".
1792 */
1793 first_char = &cardb[1];
1794 strncpy(first_char, "cray", 4);
1795 i = check_pragma(first_char + 4);
1796 if (i == CT_PPRAGMA) {
1797 strncpy(cardb, " ", 5);
1798 }
1799 return i;
1800 }
1801 if (XBIT(124, 0x100) && strncmp(b, "exe$", 4) == 0) {
1802 c = cardb[0] = cardb[1] = cardb[2] = cardb[3] = cardb[4] = ' ';
1803 goto bl_firstchar;
1804 }
1805 #if defined(TARGET_WIN)
1806 if (strncmp(b, "dec$", 4) == 0) {
1807 c = cardb[0] = cardb[1] = cardb[2] = cardb[3] = cardb[4] = ' ';
1808 ct_init = CT_DEC; /* change initial card type */
1809 goto bl_firstchar;
1810 }
1811 if (strncmp(b, "ms$", 3) == 0) {
1812 /* in fixed-form, !ms$ cannot be continued, so just immediately
1813 * return the card type.
1814 */
1815 c = cardb[0] = cardb[1] = cardb[2] = cardb[3] = ' ';
1816 first_char = &cardb[4];
1817 return CT_DEC;
1818 }
1819 #endif
1820 }
1821 return (CT_COMMENT);
1822 }
1823 if (c == '\n')
1824 return (CT_COMMENT);
1825
1826 if (c == 'd' || c == 'D') {
1827 if (!flg.dlines)
1828 return (CT_COMMENT);
1829 c = cardb[0] = ' ';
1830 }
1831 if (c == '&') {
1832 first_char = &cardb[1];
1833 cardb[0] = ' ';
1834 return (CT_CONTINUATION);
1835 }
1836 bl_firstchar:
1837
1838 /* check for a totally empty line or a line with just a comment */
1839 tab_seen = FALSE;
1840 for (p = cardb; isblank(*p); p++)
1841 if (*p == '\t')
1842 tab_seen = TRUE;
1843 ;
1844 if (*p == '\n')
1845 return (CT_COMMENT);
1846 /*
1847 * When the first non-white character is a ! then it is a comment
1848 * if a tab has been seen or if no tab seen then the ! must not
1849 * be in column 6, the continuation column.
1850 */
1851 if (*p == '!' && (tab_seen || p != &cardb[5])) {
1852 return (CT_COMMENT);
1853 }
1854
1855 /* check first 6 character positions for tab or newline char: */
1856
1857 for (i = 0; i < 6; i++) {
1858 if (cardb[i] == '\t') {
1859 first_char = &cardb[i + 1];
1860 cardb[i] = ' ';
1861 if ((c = *first_char) >= '1' && c <= '9') {
1862 first_char = &cardb[i + 2]; /* vms tab-digit continuation */
1863 return (CT_CONTINUATION);
1864 }
1865 break;
1866 } else if (cardb[i] == '\n') {
1867 first_char = &cardb[i + 1];
1868 cardb[i + 1] = '\n';
1869 return (ct_init);
1870 }
1871 }
1872
1873 /* check for normal type of continuation card: */
1874 /* We currently check error for the one we are scanning
1875 which is fihb.nextfindex */
1876 c = *(first_char - 1);
1877 if (c != ' ' && c != '0') {
1878 tmp_ptr = gbl.curr_file;
1879 for (p = cardb; p < first_char - 1; p++)
1880 if (*p != ' ') {
1881 if (hdr_level)
1882 gbl.curr_file = hdr_stack[hdr_level - 1].fname;
1883 error(21, 3, curr_line, CNULL, CNULL);
1884 gbl.curr_file = tmp_ptr;
1885 return (CT_COMMENT);
1886 }
1887 return (CT_CONTINUATION);
1888 }
1889
1890 if (ct_init != CT_INITIAL)
1891 return (ct_init);
1892
1893 /* finally- have it narrowed down to initial or end line. */
1894
1895 /* scan to first non-blank character in stmt part: */
1896 if (p < first_char)
1897 for (p = first_char; isblank(*p); p++)
1898 ;
1899
1900 if (*p != 'e' && *p != 'E')
1901 return (ct_init);
1902 if (*++p != 'n' && *p != 'N')
1903 return (ct_init);
1904 if (*++p != 'd' && *p != 'D')
1905 return (ct_init);
1906
1907 /* have a statement which begins with END -- this is the END statement
1908 * if what follows are zero or more blanks and/or tabs followed by the
1909 * end of line character or ! (inline comment)
1910 */
1911 for (++p; isblank(*p); ++p)
1912 ;
1913 if (*p != '\n' && *p != '!')
1914 return (ct_init);
1915
1916 return (CT_END);
1917 }
1918
1919 /* Construct single source listing line using cardb and curr_line. */
1920 static void
write_card(void)1921 write_card(void)
1922 {
1923 char *from, *to;
1924 int max_len;
1925 int len;
1926
1927 max_len = sizeof(printbuff) - 1; /* leave room for newline & null */
1928 sprintf(printbuff, "(%5d) ", curr_line);
1929 if (incl_level > 0)
1930 printbuff[7] = '*';
1931 len = 8;
1932 for (from = cardb, to = &printbuff[8]; *from != '\n';) {
1933 if (++len >= max_len) {
1934 *to++ = '\0';
1935 break;
1936 }
1937 *to++ = *from++;
1938 }
1939 *to = '\0';
1940 }
1941
1942 /*
1943 * Check whether this is a parsed !pgi$ pragma
1944 * Return CT_PRAGMA if not; CT_PPRAGMA if so.
1945 */
1946 static int
check_pgi_pragma(char * beg)1947 check_pgi_pragma(char *beg)
1948 {
1949 int c;
1950 int len;
1951 char *bbeg;
1952 int tkntyp;
1953
1954 bbeg = beg;
1955
1956 while (TRUE) {
1957 c = *beg;
1958 if (!iswhite(c))
1959 break;
1960 if (c == '\n')
1961 return CT_PRAGMA;
1962 beg++;
1963 }
1964 len = is_ident(beg);
1965 if (len == 0)
1966 return CT_PRAGMA;
1967 scmode = SCM_IDENT;
1968 scn.stmtyp = 0;
1969 tkntyp = keyword(beg, &ppragma_kw, &len, TRUE);
1970 if (tkntyp)
1971 return CT_PPRAGMA;
1972
1973 return CT_PRAGMA;
1974 } /* check_pgi_pragma */
1975
1976 /* Certain directives affect the state of the scanner and need to be
1977 * processed now rather than by p_pragma(). Examples are the cray
1978 * directives, fixed and free.
1979 */
1980 static int
check_pragma(char * beg)1981 check_pragma(char *beg)
1982 {
1983 int c;
1984 int len;
1985 char *bbeg;
1986
1987 bbeg = beg;
1988
1989 while (TRUE) {
1990 c = *beg;
1991 if (!iswhite(c))
1992 break;
1993 if (c == '\n')
1994 return CT_PRAGMA;
1995 beg++;
1996 }
1997 len = is_ident(beg);
1998 if (len == 4) {
1999 if (ic_strncmp(beg, "free") == 0 && is_lineblank(beg + 4))
2000 return CT_FREE;
2001 return CT_PRAGMA;
2002 }
2003 if (len == 5) {
2004 if (ic_strncmp(beg, "fixed") == 0 && is_lineblank(beg + 5))
2005 return CT_FIXED;
2006 return CT_PRAGMA;
2007 }
2008 if (len == 10) {
2009 if (ic_strncmp(beg, "distribute") == 0) {
2010 beg += 10;
2011 while (TRUE) {
2012 c = *beg;
2013 if (!iswhite(c))
2014 break;
2015 if (c == '\n')
2016 return CT_PRAGMA;
2017 beg++;
2018 }
2019 len = is_ident(beg);
2020 if (len == 5) {
2021 if (ic_strncmp(beg, "point") == 0 && is_lineblank(beg + 5)) {
2022 strcpy(bbeg, "distributepoint\n");
2023 return CT_DEC;
2024 }
2025 }
2026 }
2027 if (ic_strncmp(beg, "ignore_tkr") == 0) {
2028 return CT_PPRAGMA;
2029 }
2030 return CT_PRAGMA;
2031 }
2032 if (len == 15) {
2033 if (ic_strncmp(beg, "distributepoint") == 0 && is_lineblank(beg + 15)) {
2034 strcpy(bbeg, "distributepoint\n");
2035 return CT_DEC;
2036 }
2037 return CT_PRAGMA;
2038 }
2039
2040 return CT_PRAGMA;
2041 }
2042
2043 /* simple strncmp, ignore case: str may contain uppercase letters and may
2044 * not be null-terminated; pat contains only lower case characters and is
2045 * null-terminated. length of str is at least the length of pattern.
2046 */
2047 static int
ic_strncmp(char * str,char * pattern)2048 ic_strncmp(char *str, char *pattern)
2049 {
2050 int n;
2051 int ch;
2052 int i;
2053
2054 n = strlen(pattern);
2055 for (i = 0; i < n; i++) {
2056 ch = str[i];
2057 if (ch >= 'A' && ch <= 'Z')
2058 ch += ('a' - 'A'); /* to lower case */
2059 if (ch != pattern[i])
2060 return (ch - pattern[i]);
2061 }
2062 return 0;
2063 }
2064
2065 static LOGICAL
is_lineblank(char * start)2066 is_lineblank(char *start)
2067 {
2068 char *p;
2069 int c;
2070
2071 for (p = start; (c = *p) != '\n'; p++) {
2072 if (!iswhite(c))
2073 return FALSE;
2074 }
2075 return TRUE;
2076 }
2077
2078 /* Prepare one Fortran stmt for scanning. The contents of the statement
2079 buffer are crunched from stmtbefore to stmtbafter.
2080 The following is done:
2081 1. blanks and tabs are eliminated.
2082 2. upper case letters converted to lower case, unless -upcase flag.
2083 3. Hollerith and character constants are extracted and entered into
2084 the symbol table. A special marker is put into the crunched
2085 buffer to indicate the type of token, and the two locations which
2086 follow contain a symbol table pointer for the constant, which has
2087 been split.
2088 4 Non-decimal constants are marked in the crunch buffer. A special
2089 marker is put into the buffer and the digits and the ending quote
2090 are copied to the buffer.
2091 5. Inline comments are stripped - this is done by moving the input
2092 pointer to the end of the line containing the '!'.
2093 6. correct balancing of parentheses is checked.
2094 7. correct balancing of brackets is checked.
2095 8. exposed equal sign, exposed comma, and exposed attribute (::) flags
2096 are set.
2097 9. extract the label, if present and the input is freeform.
2098
2099 */
2100 static void
crunch(void)2101 crunch(void)
2102 {
2103 int c, ctmp; /* BOBT - better type int than char */
2104 static char *inptr; /* next char to be processed */
2105 char *outptr; /* last previous char put into crunched stmt */
2106 char *outlim; /* limit reverse scan for Holleriths */
2107 int parlev; /* current parenthesis nesting level */
2108 int upper_to_lower; /* amount to add to convert u.c. to
2109 * l.c. */
2110 int slshlv; /* current slash nesting level, = 0 or 1 */
2111 char *p; /* pointer into statement buffer */
2112 int bracket; /* current bracket nesting level */
2113 int len; /* length of character or Hollerith string */
2114 int sptr; /* symbol table pointer. */
2115 int delim; /* string delimiter ' or " */
2116 LOGICAL last_char_is_blank;
2117 int holl_kind; /* kind of Hollerith - 'h', 'l', 'r' */
2118 char *startid; /* where the first identifer starts */
2119 LOGICAL in_format;
2120 LOGICAL last_is_pseudo; /* last char copied is a pseudo char CH_... */
2121
2122 parlev = slshlv = bracket = 0;
2123 exp_equal = exp_comma = FALSE;
2124 exp_ptr_assign = exp_attr = follow_attr = par1_attr = FALSE;
2125 outptr = outlim = stmtbafter - 1;
2126 upper_to_lower = 32;
2127 if (flg.ucase)
2128 upper_to_lower = 0;
2129 sig_blanks = scn.is_hpf || is_freeform;
2130 if (scn.multiple_stmts) {
2131 scn.multiple_stmts = FALSE;
2132 len = ff_get_label(inptr);
2133 inptr += len;
2134 } else if (is_freeform) {
2135 len = ff_get_label(stmtb);
2136 inptr = stmtb + len;
2137 } else
2138 inptr = stmtb;
2139
2140 last_char_is_blank = FALSE;
2141 last_is_pseudo = FALSE;
2142
2143 /* pick up the first identifier of the statement */
2144 for (; (c = *inptr) != '\n'; inptr++) {
2145 c &= 0xFF; /* only needed because of kanji support */
2146 /*
2147 * skip over any blank and non-printing (value less than blank)
2148 * characters.
2149 */
2150 if (!iswhite(c))
2151 break;
2152 }
2153 startid = outptr + 1;
2154 while (isident(c)) {
2155 if (isupper(c))
2156 c += upper_to_lower;
2157 *++outptr = c;
2158 c = *++inptr;
2159 c &= 0xFF;
2160 }
2161 in_format = FALSE;
2162 if (outptr - startid == 5 && strncmp(stmtb, "format", 6) == 0)
2163 /* 5 may appear to be incorrect, but outptr locates the last character
2164 * of the identifier.
2165 */
2166 in_format = TRUE;
2167 for (; (c = *inptr) != '\n'; inptr++) {
2168 last_char_is_blank = FALSE;
2169 c &= 0xFF; /* only needed because of kanji support */
2170 /*
2171 * ignore the blank character, and all non-printing characters whose
2172 * integer value is less than blank. This includes tabs.
2173 */
2174 if (iswhite(c)) {
2175 if (sig_blanks) {
2176 *++outptr = ' '; /* blanks are significant */
2177 while ((c = *++inptr) != '\n') {
2178 c &= 0xFF;
2179 if (c > ' ')
2180 break;
2181 }
2182 inptr--;
2183 last_char_is_blank = TRUE;
2184 last_is_pseudo = FALSE;
2185 }
2186 continue;
2187 }
2188 if (isupper(c))
2189 c += upper_to_lower;
2190
2191 if (c == '\'' || c == '"') {
2192 char *eostr;
2193 delim = c;
2194 len = 0;
2195 for (p = inptr + 1; (c = *p++) != delim;) {
2196 if (c == '\n')
2197 goto do_string;
2198 len++;
2199 }
2200 if ((c = *p) == delim) /* watch out for two consecutive */
2201 goto do_string; /* quotes */
2202 /*
2203 * get the first printable character after the quote.
2204 */
2205 eostr = p;
2206 while (iswhite(c)) {
2207 if (c == '\n')
2208 goto chk_mil_const;
2209 c = *++p;
2210 }
2211 if (c == 'x' || c == 'X') {
2212 *++outptr = CH_X;
2213 goto copynondec;
2214 }
2215 if (c == 'o' || c == 'O') {
2216 *++outptr = CH_O;
2217 goto copynondec;
2218 }
2219 if (c == 'c' || c == 'C') {
2220 /* this notation creates a null-terminated (ala C)
2221 * string. Cleat the 'c', insert the null character.
2222 */
2223 *p = ' ';
2224 *(eostr - 1) = '\0';
2225 *eostr = delim;
2226 if (flg.standard)
2227 error(170, 2, curr_line,
2228 "c-style termination of character constants ", CNULL);
2229 goto do_string;
2230 }
2231 chk_mil_const:
2232 /*
2233 * Check for f90 style of hex, octal, and binary constants:
2234 * Z'ddddd', z'ddddd', O'ddddd', o'dddddd', B'ddddd', B"ddddd"
2235 * Begin by looking at the character immediately preceding the
2236 * first quote.
2237 */
2238 if (outptr == outlim)
2239 goto do_string;
2240 c = *outptr;
2241 if (c == 'z' || c == 'Z') {
2242 *outptr = CH_X; /* overwrite the 'z' */
2243 p--; /* leave the pointer at the ' */
2244 goto copynondec;
2245 }
2246 if (!in_format && (c == 'x' || c == 'X')) {
2247 *outptr = CH_X; /* overwrite the 'x' */
2248 p--; /* leave the pointer at the ' */
2249 if (flg.standard)
2250 error(170, 2, gbl.lineno, "X'...' hexadecimal constant notation",
2251 CNULL);
2252 goto copynondec;
2253 }
2254 if (c == 'o' || c == 'O') {
2255 *outptr = CH_O; /* overwrite the 'o' */
2256 p--;
2257 goto copynondec;
2258 }
2259 if (c == 'b' || c == 'B') {
2260 *outptr = CH_B; /* overwrite the 'b' */
2261 p--;
2262 goto copynondec;
2263 }
2264 goto do_string;
2265
2266 copynondec:
2267 while (len-- >= 0) { /* copy all digits plus end quote -
2268 * ignore white spaces */
2269 c = *++inptr;
2270 if (iswhite(c))
2271 continue;
2272 *++outptr = c;
2273 }
2274 inptr = p;
2275 last_is_pseudo = FALSE;
2276 continue;
2277 }
2278 if (isholl(c)) {
2279 /* possible Hollerith constant has been found: */
2280
2281 if (c != 'h' && in_format)
2282 goto copychar;
2283 holl_kind = c;
2284 /* `outlim` is used so that `p` doesn't reverse scan into our
2285 * tokenized string built thus far.
2286 */
2287 for (p = outptr; p > outlim && isdig(*p); p--)
2288 ;
2289 if (p == outptr)
2290 goto copychar;
2291 ctmp = *p;
2292 if (iscsym(ctmp))
2293 goto copychar;
2294 if (parlev == 0 && slshlv == 0 && !exp_equal && ctmp != ',' &&
2295 ctmp != ')')
2296 goto copychar;
2297 *(outptr + 1) = '\0'; /* limit scan */
2298 sscanf(p + 1, "%d", &len);
2299 if (XBIT(125, 4)) {
2300 int ilen = (stmtb + last_char[card_count - 1]) - inptr;
2301 /* compute #bytes */
2302 len = kanji_prefix((unsigned char *)inptr + 1, len, ilen);
2303 }
2304 /* check for sufficient chars in line: */
2305 if ((inptr - stmtb) + len > last_char[card_count - 1]) {
2306 errwarn(123);
2307 len = (stmtb + last_char[card_count - 1]) - inptr;
2308 }
2309 sptr = getstring(inptr + 1, len);
2310 sptr = gethollerith(sptr, holl_kind);
2311 outptr = p + 1; /* point back to first digit */
2312 *outptr = CH_HOLLERITH;
2313 *++outptr = (char)((sptr >> 24) & 0xFF);
2314 *++outptr = (char)((sptr >> 16) & 0xFF);
2315 *++outptr = (char)((sptr >> 8) & 0xFF);
2316 *++outptr = (char)(sptr & 0xFF);
2317 outlim = outptr;
2318 inptr += len; /* point to last char of Hollerith constant */
2319 /* (should check that we haven't moved past end of line - '\n') */
2320 last_is_pseudo = TRUE;
2321 continue;
2322 }
2323 if (c == '!') { /* strip inline comment */
2324 int pos, i;
2325 char *ppp; /* ptr to pragma stuff if present */
2326
2327 pos = inptr - stmtb; /* position of '!' */
2328
2329 /* step thru the last character positions for all the lines in
2330 * this statement beginning with the first line; the line
2331 * containing '!' will be the first line whose last char position
2332 * is > or = to the position of '!'.
2333 * After the line is found, move the input pointer to the end
2334 * of the line -- inptr is incremented by the main crunch loop.
2335 */
2336 for (i = 0; i < card_count; i++) {
2337 if (last_char[i] >= pos)
2338 break;
2339 }
2340 /*
2341 * check for sun's inline form of c$pragma.
2342 *
2343 */
2344 ppp = inptr;
2345 inptr = stmtb + last_char[i];
2346 if (ppp[1] == '$' && (ppp[2] == 'P' || ppp[2] == 'p') &&
2347 (ppp[3] == 'R' || ppp[3] == 'r') &&
2348 (ppp[4] == 'A' || ppp[4] == 'a') &&
2349 (ppp[5] == 'G' || ppp[5] == 'g') &&
2350 (ppp[6] == 'M' || ppp[6] == 'm') &&
2351 (ppp[7] == 'A' || ppp[7] == 'a')) {
2352 /*
2353 * communicate to p_pragma() that this is a sun directive.
2354 * do so by prepending the substring beginning with the
2355 * first character after "pragma" with "sun".
2356 * NOTE: p_pragma expects a terminated line; inptr locates
2357 * the end of the line containing "!c$pragma". In
2358 * the next position store a newline.
2359 */
2360 char save_ch;
2361 save_ch = inptr[1];
2362 inptr[1] = '\n';
2363 strncpy(&ppp[5], "sun", 3);
2364 p_pragma(&ppp[5], gbl.lineno);
2365 inptr[1] = save_ch;
2366 }
2367 continue;
2368 }
2369 if (c == ';') {
2370 /*
2371 * Multiple statements: save position of next character,
2372 * terminate current statement with the ';', and check
2373 * for errors in the current statement.
2374 */
2375 inptr++; /* locate the character after ';' */
2376 /* If line ends with a blank, delete it */
2377 if (outptr < outlim && !last_is_pseudo && *outptr == ' ')
2378 outptr--;
2379 /* WARNING: if the last line in multiple statements may be all
2380 * blanks, eos will point to the position one before the
2381 * beginning of stmtb and the first character will be '\n'.
2382 * This should be ok since the '\n' will cause get_token to
2383 * move on without the chance of eos being examined.
2384 */
2385 eos = outptr;
2386 *++outptr = ';';
2387 goto end_of_stmt_checks;
2388 }
2389
2390 /* just copy the character after a few state checks */
2391
2392 if (isalpha(c) || isdig(c))
2393 goto copychar;
2394 if (c == '(')
2395 parlev++;
2396 else if (c == ')') {
2397 if (--parlev < 0)
2398 break;
2399 } else if (c == '[')
2400 bracket++;
2401 else if (c == ']') {
2402 if (--bracket < 0)
2403 break;
2404 } else if (c == '/' && *(inptr + 1) != '=')
2405 slshlv = 1 - slshlv;
2406 else if (c == '=' && *(inptr + 1) == '=') {
2407 *++outptr = '='; /* == token */
2408 inptr++;
2409 } else if (c == '=' && *(inptr + 1) == '>') {
2410 *++outptr = '='; /* => token */
2411 inptr++;
2412 c = '>';
2413 exp_ptr_assign = TRUE;
2414 } else if (parlev == 0) {
2415 if (c == '=') {
2416 if (outptr > stmtb)
2417 switch (*outptr) { /* check char before '=' */
2418 #if DEBUG
2419 case '=':
2420 interr("crunch ==", 3, 2);
2421 #endif
2422 case '<':
2423 case '>':
2424 case '/':
2425 break;
2426 default:
2427 exp_equal = TRUE;
2428 }
2429 else
2430 exp_equal = TRUE;
2431 } else if (c == ',')
2432 exp_comma = TRUE;
2433 else if (c == ':' && *(inptr + 1) == ':') {
2434 exp_attr = TRUE;
2435 }
2436 } else if (parlev == 1 && c == ':' && *(inptr + 1) == ':') {
2437 par1_attr = TRUE;
2438 }
2439 copychar:
2440 *++outptr = c;
2441 last_is_pseudo = FALSE;
2442 continue;
2443
2444 do_string:
2445 /* a character string constant has been found: */
2446 sptr = get_cstring(inptr, &len);
2447
2448 if (len) {
2449 /* the character after the quoted string may indicate that the
2450 * string is actually a Hollerith constant. However, this syntatical
2451 * form is not allowed in FORMAT statements.
2452 */
2453 if (!in_format && isholl(inptr[len + 2])) {
2454 *++outptr = CH_HOLLERITH;
2455 sptr = gethollerith(sptr, inptr[len + 2]);
2456 len++; /* so the Hollerith indicator is skipped */
2457 } else {
2458 *++outptr = CH_STRING;
2459 if (outptr > outlim + 1) {
2460 c = *(outptr - 1);
2461 /* check for a possible kind value preceding the string */
2462 if (c == '_') {
2463 c = *(outptr - 2);
2464 if (isident(c))
2465 *(outptr - 1) = CH_UNDERSCORE;
2466 }
2467 /* check for NC preceding quoted string: */
2468 else if (c == 'c' || c == 'C') {
2469 c = *(outptr - 2);
2470 if (c == 'n' || c == 'N') { /* this is kanji string */
2471 outptr -= 2; /* erase NC */
2472 *outptr = CH_KSTRING;
2473 }
2474 }
2475 }
2476 }
2477 *++outptr = (char)((sptr >> 24) & 0xFF);
2478 *++outptr = (char)((sptr >> 16) & 0xFF);
2479 *++outptr = (char)((sptr >> 8) & 0xFF);
2480 *++outptr = (char)(sptr & 0xFF);
2481 } else {
2482
2483 /* Unterminated string can cause parser confusion:
2484 len is zero, and get_cstring returned error */
2485 if (scnerrfg)
2486 return;
2487
2488 /* use a special marker to denote the null string; necessary
2489 * since using CH_STRING requires >2 bytes
2490 */
2491 *++outptr = CH_NULLSTR;
2492 if (outptr > outlim + 1) {
2493 c = *(outptr - 1);
2494 /* check for a possible kind value preceding the string */
2495 if (c == '_') {
2496 c = *(outptr - 2);
2497 if (isident(c))
2498 *(outptr - 1) = CH_UNDERSCORE;
2499 }
2500 }
2501 }
2502 outlim = outptr;
2503 inptr += (len + 1);
2504 last_is_pseudo = TRUE;
2505 }
2506
2507 /* If line ends with a blank, delete it */
2508 if (last_char_is_blank)
2509 outptr--;
2510 eos = outptr;
2511 *(++outptr) = '\n'; /* mark end of stmtb contents */
2512
2513 end_of_stmt_checks:
2514 if ((parlev || bracket) && !scnerrfg) {
2515 if (parlev)
2516 error(23, 3, gbl.lineno, "parentheses", CNULL);
2517 if (bracket)
2518 error(23, 3, gbl.lineno, "brackets", CNULL);
2519 scnerrfg = TRUE;
2520 }
2521 }
2522
2523 /* ensure that the first identifier after '!$omp' is an SMP keyword. */
2524 static int
classify_smp(void)2525 classify_smp(void)
2526 {
2527 char *cp;
2528 int idlen; /* number of characters in id string; becomes
2529 * the length of a keyword.
2530 */
2531 int c, savec;
2532 char *ip;
2533 int k;
2534
2535 /* skip any leading white space */
2536
2537 cp = currc;
2538 c = *cp;
2539 while (iswhite(c)) {
2540 if (c == '\n')
2541 goto no_identifier;
2542 c = *++cp;
2543 }
2544
2545 /* extract maximal potential id string: */
2546
2547 idlen = is_ident(cp);
2548 if (idlen == 0)
2549 goto no_identifier;
2550
2551 scmode = SCM_IDENT;
2552 scn.stmtyp = 0;
2553 tkntyp = keyword(cp, &parbegkw, &idlen, TRUE);
2554 ip = cp;
2555 cp += idlen;
2556
2557 switch (scn.stmtyp = tkntyp) {
2558 case 0:
2559 goto ill_smp;
2560
2561 case TK_ENDSTMT:
2562 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
2563 switch (*++cp) {
2564 case 'a':
2565 if (k == 6 && strncmp(cp, "atomic", 6) == 0) {
2566 cp += 6;
2567 scn.stmtyp = tkntyp = TK_MP_ENDATOMIC;
2568 goto end_shared;
2569 }
2570 break;
2571 case 'c':
2572 if (k == 8 && strncmp(cp, "critical", 8) == 0) {
2573 cp += 8;
2574 scn.stmtyp = tkntyp = TK_MP_ENDCRITICAL;
2575 goto end_shared;
2576 }
2577 break;
2578 case 'd':
2579 if (k == 2 && cp[1] == 'o') {
2580 scn.stmtyp = tkntyp = TK_MP_ENDPDO;
2581 cp += 2;
2582 if (*cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
2583 strncmp(cp + 1, "simd", 4) == 0) {
2584 cp += 4 + 1;
2585 scn.stmtyp = tkntyp = TK_MP_ENDDOSIMD;
2586 }
2587 goto end_shared_nowait;
2588 }
2589 if (k == 6 && strncmp(cp, "dosimd", 6) == 0) {
2590 cp += 6;
2591 scn.stmtyp = tkntyp = TK_MP_ENDDOSIMD;
2592 goto end_shared_nowait;
2593 }
2594 if (strncmp(cp, "distribute", 10) == 0) {
2595 cp += 10;
2596 scn.stmtyp = tkntyp = TK_MP_ENDDISTRIBUTE;
2597 if ((is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) ||
2598 is_ident(cp)) {
2599 if (*cp == ' ')
2600 ++cp;
2601 switch (*cp) {
2602 case 'p':
2603 if (strncmp(cp, "parallel", 8) == 0) {
2604 cp += 8;
2605 if ((*cp == ' ' && is_ident(cp + 1) == 2 &&
2606 strncmp(cp + 1, "do", 2) == 0) ||
2607 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
2608 if (*cp == ' ')
2609 ++cp;
2610 cp += 2;
2611 if ((*cp == ' ' && is_ident(cp + 1) &&
2612 strncmp(cp + 1, "simd", 4) == 0) ||
2613 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2614 if (*cp == ' ')
2615 ++cp;
2616 cp += 4;
2617 scn.stmtyp = tkntyp = TK_MP_ENDDISTPARDOSIMD;
2618 goto end_shared;
2619 }
2620 scn.stmtyp = tkntyp = TK_MP_ENDDISTPARDO;
2621 goto end_shared;
2622 }
2623 cp -= 8;
2624 break;
2625 }
2626 goto end_shared;
2627 case 's':
2628 if (strncmp(cp, "simd", 4) == 0) {
2629 scn.stmtyp = tkntyp = TK_MP_ENDDISTSIMD;
2630 goto end_shared;
2631 }
2632 }
2633 }
2634 goto end_shared;
2635 }
2636 break;
2637 case 'm':
2638 if (k == 6 && strncmp(cp, "master", 6) == 0) {
2639 cp += 6;
2640 scn.stmtyp = tkntyp = TK_MP_ENDMASTER;
2641 goto end_shared;
2642 }
2643 break;
2644 case 'o':
2645 if (k == 7 && strncmp(cp, "ordered", 7) == 0) {
2646 cp += 7;
2647 scn.stmtyp = tkntyp = TK_MP_ENDORDERED;
2648 goto end_shared;
2649 }
2650 break;
2651 case 'p':
2652 if (k == 16 && strncmp(cp, "parallelsections", 16) == 0) {
2653 cp += 16;
2654 scn.stmtyp = tkntyp = TK_MP_ENDPARSECTIONS;
2655 goto end_shared;
2656 }
2657 if (k == 17 && strncmp(cp, "parallelworkshare", 17) == 0) {
2658 cp += 17;
2659 scn.stmtyp = tkntyp = TK_MP_ENDPARWORKSHR;
2660 goto end_shared;
2661 }
2662 if (k == 10 && strncmp(cp, "paralleldo", 10) == 0) {
2663 cp += 10;
2664 scn.stmtyp = tkntyp = TK_MP_ENDPARDO;
2665 if (*cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
2666 strncmp(cp + 1, "simd", 4) == 0) {
2667 cp += 4 + 1;
2668 scn.stmtyp = tkntyp = TK_MP_ENDPARDOSIMD;
2669 }
2670 goto end_shared;
2671 }
2672 if (k == 14 && strncmp(cp, "paralleldosimd", 14) == 0) {
2673 cp += 14;
2674 scn.stmtyp = tkntyp = TK_MP_ENDPARDOSIMD;
2675 goto end_shared;
2676 }
2677 if (strncmp(cp, "parallel", 8) == 0) {
2678 cp += 8;
2679 if ((*cp == ' ' && is_ident(cp + 1) == 2 &&
2680 strncmp(cp + 1, "do", 2) == 0) ||
2681 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
2682 if (*cp == ' ')
2683 ++cp;
2684 cp += 2;
2685 if ((*cp == ' ' && is_ident(cp + 1) &&
2686 strncmp(cp + 1, "simd", 4) == 0) ||
2687 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2688 if (*cp == ' ')
2689 ++cp;
2690 cp += 4;
2691 scn.stmtyp = tkntyp = TK_MP_ENDPARDOSIMD;
2692 goto end_shared;
2693 }
2694 scn.stmtyp = tkntyp = TK_MP_ENDPARDO;
2695 goto end_shared;
2696 } else if (*cp == ' ' && (k = is_ident(cp + 1)) == 9 &&
2697 strncmp(cp + 1, "workshare", 9) == 0) {
2698 cp += 9 + 1;
2699 scn.stmtyp = tkntyp = TK_MP_ENDPARWORKSHR;
2700 goto end_shared;
2701 } else if (*cp == ' ' && (k = is_ident(cp + 1)) == 8 &&
2702 strncmp(cp + 1, "sections", 8) == 0) {
2703 cp += 8 + 1;
2704 scn.stmtyp = tkntyp = TK_MP_ENDPARSECTIONS;
2705 goto end_shared;
2706 }
2707 scn.stmtyp = tkntyp = TK_MP_ENDPARALLEL;
2708 goto end_shared;
2709 }
2710 break;
2711 case 's':
2712 if (k == 6 && strncmp(cp, "single", 6) == 0) {
2713 cp += 6;
2714 scn.stmtyp = tkntyp = TK_MP_ENDSINGLE;
2715 goto end_shared_nowait;
2716 }
2717 if (k == 8 && strncmp(cp, "sections", 8) == 0) {
2718 cp += 8;
2719 scn.stmtyp = tkntyp = TK_MP_ENDSECTIONS;
2720 goto end_shared_nowait;
2721 }
2722 if (k == 4 && strncmp(cp, "simd", 4) == 0) {
2723 cp += 4;
2724 scn.stmtyp = tkntyp = TK_MP_ENDSIMD;
2725 goto end_shared_nowait;
2726 }
2727 break;
2728 case 't':
2729 if (k == 8 && strncmp(cp, "taskloop", 8) == 0) {
2730 cp += 8;
2731 if ((*cp == ' ' && is_ident(cp + 1) &&
2732 strncmp(cp + 1, "simd", 4) == 0) ||
2733 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2734 if (*cp == ' ')
2735 ++cp;
2736 cp += 4;
2737 scn.stmtyp = tkntyp = TK_MP_ENDTASKLOOPSIMD;
2738 goto end_shared_nowait;
2739 }
2740 scn.stmtyp = tkntyp = TK_MP_ENDTASKLOOP;
2741 goto end_shared_nowait;
2742 }
2743 if (k == 4 && strncmp(cp, "task", 4) == 0) {
2744 cp += 4;
2745 scn.stmtyp = tkntyp = TK_MP_ENDTASK;
2746 goto end_shared_nowait;
2747 }
2748 if ((*cp == ' ' && is_ident(cp + 1) &&
2749 strncmp(cp + 1, "teams", 5) == 0) ||
2750 (is_ident(cp) && strncmp(cp, "teams", 5) == 0)) {
2751 if (*cp == ' ')
2752 ++cp;
2753 cp += 5;
2754 if ((*cp == ' ' && is_ident(cp + 1) &&
2755 strncmp(cp + 1, "distribute", 10) == 0) ||
2756 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
2757 if (*cp == ' ')
2758 ++cp;
2759 cp += 10;
2760 if ((*cp == ' ' && is_ident(cp + 1) &&
2761 strncmp(cp + 1, "simd", 4) == 0) ||
2762 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2763 if (*cp == ' ')
2764 ++cp;
2765 cp += 4;
2766 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTSIMD;
2767 goto end_shared_nowait;
2768 }
2769 if ((*cp == ' ' && is_ident(cp + 1) &&
2770 strncmp(cp + 1, "parallel", 8) == 0) ||
2771 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
2772 if (*cp == ' ')
2773 ++cp;
2774 cp += 8;
2775 if ((*cp == ' ' && is_ident(cp + 1) == 2 &&
2776 strncmp(cp + 1, "do", 2) == 0) ||
2777 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
2778 if (*cp == ' ')
2779 ++cp;
2780 cp += 2;
2781 if ((*cp == ' ' && is_ident(cp + 1) &&
2782 strncmp(cp + 1, "simd", 4) == 0) ||
2783 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2784 if (*cp == ' ')
2785 ++cp;
2786 cp += 4;
2787 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTPARDOSIMD;
2788 goto end_shared_nowait;
2789 }
2790 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTPARDO;
2791 goto end_shared_nowait;
2792 }
2793 cp -= 8;
2794 break;
2795 }
2796 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDIST;
2797 goto end_shared_nowait;
2798 }
2799 scn.stmtyp = tkntyp = TK_MP_ENDTEAMS;
2800 goto end_shared_nowait;
2801 }
2802 if (strncmp(cp, "target", 6) == 0) {
2803 cp += 6;
2804 if (*cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
2805 strncmp(cp + 1, "data", 4) == 0) {
2806 cp += 4 + 1;
2807 scn.stmtyp = tkntyp = TK_MP_ENDTARGETDATA;
2808 goto end_shared;
2809 }
2810 if ((*cp == ' ' && is_ident(cp + 1) &&
2811 strncmp(cp + 1, "teams", 5) == 0) ||
2812 (is_ident(cp) && strncmp(cp, "teams", 5) == 0)) {
2813 if (*cp == ' ')
2814 ++cp;
2815 cp += 5;
2816 if ((*cp == ' ' && is_ident(cp + 1) &&
2817 strncmp(cp + 1, "distribute", 10) == 0) ||
2818 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
2819 if (*cp == ' ')
2820 ++cp;
2821 cp += 10;
2822 if ((*cp == ' ' && is_ident(cp + 1) &&
2823 strncmp(cp + 1, "simd", 4) == 0) ||
2824 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2825 if (*cp == ' ')
2826 ++cp;
2827 cp += 4;
2828 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTSIMD;
2829 goto end_shared;
2830 }
2831 if ((*cp == ' ' && is_ident(cp + 1) &&
2832 strncmp(cp + 1, "parallel", 8) == 0) ||
2833 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
2834 if (*cp == ' ')
2835 ++cp;
2836 cp += 8;
2837 if ((*cp == ' ' && is_ident(cp + 1) &&
2838 strncmp(cp + 1, "do", 2) == 0) ||
2839 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
2840 if (*cp == ' ')
2841 ++cp;
2842 cp += 2;
2843 if ((*cp == ' ' && is_ident(cp + 1) &&
2844 strncmp(cp + 1, "simd", 4) == 0) ||
2845 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2846 if (*cp == ' ')
2847 ++cp;
2848 cp += 4;
2849 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDOSIMD;
2850 goto end_shared;
2851 }
2852 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
2853 goto end_shared;
2854 } else {
2855 cp -= 8;
2856 goto end_shared;
2857 }
2858 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
2859 goto end_shared;
2860 }
2861
2862 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDIST;
2863 goto end_shared;
2864 }
2865 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMS;
2866 goto end_shared;
2867 }
2868 if ((*cp == ' ' && is_ident(cp + 1) &&
2869 strncmp(cp + 1, "simd", 4) == 0) ||
2870 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2871 if (*cp == ' ')
2872 ++cp;
2873 cp += 4;
2874 scn.stmtyp = tkntyp = TK_MP_ENDTARGSIMD;
2875 goto end_shared;
2876 }
2877 if ((*cp == ' ' && is_ident(cp + 1) &&
2878 strncmp(cp + 1, "parallel", 8) == 0) ||
2879 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
2880 if (*cp == ' ')
2881 ++cp;
2882 cp += 8;
2883 if ((*cp == ' ' && is_ident(cp + 1) &&
2884 strncmp(cp + 1, "do", 2) == 0) ||
2885 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
2886 if (*cp == ' ')
2887 ++cp;
2888 cp += 2;
2889 if ((*cp == ' ' && is_ident(cp + 1) &&
2890 strncmp(cp + 1, "simd", 4) == 0) ||
2891 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
2892 if (*cp == ' ')
2893 ++cp;
2894 cp += 4;
2895 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDOSIMD;
2896 goto end_shared;
2897 }
2898 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDO;
2899 goto end_shared;
2900 }
2901 scn.stmtyp = tkntyp = TK_MP_ENDTARGPAR;
2902 goto end_shared;
2903 }
2904 scn.stmtyp = tkntyp = TK_MP_ENDTARGET;
2905 goto end_shared;
2906 }
2907 if (k == 9 && strncmp(cp, "taskgroup", 9) == 0) {
2908 cp += 9;
2909 scn.stmtyp = tkntyp = TK_MP_ENDTASKGROUP;
2910 goto end_shared_nowait;
2911 }
2912 if (k == 35 &&
2913 strncmp(cp, "targetteamsdistributeparalleldosimd", 35) == 0) {
2914 cp += 35;
2915 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDOSIMD;
2916 goto end_shared;
2917 }
2918 if (k == 25 && strncmp(cp, "targetteamsdistributesimd", 25) == 0) {
2919 cp += 25;
2920 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTSIMD;
2921 goto end_shared;
2922 }
2923 if (k == 21 && strncmp(cp, "targetteamsdistribute", 21) == 0) {
2924 cp += 21;
2925 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDIST;
2926 goto end_shared;
2927 }
2928 if (k == 10 && strncmp(cp, "targetdata", 10) == 0) {
2929 cp += 10;
2930 scn.stmtyp = tkntyp = TK_MP_ENDTARGETDATA;
2931 goto end_shared;
2932 }
2933 if (k == 11 && strncmp(cp, "targetteams", 11) == 0) {
2934 cp += 11;
2935 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMS;
2936 goto end_shared;
2937 }
2938 if (k == 14 && strncmp(cp, "targetparallel", 14) == 0) {
2939 cp += 14;
2940 scn.stmtyp = tkntyp = TK_MP_ENDTARGPAR;
2941 goto end_shared;
2942 }
2943 if (k == 16 && strncmp(cp, "targetparalleldo", 16) == 0) {
2944 cp += 16;
2945 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDO;
2946 goto end_shared;
2947 }
2948 if (k == 20 && strncmp(cp, "targetparalleldosimd", 20) == 0) {
2949 cp += 20;
2950 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDOSIMD;
2951 goto end_shared;
2952 }
2953
2954 break;
2955 case 'w':
2956 if (k == 9 && strncmp(cp, "workshare", 9) == 0) {
2957 cp += 9;
2958 scn.stmtyp = tkntyp = TK_MP_ENDWORKSHARE;
2959 goto end_shared_nowait;
2960 }
2961 break;
2962 default:
2963 break;
2964 }
2965 }
2966 goto ill_smp;
2967
2968 case TK_MP_ENDPDO:
2969 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
2970 switch (*++cp) {
2971 case 'd':
2972 if (k == 6 && strncmp(cp, "dosimd", 6) == 0) {
2973 cp += 6;
2974 scn.stmtyp = tkntyp = TK_MP_ENDDOSIMD;
2975 }
2976 break;
2977 case 's':
2978 if (k == 4 && strncmp(cp, "simd", 4) == 0) {
2979 cp += 4;
2980 scn.stmtyp = tkntyp = TK_MP_ENDDOSIMD;
2981 }
2982 }
2983 }
2984 /* fall thru to end_shared_nowait: */
2985 case TK_MP_ENDSECTIONS:
2986 case TK_MP_ENDSIMD:
2987 case TK_MP_ENDSINGLE:
2988 case TK_MP_ENDWORKSHARE:
2989 case TK_MP_ENDTASK:
2990 case TK_MP_ENDTASKGROUP:
2991 end_shared_nowait:
2992 scmode = SCM_PAR;
2993 break;
2994
2995 case TK_MP_ENDTARGET:
2996 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
2997 switch (*++cp) {
2998 case 'd':
2999 if (k == 4 && strncmp(cp, "data", 4) == 0) {
3000 cp += 4;
3001 scn.stmtyp = tkntyp = TK_MP_ENDTARGETDATA;
3002 }
3003 break;
3004 case 't':
3005 if (k == 5 && strncmp(cp, "teams", 5) == 0) {
3006 cp += 5;
3007 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMS;
3008 if ((*cp == ' ' && is_ident(cp + 1) &&
3009 strncmp(cp + 1, "distribute", 10) == 0) ||
3010 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
3011 if (*cp == ' ')
3012 ++cp;
3013 cp += 10;
3014 if ((*cp == ' ' && is_ident(cp + 1) &&
3015 strncmp(cp + 1, "simd", 4) == 0) ||
3016 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3017 if (*cp == ' ')
3018 ++cp;
3019 cp += 4;
3020 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTSIMD;
3021 goto end_shared;
3022 }
3023 if ((*cp == ' ' && is_ident(cp + 1) &&
3024 strncmp(cp + 1, "parallel", 8) == 0) ||
3025 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
3026 if (*cp == ' ')
3027 ++cp;
3028 cp += 8;
3029 if ((*cp == ' ' && is_ident(cp + 1) &&
3030 strncmp(cp + 1, "do", 2) == 0) ||
3031 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3032 if (*cp == ' ')
3033 ++cp;
3034 cp += 2;
3035 if ((*cp == ' ' && is_ident(cp + 1) &&
3036 strncmp(cp + 1, "simd", 4) == 0) ||
3037 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3038 if (*cp == ' ')
3039 ++cp;
3040 cp += 4;
3041 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDOSIMD;
3042 goto end_shared;
3043 }
3044 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
3045 goto end_shared;
3046 } else {
3047 cp -= 8;
3048 goto end_shared;
3049 }
3050 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
3051 goto end_shared;
3052 }
3053 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDIST;
3054 goto end_shared;
3055 }
3056 }
3057 break;
3058 case 'p':
3059 if ((*cp == ' ' && is_ident(cp + 1) &&
3060 strncmp(cp + 1, "parallel", 8) == 0) ||
3061 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
3062 if (*cp == ' ')
3063 ++cp;
3064 cp += 8;
3065 if ((*cp == ' ' && is_ident(cp + 1) &&
3066 strncmp(cp + 1, "do", 2) == 0) ||
3067 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3068 if (*cp == ' ')
3069 ++cp;
3070 cp += 2;
3071 if ((*cp == ' ' && is_ident(cp + 1) &&
3072 strncmp(cp + 1, "simd", 4) == 0) ||
3073 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3074 if (*cp == ' ')
3075 ++cp;
3076 cp += 4;
3077 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDOSIMD;
3078 goto end_shared;
3079 }
3080 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDO;
3081 goto end_shared;
3082 }
3083 scn.stmtyp = tkntyp = TK_MP_ENDTARGPAR;
3084 goto end_shared;
3085 }
3086 break;
3087 }
3088 }
3089 goto end_shared;
3090
3091 case TK_MP_ENDPARDO:
3092 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3093 strncmp(cp + 1, "simd", 4) == 0) {
3094 cp += 4 + 1;
3095 scn.stmtyp = tkntyp = TK_MP_ENDPARDOSIMD;
3096 }
3097 goto end_shared;
3098
3099 case TK_MP_ENDDISTRIBUTE:
3100 if ((is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) ||
3101 is_ident(cp)) {
3102 if (*cp == ' ')
3103 ++cp;
3104 switch (*cp) {
3105 case 'p':
3106 if (strncmp(cp, "parallel", 8) == 0) {
3107 cp += 8;
3108 if ((*cp == ' ' && is_ident(cp + 1) == 2 &&
3109 strncmp(cp + 1, "do", 2) == 0) ||
3110 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3111 if (*cp == ' ')
3112 ++cp;
3113 cp += 2;
3114 if ((*cp == ' ' && is_ident(cp + 1) &&
3115 strncmp(cp + 1, "simd", 4) == 0) ||
3116 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3117 if (*cp == ' ')
3118 ++cp;
3119 cp += 4;
3120 scn.stmtyp = tkntyp = TK_MP_ENDDISTPARDOSIMD;
3121 goto end_shared;
3122 }
3123 scn.stmtyp = tkntyp = TK_MP_ENDDISTPARDO;
3124 goto end_shared;
3125 }
3126 cp -= 8;
3127 break;
3128 }
3129 case 's':
3130 if (strncmp(cp, "simd", 4) == 0) {
3131 scn.stmtyp = tkntyp = TK_MP_ENDDISTSIMD;
3132 goto end_shared;
3133 }
3134 }
3135 }
3136 break;
3137
3138 case TKF_ENDDISTPAR:
3139 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 2 &&
3140 strncmp(cp + 1, "do", 2) == 0) {
3141 cp += 2 + 1;
3142 scn.stmtyp = tkntyp = TK_MP_ENDDISTPARDO;
3143 scmode = SCM_PAR;
3144 break;
3145 }
3146 goto ill_smp;
3147
3148 case TK_MP_ENDPARALLEL:
3149 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
3150 switch (*++cp) {
3151 case 'd':
3152 if (k == 2 && cp[1] == 'o') {
3153 cp += 2;
3154 scn.stmtyp = tkntyp = TK_MP_ENDPARDO;
3155 } else if (k == 6 && strncmp(cp, "dosimd", 6) == 0) {
3156 cp += 6;
3157 scn.stmtyp = tkntyp = TK_MP_ENDPARDOSIMD;
3158 }
3159 break;
3160 }
3161 }
3162 /* fall thru to end_shared: */
3163 case TK_MP_ENDCRITICAL:
3164 case TK_MP_ENDMASTER:
3165 case TK_MP_ENDORDERED:
3166 case TK_MP_ENDPARSECTIONS:
3167 case TK_MP_ENDPARWORKSHR:
3168 case TK_MP_ENDTARGPARDOSIMD:
3169 end_shared:
3170 break;
3171
3172 case TK_MP_ENDTARGTEAMS:
3173 if ((*cp == ' ' && is_ident(cp + 1) &&
3174 strncmp(cp + 1, "distribute", 10) == 0) ||
3175 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
3176 if (*cp == ' ')
3177 ++cp;
3178 cp += 10;
3179 if ((*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0) ||
3180 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3181 if (*cp == ' ')
3182 ++cp;
3183 cp += 4;
3184 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTSIMD;
3185 goto end_shared;
3186 }
3187 if ((*cp == ' ' && is_ident(cp + 1) &&
3188 strncmp(cp + 1, "parallel", 8) == 0) ||
3189 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
3190 if (*cp == ' ')
3191 ++cp;
3192 cp += 8;
3193 if ((*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "do", 2) == 0) ||
3194 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3195 if (*cp == ' ')
3196 ++cp;
3197 cp += 2;
3198 if ((*cp == ' ' && is_ident(cp + 1) &&
3199 strncmp(cp + 1, "simd", 4) == 0) ||
3200 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3201 if (*cp == ' ')
3202 ++cp;
3203 cp += 4;
3204 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDOSIMD;
3205 goto end_shared;
3206 }
3207 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
3208 goto end_shared;
3209 } else {
3210 cp -= 8;
3211 goto end_shared;
3212 }
3213 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
3214 goto end_shared;
3215 }
3216 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDIST;
3217 goto end_shared;
3218 }
3219
3220 break;
3221 case TK_MP_ENDTARGTEAMSDIST:
3222 if ((is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) ||
3223 is_ident(cp)) {
3224 if (*cp == ' ')
3225 ++cp;
3226 switch (*cp) {
3227 case 'p':
3228 if (strncmp(cp, "parallel", 8) == 0) {
3229 cp += 8;
3230 if ((*cp == ' ' && is_ident(cp + 1) == 2 &&
3231 strncmp(cp + 1, "do", 2) == 0) ||
3232 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3233 if (*cp == ' ')
3234 ++cp;
3235 cp += 2;
3236 if ((*cp == ' ' && is_ident(cp + 1) &&
3237 strncmp(cp + 1, "simd", 4) == 0) ||
3238 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3239 if (*cp == ' ')
3240 ++cp;
3241 cp += 4;
3242 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDOSIMD;
3243 goto end_shared;
3244 }
3245 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDO;
3246 goto end_shared;
3247 }
3248 cp -= 8;
3249 break;
3250 }
3251 case 's':
3252 if (strncmp(cp, "simd", 4) == 0) {
3253 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTSIMD;
3254 goto end_shared;
3255 }
3256 }
3257 }
3258 break;
3259
3260 case TK_MP_ENDTARGPAR:
3261 if (is_freeform &&
3262 (*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "do", 2) == 0)) {
3263 if (*cp == ' ')
3264 ++cp;
3265 cp += 2;
3266 if ((*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0) ||
3267 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3268 if (*cp == ' ')
3269 ++cp;
3270 cp += 4;
3271 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDOSIMD;
3272 goto end_shared;
3273 }
3274 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDO;
3275 goto end_shared;
3276 }
3277 break;
3278 case TK_MP_ENDTARGPARDO:
3279 if (is_freeform &&
3280 (*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0)) {
3281 if (*cp == ' ')
3282 ++cp;
3283 cp += 4;
3284 scn.stmtyp = tkntyp = TK_MP_ENDTARGPARDOSIMD;
3285 goto end_shared;
3286 }
3287 break;
3288 case TK_MP_ENDDISTPARDO:
3289 if (is_freeform &&
3290 (*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0)) {
3291 if (*cp == ' ')
3292 ++cp;
3293 cp += 4;
3294 scn.stmtyp = tkntyp = TK_MP_ENDDISTPARDOSIMD;
3295 goto end_shared;
3296 }
3297 break;
3298
3299 case TK_MP_ENDTARGTEAMSDISTPARDO:
3300 if (is_freeform &&
3301 (*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0)) {
3302 if (*cp == ' ')
3303 ++cp;
3304 cp += 4;
3305 scn.stmtyp = tkntyp = TK_MP_ENDTARGTEAMSDISTPARDOSIMD;
3306 goto end_shared;
3307 }
3308 break;
3309
3310 case TK_MP_ENDTEAMS:
3311 if ((*cp == ' ' && is_ident(cp + 1) &&
3312 strncmp(cp + 1, "distribute", 10) == 0) ||
3313 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
3314 if (*cp == ' ')
3315 ++cp;
3316 cp += 10;
3317 if ((*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0) ||
3318 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3319 if (*cp == ' ')
3320 ++cp;
3321 cp += 4;
3322 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTSIMD;
3323 goto end_shared;
3324 }
3325 if ((*cp == ' ' && is_ident(cp + 1) &&
3326 strncmp(cp + 1, "parallel", 8) == 0) ||
3327 (is_ident(cp) && strncmp(cp, "parallel", 8) == 0)) {
3328 if (*cp == ' ')
3329 ++cp;
3330 cp += 8;
3331 if ((*cp == ' ' && is_ident(cp + 1) && strncmp(cp + 1, "do", 2) == 0) ||
3332 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3333 if (*cp == ' ')
3334 ++cp;
3335 cp += 2;
3336 if ((*cp == ' ' && is_ident(cp + 1) &&
3337 strncmp(cp + 1, "simd", 4) == 0) ||
3338 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3339 if (*cp == ' ')
3340 ++cp;
3341 cp += 4;
3342 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTPARDOSIMD;
3343 goto end_shared;
3344 }
3345 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTPARDO;
3346 goto end_shared;
3347 } else {
3348 cp -= 8;
3349 goto end_shared;
3350 }
3351 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDISTPARDO;
3352 goto end_shared;
3353 }
3354 scn.stmtyp = tkntyp = TK_MP_ENDTEAMSDIST;
3355 goto end_shared;
3356 }
3357
3358 break;
3359
3360 case TK_MP_PARALLEL:
3361 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
3362 switch (*++cp) {
3363 case 'd':
3364 if (k == 2 && cp[1] == 'o') {
3365 cp += 2;
3366 scn.stmtyp = tkntyp = TK_MP_PARDO;
3367 if (*cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3368 strncmp(cp + 1, "simd", 4) == 0) {
3369 cp += 4 + 1;
3370 scn.stmtyp = tkntyp = TK_MP_PARDOSIMD;
3371 }
3372 } else if (k == 6 && strncmp(cp, "dosimd", 6) == 0) {
3373 cp += 6;
3374 scn.stmtyp = tkntyp = TK_MP_PARDOSIMD;
3375 }
3376 break;
3377 case 's':
3378 if (k == 8 && strncmp(cp, "sections", 8) == 0) {
3379 cp += 8;
3380 scn.stmtyp = tkntyp = TK_MP_PARSECTIONS;
3381 }
3382 break;
3383 case 'w':
3384 if (k == 9 && strncmp(cp, "workshare", 9) == 0) {
3385 cp += 9;
3386 scn.stmtyp = tkntyp = TK_MP_PARWORKSHR;
3387 }
3388 break;
3389 default:
3390 break;
3391 }
3392 }
3393 scmode = SCM_PAR;
3394 break;
3395
3396 case TK_MP_PARDO:
3397 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3398 strncmp(cp + 1, "simd", 4) == 0) {
3399 cp += 4 + 1;
3400 scn.stmtyp = tkntyp = TK_MP_PARDOSIMD;
3401 }
3402 case TK_MP_PARSECTIONS:
3403 case TK_MP_PARWORKSHR:
3404 case TK_MP_PARDOSIMD:
3405 scmode = SCM_PAR;
3406 break;
3407
3408 case TK_MP_PDO:
3409 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3410 strncmp(cp + 1, "simd", 4) == 0) {
3411 cp += 4 + 1;
3412 scn.stmtyp = tkntyp = TK_MP_DOSIMD;
3413 }
3414 scmode = SCM_PAR;
3415 break;
3416
3417 case TK_DECLARE:
3418 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
3419 if (k == 9 && strncmp(cp + 1, "reduction", 9) == 0) {
3420 cp += 9 + 1;
3421 scn.stmtyp = tkntyp = TK_MP_DECLAREREDUCTION;
3422 break;
3423 }
3424 if (k == 4 && strncmp(cp + 1, "simd", 4) == 0) {
3425 cp += 4 + 1;
3426 scn.stmtyp = tkntyp = TK_MP_DECLARESIMD;
3427 scmode = SCM_PAR;
3428 break;
3429 }
3430 if (k == 6 && strncmp(cp + 1, "target", 6) == 0) {
3431 cp += 6 + 1;
3432 scn.stmtyp = tkntyp = TK_MP_DECLARETARGET;
3433 scmode = SCM_PAR;
3434 break;
3435 }
3436 }
3437 goto ill_smp;
3438
3439 case TK_MP_DECLARESIMD:
3440 case TK_MP_DECLARETARGET:
3441 scmode = SCM_PAR;
3442 break;
3443
3444 case TK_MP_DISTRIBUTE:
3445 if ((is_freeform && *cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3446 if (*cp == ' ')
3447 ++cp;
3448 switch (*cp) {
3449 case 's':
3450 if (strncmp(cp, "simd", 4) == 0) {
3451 cp += 4;
3452 scn.stmtyp = tkntyp = TK_MP_DISTSIMD;
3453 break;
3454 }
3455 break;
3456 case 'p':
3457 if (strncmp(cp, "parallel", 8) == 0) {
3458 cp += 8;
3459 if ((*cp == ' ' &&
3460 (is_ident(cp + 1) && strncmp(cp + 1, "do", 2) == 0)) ||
3461 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3462 if (*cp == ' ')
3463 ++cp;
3464 cp += 2;
3465
3466 if ((*cp == ' ' &&
3467 (is_ident(cp + 1) && strncmp(cp + 1, "simd", 4) == 0)) ||
3468 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3469 if (*cp == ' ')
3470 ++cp;
3471 cp += 4;
3472 scn.stmtyp = tkntyp = TK_MP_DISTPARDOSIMD;
3473 } else {
3474 scn.stmtyp = tkntyp = TK_MP_DISTPARDO;
3475 }
3476 break;
3477 } else {
3478 cp -= 8;
3479 goto ill_smp;
3480 }
3481 }
3482 if (strncmp(cp, "paralleldo", 10) == 0) {
3483 scn.stmtyp = tkntyp = TK_MP_DISTPARDO;
3484 }
3485 if (strncmp(cp, "paralleldosimd", 14) == 0) {
3486 scn.stmtyp = tkntyp = TK_MP_DISTPARDOSIMD;
3487 }
3488 break;
3489 default:
3490 break;
3491 }
3492 }
3493 scmode = SCM_PAR;
3494 break;
3495 case TKF_DISTPAR:
3496 if ((*cp == ' ' && (is_ident(cp + 1) && strncmp(cp + 1, "do", 2) == 0)) ||
3497 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3498 if (*cp == ' ')
3499 ++cp;
3500 cp += 2;
3501 if (is_ident(cp) && strncmp(cp, "simd", 4) == 0) {
3502 cp += 4;
3503 scn.stmtyp = tkntyp = TK_MP_DISTPARDOSIMD;
3504 } else {
3505 scn.stmtyp = tkntyp = TK_MP_DISTPARDO;
3506 }
3507 } else {
3508 cp -= 8;
3509 goto ill_smp;
3510 }
3511 scmode = SCM_PAR;
3512 break;
3513
3514 case TK_MP_DOACROSS:
3515 case TK_MP_SECTIONS:
3516 case TK_MP_SINGLE:
3517 case TK_MP_WORKSHARE:
3518 case TK_MP_TASKLOOPSIMD:
3519 case TK_MP_ATOMIC:
3520 case TK_MP_DOSIMD:
3521 case TK_MP_SIMD:
3522 case TK_MP_TARGETDATA:
3523 case TK_MP_TARGETENTERDATA:
3524 case TK_MP_TARGETEXITDATA:
3525 case TK_MP_TARGETUPDATE:
3526 case TK_MP_TARGTEAMSDISTPARDOSIMD:
3527 case TK_MP_TARGTEAMSDISTSIMD:
3528 case TK_MP_TARGSIMD:
3529 case TK_MP_TEAMSDISTPARDOSIMD:
3530 case TK_MP_TEAMSDISTSIMD:
3531 case TK_MP_DISTPARDOSIMD:
3532 case TK_MP_DISTSIMD:
3533 case TK_MP_CANCEL:
3534 scmode = SCM_PAR;
3535 break;
3536 case TK_MP_TASK:
3537 if (is_ident(cp) && strncmp(cp, "loop", 4) == 0) {
3538 cp += 4;
3539 goto taskloop;
3540 } else {
3541 scn.stmtyp = tkntyp = TK_MP_TASK;
3542 scmode = SCM_PAR;
3543 break;
3544 }
3545 case TK_MP_TASKLOOP:
3546 taskloop:
3547 if ((*cp == ' ' && (is_ident(cp + 1)) &&
3548 strncmp(cp + 1, "simd", 4) == 0) ||
3549 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3550 if (*cp == ' ')
3551 ++cp;
3552 cp += 4;
3553 scn.stmtyp = tkntyp = TK_MP_TASKLOOPSIMD;
3554 }
3555 scn.stmtyp = tkntyp = TK_MP_TASKLOOP;
3556 scmode = SCM_PAR;
3557 break;
3558
3559 case TK_MP_TARGTEAMS:
3560 if ((*cp == ' ' && (is_ident(cp + 1)) &&
3561 strncmp(cp + 1, "distribute", 10) == 0) ||
3562 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
3563 if (*cp == ' ')
3564 ++cp;
3565 cp += 10;
3566 if ((*cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3567 if (*cp == ' ')
3568 ++cp;
3569 switch (*cp) {
3570 case 's':
3571 if (strncmp(cp, "simd", 4) == 0) {
3572 cp += 4;
3573 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTSIMD;
3574 break;
3575 }
3576 break;
3577 case 'p':
3578 if (strncmp(cp, "parallel", 8) == 0) {
3579 cp += 8;
3580 if ((*cp == ' ' && is_ident(cp + 1) &&
3581 strncmp(cp + 1, "do", 2) == 0) ||
3582 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3583 if (*cp == ' ')
3584 ++cp;
3585 cp += 2;
3586 if ((*cp == ' ' && is_ident(cp + 1) &&
3587 strncmp(cp + 1, "simd", 4) == 0) ||
3588 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3589 if (*cp == ' ')
3590 ++cp;
3591 cp += 4;
3592 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3593 } else {
3594 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO;
3595 }
3596 break;
3597 } else {
3598 cp -= 8;
3599 goto ill_smp;
3600 }
3601 }
3602 if (strncmp(cp, "paralleldo", 10) == 0) {
3603 cp += 10;
3604 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO;
3605 }
3606 if (strncmp(cp, "paralleldosimd", 14) == 0) {
3607 cp += 14;
3608 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3609 }
3610 break;
3611 default:
3612 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDIST;
3613 break;
3614 }
3615 } else {
3616 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDIST;
3617 }
3618 }
3619 scmode = SCM_PAR;
3620 break;
3621
3622 case TK_MP_TEAMSDISTPARDO:
3623 if (is_freeform && *cp == ' ' && is_ident(cp + 1) &&
3624 strncmp(cp + 1, "simd", 4) == 0) {
3625 cp += 4 + 1;
3626 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDOSIMD;
3627 }
3628
3629 scmode = SCM_PAR;
3630 break;
3631 case TK_MP_TEAMSDIST:
3632 if ((is_freeform && *cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3633 if (*cp == ' ')
3634 ++cp;
3635 switch (*cp) {
3636 case 's':
3637 if (strncmp(cp, "simd", 4) == 0) {
3638 cp += 4;
3639 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTSIMD;
3640 break;
3641 }
3642 break;
3643 case 'p':
3644 if (strncmp(cp, "parallel", 8) == 0) {
3645 cp += 8;
3646 if ((*cp == ' ' &&
3647 (is_ident(cp + 1) && strncmp(cp + 1, "do", 2) == 0)) ||
3648 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3649 if (*cp == ' ')
3650 ++cp;
3651 cp += 2;
3652 if ((is_ident(cp) && strncmp(cp, "simd", 4) == 0) ||
3653 (*cp == ' ' && is_ident(cp + 1) &&
3654 strncmp(cp + 1, "simd", 4) == 0)) {
3655 if (*cp == ' ')
3656 ++cp;
3657 cp += 4;
3658 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDOSIMD;
3659 } else {
3660 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDO;
3661 }
3662 break;
3663 } else {
3664 cp -= 8;
3665 goto ill_smp;
3666 }
3667 }
3668 if (strncmp(cp, "paralleldo", 10) == 0) {
3669 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDO;
3670 }
3671 if (strncmp(cp, "paralleldosimd", 14) == 0) {
3672 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDOSIMD;
3673 }
3674 break;
3675 default:
3676 break;
3677 }
3678 }
3679 scmode = SCM_PAR;
3680 break;
3681
3682 case TK_MP_DISTPARDO:
3683 if (is_freeform && *cp == ' ' && is_ident(cp + 1) &&
3684 strncmp(cp + 1, "simd", 4) == 0) {
3685 cp += 4 + 1;
3686 scn.stmtyp = tkntyp = TK_MP_DISTPARDOSIMD;
3687 }
3688 scmode = SCM_PAR;
3689 break;
3690
3691 case TK_MP_TARGTEAMSDISTPARDO:
3692 if ((*cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3693 if (*cp == ' ')
3694 ++cp;
3695 if (strncmp(cp, "simd", 4) == 0) {
3696 cp += 4;
3697 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3698 }
3699 }
3700 scmode = SCM_PAR;
3701 break;
3702 case TK_MP_TARGTEAMSDIST:
3703 if ((*cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3704 if (*cp == ' ')
3705 ++cp;
3706 switch (*cp) {
3707 case 's':
3708 if (strncmp(cp, "simd", 4) == 0) {
3709 cp += 4;
3710 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTSIMD;
3711 break;
3712 }
3713 break;
3714 case 'p':
3715 if (strncmp(cp, "parallel", 8) == 0) {
3716 cp += 8;
3717 if ((*cp == ' ' && is_ident(cp + 1) &&
3718 strncmp(cp + 1, "do", 2) == 0) ||
3719 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3720 if (*cp == ' ')
3721 ++cp;
3722 cp += 2;
3723 if ((*cp == ' ' && is_ident(cp + 1) &&
3724 strncmp(cp + 1, "simd", 4) == 0) ||
3725 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3726 if (*cp == ' ')
3727 ++cp;
3728 cp += 4;
3729 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3730 } else {
3731 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO;
3732 }
3733 break;
3734 } else {
3735 cp -= 8;
3736 goto ill_smp;
3737 }
3738 }
3739 if (strncmp(cp, "paralleldo", 10) == 0) {
3740 cp += 10;
3741 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO;
3742 }
3743 if (strncmp(cp, "paralleldosimd", 14) == 0) {
3744 cp += 14;
3745 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3746 }
3747 break;
3748 default:
3749 break;
3750 }
3751 }
3752 scmode = SCM_PAR;
3753 break;
3754
3755 case TK_MP_TEAMS:
3756 if ((*cp == ' ' && (is_ident(cp + 1)) &&
3757 strncmp(cp + 1, "distribute", 10) == 0) ||
3758 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
3759 if (*cp == ' ')
3760 ++cp;
3761 cp += 10;
3762 if ((*cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3763 if (*cp == ' ')
3764 ++cp;
3765 switch (*cp) {
3766 case 's':
3767 if (strncmp(cp, "simd", 4) == 0) {
3768 cp += 4;
3769 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTSIMD;
3770 break;
3771 }
3772 break;
3773 case 'p':
3774 if (strncmp(cp, "parallel", 8) == 0) {
3775 cp += 8;
3776 if ((*cp == ' ' && is_ident(cp + 1) &&
3777 strncmp(cp + 1, "do", 2) == 0) ||
3778 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3779 if (*cp == ' ')
3780 ++cp;
3781 cp += 2;
3782 if ((*cp == ' ' && is_ident(cp + 1) &&
3783 strncmp(cp + 1, "simd", 4) == 0) ||
3784 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3785 if (*cp == ' ')
3786 ++cp;
3787 cp += 4;
3788 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDOSIMD;
3789 } else {
3790 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDO;
3791 }
3792 break;
3793 } else {
3794 cp -= 8;
3795 goto ill_smp;
3796 }
3797 }
3798 if (strncmp(cp, "paralleldo", 10) == 0) {
3799 cp += 10;
3800 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDO;
3801 }
3802 if (strncmp(cp, "paralleldosimd", 14) == 0) {
3803 cp += 14;
3804 scn.stmtyp = tkntyp = TK_MP_TEAMSDISTPARDOSIMD;
3805 }
3806 break;
3807 default:
3808 scn.stmtyp = tkntyp = TK_MP_TEAMSDIST;
3809 break;
3810 }
3811 } else {
3812 scn.stmtyp = tkntyp = TK_MP_TEAMSDIST;
3813 }
3814 }
3815 scmode = SCM_PAR;
3816 break;
3817
3818 case TK_MP_TARGET:
3819 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) != 0) {
3820 switch (*++cp) {
3821 case 'd':
3822 if (k == 4 && strncmp(cp, "data", 4) == 0) {
3823 cp += 4;
3824 scn.stmtyp = tkntyp = TK_MP_TARGETDATA;
3825 }
3826 break;
3827 case 'e':
3828 if (k == 4 && strncmp(cp, "exit", 4) == 0) {
3829 cp += 4;
3830 if (*cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3831 strncmp(cp + 1, "data", 4) == 0) {
3832 cp += 4 + 1;
3833 scn.stmtyp = tkntyp = TK_MP_TARGETEXITDATA;
3834 } else
3835 cp -= 4;
3836 } else if (k == 5 && strncmp(cp, "enter", 5) == 0) {
3837 cp += 5;
3838 if (*cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3839 strncmp(cp + 1, "data", 4) == 0) {
3840 cp += 4 + 1;
3841 scn.stmtyp = tkntyp = TK_MP_TARGETENTERDATA;
3842 } else
3843 cp -= 5;
3844 } else if (k == 8 && strncmp(cp, "exitdata", 8) == 0) {
3845 cp += 8;
3846 scn.stmtyp = tkntyp = TK_MP_TARGETEXITDATA;
3847 } else if (k == 9 && strncmp(cp, "enterdata", 9) == 0) {
3848 cp += 9;
3849 scn.stmtyp = tkntyp = TK_MP_TARGETENTERDATA;
3850 }
3851 break;
3852 case 'p':
3853 if (strncmp(cp, "parallel", 8) == 0) {
3854 cp += 8;
3855 if ((*cp == ' ' && is_ident(cp + 1) &&
3856 strncmp(cp + 1, "do", 2) == 0) ||
3857 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3858 if (*cp == ' ')
3859 ++cp;
3860 cp += 2;
3861 if ((*cp == ' ' && is_ident(cp + 1) &&
3862 strncmp(cp + 1, "simd", 4) == 0) ||
3863 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3864 if (*cp == ' ')
3865 ++cp;
3866 cp += 4;
3867 scn.stmtyp = tkntyp = TK_MP_TARGPARDOSIMD;
3868 } else {
3869 scn.stmtyp = tkntyp = TK_MP_TARGPARDO;
3870 }
3871 break;
3872 } else {
3873 scn.stmtyp = tkntyp = TK_MP_TARGPAR;
3874 }
3875 }
3876 if (is_ident(cp) && strncmp(cp, "paralleldo", 10) == 0) {
3877 cp += 10;
3878 scn.stmtyp = tkntyp = TK_MP_TARGPARDO;
3879 }
3880 if (is_ident(cp) && strncmp(cp, "paralleldosimd", 14) == 0) {
3881 cp += 14;
3882 scn.stmtyp = tkntyp = TK_MP_TARGPARDOSIMD;
3883 }
3884 break;
3885
3886 case 't':
3887 if (k == 5 && strncmp(cp, "teams", 5) == 0) {
3888 cp += 5;
3889 scn.stmtyp = tkntyp = TK_MP_TARGTEAMS;
3890 if ((*cp == ' ' && (is_ident(cp + 1)) &&
3891 strncmp(cp + 1, "distribute", 10) == 0) ||
3892 (is_ident(cp) && strncmp(cp, "distribute", 10) == 0)) {
3893 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDIST;
3894 if (*cp == ' ')
3895 ++cp;
3896 cp += 10;
3897 if ((*cp == ' ' && is_ident(cp + 1)) || is_ident(cp)) {
3898 if (*cp == ' ')
3899 ++cp;
3900 switch (*cp) {
3901 case 's':
3902 if (strncmp(cp, "simd", 4) == 0) {
3903 cp += 4;
3904 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTSIMD;
3905 break;
3906 }
3907 break;
3908 case 'p':
3909 if (strncmp(cp, "parallel", 8) == 0) {
3910 cp += 8;
3911 if ((*cp == ' ' && is_ident(cp + 1) &&
3912 strncmp(cp + 1, "do", 2) == 0) ||
3913 (is_ident(cp) && strncmp(cp, "do", 2) == 0)) {
3914 if (*cp == ' ')
3915 ++cp;
3916 cp += 2;
3917 if ((*cp == ' ' && is_ident(cp + 1) &&
3918 strncmp(cp + 1, "simd", 4) == 0) ||
3919 (is_ident(cp) && strncmp(cp, "simd", 4) == 0)) {
3920 if (*cp == ' ')
3921 ++cp;
3922 cp += 4;
3923 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3924 } else {
3925 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO;
3926 }
3927 break;
3928 } else {
3929 cp -= 8;
3930 goto ill_smp;
3931 }
3932 }
3933 if (strncmp(cp, "paralleldo", 10) == 0) {
3934 cp += 10;
3935 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDO;
3936 }
3937 if (strncmp(cp, "paralleldosimd", 14) == 0) {
3938 cp += 14;
3939 scn.stmtyp = tkntyp = TK_MP_TARGTEAMSDISTPARDOSIMD;
3940 }
3941 break;
3942 default:
3943 break;
3944 }
3945 }
3946 }
3947 }
3948 break;
3949 case 'u':
3950 if (k == 6 && strncmp(cp, "update", 6) == 0) {
3951 cp += 6;
3952 scn.stmtyp = tkntyp = TK_MP_TARGETUPDATE;
3953 }
3954 break;
3955 case 's':
3956 if (k == 4 && strncmp(cp, "simd", 4) == 0) {
3957 cp += 4;
3958 scn.stmtyp = tkntyp = TK_MP_TARGSIMD;
3959 }
3960 break;
3961 default:
3962 break;
3963 }
3964 }
3965 scmode = SCM_PAR;
3966 break;
3967
3968 case TK_MP_BARRIER:
3969 case TK_MP_CRITICAL:
3970 case TK_MP_FLUSH:
3971 case TK_MP_MASTER:
3972 case TK_MP_SECTION:
3973 case TK_MP_THREADPRIVATE:
3974 case TK_MP_TASKWAIT:
3975 case TK_MP_TASKGROUP:
3976 break;
3977
3978 case TK_MP_ORDERED:
3979 scn.stmtyp = tkntyp = TK_MP_ORDERED;
3980 scmode = SCM_PAR;
3981 break;
3982
3983
3984 case TKF_TARGETENTER:
3985 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3986 strncmp(cp + 1, "data", 4) == 0) {
3987 cp += 4 + 1;
3988 scn.stmtyp = tkntyp = TK_MP_TARGETENTERDATA;
3989 scmode = SCM_PAR;
3990 break;
3991 }
3992 goto ill_smp;
3993
3994 case TKF_TARGETEXIT:
3995 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 4 &&
3996 strncmp(cp + 1, "data", 4) == 0) {
3997 cp += 4 + 1;
3998 scn.stmtyp = tkntyp = TK_MP_TARGETEXITDATA;
3999 scmode = SCM_PAR;
4000 break;
4001 }
4002 goto ill_smp;
4003
4004 case TKF_CANCELLATION:
4005 if (is_freeform && *cp == ' ' && (k = is_ident(cp + 1)) == 5 &&
4006 strncmp(cp + 1, "point", 5) == 0) {
4007 cp += 5 + 1;
4008 scn.stmtyp = tkntyp = TK_MP_CANCELLATIONPOINT;
4009 break;
4010 }
4011 goto ill_smp;
4012
4013 default:
4014 break;
4015 }
4016
4017 ret:
4018 currc = cp;
4019 return tkntyp;
4020
4021 ill_smp:
4022 savec = *cp;
4023 *cp = 0;
4024 error(287, 2, gbl.lineno, "OpenMP", ip);
4025 *cp = savec;
4026 return 0;
4027
4028 no_identifier:
4029 error(288, 2, gbl.lineno, "OpenMP", CNULL);
4030 return 0;
4031 }
4032
4033 /* ensure that the first identifier after '!dec$' is a DEC keyword. */
4034 static int
classify_dec(void)4035 classify_dec(void)
4036 {
4037 char *cp;
4038 int idlen; /* number of characters in id string; becomes
4039 * the length of a keyword.
4040 */
4041 int c, savec;
4042 char *ip;
4043 int k;
4044
4045 /* skip any leading white space */
4046
4047 cp = currc;
4048 c = *cp;
4049 while (iswhite(c)) {
4050 if (c == '\n')
4051 goto no_identifier;
4052 c = *++cp;
4053 }
4054
4055 /* extract maximal potential id string: */
4056
4057 idlen = is_ident(cp);
4058 if (idlen == 0)
4059 goto no_identifier;
4060
4061 scmode = SCM_IDENT;
4062 scn.stmtyp = 0;
4063 tkntyp = keyword(cp, &deckw, &idlen, TRUE);
4064 ip = cp;
4065 cp += idlen;
4066
4067 switch (scn.stmtyp = tkntyp) {
4068 case 0:
4069 goto ill_dec;
4070 case TK_DISTRIBUTE:
4071 if (*cp == ' ' && (k = is_ident(cp + 1)) != 0) {
4072 if (k == 5 && strncmp(cp + 1, "point", 5) == 0) {
4073 tkntyp = TK_DISTRIBUTEPOINT;
4074 cp += 5 + 1;
4075 break;
4076 }
4077 goto ill_dec;
4078 }
4079 default:
4080 break;
4081 }
4082
4083 ret:
4084 currc = cp;
4085 return tkntyp;
4086
4087 ill_dec:
4088 savec = *cp;
4089 *cp = 0;
4090 error(287, 2, gbl.lineno, "DEC", ip);
4091 *cp = savec;
4092 return 0;
4093
4094 no_identifier:
4095 error(288, 2, gbl.lineno, "DEC", CNULL);
4096 return 0;
4097 }
4098
4099 /* ensure that the first identifier after a misc. sentinel is
4100 * pragma keyword.
4101 */
4102 static int
classify_pragma(void)4103 classify_pragma(void)
4104 {
4105 char *cp;
4106 int idlen; /* number of characters in id string; becomes
4107 * the length of a keyword.
4108 */
4109 int c, savec;
4110 char *ip;
4111 int k;
4112
4113 /* skip any leading white space */
4114
4115 cp = currc;
4116 c = *cp;
4117 while (iswhite(c)) {
4118 if (c == '\n')
4119 goto no_identifier;
4120 c = *++cp;
4121 }
4122
4123 /* extract maximal potential id string: */
4124
4125 idlen = is_ident(cp);
4126 if (idlen == 0)
4127 goto no_identifier;
4128
4129 scmode = SCM_IDENT;
4130 scn.stmtyp = 0;
4131 tkntyp = keyword(cp, &pragma_kw, &idlen, TRUE);
4132 ip = cp;
4133 cp += idlen;
4134
4135 switch (scn.stmtyp = tkntyp) {
4136 case 0:
4137 goto ill_dir;
4138 default:
4139 break;
4140 }
4141
4142 ret:
4143 currc = cp;
4144 return tkntyp;
4145
4146 ill_dir:
4147 savec = *cp;
4148 *cp = 0;
4149 error(287, 2, gbl.lineno, "MEM", ip);
4150 *cp = savec;
4151 return 0;
4152
4153 no_identifier:
4154 error(288, 2, gbl.lineno, "MEM", CNULL);
4155 return 0;
4156 }
4157
4158 /*
4159 * ensure that the first identifier after a misc. sentinel is
4160 * parsed PGI pragma keyword.
4161 */
4162 static int
classify_pgi_pragma(void)4163 classify_pgi_pragma(void)
4164 {
4165 char *cp;
4166 int idlen; /* number of characters in id string; becomes
4167 * the length of a keyword. */
4168 int c, savec;
4169 char *ip;
4170 int k;
4171
4172 /* skip any leading white space */
4173 cp = currc;
4174 c = *cp;
4175 while (iswhite(c)) {
4176 if (c == '\n')
4177 goto no_identifier;
4178 c = *++cp;
4179 }
4180
4181 /* extract maximal potential id string: */
4182
4183 idlen = is_ident(cp);
4184 if (idlen == 0)
4185 goto no_identifier;
4186
4187 scmode = SCM_IDENT;
4188 scn.stmtyp = 0;
4189 tkntyp = keyword(cp, &ppragma_kw, &idlen, TRUE);
4190 ip = cp;
4191 cp += idlen;
4192
4193 if (tkntyp == 0)
4194 goto ill_dir;
4195 scn.stmtyp = tkntyp;
4196
4197 ret:
4198 currc = cp;
4199 return tkntyp;
4200
4201 ill_dir:
4202 savec = *cp;
4203 *cp = 0;
4204 error(287, 2, gbl.lineno, "PGI", ip);
4205 *cp = savec;
4206 return 0;
4207
4208 no_identifier:
4209 error(288, 2, gbl.lineno, "PGI", CNULL);
4210 return 0;
4211 }
4212
4213 static int
classify_pgi_dir(void)4214 classify_pgi_dir(void)
4215 {
4216 char *cp;
4217 int idlen; /* number of characters in id string; becomes
4218 * the length of a keyword. */
4219 int c, savec;
4220 char *ip;
4221 int k;
4222
4223 /* skip any leading white space */
4224 cp = currc;
4225 c = *cp;
4226 while (iswhite(c)) {
4227 if (c == '\n')
4228 goto no_identifier;
4229 c = *++cp;
4230 }
4231
4232 /* extract maximal potential id string: */
4233
4234 idlen = is_ident(cp);
4235 if (idlen == 0)
4236 goto no_identifier;
4237
4238 scmode = SCM_IDENT;
4239 scn.stmtyp = 0;
4240 tkntyp = keyword(cp, &pgi_kw, &idlen, TRUE);
4241 ip = cp;
4242 cp += idlen;
4243
4244 scmode = SCM_ACCEL;
4245
4246 if (tkntyp == 0)
4247 goto ill_dir;
4248 scn.stmtyp = tkntyp;
4249
4250 ret:
4251 currc = cp;
4252 return tkntyp;
4253
4254 ill_dir:
4255 savec = *cp;
4256 *cp = 0;
4257 error(287, 2, gbl.lineno, "pgi", ip);
4258 *cp = savec;
4259 return 0;
4260
4261 no_identifier:
4262 error(288, 2, gbl.lineno, "pgi", CNULL);
4263 return 0;
4264 }
4265
4266 /*
4267 * ensure that the first identifier after a misc. sentinel is
4268 * parsed cuda kernel directive keyword.
4269 */
4270 static int
classify_kernel_pragma(void)4271 classify_kernel_pragma(void)
4272 {
4273 char *cp;
4274 int idlen; /* number of characters in id string; becomes
4275 * the length of a keyword. */
4276 int c, savec;
4277 char *ip;
4278 int k;
4279
4280 /* skip any leading white space */
4281 cp = currc;
4282 c = *cp;
4283 while (iswhite(c)) {
4284 if (c == '\n')
4285 goto no_identifier;
4286 c = *++cp;
4287 }
4288
4289 /* extract maximal potential id string: */
4290
4291 idlen = is_ident(cp);
4292 if (idlen == 0)
4293 goto no_identifier;
4294
4295 scmode = SCM_IDENT;
4296 scn.stmtyp = 0;
4297 tkntyp = keyword(cp, &kernel_kw, &idlen, TRUE);
4298 ip = cp;
4299 cp += idlen;
4300 scmode = SCM_KERNEL;
4301
4302 if (tkntyp == 0)
4303 goto ill_dir;
4304 scn.stmtyp = tkntyp;
4305
4306 ret:
4307 currc = cp;
4308 return tkntyp;
4309
4310 ill_dir:
4311 savec = *cp;
4312 *cp = 0;
4313 error(287, 2, gbl.lineno, "CUF", ip);
4314 *cp = savec;
4315 return 0;
4316
4317 no_identifier:
4318 error(288, 2, gbl.lineno, "CUF", CNULL);
4319 return 0;
4320 }
4321
4322 /*
4323 * ensure that the first identifier after (/ is
4324 * parsed as type keyword for array constructor.
4325 */
4326 static int
classify_ac_type(void)4327 classify_ac_type(void)
4328 {
4329 char *cp, *ip;
4330 int c, idlen;
4331 int colon = 0;
4332 int paren = 0;
4333
4334 /* skip any leading white space */
4335 cp = currc;
4336 c = *cp;
4337
4338 cp = currc;
4339 c = *cp;
4340 while (iswhite(c)) {
4341 if (c == '\n')
4342 goto no_ac_type;
4343 c = *++cp;
4344 }
4345
4346 idlen = is_ident(cp);
4347 if (idlen == 0)
4348 goto no_ac_type;
4349
4350 ip = cp;
4351 cp += idlen;
4352
4353 if (*cp == ' ')
4354 ++cp;
4355
4356 if (*cp == '*') {
4357 ++cp;
4358 if (*cp == ' ')
4359 ++cp;
4360 idlen = is_digit_string(cp);
4361 cp += idlen;
4362
4363 } else if (*cp == '(') {
4364 ++cp;
4365 ++paren;
4366 if (*cp == ' ')
4367 ++cp;
4368 c = *cp;
4369 while (paren) {
4370 if (c == '(')
4371 ++paren;
4372 if (c == ')')
4373 --paren;
4374 if (c == '\n')
4375 goto no_ac_type;
4376 c = *++cp;
4377 }
4378 }
4379 if (*cp == ' ')
4380 ++cp;
4381
4382 /* now search for :: */
4383 if (*cp == ':' && *(cp + 1) == ':') {
4384 return 1;
4385 }
4386
4387 no_ac_type:
4388 return 0;
4389 }
4390
4391 /* extract token which begins with an alphabetic token -
4392 either a keyword or identifier.
4393 Call keyword look-up routine if necessary.
4394 */
4395 static void
alpha(void)4396 alpha(void)
4397 {
4398 int idlen; /* number of characters in id string; becomes
4399 * the length of a keyword.
4400 */
4401 int o_idlen; /* length of original id string */
4402 char *cp; /* pointer into stmtb. */
4403 char id[MAXIDLEN * 4]; /* temp buffer to hold id; larger
4404 * for 'identifier too long' message */
4405 int c, count;
4406 char *ip;
4407 int k;
4408
4409 /* step 1: extract maximal potential id string: */
4410
4411 ip = id;
4412 cp = --currc;
4413 count = MAXIDLEN * 4;
4414 do {
4415 c = *cp++;
4416 if (--count >= 0)
4417 *ip++ = c;
4418 } while (isident(c));
4419 if (ip != id)
4420 --ip;
4421 *ip = '\0';
4422 --cp; /* point to first char after identifier
4423 * string */
4424 o_idlen = idlen = cp - currc;
4425
4426 /* step 2 - check scan mode to determine further processing */
4427
4428 switch (scmode) {
4429 case SCM_FIRST: /* first token of a statement is to be
4430 * processed */
4431 if ((cp[0] == ':' && cp[1] != ':') ||
4432 (is_freeform && cp[0] == ' ' && cp[1] == ':' && cp[2] != ':')) {
4433 tknval = get_id_name(id, idlen);
4434 tkntyp = TK_NAMED_CONSTRUCT;
4435 scn.stmtyp = 0;
4436 goto check_name;
4437 }
4438 if (idlen == 5 && strncmp(id, "error", 5) == 0 &&
4439 *cp == ' ' && strncmp((cp+1), "stop", 4) == 0) {
4440 ERROR_STOP();
4441 goto alpha_exit;
4442 }
4443 if (exp_comma && idlen == 5 && strncmp(id, "quiet", 5) == 0) {
4444 tkntyp = TK_QUIET;
4445 goto alpha_exit;
4446 }
4447 if (exp_attr && exp_comma && idlen == 4 && strncmp(id, "kind", 4) == 0) {
4448 tkntyp = TK_KIND;
4449 goto alpha_exit;
4450 }
4451 if (exp_attr && exp_comma && idlen == 3 && strncmp(id, "len", 3) == 0) {
4452 tkntyp = TK_LEN;
4453 goto alpha_exit;
4454 }
4455 break;
4456 case SCM_GENERIC:
4457 if (follow_attr) {
4458 if (idlen == 8 && strncmp(id, "operator", 8) == 0) {
4459 scmode = SCM_OPERATOR;
4460 if (sem.type_mode == 2) {
4461 /* generic type bound procedure case */
4462 tkntyp = TK_OPERATOR;
4463 goto alpha_exit;
4464 }
4465 }
4466 if (idlen == 10 && strncmp(id, "assignment", 10) == 0 &&
4467 sem.type_mode == 2) {
4468 /* generic type bound procedure case */
4469 tkntyp = TK_ASSIGNMENT;
4470 goto alpha_exit;
4471 }
4472 }
4473 goto fall_thru_scm_ident;
4474 case SCM_LOOKFOR_OPERATOR: /* look for 'operator' followed by '(' */
4475 if (idlen == 8 && *cp == '(' && strncmp(id, "operator", 8) == 0) {
4476 scmode = SCM_OPERATOR;
4477 }
4478 /* fall through */
4479 fall_thru_scm_ident:
4480 case SCM_IDENT: /* look only for identifiers */
4481 if (bind_state == B_RPAREN_FOUND) {
4482 if ((strncmp(id, "result", 6) == 0))
4483 bind_state = B_RESULT_FOUND;
4484 if ((strncmp(id, "bind", 6) == 0)) {
4485 bind_state = B_NONE;
4486 goto get_keyword;
4487 }
4488 }
4489
4490 goto return_identifier;
4491
4492 case SCM_FORMAT: /* look for keywords inside FORMAT
4493 * statements: */
4494 if (*id == '$') {
4495 tkntyp = TK_DOLLAR;
4496 idlen = 1;
4497 goto alpha_exit;
4498 }
4499 tkntyp = keyword(id, &formatkw, &idlen, FALSE);
4500 if (tkntyp <= 0)
4501 goto return_identifier;
4502
4503 /*
4504 * special case for edit descriptors not followed by a digit
4505 */
4506 if (!isdig(id[1])) {
4507 switch (tkntyp) {
4508 case TK_A:
4509 tkntyp = TK_AFORMAT;
4510 break;
4511 case TK_N:
4512 tkntyp = TK_NFORMAT;
4513 break;
4514 case TK_L:
4515 tkntyp = TK_LFORMAT;
4516 break;
4517 case TK_I:
4518 tkntyp = TK_IFORMAT;
4519 break;
4520 case TK_O:
4521 tkntyp = TK_OFORMAT;
4522 break;
4523 case TK_Z:
4524 tkntyp = TK_ZFORMAT;
4525 break;
4526 case TK_F:
4527 tkntyp = TK_FFORMAT;
4528 break;
4529 case TK_E:
4530 tkntyp = TK_EFORMAT;
4531 break;
4532 case TK_G:
4533 tkntyp = TK_GFORMAT;
4534 break;
4535 case TK_D:
4536 tkntyp = TK_DFORMAT;
4537 break;
4538 case TK_DT:
4539 if (*cp == ' ' || *cp == ',' || *cp == ')') {
4540 tkntyp = TK_DTFORMAT;
4541 } else if (*cp == '(') {
4542 } else {
4543 }
4544 break;
4545 default:
4546 break;
4547 }
4548 } else if (id[1] == '0') {
4549 if (*cp == ' ' || *cp == ',' || *cp == ')') {
4550 tkntyp = TK_G0FORMAT; /* G0 */
4551 idlen += 1;
4552 }
4553 }
4554 goto alpha_exit;
4555
4556 case SCM_IMPLICIT: /* look for letters, NONE, or keywords in
4557 * IMPLICIT stmt */
4558 if (seen_implp) {
4559 if (idlen > 1)
4560 goto return_identifier;
4561 tkntyp = TK_LETTER;
4562 tknval = *currc;
4563 } else if (par_depth)
4564 goto return_identifier;
4565 else if (idlen == 4 && strncmp(id, "none", 4) == 0)
4566 tkntyp = TK_NONE;
4567 else if ((tkntyp = keyword(id, &normalkw, &idlen, sig_blanks)) == 0)
4568 goto return_identifier;
4569 else if (tkntyp == TKF_DOUBLE) {
4570 tkntyp = double_type(&currc[idlen], &idlen);
4571 if (tkntyp) {
4572 goto alpha_exit;
4573 }
4574 goto return_identifier;
4575 } else if (tkntyp < 0) /* one of other TKF_ values */
4576 goto return_identifier;
4577 goto alpha_exit;
4578
4579 case SCM_PROCEDURE:
4580 /*
4581 * First identifer after TK_PROCEDURE.
4582 * For procedures, procedure pointers, and procedure component
4583 * pointers, parens must follow PROCEDURE and enclose the
4584 * procedure interface. Also, if attributes are present, this
4585 * declaration must be entity style.
4586 */
4587 if (par_depth) {
4588 /*
4589 * looking at <proc interf>, so it could be an identifier or
4590 * a type; in any case, keep the same scmode.
4591 */
4592 if ((tkntyp = keyword(id, &normalkw, &idlen, sig_blanks)) == 0)
4593 goto return_identifier;
4594 switch (tkntyp) {
4595 /* should only look for type keywords */
4596 case TK_REAL:
4597 case TK_INTEGER:
4598 case TK_DBLEPREC:
4599 case TK_LOGICAL:
4600 case TK_COMPLEX:
4601 case TK_CHARACTER:
4602 case TK_NCHARACTER:
4603 case TK_DBLECMPLX:
4604 case TK_BYTE:
4605 if (o_idlen == idlen)
4606 goto alpha_exit;
4607 break;
4608 case TK_TYPE:
4609 /* check for TYPE or CLASS */
4610
4611 /* "type (...)" or class (...)" */
4612 if (o_idlen == idlen)
4613 goto alpha_exit;
4614
4615 /* Possible type(...) or class(...) */
4616 if (idlen == 4 && strncmp(id, "type", 4) == 0) {
4617 if (id[4] != '(') {
4618 idlen = is_ident(id);
4619 if (idlen == o_idlen) {
4620 goto return_identifier;
4621 }
4622 }
4623 } else if (idlen == 5 && strncmp(id, "class", 5) == 0) {
4624 if (id[5] != '(') {
4625 idlen = is_ident(id);
4626 if (idlen == o_idlen) {
4627 goto return_identifier;
4628 }
4629 }
4630 }
4631 goto alpha_exit;
4632 case TKF_DOUBLE:
4633 tkntyp = double_type(&currc[idlen], &idlen);
4634 if (tkntyp) {
4635 goto alpha_exit;
4636 }
4637 break;
4638 }
4639 idlen = o_idlen;
4640 goto return_identifier;
4641 }
4642 if (exp_attr) {
4643 scmode = SCM_FIRST;
4644 goto get_keyword;
4645 }
4646 scmode = SCM_IDENT;
4647 goto return_identifier;
4648
4649 case SCM_FUNCTION: /* look for the keyword FUNCTION after a type */
4650 if (par_depth == 0) {
4651 k = idlen;
4652 tkntyp = keyword(id, &normalkw, &k, sig_blanks);
4653 switch (tkntyp) {
4654 case TK_FUNCTION:
4655 scmode = SCM_IDENT;
4656 bind_state = B_FUNC_FOUND;
4657 idlen = k;
4658 goto alpha_exit;
4659 case TK_ELEMENTAL:
4660 case TK_RECURSIVE:
4661 case TK_PURE:
4662 case TK_IMPURE:
4663 case TK_MODULE:
4664 scmode = SCM_FIRST;
4665 idlen = k;
4666 goto alpha_exit;
4667 case TK_ATTRIBUTES:
4668 scmode = SCM_NEXTIDENT;
4669 idlen = k;
4670 goto alpha_exit;
4671 }
4672 scmode = SCM_IDENT;
4673 }
4674 goto return_identifier;
4675
4676 case SCM_IO: /* check for keywords in I/O statements: */
4677 if (par_depth == 0) {
4678 scmode = SCM_IDENT;
4679 goto return_identifier;
4680 }
4681 if (*cp == ' ')
4682 cp++;
4683 if (*cp != '=') {
4684 if (strcmp(id, "readonly") == 0) {
4685 /* should we allow readonly= for better error checking? */
4686 tkntyp = TK_READONLY;
4687 goto alpha_exit;
4688 }
4689 if (strcmp(id, "shared") == 0) {
4690 /* should we allow shared= for better error checking? */
4691 tkntyp = TK_SHARED;
4692 goto alpha_exit;
4693 }
4694 goto return_identifier;
4695 }
4696 tkntyp = keyword(id, &iokw, &idlen, sig_blanks);
4697 if (tkntyp <= 0)
4698 goto return_identifier;
4699 goto alpha_exit;
4700
4701 case SCM_TO: /* look for the "TO" keyword in a goto
4702 * assignment: */
4703 scmode = SCM_IDENT;
4704 if (id[0] == 't' && id[1] == 'o') {
4705 tkntyp = TK_TO;
4706 idlen = 2;
4707 goto alpha_exit;
4708 }
4709 goto return_identifier;
4710
4711 case SCM_IF: /* alphabetic token in an IF or ELSEIF stmt: */
4712 if (par_depth)
4713 goto return_identifier;
4714
4715 /*
4716 * have eaten the expression enclosed in parens following the IF or
4717 * ELSEIF. Now, treat the statement as if scmode = SCM_FIRST;
4718 */
4719 break;
4720
4721 case SCM_DOLAB: /* have finished processing DO <label> : */
4722 scmode = SCM_IDENT;
4723 goto return_identifier;
4724
4725 case SCM_GOTO: /* currently in a GOTO stmt? */
4726 goto return_identifier;
4727
4728 case SCM_DONEXT: /* statement is a DO <label> WHILE or CONCURRENT. This mode
4729 * is entered when the DO keyword is seen. What follows
4730 * should be the WHILE or CONCURRENT keyword.
4731 */
4732 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
4733 if (tkntyp == TK_WHILE || tkntyp == TK_CONCURRENT) {
4734 is_doconcurrent = tkntyp == TK_CONCURRENT;
4735 scmode = SCM_IDENT;
4736 goto alpha_exit;
4737 }
4738 /*
4739 * Could give an error message indicating that the WHILE/CONCURRENT
4740 * keyword is expected.
4741 */
4742 goto return_identifier;
4743
4744 case SCM_LOCALITY:
4745 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
4746 switch (tkntyp) {
4747 case TK_LOCAL:
4748 case TK_LOCAL_INIT:
4749 case TK_SHARED:
4750 case TK_NONE:
4751 scmode = SCM_IDENT;
4752 goto alpha_exit;
4753 case TK_DEFAULT:
4754 /* Remain in SCM_LOCALITY mode to look for NONE. */
4755 goto alpha_exit;
4756 }
4757 break;
4758
4759 case SCM_TYPEIS:
4760 /* In the context of "type is", check to see if these
4761 * are a part of an identifier, or if they really are intrinsic
4762 * type tokens.
4763 */
4764 if (par_depth) {
4765 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
4766 switch (tkntyp) {
4767 /* should only look for type keywords */
4768 case TK_REAL:
4769 case TK_INTEGER:
4770 case TK_DBLEPREC:
4771 case TK_LOGICAL:
4772 case TK_COMPLEX:
4773 case TK_CHARACTER:
4774 case TK_NCHARACTER:
4775 case TK_DBLECMPLX:
4776 case TK_BYTE:
4777 if (o_idlen == idlen) {
4778 if (*(currc + idlen) == '*')
4779 ionly = TRUE;
4780 goto alpha_exit;
4781 }
4782 break;
4783 case TKF_DOUBLE:
4784 tkntyp = double_type(&currc[idlen], &idlen);
4785 if (tkntyp) {
4786 goto alpha_exit;
4787 }
4788 break;
4789 }
4790 }
4791 idlen = o_idlen;
4792 goto return_identifier;
4793 case SCM_ALLOC: /* keywords in allocate/deallocate stmts: */
4794 if (*cp == ' ')
4795 cp++;
4796 if (par1_attr) {
4797 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
4798 switch (tkntyp) {
4799 case TK_REAL:
4800 case TK_INTEGER:
4801 case TK_DBLEPREC:
4802 case TK_LOGICAL:
4803 case TK_COMPLEX:
4804 case TK_CHARACTER:
4805 case TK_NCHARACTER:
4806 case TK_DBLECMPLX:
4807 case TK_BYTE:
4808 if (o_idlen == idlen) {
4809 if (*(currc + idlen) == '*')
4810 ionly = TRUE;
4811 goto alpha_exit;
4812 }
4813 case TKF_DOUBLE:
4814 tkntyp = double_type(&currc[idlen], &idlen);
4815 if (tkntyp) {
4816 goto alpha_exit;
4817 }
4818 break;
4819 }
4820 idlen = o_idlen;
4821 goto return_identifier;
4822 }
4823 if (*cp == '=') {
4824 tkntyp = keyword(id, &iokw, &idlen, sig_blanks);
4825 if (tkntyp > 0)
4826 goto alpha_exit;
4827 }
4828 goto return_identifier;
4829
4830 case SCM_ID_ATTR:
4831 /* exposed comma not seen; just return an identifier */
4832 goto return_identifier;
4833
4834 case SCM_NEXTIDENT:
4835 /* par_depth should be 1; return an identifer; set scan mode so
4836 * that the next exposed id is as if the next ident begins a
4837 * statement
4838 */
4839 goto return_identifier;
4840
4841 case SCM_INTERFACE:
4842 if (idlen == 8 && strncmp(id, "operator", 8) == 0) {
4843 tkntyp = TK_OPERATOR;
4844 scmode = SCM_OPERATOR;
4845 goto alpha_exit;
4846 }
4847 if (idlen == 10 && strncmp(id, "assignment", 10) == 0) {
4848 tkntyp = TK_ASSIGNMENT;
4849 goto alpha_exit;
4850 }
4851 if (strncmp(id, "read", 4) == 0 || strncmp(id, "write", 5) == 0) {
4852 scmode = SCM_DEFINED_IO;
4853 goto return_identifier;
4854 }
4855 /* fall thru */
4856 case SCM_OPERATOR:
4857 scmode = SCM_FIRST;
4858 if (scn.stmtyp == TK_USE) {
4859 scmode = SCM_LOOKFOR_OPERATOR;
4860 }
4861 goto return_identifier;
4862
4863 case SCM_PAR:
4864 if (par_depth)
4865 goto return_identifier;
4866 tkntyp = keyword(id, ¶llelkw, &idlen, sig_blanks);
4867 if (tkntyp == 0)
4868 goto return_identifier;
4869 goto alpha_exit;
4870
4871 case SCM_KERNEL:
4872 if (par_depth)
4873 goto return_identifier;
4874 tkntyp = keyword(id, &kernel_kw, &idlen, sig_blanks);
4875 if (tkntyp == 0)
4876 goto return_identifier;
4877 goto alpha_exit;
4878
4879 case SCM_BIND:
4880 if (idlen == 4 && strncmp(id, "bind", 4) == 0) {
4881 tkntyp = TK_BIND;
4882 scmode = SCM_IDENT;
4883 goto alpha_exit;
4884 }
4885 break;
4886 case SCM_DEFINED_IO:
4887 if ((idlen == 9 && strncmp(id, "formatted", 9) == 0) ||
4888 (idlen == 11 && strncmp(id, "unformatted", 11) == 0)) {
4889 goto return_identifier;
4890 }
4891 break;
4892
4893 default:
4894 interr("alpha: bad scan mode", scmode, 4);
4895 }
4896
4897 /* step 3 - process the first token of a statement: */
4898
4899 scmode = SCM_IDENT;
4900 scn.stmtyp = 0;
4901 if (idlen == 5 && strncmp(id, "error", 5) == 0 &&
4902 *cp == ' ' && strncmp((cp+1), "stop", 4) == 0) {
4903 ERROR_STOP();
4904 goto alpha_exit;
4905 }
4906 if (idlen == 9 && strncmp(id, "associate", 9) == 0) {
4907 char *cp2 = cp;
4908 if (*cp == ' ')
4909 cp++;
4910 if (*cp == '(') {
4911 tkntyp = TK_ASSOCIATE;
4912 goto alpha_exit;
4913 }
4914 cp = cp2;
4915 }
4916 if (idlen == 6 && strncmp(id, "select", 6) == 0) {
4917 char *cp2 = cp;
4918 if (*cp == ' ')
4919 cp++;
4920 if (strncmp(cp, "type", 4) == 0) {
4921 cp += 4;
4922 if (*cp == ' ')
4923 cp++;
4924 if (*cp == '(') {
4925 tkntyp = TK_SELECTTYPE;
4926 idlen += 4 + 1;
4927 goto alpha_exit;
4928 }
4929 }
4930 cp = cp2;
4931 }
4932 if (idlen == 10 && strncmp(id, "selecttype", 10) == 0) {
4933 char *cp2 = cp;
4934 if (*cp == ' ')
4935 cp++;
4936 if (*cp == '(') {
4937 tkntyp = TK_SELECTTYPE;
4938 goto alpha_exit;
4939 }
4940 cp = cp2;
4941 }
4942 /*
4943 * if this stmt contains an exposed equals sign, this indicates that id
4944 * is an identifier on the left hand side of an assignment stmt except
4945 * for:
4946 * 1. IF(exp) a = b
4947 * 2. DO [<label>] var = m1, m2 [, m3]
4948 * 3. WHERE (expr) a = b
4949 * FORALL (stuff) a = b
4950 * 4. PARAMETER a = const, if no executable statement
4951 * has been seen.
4952 * 5. OPTIONS/...[/]=...
4953 * 6. ENUMERATOR ... a = 2
4954 */
4955 if (exp_equal && !exp_attr) {
4956 if (idlen < 2)
4957 goto return_identifier;
4958 if (*cp == ' ')
4959 cp++;
4960 if (idlen == 2 && id[0] == 'i' && id[1] == 'f' && *cp == '(') {
4961
4962 /* possible IF stmt. Scan to matching ')'. */
4963
4964 count = 1;
4965 do {
4966 ++cp;
4967 if (*cp == CH_STRING || *cp == CH_HOLLERITH)
4968 cp += 5; /* next four chars sym pointer */
4969 if (*cp == ')')
4970 count--;
4971 else if (*cp == '(')
4972 count++;
4973 } while (count > 0);
4974 if (cp[1] == ' ')
4975 ++cp;
4976 if (cp[1] == '=' || cp[1] == '(' || cp[1] == '.')
4977 /* if(...) =, if(...)(...) =, if(10).t */
4978 goto return_identifier;
4979 goto get_keyword;
4980 }
4981 if (exp_comma && (!is_freeform || idlen == 2) && id[0] == 'd' &&
4982 id[1] == 'o') {
4983 /* return keyword "DO" since a comma is exposed */
4984
4985 tkntyp = TK_DO;
4986 idlen = 2;
4987 scmode = SCM_DOLAB;
4988 scn.stmtyp = TK_DO;
4989 goto alpha_exit;
4990 }
4991 if (*cp == '(' && ((idlen == 5 && strncmp(id, "where", 5) == 0) ||
4992 (idlen == 6 && strncmp(id, "forall", 6) == 0))) {
4993 /* possible WHERE/FORALL stmt. Scan to matching ')'. */
4994
4995 count = 1;
4996 do {
4997 cp++;
4998 if (*cp == CH_STRING || *cp == CH_HOLLERITH)
4999 cp += 5; /* next four chars sym pointer */
5000 if (*cp == ')')
5001 count--;
5002 else if (*cp == '(')
5003 count++;
5004 } while (count > 0);
5005 if (cp[1] == ' ')
5006 ++cp;
5007 if (cp[1] == '=')
5008 goto return_identifier; /* where(...) = ... */
5009 goto get_keyword;
5010 }
5011 if (sem.pgphase <= PHASE_SPEC && is_keyword(id, idlen, "parameter")) {
5012 if (idlen == 9) {
5013 if (!is_freeform)
5014 /* in fixed form, 'parameter' is the only identifier */
5015 goto return_identifier;
5016 if (!iscsym(*cp))
5017 /* in freeform, 'parameter' is not followed by another
5018 * identifier.
5019 */
5020 goto return_identifier;
5021 }
5022 if (!is_freeform && *cp != '=')
5023 goto return_identifier;
5024 scn.stmtyp = tkntyp = TK_PARAMETER;
5025 idlen = 9;
5026 goto alpha_exit;
5027 }
5028 if (*cp == '/' && is_keyword(id, idlen, "options"))
5029 goto get_keyword;
5030 if (sem.in_enum && is_keyword(id, idlen, "enumerator")) {
5031 scn.stmtyp = tkntyp = TK_ENUMERATOR;
5032 idlen = 10;
5033 goto alpha_exit;
5034 }
5035 goto return_identifier;
5036 }
5037
5038 /* USE , INTRINSIC :: mod_name */
5039 if (exp_attr && is_keyword(id, idlen, "use")) {
5040 goto get_keyword;
5041 }
5042 /*
5043 * if this stmt contains an exposed pointer assign, this indicates that id
5044 * is an identifier on the left hand side of an assignment stmt except
5045 * for:
5046 * 1. USE <ident> , ... => ...
5047 * 2. IF(exp) a = b
5048 * 3. FORALL (stuff) a = b
5049 * 4. a type bound procedure, e.g.,
5050 * PROCEDURE ... <ident> => <ident>
5051 */
5052 if (exp_ptr_assign && !exp_attr) {
5053 if (idlen < 2)
5054 goto return_identifier;
5055 if (sem.type_mode == 2 && idlen >= strlen("procedure"))
5056 goto get_keyword;
5057 if (*cp == ' ')
5058 cp++;
5059 if (exp_comma && is_keyword(id, idlen, "use"))
5060 goto get_keyword;
5061 if (idlen == 2 && id[0] == 'i' && id[1] == 'f' && *cp == '(') {
5062
5063 /* possible IF stmt. Scan to matching ')'. */
5064
5065 count = 1;
5066 do {
5067 ++cp;
5068 if (*cp == CH_STRING || *cp == CH_HOLLERITH)
5069 cp += 5; /* next four chars sym pointer */
5070 if (*cp == ')')
5071 count--;
5072 else if (*cp == '(')
5073 count++;
5074 } while (count > 0);
5075 if (cp[1] == ' ')
5076 ++cp;
5077 if (cp[1] == '=' || cp[1] == '(' || cp[1] == '.')
5078 /* if(...) =, if(...)(...) =, if(5).t */
5079 goto return_identifier;
5080 goto get_keyword;
5081 }
5082 if (*cp == '(' && idlen == 6 && strncmp(id, "forall", 6) == 0) {
5083 /* possible FORALL stmt. Scan to matching ')'. */
5084
5085 count = 1;
5086 do {
5087 cp++;
5088 if (*cp == CH_STRING || *cp == CH_HOLLERITH)
5089 cp += 5; /* next four chars sym pointer */
5090 if (*cp == ')')
5091 count--;
5092 else if (*cp == '(')
5093 count++;
5094 } while (count > 0);
5095 if (cp[1] == ' ')
5096 ++cp;
5097 if (cp[1] == '=')
5098 goto return_identifier; /* forall(...) = ... */
5099 goto get_keyword;
5100 }
5101 goto return_identifier;
5102 }
5103 get_keyword:
5104 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
5105 if (tkntyp == 0)
5106 goto return_identifier;
5107 bind_state = B_NONE;
5108 switch (scn.stmtyp = tkntyp) {
5109 case TK_FUNCTION:
5110 case TK_SUBROUTINE:
5111 case TK_ENTRY:
5112 bind_state = B_FUNC_FOUND;
5113 break;
5114 case TKF_BLOCK:
5115 if (!is_freeform)
5116 goto return_identifier;
5117 ip = &currc[idlen];
5118 if (*ip != ' ' || is_ident(ip + 1) != 4 || strncmp(ip + 1, "data", 4) != 0)
5119 goto return_identifier;
5120 scn.stmtyp = tkntyp = TK_BLOCKDATA;
5121 idlen += 4 + 1;
5122 break;
5123 case TKF_DOUBLE:
5124 tkntyp = double_type(&currc[idlen], &idlen);
5125 if (tkntyp) {
5126 scn.stmtyp = tkntyp;
5127 goto begins_with_type;
5128 }
5129 goto return_identifier;
5130 case TKF_GO:
5131 if (!is_freeform)
5132 goto return_identifier;
5133 ip = &currc[idlen];
5134 if (*ip != ' ' || is_ident(ip + 1) != 2 || ip[1] != 't' || ip[2] != 'o')
5135 goto return_identifier;
5136 scn.stmtyp = tkntyp = TK_GOTO;
5137 ip += 3;
5138 if (*ip == ' ')
5139 ip++;
5140 if (!isdig(*ip))
5141 tkntyp = TK_GOTOX;
5142 idlen += 2 + 1;
5143 scmode = SCM_GOTO;
5144 break;
5145 case TKF_SELECT:
5146 if (!is_freeform)
5147 goto return_identifier;
5148 ip = &currc[idlen];
5149 if (*ip != ' ' || is_ident(ip + 1) != 4 || strncmp(ip + 1, "case", 4) != 0)
5150 goto return_identifier;
5151 scn.stmtyp = tkntyp = TK_SELECTCASE;
5152 idlen += 4 + 1;
5153 break;
5154 case TKF_NO:
5155 ip = &currc[idlen];
5156 if (*ip != ' ' || is_ident(ip + 1) != 8 ||
5157 strncmp(ip + 1, "sequence", 8) != 0)
5158 goto return_identifier;
5159 scn.stmtyp = tkntyp = TK_NOSEQUENCE;
5160 idlen += 8 + 1;
5161 break;
5162 case TK_CASE:
5163 if (is_freeform) {
5164 ip = &currc[idlen];
5165 if (*ip != ' ' || is_ident(ip + 1) != 7 ||
5166 strncmp(ip + 1, "default", 7) != 0)
5167 break; /* just return the token for case */
5168 tkntyp = TK_CASEDEFAULT;
5169 idlen += 7 + 1;
5170 }
5171 break;
5172 case TK_CASEDEFAULT:
5173 if (is_freeform)
5174 /* blank is required between 'case' and 'default' */
5175 goto return_identifier;
5176 scn.stmtyp = TK_CASE;
5177 tkntyp = TK_CASEDEFAULT;
5178 break;
5179
5180 case TK_GOTO:
5181 if (is_freeform) {
5182 ip = &currc[idlen];
5183 if (*ip == ' ')
5184 ip++;
5185 if (!isdig(*ip))
5186 tkntyp = TK_GOTOX;
5187 } else if (!isdig(id[4]))
5188 tkntyp = TK_GOTOX;
5189 scmode = SCM_GOTO;
5190 break;
5191
5192 case TK_IF:
5193 scmode = SCM_IF;
5194 break;
5195
5196 case TK_ELSEIF:
5197 /* Ensure that ELSEIF is followed by a left paren; otherwise,
5198 * assume that the token is ELSE and the IF is a construct name.
5199 * Need to do this for both free- & fixed- form; the standard
5200 * says that in freeform, the blank between ELSE & IF is optional.
5201 */
5202 if (!is_next_char(cp, '(')) {
5203 scn.stmtyp = tkntyp = TK_ELSE;
5204 idlen = 4;
5205 goto alpha_exit;
5206 }
5207 scmode = SCM_IF;
5208 break;
5209
5210 case TK_ELSE:
5211 ip = &currc[idlen];
5212 /*
5213 * In freeform, the blank between ELSE & IF is optional.
5214 */
5215 if (is_freeform && *ip == ' ') {
5216 switch (is_ident(ip + 1)) {
5217 case 2:
5218 if (ip[1] == 'i' && ip[2] == 'f') {
5219 /* Ensure that ELSE IF is followed by a left paren;
5220 * otherwise, assume that the token is ELSE and the IF
5221 * is a contruct name.
5222 */
5223 if (!is_next_char(ip + 3, '(')) {
5224 scn.stmtyp = tkntyp = TK_ELSE;
5225 idlen = 5; /* 4 for the 'else' + 1 for the ' ' */
5226 goto alpha_exit;
5227 }
5228 idlen += 2 + 1; /* length of "if" + 1 for the ' ' */
5229 scn.stmtyp = tkntyp = TK_ELSEIF;
5230 scmode = SCM_IF;
5231 }
5232 break;
5233 case 5:
5234 if (strncmp(ip + 1, "where", 5) == 0) {
5235 idlen += 5 + 1; /* length of "where" + 1 for the ' ' */
5236 scn.stmtyp = tkntyp = TK_ELSEWHERE;
5237 }
5238 break;
5239 default:
5240 break;
5241 }
5242 }
5243 break;
5244
5245 case TK_ALLOCATABLE:
5246 if (exp_attr)
5247 scmode = SCM_ID_ATTR;
5248 break;
5249
5250 case TK_COMMON:
5251 if (*(currc + idlen) == ',') {
5252 /*
5253 * COMMON , <attr> [, <attr>]... <common stuff>
5254 * common attributes are expected -- treat next alpha as a
5255 * keyword.
5256 */
5257 scmode = SCM_FIRST;
5258 break;
5259 }
5260 /* else fall thru */
5261 case TK_RECORD:
5262 case TK_STRUCTURE:
5263 scmode = SCM_IDENT;
5264 break;
5265 case TK_SAVE:
5266 if (exp_attr)
5267 scmode = SCM_ID_ATTR;
5268 else
5269 scmode = SCM_IDENT;
5270 break;
5271
5272 case TK_REAL:
5273 case TK_INTEGER:
5274 case TK_DBLEPREC:
5275 case TK_LOGICAL:
5276 case TK_COMPLEX:
5277 case TK_CHARACTER:
5278 case TK_NCHARACTER:
5279 case TK_DBLECMPLX:
5280 case TK_BYTE:
5281 if (*(currc + idlen) == '*')
5282 ionly = TRUE;
5283 case TK_TYPE:
5284 case TK_CLASS:
5285 begins_with_type:
5286 if (sem.pgphase == PHASE_EXEC &&
5287 (tkntyp == TK_TYPE || tkntyp == TK_CLASS)) {
5288 if (!is_freeform) {
5289 if (tkntyp == TK_TYPE && strncmp(currc, "typeis", 6) == 0) {
5290 tkntyp = TK_TYPEIS;
5291 currc += 6;
5292 scmode = SCM_TYPEIS;
5293 return;
5294 } else {
5295 if (strncmp(currc, "classis", 7) == 0) {
5296 tkntyp = TK_CLASSIS;
5297 currc += 7;
5298 return;
5299 }
5300 if (strncmp(currc, "classdefault", 12) == 0) {
5301 tkntyp = TK_CLASSDEFAULT;
5302 currc += 12;
5303 return;
5304 }
5305 }
5306 break;
5307 }
5308
5309 if (*(currc + idlen) == ' ' && *(currc + idlen + 1) == 'i' &&
5310 *(currc + idlen + 2) == 's') {
5311
5312 tkntyp = (tkntyp == TK_TYPE) ? TK_TYPEIS : TK_CLASSIS;
5313
5314 currc += idlen + 3;
5315 if (tkntyp == TK_TYPEIS)
5316 scmode = SCM_TYPEIS;
5317 return;
5318 } else if (tkntyp == TK_CLASS &&
5319 strncmp(currc + idlen, " default", 8) == 0) {
5320 tkntyp = TK_CLASSDEFAULT;
5321 currc += idlen + 8;
5322 return;
5323 }
5324 }
5325 if (!exp_comma && sem.pgphase == PHASE_INIT)
5326 scmode = SCM_FUNCTION;
5327 if (exp_attr)
5328 scmode = SCM_ID_ATTR;
5329 break;
5330
5331 case TK_FORMAT:
5332 scmode = SCM_FORMAT;
5333 /* may want to create a character string for the edit list. */
5334 k = get_fmtstr(currc + 6);
5335 if (k) {
5336 /* format string has been created */
5337 currc[0] = CH_FMTSTR;
5338 currc[1] = (char)((k >> 24) & 0xFF);
5339 currc[2] = (char)((k >> 16) & 0xFF);
5340 currc[3] = (char)((k >> 8) & 0xFF);
5341 currc[4] = (char)(k & 0xFF);
5342 currc[5] = '\n';
5343 return;
5344 }
5345 /* otherwise, lex and parse the edit list */
5346 break;
5347
5348 case TK_IMPLICIT:
5349 scmode = SCM_IMPLICIT;
5350 seen_implp = FALSE;
5351 /* if last character is a right paren, scan backwards to find the
5352 * matching left paren and replace with a special marker so that
5353 * a context sensitive left paren can be returned for IMPLICIT
5354 * statements. This is due to the ambiguity in
5355 * IMPLICIT CHARACTER (n) (a-z)
5356 * i.e., don't know if the first left paren begins a length
5357 * specifier or a range-list.
5358 * NOTE: To get here, parens must be balanced.
5359 */
5360 if (*eos == ')') {
5361 ip = eos;
5362 imp_lp:
5363 *ip = CH_IMPRP; /* mark matching right paren */
5364 while (*--ip != '(')
5365 ;
5366 *ip = CH_IMPLP; /* mark matching left paren */
5367 /*
5368 * since implicit specifiers may be a list (separated by commas),
5369 * need to scan backwards to find other cases of a range enclosed
5370 * by parens. By definition, if a comma is found which is not
5371 * enclosed by parens, the right paren which immediately precedes
5372 * the comma is the right paren of the range.
5373 */
5374 k = 0; /* paren depth */
5375 while (cp < ip) {
5376 c = *--ip;
5377 if (c == ')')
5378 k++;
5379 else if (c == '(')
5380 k--;
5381 else if (c == ',' && k == 0) {
5382 /*
5383 * found comma not enclosed by parens. if the syntax of
5384 * the statement is correct, the comma will be preceded
5385 * by a right paren.
5386 */
5387 while (*--ip != ')')
5388 if (cp > ip)
5389 break;
5390 if (*ip == ')')
5391 goto imp_lp;
5392 }
5393 }
5394 }
5395 break;
5396
5397 case TK_ASSIGN:
5398 scmode = SCM_TO;
5399 break;
5400
5401 case TK_PRINT:
5402 past_equal = TRUE;
5403 reset_past_equal = FALSE;
5404 break;
5405
5406 case TK_WRITE:
5407 case TK_ENCODE:
5408 case TK_INQUIRE:
5409 past_equal = TRUE;
5410 reset_past_equal = FALSE;
5411 case TK_BACKSPACE:
5412 case TK_CLOSE:
5413 case TK_DECODE:
5414 case TK_ENDFILE:
5415 case TK_FLUSH:
5416 case TK_OPEN:
5417 case TK_READ:
5418 case TK_REWIND:
5419 case TK_WAIT:
5420 any_io:
5421 scmode = SCM_IO;
5422 if (*(currc + idlen) == '(')
5423 *(currc + idlen) = CH_IOLP;
5424 else if (*(currc + idlen) == ' ' && *(currc + idlen + 1) == '(') {
5425 idlen++; /* eat space */
5426 *(currc + idlen) = CH_IOLP;
5427 }
5428 break;
5429
5430 case TK_DO:
5431 /*
5432 * this DO statement is not of the 'DO iteration' variety since this
5433 * type of DO is found in step 3 when there is an exposed equal and
5434 * comma. The next identifier should be the keyword WHILE or CONCURRENT
5435 */
5436 scmode = SCM_DONEXT;
5437 break;
5438
5439 case TKF_DOWHILE:
5440 /*
5441 * 'dowhile' seen as a single keyword; this is only legal if the input
5442 * source form is fixed.
5443 */
5444 if (!is_freeform) {
5445 scn.stmtyp = tkntyp = TK_DO;
5446 scmode = SCM_DONEXT;
5447 idlen = 2;
5448 goto alpha_exit;
5449 }
5450 goto return_identifier;
5451
5452 case TKF_DOCONCURRENT:
5453 /*
5454 * 'doconcurrent' seen as a single keyword; this is only legal if the input
5455 * source form is fixed.
5456 */
5457 if (!is_freeform) {
5458 scn.stmtyp = tkntyp = TK_DO;
5459 scmode = SCM_DONEXT;
5460 idlen = 2;
5461 goto alpha_exit;
5462 }
5463 goto return_identifier;
5464
5465 case TK_ALLOCATE:
5466 case TK_DEALLOCATE:
5467 scmode = SCM_ALLOC;
5468 break;
5469
5470 case TK_OPTIONS:
5471 /*
5472 * overwrite '/' which follows "options" with '\n' to force end
5473 * of statement token the next time get_token is called. Also,
5474 * save location of stuff after "options/".
5475 */
5476 currc += idlen;
5477 *currc = '\n';
5478 ip = currc + 1;
5479 k = 1; /* for null-terminating character */
5480 while (*ip++ != '\n')
5481 k++;
5482 NEED(k, scn.options, char, options_sz, k + CARDB_SIZE);
5483 strncpy(scn.options, currc + 1, k - 1);
5484 scn.options[k - 1] = '\0';
5485 return;
5486
5487 /*
5488 * Need to determine if special scan mode is needed for any of the
5489 * following.
5490 */
5491 case TK_ELEMENTAL:
5492 case TK_PURE:
5493 case TK_IMPURE:
5494 case TK_RECURSIVE:
5495 scmode = SCM_FIRST;
5496 break;
5497 case TK_ABSTRACT:
5498 if (exp_attr)
5499 scmode = SCM_ID_ATTR;
5500 else
5501 scmode = SCM_FIRST;
5502 break;
5503 case TK_ATTRIBUTES:
5504 case TK_LAUNCH_BOUNDS:
5505 scmode = SCM_NEXTIDENT;
5506 break;
5507 case TK_SEQUENCE:
5508 break;
5509 case TK_DIMENSION:
5510 if (exp_attr) {
5511 tkntyp = TK_DIMATTR;
5512 scmode = SCM_ID_ATTR;
5513 }
5514 break;
5515 case TKF_ARRAY:
5516 if (exp_attr) {
5517 tkntyp = TK_DIMATTR;
5518 scmode = SCM_ID_ATTR;
5519 if (flg.standard)
5520 error(170, 2, gbl.lineno, "ARRAY attribute should be DIMENSION", CNULL);
5521 break;
5522 }
5523 goto return_identifier;
5524 /* SAVE and ALLOCATABLE handled separately */
5525 case TK_ASYNCHRONOUS:
5526 case TK_AUTOMATIC:
5527 case TK_EXTERNAL:
5528 case TK_INTENT:
5529 case TK_INTRINSIC:
5530 case TK_OPTIONAL:
5531 case TK_NON_INTRINSIC:
5532 case TK_PARAMETER:
5533 case TK_POINTER:
5534 case TK_PROTECTED:
5535 case TK_STATIC:
5536 case TK_TARGET:
5537 case TK_BIND:
5538 case TK_VALUE:
5539 case TK_VOLATILE:
5540 case TK_PASS:
5541 case TK_NOPASS:
5542 case TK_EXTENDS:
5543 case TK_CONTIGUOUS:
5544 id_attr_shared:
5545 if (exp_attr)
5546 scmode = SCM_ID_ATTR;
5547 break;
5548 case TK_PRIVATE:
5549 case TK_PUBLIC:
5550 if (exp_attr)
5551 scmode = SCM_ID_ATTR;
5552 else {
5553 scmode = SCM_LOOKFOR_OPERATOR;
5554 follow_attr = TRUE;
5555 }
5556 break;
5557
5558 case TK_PROCEDURE:
5559 if (sem.type_mode == 2) {
5560 tkntyp = TK_TPROCEDURE;
5561 break;
5562 }
5563 scmode = SCM_PROCEDURE;
5564 break;
5565
5566 case TK_MODULE:
5567 scmode =
5568 sem.pgphase == PHASE_INIT && sem.mod_cnt == 0 && !sem.interface ? SCM_IDENT
5569 : SCM_FIRST;
5570 break;
5571
5572 case TK_SUBMODULE:
5573 scmode = SCM_IDENT;
5574 break;
5575
5576 case TKF_ENDBLOCK:
5577 ip = &currc[idlen];
5578 if (is_freeform && *ip == ' ' && is_ident(ip + 1) == 4 &&
5579 strncmp(ip + 1, "data", 4) == 0) {
5580 idlen += 4 + 1;
5581 scn.stmtyp = tkntyp = TK_ENDBLOCKDATA;
5582 goto end_program_unit;
5583 }
5584 goto return_identifier;
5585
5586 case TK_ENDSTMT:
5587 ip = &currc[idlen];
5588 if (is_freeform && *ip == ' ' && (k = is_ident(ip + 1)) != 0) {
5589 switch (*++ip) {
5590 case 'a':
5591 if (k == 9 && strncmp(ip, "associate", 9) == 0) {
5592 idlen += 9 + 1;
5593 scn.stmtyp = tkntyp = TK_ENDASSOCIATE;
5594 goto alpha_exit;
5595 }
5596 break;
5597 case 'b':
5598 if (k == 9 && strncmp(ip, "blockdata", 9) == 0) {
5599 idlen += 9 + 1;
5600 scn.stmtyp = tkntyp = TK_ENDBLOCKDATA;
5601 goto end_program_unit;
5602 }
5603 if (k == 5 && strncmp(ip, "block", 5) == 0) {
5604 ip += 5;
5605 if (*ip == ' ' && (k = is_ident(ip + 1)) == 4 &&
5606 strncmp(ip + 1, "data", 4) == 0) {
5607 idlen += 10 + 1;
5608 scn.stmtyp = tkntyp = TK_ENDBLOCKDATA;
5609 goto end_program_unit;
5610 }
5611 }
5612 break;
5613 case 'd':
5614 if (k == 2 && ip[1] == 'o') {
5615 idlen += 2 + 1;
5616 scn.stmtyp = tkntyp = TK_ENDDO;
5617 goto alpha_exit;
5618 }
5619 break;
5620 case 'e':
5621 if (k == 4 && strncmp(ip, "enum", 4) == 0) {
5622 idlen += 4 + 1;
5623 if (!sem.in_enum) {
5624 goto return_identifier;
5625 }
5626 scn.stmtyp = tkntyp = TK_ENDENUM;
5627 goto alpha_exit;
5628 }
5629 break;
5630 case 'f':
5631 if (k == 4 && strncmp(ip, "file", 4) == 0) {
5632 idlen += 4 + 1;
5633 scn.stmtyp = tkntyp = TK_ENDFILE;
5634 goto any_io;
5635 }
5636 if (k == 6 && strncmp(ip, "forall", 6) == 0) {
5637 idlen += 6 + 1;
5638 scn.stmtyp = tkntyp = TK_ENDFORALL;
5639 goto alpha_exit;
5640 }
5641 if (k == 8 && strncmp(ip, "function", 8) == 0) {
5642 idlen += 8 + 1;
5643 scn.stmtyp = tkntyp = TK_ENDFUNCTION;
5644 goto end_program_unit;
5645 }
5646 break;
5647 case 'i':
5648 if (k == 2 && ip[1] == 'f') {
5649 idlen += 2 + 1;
5650 scn.stmtyp = tkntyp = TK_ENDIF;
5651 goto alpha_exit;
5652 }
5653 if (k == 9 && strncmp(ip, "interface", 9) == 0) {
5654 idlen += 9 + 1;
5655 scn.stmtyp = tkntyp = TK_ENDINTERFACE;
5656 scmode = SCM_INTERFACE;
5657 goto alpha_exit;
5658 }
5659 break;
5660 case 'm':
5661 if (k == 6 && strncmp(ip, "module", 6) == 0) {
5662 idlen += 6 + 1;
5663 scn.stmtyp = tkntyp = TK_ENDMODULE;
5664 goto end_module;
5665 }
5666 if (k == 3 && strncmp(ip, "map", 3) == 0) {
5667 idlen += 3 + 1;
5668 scn.stmtyp = tkntyp = TK_ENDMAP;
5669 goto alpha_exit;
5670 }
5671 break;
5672 case 'p':
5673 if (k == 9 && strncmp(ip, "procedure", k) == 0) {
5674 idlen += k + 1;
5675 scn.stmtyp = tkntyp = TK_ENDPROCEDURE;
5676 goto end_program_unit;
5677 }
5678 if (k == 7 && strncmp(ip, "program", 7) == 0) {
5679 idlen += 7 + 1;
5680 scn.stmtyp = tkntyp = TK_ENDPROGRAM;
5681 goto end_program_unit;
5682 }
5683 break;
5684 case 's':
5685 if (k == 6 && strncmp(ip, "select", 6) == 0) {
5686 idlen += 6 + 1;
5687 scn.stmtyp = tkntyp = TK_ENDSELECT;
5688 goto alpha_exit;
5689 }
5690 if (k == 9 && strncmp(ip, "structure", 9) == 0) {
5691 idlen += 9 + 1;
5692 scn.stmtyp = tkntyp = TK_ENDSTRUCTURE;
5693 goto alpha_exit;
5694 }
5695 if (k == 9 && strncmp(ip, "submodule", k) == 0) {
5696 idlen += k + 1;
5697 scn.stmtyp = tkntyp = TK_ENDSUBMODULE;
5698 goto end_module;
5699 }
5700 if (k == 10 && strncmp(ip, "subroutine", 10) == 0) {
5701 idlen += 10 + 1;
5702 scn.stmtyp = tkntyp = TK_ENDSUBROUTINE;
5703 goto end_program_unit;
5704 }
5705 break;
5706 case 't':
5707 if (k == 4 && strncmp(ip, "type", 4) == 0) {
5708 idlen += 4 + 1;
5709 scn.stmtyp = tkntyp = TK_ENDTYPE;
5710 goto alpha_exit;
5711 }
5712 break;
5713 case 'u':
5714 if (k == 5 && strncmp(ip, "union", 5) == 0) {
5715 idlen += 5 + 1;
5716 scn.stmtyp = tkntyp = TK_ENDUNION;
5717 goto alpha_exit;
5718 }
5719 break;
5720 case 'w':
5721 if (k == 5 && strncmp(ip, "where", 5) == 0) {
5722 idlen += 5 + 1;
5723 scn.stmtyp = tkntyp = TK_ENDWHERE;
5724 goto alpha_exit;
5725 }
5726 break;
5727
5728 default:
5729 break;
5730 }
5731 goto return_identifier;
5732 }
5733 goto end_program_unit;
5734 case TK_CONTAINS:
5735 if (sem.type_mode == 1) {
5736 tkntyp = TK_TCONTAINS;
5737 break;
5738 }
5739 if (gbl.currsub == 0 && gbl.currmod > NOSYM) {
5740 /* CONTAINS within a module - statement will be treated as the
5741 * END of a blockdata
5742 */
5743 goto end_program_unit;
5744 }
5745 /*
5746 * CONTAINS of an internal procedure. Don't treat as an end of
5747 * subprogram yet.
5748 */
5749 break;
5750 case TK_ENDBLOCKDATA:
5751 case TK_ENDFUNCTION:
5752 case TK_ENDPROCEDURE:
5753 case TK_ENDPROGRAM:
5754 case TK_ENDSUBROUTINE:
5755 end_program_unit:
5756 if (sem.interface)
5757 break;
5758 if (gbl.internal && gbl.currsub)
5759 break;
5760 scn.end_program_unit = TRUE;
5761 break;
5762 case TK_ENDMODULE:
5763 case TK_ENDSUBMODULE:
5764 end_module:
5765 scn.end_program_unit = TRUE;
5766 break;
5767
5768 case TK_INTERFACE:
5769 case TK_ENDINTERFACE:
5770 scmode = SCM_INTERFACE;
5771 break;
5772
5773 case TK_GENERIC:
5774 if (sem.type_mode == 2)
5775 scmode = SCM_GENERIC; /* generic type bound procedure */
5776 break;
5777
5778 case TK_USE:
5779 if (exp_attr)
5780 scmode = SCM_ID_ATTR;
5781 break;
5782 case TK_ENUM:
5783 scmode = SCM_BIND;
5784 break;
5785 case TK_ENUMERATOR:
5786 case TK_ENDENUM:
5787 if (!sem.in_enum) {
5788 goto return_identifier;
5789 }
5790 default:
5791 break;
5792 }
5793 goto alpha_exit;
5794
5795 /* step 4 - enter identifier into symtab and return it: */
5796
5797 return_identifier:
5798 if (par1_attr == 1 && par_depth == 1 &&
5799 (is_doconcurrent || scn.stmtyp == TK_FORALL)) {
5800 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
5801 if (tkntyp == TK_INTEGER && o_idlen == idlen)
5802 goto alpha_exit;
5803 }
5804 if (exp_ac) {
5805 if (*cp == ' ')
5806 cp++;
5807 if (acb_depth) {
5808 tkntyp = keyword(id, &normalkw, &idlen, sig_blanks);
5809 switch (tkntyp) {
5810 case TK_REAL:
5811 case TK_INTEGER:
5812 case TK_DBLEPREC:
5813 case TK_LOGICAL:
5814 case TK_COMPLEX:
5815 case TK_CHARACTER:
5816 case TK_NCHARACTER:
5817 case TK_DBLECMPLX:
5818 case TK_BYTE:
5819 if (o_idlen == idlen) {
5820 if (*(currc + idlen) == '*')
5821 ionly = TRUE;
5822 goto alpha_exit;
5823 }
5824 }
5825 idlen = o_idlen;
5826 goto do_idtoken;
5827 }
5828 if (acb_depth && *cp == '=') {
5829 tkntyp = keyword(id, &iokw, &idlen, sig_blanks);
5830 if (tkntyp > 0)
5831 goto alpha_exit;
5832 }
5833 }
5834
5835 do_idtoken:
5836 tkntyp = TK_IDENT;
5837 tknval = get_id_name(id, idlen);
5838 check_name:
5839 if (flg.standard || !XBIT(57, 0x40)) {
5840 /* these errors are severe, since at least one compiler (cf90)
5841 * will report severe errors also.
5842 */
5843 char *nm = scn.id.name + tknval;
5844 if (id[0] == '_') {
5845 if (!XBIT(57, 0x40))
5846 error(34, 3, gbl.lineno, nm, CNULL);
5847 else
5848 error(170, 2, gbl.lineno, "Identifier begins with '_' -", nm);
5849 } else if (id[0] == '$') {
5850 if (!XBIT(57, 0x40))
5851 error(34, 3, gbl.lineno, nm, CNULL);
5852 else
5853 error(170, 2, gbl.lineno, "Identifier begins with '$' -", nm);
5854 }
5855 if (flg.standard) {
5856 if (strchr(nm + 1, (int)'$'))
5857 error(170, 2, gbl.lineno, "Identifier contains '$' -", nm);
5858 }
5859 }
5860 alpha_exit:
5861 currc += idlen;
5862 }
5863
5864 static void
init_ktable(KTABLE * ktable)5865 init_ktable(KTABLE *ktable)
5866 {
5867 int nkwds;
5868 KWORD *base;
5869 char *kwd;
5870 int i;
5871 int ch;
5872
5873 nkwds = ktable->kcount;
5874 base = ktable->kwds;
5875 /*
5876 * Scan the keyword table (KTABLE) to determine the keywords which begin
5877 * with each lowercase letter. When completed, the first and last members
5878 * of the keyword table will be used by keyword() to inclusively search
5879 * the first and last keywords beginning with the first letter of an
5880 * identifer. Note that first[ch-'a'] is zero if there does not exist a
5881 * keyword which begins with 'ch'. A nonzero value, i, represents the
5882 * index, i, into the KWORD table.
5883 */
5884 for (i = 1; i < nkwds; i++) {
5885 ch = *(base[i].keytext) - 'a';
5886 #if DEBUG
5887 /* ensure keywords begin with a lowercase letter */
5888 if ((ch + 'a') < 'a' || (ch + 'a') > 'z') {
5889 interrf(ERR_Fatal, "Illegal keyword, %s, for init_ktable",
5890 base[i].keytext);
5891 }
5892 #endif
5893 if (ktable->first[ch] == 0)
5894 ktable->first[ch] = i;
5895 ktable->last[ch] = i;
5896 }
5897 }
5898
5899 static int
get_id_name(char * id,int idlen)5900 get_id_name(char *id, int idlen)
5901 {
5902 int tkv;
5903 char *p;
5904
5905 tkv = scn.id.avl;
5906 scn.id.avl += idlen + 1; /* 1 extra for '\0' */
5907 NEED(scn.id.avl, scn.id.name, char, scn.id.size, scn.id.avl + 256);
5908 p = scn.id.name + tkv;
5909 while (idlen-- > 0)
5910 *p++ = *id++;
5911 *p = '\0';
5912 return tkv;
5913 }
5914
5915 /*
5916 * Determine if the identifier is the given keyword. If the source input
5917 * form is fixed, the keyword need only be a prefix of the identifier.
5918 * If the source form is free, the keyword and identifier need to be an
5919 * exact match.
5920 */
5921 static LOGICAL
is_keyword(char * id,int idlen,char * kwd)5922 is_keyword(char *id, int idlen, char *kwd)
5923 {
5924 int len;
5925
5926 len = strlen(kwd);
5927 if (strncmp(id, kwd, len) == 0) {
5928 if (is_freeform)
5929 return idlen == len;
5930 return TRUE;
5931 }
5932 return FALSE;
5933 }
5934
5935 /*
5936 * Determine if the 'token' beginning at ip is an identifer.
5937 * Return the length of the identifer; 0 is returned if it
5938 * isn't an identifier.
5939 */
5940 static int
is_ident(char * ip)5941 is_ident(char *ip)
5942 {
5943 int count;
5944 char c;
5945
5946 c = *ip++;
5947 if (iscsym(c)) {
5948 count = 1;
5949 while (TRUE) {
5950 c = *ip++;
5951 if (isident(c))
5952 ;
5953 else
5954 break;
5955 count++;
5956 }
5957 } else
5958 count = 0;
5959
5960 return count;
5961 }
5962
5963 /*
5964 * Determine if the 'token' beginning at ip is a string of digits.
5965 * Return the length of the digits; 0 is returned if it isn't a digit string.
5966 */
5967 static int
is_digit_string(char * ip)5968 is_digit_string(char *ip)
5969 {
5970 int count;
5971 char c;
5972
5973 count = 0;
5974 while (TRUE) {
5975 c = *ip++;
5976 if (isdig(c))
5977 ;
5978 else
5979 break;
5980 count++;
5981 }
5982
5983 return count;
5984 }
5985
5986 /*
5987 * expecting a kind parameter; return values:
5988 * o if an identifier is found, its length is returned.
5989 * 'kind_id' is the sptr of the ST_PARAM if the identifier is a legal
5990 * KIND parameter; otherwise, 'kind_id' is 0.
5991 * o value of the function is 0 if an identfier is not found.
5992 */
5993 static int
get_kind_id(char * ip)5994 get_kind_id(char *ip)
5995 {
5996 int kind_id_len;
5997 int alias_id;
5998 if ((kind_id_len = is_ident(ip))) {
5999
6000 kind_id = getsym(ip, kind_id_len);
6001 while (kind_id) {
6002 alias_id = kind_id;
6003 if (STYPEG(kind_id) == ST_ALIAS)
6004 kind_id = SYMLKG(kind_id);
6005 if (STYPEG(kind_id) == ST_PARAM && DT_ISINT(DTYPEG(kind_id))) {
6006 return kind_id_len;
6007 }
6008 kind_id = alias_id;
6009 for (kind_id = HASHLKG(kind_id); kind_id != 0;
6010 kind_id = HASHLKG(kind_id)) {
6011 if (HIDDENG(kind_id))
6012 continue;
6013 if (strncmp(ip, SYMNAME(kind_id), kind_id_len) != 0 ||
6014 *(SYMNAME(kind_id) + kind_id_len) != '\0')
6015 continue;
6016
6017 if (stb.ovclass[STYPEG(kind_id)] != OC_OTHER)
6018 continue;
6019
6020 if (STYPEG(kind_id) == ST_ALIAS)
6021 kind_id = SYMLKG(kind_id);
6022
6023 break;
6024 }
6025 }
6026 if (!kind_id) {
6027 kind_id = getsym(ip, kind_id_len);
6028 error(84, 3, gbl.lineno, SYMNAME(kind_id), "- KIND parameter");
6029 kind_id = 0;
6030 }
6031 } else if ((kind_id_len = is_digit_string(ip))) {
6032 INT num[2];
6033 num[0] = 0;
6034 (void)atoxi(ip, &num[1], kind_id_len, 10);
6035 kind_id = getcon(num, DT_INT4);
6036 } else
6037 kind_id = 0;
6038 return kind_id_len;
6039 }
6040
6041 static INT
get_kind_value(int knd)6042 get_kind_value(int knd)
6043 {
6044 int dtype;
6045
6046 if (STYPEG(knd) == ST_PARAM) {
6047 dtype = DTYPEG(knd);
6048 if (!DT_ISINT(dtype)) {
6049 error(84, 3, gbl.lineno, SYMNAME(knd), "- KIND parameter");
6050 return 0;
6051 }
6052 return cngcon(CONVAL1G(knd), dtype, DT_INT4);
6053 }
6054 #if DEBUG
6055 assert(STYPEG(knd) == ST_CONST, "get_kind_value:unexp.stype", STYPEG(knd), 3);
6056 #endif
6057 if (STYPEG(knd) != ST_CONST) {
6058 interr("get_kind_value:unexp.stype", STYPEG(knd), 3);
6059 return 0;
6060 }
6061 dtype = DTYPEG(knd);
6062 if (!DT_ISINT(dtype)) {
6063 error(33, 3, gbl.lineno, "- KIND parameter", CNULL);
6064 return 0;
6065 }
6066 return cngcon(CONVAL2G(knd), dtype, DT_INT4);
6067 }
6068
6069 /* return token id for the longest keyword in keyword table
6070 * 'ktype', which is a prefix of the id string.
6071 * Set 'keylen' to the length of the keyword found.
6072 * Possible return values:
6073 * > 0 - keyword found (corresponds to a TK_ value).
6074 * == 0 - keyword not found.
6075 * < 0 - keyword 'prefix' found (corresponds to a TKF_ value).
6076 * If a match is found, keyword_idx is set to the index of the KWORD
6077 * entry matching the keyword.
6078 */
6079 static int
keyword(char * id,KTABLE * ktable,int * keylen,LOGICAL exact)6080 keyword(char *id, KTABLE *ktable, int *keylen, LOGICAL exact)
6081 {
6082 int chi, low, high, p, kl, cond;
6083 KWORD *base;
6084
6085 /* convert first character (a letter) of an identifier into a subscript */
6086 chi = *id - 'a';
6087 if (chi < 0 || chi > 25)
6088 return 0; /* not a letter 'a' .. 'z' */
6089 low = ktable->first[chi];
6090 if (low == 0)
6091 return 0; /* a keyword does not begin with the letter */
6092 high = ktable->last[chi];
6093 base = ktable->kwds;
6094 /*
6095 * Searching for the longest keyword which is a prefix of the identifier.
6096 */
6097 p = 0;
6098 for (; low <= high; low++) {
6099 cond = cmp(id, base[low].keytext, keylen);
6100 if (cond < 0)
6101 break;
6102 if (cond == 0)
6103 p = low;
6104 }
6105 if (p) {
6106 keyword_idx = p;
6107 return base[p].toktyp;
6108 }
6109 return 0;
6110 }
6111
6112 /* Return 0 if kw is a prefix of id. Otherwise find
6113 * the first differing character position and return
6114 * a negative number if id < kw and a positive number
6115 * if id > kw.
6116 * If id is a prefix of kw, return -1.
6117 * When 0 is returned, keylen is set to length of keyword.
6118 */
6119 static int
cmp(char * id,char * kw,int * keylen)6120 cmp(char *id, char *kw, int *keylen)
6121 {
6122 char c;
6123 char *first = kw;
6124
6125 do {
6126 if ((c = *(id++)) != *kw) {
6127 if (!c)
6128 return (-1); /* end of id reached */
6129 return (c - *kw);
6130 }
6131 } while (*++kw);
6132
6133 *keylen = kw - first;
6134 return (0);
6135 }
6136
6137 static int
get_cstring(char * p,int * len)6138 get_cstring(char *p, int *len)
6139 {
6140 int c, n;
6141 char *outp, delimc;
6142 char *begin;
6143
6144 delimc = *p++;
6145 outp = begin = p;
6146 do {
6147 c = *p++;
6148 if (c == delimc) {
6149 if (*p != delimc)
6150 break;
6151 c = *p++;
6152 } else if (c == '\\') {
6153 if (!flg.standard && !XBIT(124, 0x40)) {
6154 c = *p++;
6155 if (c == 'n')
6156 c = '\n';
6157 else if (c == 't')
6158 c = '\t';
6159 else if (c == 'v')
6160 c = '\v';
6161 else if (c == 'b')
6162 c = '\b';
6163 else if (c == 'r')
6164 c = '\r';
6165 else if (c == 'f')
6166 c = '\f';
6167 else if (isodigit(c)) {
6168 n = c - '0';
6169 if (isodigit(*p)) {
6170 n = (n * 8) + ((*p++) - '0');
6171 if (isodigit(*p))
6172 n = (n * 8) + ((*p++) - '0');
6173 }
6174 c = n;
6175 } else if (c == '\n')
6176 goto err;
6177 }
6178 } else if (c == '\n') {
6179 err: /* missing end quote */
6180 errsev(26);
6181 scnerrfg = TRUE;
6182 *len = 0;
6183 return 0;
6184 }
6185 *outp++ = c;
6186 } while (TRUE);
6187
6188 *len = (p - begin) - 1;
6189 if (*len <= 0) { /* error if zero length string */
6190 return getstring("", 0);
6191 }
6192 return getstring(begin, outp - begin);
6193 }
6194
6195 static void fmt_putchar(int);
6196 static void fmt_putstr(char *);
6197 static void char_to_text(int);
6198
6199 static struct {
6200 char *str;
6201 int len;
6202 int sz;
6203 } fmtstr;
6204
6205 static int
get_fmtstr(char * p)6206 get_fmtstr(char *p)
6207 {
6208 char c;
6209 int sptr, sptr2;
6210 char *from;
6211 int dtype;
6212 int len;
6213 char b[64];
6214
6215 /* Only create the format string if requested */
6216 if (!XBIT(58, 0x200)) { /* similar check exists in semantio.c:chk_fmtid() */
6217 if (is_freeform) {
6218 /* blanks are not significant in a format list; need to 'crunch' */
6219 char *avl = p;
6220 char *q = p;
6221 while ((c = *q++) != '\n') {
6222 switch (c) {
6223 case CH_X:
6224 case CH_O:
6225 case CH_B:
6226 case CH_UNDERSCORE:
6227 *avl++ = c;
6228 break;
6229 case CH_HOLLERITH:
6230 case CH_KSTRING:
6231 case CH_STRING:
6232 *avl++ = c;
6233 *avl++ = *q++;
6234 *avl++ = *q++;
6235 *avl++ = *q++;
6236 *avl++ = *q++;
6237 break;
6238 case CH_NULLSTR:
6239 *avl++ = c;
6240 break;
6241 default:
6242 if (!iswhite(c))
6243 *avl++ = c;
6244 break;
6245 }
6246 }
6247 *avl = '\n';
6248 }
6249 return 0;
6250 }
6251 while (TRUE) {
6252 c = *p;
6253 if (c == '\0' || c == '\n')
6254 return 0;
6255 if (c == '(')
6256 break;
6257 ++p;
6258 }
6259 fmtstr.sz = 4096;
6260 fmtstr.len = 0;
6261 NEW(fmtstr.str, char, fmtstr.sz);
6262 /*
6263 * crunch() has already determined that the edit list is properly
6264 * parenthesized.
6265 */
6266 while ((c = *p++) != '\n') {
6267 switch (c) {
6268 case CH_X:
6269 case CH_O:
6270 case CH_B:
6271 case CH_UNDERSCORE:
6272 goto err;
6273 case CH_HOLLERITH:
6274 sptr = MERGE(p);
6275 p += 4;
6276 sptr2 = CONVAL1G(sptr);
6277 dtype = DTYPEG(sptr2);
6278 from = stb.n_base + CONVAL1G(sptr2);
6279 len = string_length(dtype);
6280 sprintf(b, "%d", len);
6281 fmt_putstr(b);
6282 /* kind of hollerith - 'h', 'l', or 'r' */
6283 fmt_putchar(CONVAL2G(sptr));
6284 while (len--) {
6285 c = *from++ & 0xff;
6286 fmt_putchar(c);
6287 }
6288 break;
6289 case CH_KSTRING:
6290 sptr = MERGE(p);
6291 p += 4;
6292 fmt_putstr("nc");
6293 sptr = CONVAL1G(sptr);
6294 goto do_str;
6295 case CH_STRING:
6296 sptr = MERGE(p);
6297 p += 4;
6298 do_str:
6299 fmt_putchar('\'');
6300 dtype = DTYPEG(sptr);
6301 from = stb.n_base + CONVAL1G(sptr);
6302 len = string_length(dtype);
6303 while (len--)
6304 char_to_text(*from++);
6305 fmt_putchar('\'');
6306 break;
6307 case CH_NULLSTR:
6308 fmt_putstr("\'\'");
6309 break;
6310 default:
6311 fmt_putchar(c);
6312 break;
6313 }
6314 }
6315 fmt_putchar('\0');
6316 sptr = getstring(fmtstr.str, fmtstr.len - 1);
6317 FREE(fmtstr.str);
6318 return sptr;
6319 err:
6320 FREE(fmtstr.str);
6321 return 0;
6322 }
6323
6324 static void
fmt_putchar(int ch)6325 fmt_putchar(int ch)
6326 {
6327 int pos;
6328
6329 pos = fmtstr.len++;
6330 NEED(fmtstr.len, fmtstr.str, char, fmtstr.sz, fmtstr.sz + 4096);
6331 fmtstr.str[pos] = ch;
6332 }
6333
6334 static void
fmt_putstr(char * str)6335 fmt_putstr(char *str)
6336 {
6337 int ch;
6338
6339 while ((ch = *str++))
6340 fmt_putchar(ch);
6341 }
6342
6343 /*
6344 * emit a character with consideration given to the ', escape sequences,
6345 * unprintable characters, etc.
6346 */
6347 static void
char_to_text(int ch)6348 char_to_text(int ch)
6349 {
6350 int c;
6351 char b[8];
6352
6353 c = ch & 0xff;
6354 if (c == '\\' && !flg.standard && !XBIT(124, 0x40)) {
6355 fmt_putchar('\\');
6356 fmt_putchar('\\');
6357 } else if (c == '\'') {
6358 fmt_putchar('\'');
6359 fmt_putchar('\'');
6360 } else if (c >= ' ' && c <= '~')
6361 fmt_putchar(c);
6362 else if (c == '\n') {
6363 fmt_putchar('\\');
6364 fmt_putchar('n');
6365 } else if (c == '\t') {
6366 fmt_putchar('\\');
6367 fmt_putchar('t');
6368 } else if (c == '\v') {
6369 fmt_putchar('\\');
6370 fmt_putchar('v');
6371 } else if (c == '\b') {
6372 fmt_putchar('\\');
6373 fmt_putchar('b');
6374 } else if (c == '\r') {
6375 fmt_putchar('\\');
6376 fmt_putchar('r');
6377 } else if (c == '\f') {
6378 fmt_putchar('\\');
6379 fmt_putchar('f');
6380 } else {
6381 /* Mask off 8 bits worth of unprintable character */
6382 sprintf(b, "\\%03o", c);
6383 fmt_putstr(b);
6384 }
6385 }
6386
6387 /* extract integer, real, or double precision constant token
6388 and convert into SC form:
6389 */
6390 /* == 0 normal case. == 1 this is first part
6391 * of complex constant. == 2 this is 2nd part
6392 * of complex constant. */
6393 static void
get_number(int cplxno)6394 get_number(int cplxno)
6395 {
6396 char c;
6397 char *cp;
6398 INT num[4];
6399 int sptr;
6400 LOGICAL d_exp;
6401 int kind_id_len;
6402 int errcode;
6403 int nmptr;
6404 int kind;
6405 LOGICAL chk_octal;
6406
6407 chk_octal = TRUE; /* Attempt to recognize Cray's octal extension */
6408 kind_id_len = 0;
6409 d_exp = FALSE;
6410 nmptr = 0;
6411 c = *(cp = currc);
6412 if (c == '-' || c == '+')
6413 c = *++cp;
6414 if (c == '.')
6415 goto state2;
6416 assert(isdig(c), "get_number: bad start", (int)c, 3);
6417
6418 state1: /* digits */
6419 do {
6420 c = *++cp;
6421 } while (isdig(c));
6422 if (scmode == SCM_FORMAT || scmode == SCM_DOLAB || ionly) {
6423 /* Cray's octal extension is not allowed in this context; problematic
6424 * cases:
6425 * format (... 10b ...)
6426 * do 10 b= ...
6427 * real*1 b
6428 */
6429 chk_octal = FALSE;
6430 goto return_integer;
6431 }
6432 if (c == '.') {
6433 /*
6434 * watch out for: digits . eq|digits|e|d|E|D
6435 */
6436 if (cp[1] == 'e') {
6437 if (cp[2] == 'q')
6438 goto return_integer; /* digits .eq */
6439 goto state2; /* digits .e */
6440 }
6441 if (isdig(cp[1]) || cp[1] == 'd')
6442 goto state2; /* digits . digits|d */
6443 if (islower(cp[1]))
6444 goto return_integer; /* digits . <lowercase letter> */
6445 goto state2; /* could still be digits . E|D */
6446 }
6447 if (c == 'e' || c == 'E' || c == 'd' || c == 'D')
6448 goto state3;
6449 goto return_integer;
6450 state2: /* digits . [ digits ] */
6451 do {
6452 c = *++cp;
6453 } while (isdig(c));
6454 assert(cp > currc + 1, "get_number:single dot", (int)c, 3);
6455 if (c == 'e' || c == 'E' || c == 'd' || c == 'D')
6456 goto state3;
6457 goto return_real;
6458
6459 state3: /* digits [ . [ digits ] ] { e | d } */
6460 if (c == 'd') {
6461 d_exp = TRUE;
6462 }
6463 c = *++cp;
6464 if (isdig(c))
6465 goto state5;
6466 if (c == '+' || c == '-')
6467 goto state4;
6468 goto syntax_error;
6469
6470 state4: /* digits [ . [ digits ] ] { e | d } { + | - } */
6471 c = *++cp;
6472 if (!isdig(c))
6473 goto syntax_error;
6474
6475 state5: /* digits [ . [ digits ] ] { e | d } [ + | - ] digits */
6476 c = *++cp;
6477 if (isdig(c))
6478 goto state5;
6479 goto return_real;
6480
6481 syntax_error:
6482 errsev(28);
6483 scnerrfg = 1;
6484 return;
6485
6486 return_integer:
6487 ionly = FALSE; /* Can now allow real numbers */
6488 if (cplxno) {
6489 if (*cp == '_' && (kind_id_len = get_kind_id(cp + 1))) {
6490 kind_id_len++; /* account for '_' */
6491 if (kind_id) { /* kind_id is non-zero if ident is a KIND parameter*/
6492 int dtype;
6493 dtype = select_kind(DT_INT, TY_INT, get_kind_value(kind_id));
6494 c = *(cp + kind_id_len);
6495 if ((cplxno == 1 && c != ',') || (cplxno == 2 && c != ')'))
6496 return;
6497 num[0] = 0;
6498 errcode = atosi32(currc, &num[1], (int)(cp - currc), 10);
6499 if (dtype == DT_INT8 && (errcode == -2 || errcode == -3))
6500 errcode = atoxi64(currc, num, (int)(cp - currc), 10);
6501 tkntyp = TK_K_ICON;
6502 tknval = getcon(num, dtype);
6503 goto chk_err;
6504 }
6505 }
6506 goto return_real;
6507 }
6508 tkntyp = TK_ICON;
6509 if (*cp == '_' && (kind_id_len = get_kind_id(cp + 1))) {
6510 kind_id_len++; /* account for '_' */
6511 if (kind_id) { /* kind_id is non-zero if ident is a KIND parameter */
6512 int dtype;
6513 dtype = select_kind(DT_INT, TY_INT, get_kind_value(kind_id));
6514 num[0] = 0;
6515 errcode = atosi32(currc, &num[1], (int)(cp - currc), 10);
6516 if (dtype == DT_INT8 && (errcode == -2 || errcode == -3))
6517 errcode = atoxi64(currc, num, (int)(cp - currc), 10);
6518 tkntyp = TK_K_ICON;
6519 tknval = getcon(num, dtype);
6520 goto chk_err;
6521 }
6522 } else if (chk_octal && (*cp == 'b' || *cp == 'B')) {
6523 /* Possible Cray extension for octal constants - octal digits followed
6524 * by 'b'.
6525 */
6526 int len;
6527 char *p;
6528
6529 len = cp - currc; /* length of digit string */
6530 p = currc;
6531 while (len > 0) { /* determine if all are octal digits */
6532 if (*p > '7')
6533 break;
6534 p++;
6535 len--;
6536 }
6537 if (len == 0) {
6538 /* Have a cray octal number. Overwrite the 'b' with '"' thus
6539 * terminating the octal constant for get_nondec().
6540 */
6541 if (flg.standard)
6542 error(170, 2, gbl.lineno,
6543 "octal constant composed of octal digits followed by 'b'", CNULL);
6544 *cp = '"';
6545 get_nondec(8);
6546 return;
6547 }
6548 }
6549 errcode = atosi32(currc, &tknval, (int)(cp - currc), 10);
6550 if (kind_id_len == 0 && errcode == 0 && *cp == '#') {
6551 switch (tknval) {
6552 char *savep;
6553 case 2:
6554 case 8:
6555 case 10:
6556 case 16:
6557 savep = currc;
6558 currc = cp + 1;
6559 if (!get_prefixed_int(tknval))
6560 return;
6561 currc = savep;
6562 break;
6563 }
6564 tkntyp = TK_ICON;
6565 error(34, 3, gbl.lineno, "#", CNULL);
6566 currc = cp + 1; /* skip over # */
6567 return;
6568 }
6569 if (!XBIT(57, 0x2) && (errcode == -2 || errcode == -3)) {
6570 errcode = atoxi64(currc, num, (int)(cp - currc), 10);
6571 tkntyp = TK_K_ICON;
6572 tknval = getcon(num, DT_INT8);
6573 }
6574 chk_err:
6575 if (errcode == -1 || errcode == -2)
6576 CERROR(27, 3, gbl.lineno, currc, cp, CNULL);
6577 currc = cp + kind_id_len;
6578 return;
6579
6580 return_real:
6581 kind = stb.user.dt_real;
6582 if (*cp == '_' && (kind_id_len = get_kind_id(cp + 1))) {
6583 if (kind_id) { /* kind_id is non-zero if ident is a KIND parameter */
6584 kind = select_kind(DT_REAL, TY_REAL, get_kind_value(kind_id));
6585 if (d_exp) /* can't say 'D' and kind */
6586 error(84, 3, gbl.lineno, SYMNAME(kind_id), "- KIND parameter");
6587 }
6588 kind_id_len++; /* account for '_' */
6589 /* save the string */
6590 nmptr = putsname(currc, cp - currc + kind_id_len);
6591 if (XBIT(57, 0x10) && DTY(kind) == TY_QUAD) {
6592 error(437, 2, gbl.lineno, "Constant with kind type 16 ", "REAL");
6593 kind = DT_REAL8;
6594 }
6595 } else {
6596 /* constant was not explicitly kinded */
6597 if (d_exp) {
6598 kind = DT_DBLE;
6599 if (!XBIT(49, 0x200))
6600 /* not -dp */
6601 nmptr = putsname(currc, cp - currc);
6602 if (XBIT(57, 0x10) && DTY(kind) == TY_QUAD) {
6603 error(437, 2, gbl.lineno, "DOUBLE PRECISION constant", "REAL");
6604 kind = DT_REAL;
6605 }
6606 } else {
6607 kind = stb.user.dt_real;
6608 nmptr = putsname(currc, cp - currc);
6609 }
6610 }
6611 if (cplxno) {
6612 c = *(cp + kind_id_len);
6613 if ((cplxno == 1 && c != ',') || (cplxno == 2 && c != ')'))
6614 return;
6615 }
6616 switch (DTY(kind)) {
6617 case TY_DBLE:
6618 tkntyp = TK_DCON;
6619 errcode = atoxd(currc, num, (int)(cp - currc));
6620 switch (errcode) {
6621 case 0:
6622 break;
6623 case -1:
6624 default:
6625 CERROR(28, 3, gbl.lineno, currc, cp, CNULL);
6626 break;
6627 case -2:
6628 CERROR(112, 1, gbl.lineno, currc, cp, CNULL);
6629 break;
6630 case -3:
6631 CERROR(111, 1, gbl.lineno, currc, cp, CNULL);
6632 break;
6633 }
6634 sptr = tknval = getcon(num, DT_REAL8);
6635 break;
6636 case TY_REAL:
6637 tkntyp = TK_RCON;
6638 errcode = atoxf(currc, &tknval, (int)(cp - currc));
6639 switch (errcode) {
6640 case 0:
6641 break;
6642 case -1:
6643 default:
6644 CERROR(28, 3, gbl.lineno, currc, cp, CNULL);
6645 break;
6646 case -2:
6647 CERROR(112, 1, gbl.lineno, currc, cp, CNULL);
6648 break;
6649 case -3:
6650 CERROR(111, 1, gbl.lineno, currc, cp, CNULL);
6651 break;
6652 }
6653 num[0] = 0;
6654 num[1] = tknval;
6655 sptr = getcon(num, DT_REAL4);
6656 break;
6657 default:
6658 interr("get_number: can't happen", 0, 4);
6659 break;
6660 }
6661 /* NMPTRP(sptr, nmptr); */
6662 currc = cp + kind_id_len;
6663 }
6664
6665 static void
get_nondec(int radix)6666 get_nondec(int radix)
6667 {
6668 char *cp;
6669 int rtn;
6670 INT val[2];
6671 int ndig;
6672
6673 for (cp = currc; *cp != '\'' && *cp != '"'; cp++)
6674 ;
6675
6676 tkntyp = TK_NONDEC;
6677 ndig = cp - currc;
6678 if ((rtn = atoxi(currc, &tknval, ndig, radix)) < 0) {
6679 if ((rtn == -1) && (radix == 8)) {
6680 /* illegal digit */
6681 tknval = 0;
6682 CERROR(29, 3, gbl.lineno, "octal", cp, currc);
6683 } else if ((rtn == -1) && (radix == 16)) {
6684 /* illegal digit */
6685 tknval = 0;
6686 CERROR(29, 3, gbl.lineno, "hexadecimal", cp, currc);
6687 } else if ((rtn == -1) && (radix == 2)) {
6688 /* illegal digit */
6689 tknval = 0;
6690 CERROR(29, 3, gbl.lineno, "binary", cp, currc);
6691 } else {
6692 /* 64-bit nondecimal constant */
6693 tkntyp = TK_NONDDEC;
6694 if (radix == 8) {
6695 rtn = otodi(currc, ndig, val);
6696 if (rtn == -1) { /* illegal digit */
6697 val[0] = val[1] = 0;
6698 CERROR(29, 3, gbl.lineno, "octal", cp, currc);
6699 }
6700 if (rtn == -2)
6701 CERROR(109, 1, gbl.lineno, "octal", cp, currc);
6702 } else if (radix == 2) {
6703 rtn = btodi(currc, ndig, val);
6704 if (rtn == -1) { /* illegal digit */
6705 val[0] = val[1] = 0;
6706 CERROR(29, 3, gbl.lineno, "binary", cp, currc);
6707 }
6708 if (rtn == -2)
6709 CERROR(109, 1, gbl.lineno, "binary", cp, currc);
6710 } else { /* hex digits */
6711 rtn = htodi(currc, ndig, val);
6712 if (rtn == -1) { /* illegal digit */
6713 val[0] = val[1] = 0;
6714 CERROR(29, 3, gbl.lineno, "hexadecimal", cp, currc);
6715 }
6716 if (rtn == -2)
6717 CERROR(109, 1, gbl.lineno, "hexadecimal", cp, currc);
6718 }
6719 tknval = getcon(val, DT_DWORD);
6720 }
6721 } else {
6722 switch (radix) {
6723 case 2:
6724 if (ndig > 32)
6725 goto mk_dw;
6726 break;
6727 case 8:
6728 if (ndig > 10)
6729 goto mk_dw;
6730 break;
6731 case 16:
6732 if (ndig <= 8)
6733 break;
6734 mk_dw:
6735 val[0] = 0;
6736 val[1] = tknval;
6737 tknval = getcon(val, DT_DWORD);
6738 tkntyp = TK_NONDDEC;
6739 break;
6740 }
6741 }
6742 currc = cp + 1;
6743 }
6744
6745 /*
6746 * Extracts radix-prefixed integer constants; unlike get_nondec(), the
6747 * type of the constants is integer, not 'typeless'.
6748 */
6749 static int
get_prefixed_int(int radix)6750 get_prefixed_int(int radix)
6751 {
6752 char *cp;
6753 int rtn;
6754 INT val[2];
6755 int errcode;
6756
6757 switch (radix) {
6758 case 2:
6759 for (cp = currc; *cp == '0' || *cp == '1'; cp++)
6760 ;
6761 break;
6762 case 8:
6763 for (cp = currc; isodigit(*cp); cp++)
6764 ;
6765 break;
6766 case 10:
6767 for (cp = currc; isdig(*cp); cp++)
6768 ;
6769 break;
6770 case 16:
6771 for (cp = currc; ishex(*cp); cp++)
6772 ;
6773 break;
6774 }
6775 if (cp == currc)
6776 return 1; /* error */
6777
6778 tkntyp = TK_ICON;
6779 if (radix == 10) {
6780 errcode = atosi32(currc, &tknval, (int)(cp - currc), 10);
6781 if (!XBIT(57, 0x2) && (errcode == -2 || errcode == -3)) {
6782 errcode = atoxi64(currc, val, (int)(cp - currc), 10);
6783 tkntyp = TK_K_ICON;
6784 tknval = getcon(val, DT_INT8);
6785 }
6786 if (errcode == -1 || errcode == -2)
6787 CERROR(27, 3, gbl.lineno, currc, cp, CNULL);
6788 } else if ((rtn = atoxi(currc, &tknval, (int)(cp - currc), radix)) < 0) {
6789 if (rtn == -1) {
6790 interr("get_prefixed_int: bad digit for radix", radix, 4);
6791 } else {
6792 /* 64-bit nondecimal constant */
6793 tkntyp = TK_K_ICON;
6794 if (radix == 8) {
6795 rtn = otodi(currc, (int)(cp - currc), val);
6796 if (rtn == -2)
6797 CERROR(109, 1, gbl.lineno, "octal", cp, currc);
6798 } else if (radix == 2) {
6799 rtn = btodi(currc, (int)(cp - currc), val);
6800 if (rtn == -2)
6801 CERROR(109, 1, gbl.lineno, "binary", cp, currc);
6802 } else { /* hex digits */
6803 rtn = htodi(currc, (int)(cp - currc), val);
6804 if (rtn == -2)
6805 CERROR(109, 1, gbl.lineno, "hexadecimal", cp, currc);
6806 }
6807 tknval = getcon(val, DT_INT8);
6808 }
6809 }
6810 if (flg.standard)
6811 error(170, 2, gbl.lineno, "radix prefixed constant", CNULL);
6812 currc = cp;
6813 return 0;
6814 }
6815
6816 /* Convert hex digits to a 64-bit constant. Hex digits must be larger
6817 * than 32-bits. Returns -2 for overflow, -1 for an illegal digit.
6818 * On overflow truncation occurs at left, with most significant digits.
6819 */
6820 static int
htodi(char * s,int l,INT * num)6821 htodi(char *s, int l, INT *num)
6822 {
6823 int i, j, k;
6824 char *end;
6825 int v;
6826
6827 i = k = 0;
6828 j = 1;
6829 num[1] = num[0] = 0;
6830 end = s + l;
6831
6832 while (i < l) {
6833 if ((num[0] & 0xF0000000L) != 0)
6834 return (-2);
6835
6836 v = hex_to_i((int)*(end - i - 1));
6837 if (v == -1)
6838 return (-1);
6839 num[j] |= v << (4 * k);
6840 i++;
6841 k++;
6842 if (i == 8) {
6843 j--;
6844 k = 0;
6845 }
6846 } /* while */
6847 return (0);
6848 }
6849
6850 static int
hex_to_i(int c)6851 hex_to_i(int c)
6852 {
6853 int v;
6854
6855 if (c >= '0' && c <= '9')
6856 v = (c - '0');
6857 else if (c >= 'A' && c <= 'F')
6858 v = (c - 'A' + 10);
6859 else if (c >= 'a' && c <= 'f')
6860 v = (c - 'a' + 10);
6861 else
6862 v = -1;
6863 return v;
6864 }
6865
6866 /* Convert octal digits to a 64-bit constant. Octal digits must be larger
6867 * than 32-bits. Returns -2 for overflow, -1 for an illegal digit.
6868 * On overflow truncation occurs at left, with most significant digits.
6869 */
6870 static int
otodi(char * s,int l,INT * num)6871 otodi(char *s, int l, INT *num)
6872 {
6873 int i, save;
6874 char *end;
6875
6876 for (i = 0; i < l; i++)
6877 if (*(s + i) < '0' || *(s + i) > '7')
6878 return (-1);
6879
6880 end = s + l;
6881 num[1] = num[0] = 0;
6882
6883 /* low-order 10 digits go to low-order 60 bits of low-order word */
6884 for (i = 0; i < 10 && l > 0; ++i, --l) {
6885 --end;
6886 num[1] |= ((*end) - '0') << (3 * i);
6887 }
6888
6889 if (l > 0) {
6890 /* 11-th digit is split: 2 bits to low-order word, 1 bit to high
6891 * order word */
6892 --end;
6893 save = (*end) - '0';
6894 num[1] |= (save & 03) << 30;
6895 --l;
6896 num[0] = save >> 2;
6897 for (i = 0; i < 10 && l > 0; ++i, --l) {
6898 --end;
6899 num[0] |= ((*end) - '0') << (3 * i + 1);
6900 }
6901 if (l > 0) {
6902 /* if there is still another digit, it can only be a '1' */
6903 --end;
6904 --l;
6905 save = (*end) - '0';
6906 num[0] |= (save & 01) << 31;
6907 if (save > 1)
6908 return -2;
6909 }
6910 /* can't handle any more digits, have handled all digits
6911 * to this point correctly, though */
6912 if (l > 0)
6913 return -2;
6914 }
6915 return 0;
6916 }
6917
6918 /* Convert binary digits to a 64-bit constant. Binary digits must be larger
6919 * than 32-bits. Returns -2 for overflow, -1 for an illegal digit.
6920 * On overflow truncation occurs at left, with most significant digits.
6921 */
6922 static int
btodi(char * s,int l,INT * num)6923 btodi(char *s, int l, INT *num)
6924 {
6925 int i, j, k;
6926 char *end;
6927 char c;
6928
6929 i = k = 0;
6930 j = 1;
6931 num[1] = num[0] = 0;
6932 end = s + l;
6933
6934 while (i < l) {
6935 if ((num[0] & 0x80000000L) != 0)
6936 return (-2);
6937
6938 c = *(end - i - 1);
6939 if (c != '0' && c != '1')
6940 return (-1);
6941 if (c == '1')
6942 num[j] |= 1 << k;
6943 i++;
6944 k++;
6945 if (i == 32) {
6946 j--;
6947 k = 0;
6948 }
6949 } /* while */
6950 return (0);
6951 }
6952
6953 /* A left paren has been reached. Scan ahead to determine if it is
6954 the beginning of a complex constant. If it is a complex constant,
6955 enter it into symtab and return complex constant token, else just
6956 return left parenthesis token.
6957 */
6958 static void
check_ccon(void)6959 check_ccon(void)
6960 {
6961 char c, *save_currc, *nextc;
6962 INT num[4], val[4], val1[4];
6963 int tok1;
6964 int rdx, idx;
6965 INT swp;
6966
6967 save_currc = currc;
6968 switch (scmode) {
6969 case SCM_IDENT:
6970 case SCM_IF:
6971 case SCM_LOOKFOR_OPERATOR:
6972 break;
6973 case SCM_CHEVRON:
6974 scmode = SCM_IDENT;
6975 goto return_paren;
6976 default:
6977 goto return_paren;
6978 }
6979 c = *(currc - 2);
6980 if (isident(c))
6981 goto return_paren;
6982 if (c == ' ' && (is_freeform || scn.is_hpf)) {
6983 char *p;
6984 p = currc - 2;
6985 while (p > stmtb) {
6986 c = *--p;
6987 if (isident(c))
6988 goto return_paren;
6989 if (c != ' ')
6990 break;
6991 }
6992 }
6993
6994 c = *currc;
6995 if (c == ' ')
6996 c = *++currc;
6997 nextc = currc + 1;
6998 if (c == '+' || c == '-') {
6999 c = *nextc;
7000 nextc++;
7001 }
7002 if (!isdig(c) && c != '.')
7003 goto return_paren;
7004 if (c == '.' && !isdig(*nextc))
7005 goto return_paren;
7006 tkntyp = 0;
7007 get_number(1);
7008 if (scnerrfg)
7009 return;
7010 if (tkntyp == 0)
7011 goto return_paren;
7012 num[0] = tknval;
7013 tok1 = tkntyp; /* remember first token type - real, double, or TK_K_ICON */
7014 assert(*currc == ',', "check_ccon: not comma", (int)*currc, 3);
7015 c = *++currc;
7016 if (c == ' ')
7017 c = *++currc;
7018 nextc = currc + 1;
7019 if (c == '+' || c == '-') {
7020 c = *nextc;
7021 nextc++;
7022 }
7023 if (!isdig(c) && c != '.')
7024 goto return_paren;
7025 if (c == '.' && !isdig(*nextc))
7026 goto return_paren;
7027 tkntyp = 0;
7028 get_number(2);
7029 if (scnerrfg)
7030 return;
7031 if (tkntyp == 0)
7032 goto return_paren;
7033 num[1] = tknval;
7034 currc++;
7035
7036 /* check real and imaginary parts to ensure identical types */
7037
7038 /* Note: we don't try to save the string for the whole constant */
7039 rdx = 0;
7040 idx = 1;
7041 if (tok1 == TK_K_ICON || tkntyp == TK_K_ICON) {
7042 int dtype;
7043 if (tok1 != TK_K_ICON) {
7044 /* swap to put in form k_icon, xxx */
7045 swp = num[0];
7046 num[0] = num[1];
7047 num[1] = swp;
7048 swp = tok1;
7049 tok1 = tkntyp;
7050 tkntyp = swp;
7051 rdx = 1;
7052 idx = 0;
7053 }
7054 if (DTYPEG(num[0]) != DT_INT8)
7055 val[0] = CONVAL2G(num[0]);
7056 else
7057 val[0] = num[0];
7058 switch (tkntyp) {
7059 case TK_K_ICON:
7060 if (DTYPEG(num[1]) != DT_INT8)
7061 val[1] = CONVAL2G(num[1]);
7062 else
7063 val[1] = num[1];
7064 num[0] = cngcon(val[0], DTYPEG(num[0]), stb.user.dt_real);
7065 num[1] = cngcon(val[1], DTYPEG(num[1]), stb.user.dt_real);
7066 switch (DTY(stb.user.dt_real)) {
7067 case TY_DBLE:
7068 tkntyp = TK_DCON;
7069 break;
7070 default:
7071 tkntyp = TK_RCON;
7072 break;
7073 }
7074 break;
7075 case TK_RCON:
7076 num[0] = cngcon(val[0], DTYPEG(num[0]), DT_REAL4);
7077 break;
7078 case TK_DCON:
7079 num[0] = cngcon(val[0], DTYPEG(num[0]), DT_REAL8);
7080 break;
7081 default:
7082 interr("check_ccon: unexp.constant", tkntyp, 3);
7083 tkntyp = TK_RCON;
7084 break;
7085 }
7086 val[0] = num[rdx];
7087 val[1] = num[idx];
7088 switch (tkntyp) {
7089 case TK_RCON:
7090 tkntyp = TK_CCON;
7091 tknval = getcon(val, DT_CMPLX);
7092 break;
7093 case TK_DCON:
7094 tkntyp = TK_DCCON;
7095 tknval = getcon(val, DT_CMPLX16);
7096 break;
7097 }
7098 } else {
7099 if (tok1 == TK_DCON) {
7100 if (tkntyp == TK_RCON) { /* (double, real) */
7101 xdble(num[1], val);
7102 num[1] = getcon(val, DT_DBLE);
7103 }
7104 } else if (tkntyp == TK_RCON) { /* (real, real) */
7105 tkntyp = TK_CCON;
7106 tknval = getcon(num, DT_CMPLX);
7107 /** NOTE: "name" includes parens **/
7108 NMPTRP(tknval, putsname(save_currc - 1, currc - save_currc + 1));
7109 return;
7110 } else { /* (real, double) */
7111 xdble(num[0], val);
7112 num[0] = getcon(val, DT_DBLE);
7113 }
7114 tkntyp = TK_DCCON;
7115 tknval = getcon(num, DT_CMPLX16);
7116 }
7117 return;
7118
7119 return_paren:
7120 currc = save_currc;
7121 tkntyp = TK_LPAREN; /* add as case in _rd_token() */
7122 par_depth++;
7123 }
7124
7125 /* A dot (.) has been reached. The token is either a keyword
7126 enclosed in dots, a real constant, or just a dot.
7127 */
7128 static void
do_dot(void)7129 do_dot(void)
7130 {
7131 int len;
7132 char c = *currc;
7133 INT val[2];
7134
7135 if (scmode != SCM_FORMAT) {
7136 if (isalpha(c)) {
7137 len = is_ident(currc);
7138 /*
7139 * Check for user defined operators first. If one of the
7140 * non-standard 'logical keywords' is declared as a user
7141 * defined operator, we do not want to return it as an intrinsic
7142 * operator or logical constant.
7143 */
7144 if (currc[len] == '.') {
7145 int sptr = lookupsym(currc, len);
7146 if (sptr) {
7147 sptr = refocsym(sptr, OC_OPERATOR);
7148 if (sptr && STYPEG(sptr) == ST_OPERATOR) {
7149 currc += (len + 1);
7150 tkntyp = TK_DEFINED_OP;
7151 tknval = sptr;
7152 return;
7153 }
7154 }
7155 }
7156 tkntyp = keyword(currc, &logicalkw, &len, TRUE);
7157 if (tkntyp != 0 && currc[len] == '.') {
7158 /*
7159 * If this identifier is expected to be defined as an OPERATOR,
7160 * any nonstandard 'logical' keyword must be returned as the
7161 * sequence of tokens '.' <ident> '.'; the logical keyword
7162 * must not be returned as an intrinsic operator or logical
7163 * constant.
7164 */
7165 if (scmode == SCM_OPERATOR && t2[keyword_idx].nonstandard) {
7166 tkntyp = TK_DOT;
7167 return;
7168 }
7169 if (tkntyp == TK_LOGCONST) {
7170 char *cp;
7171 int kind_id_len;
7172 cp = currc + (len + 1);
7173 tknval = (c == 't' ? SCFTN_TRUE : SCFTN_FALSE);
7174 if (*cp == '_' && (kind_id_len = get_kind_id(cp + 1))) {
7175 /* kind_id is non-zero if ident is a KIND parameter */
7176 if (kind_id) {
7177 int dtype;
7178 dtype = select_kind(DT_LOG, TY_LOG, get_kind_value(kind_id));
7179 if (dtype != DT_LOG8) {
7180 val[0] = 0;
7181 val[1] = tknval;
7182 } else {
7183 if (c != 't')
7184 val[0] = val[1] = 0;
7185 else if (gbl.ftn_true == -1)
7186 val[0] = val[1] = -1;
7187 else {
7188 val[0] = 0;
7189 val[1] = 1;
7190 }
7191 }
7192 tknval = getcon(val, dtype);
7193 tkntyp = TK_K_LOGCONST;
7194 }
7195 kind_id_len++; /* account for '_' */
7196 len += kind_id_len;
7197 }
7198 }
7199 currc += (len + 1);
7200 return;
7201 }
7202 } else if (isdig(c)) {
7203 currc--;
7204 get_number(0);
7205 return;
7206 }
7207 }
7208 tkntyp = TK_DOT;
7209 }
7210
7211 /* for supporting file $INSERT directive */
7212 static void
push_include(char * p)7213 push_include(char *p)
7214 {
7215 char *fullname, *begin;
7216 char c;
7217 FILE *tmp_fd;
7218
7219 while (*p == ' ' || *p == '\t')
7220 ++p;
7221 c = *p++; /* delimiter character */
7222 if (c != '\'' && c != '"') {
7223 c = '\n';
7224 p--;
7225 }
7226 begin = p;
7227 while (*p != c && *p != '\n')
7228 ++p;
7229 *p = '\0';
7230
7231 fullname = getitem(8, MAX_PATHNAME_LEN + 1);
7232 if (incl_level < MAX_IDEPTH) {
7233 if (flg.idir) {
7234 for (c = 0; (p = flg.idir[c]); ++c)
7235 if (fndpath(begin, fullname, MAX_PATHNAME_LEN, p) == 0)
7236 goto found;
7237 }
7238 if (fndpath(begin, fullname, MAX_PATHNAME_LEN, DIRWORK) == 0)
7239 goto found;
7240 if (flg.stdinc == 0) {
7241 if (fndpath(begin, fullname, MAX_PATHNAME_LEN, DIRSINCS) == 0)
7242 goto found;
7243 } else if (flg.stdinc != (char *)1) {
7244 if (fndpath(begin, fullname, MAX_PATHNAME_LEN, flg.stdinc) == 0)
7245 goto found;
7246 }
7247 goto not_found;
7248 found:
7249 in_include = TRUE;
7250 NEED(incl_level + 1, incl_stack, ISTACK, incl_stacksz, incl_level + 3);
7251 incl_stack[incl_level].fd = curr_fd;
7252 incl_stack[incl_level].findex = gbl.findex;
7253 incl_stack[incl_level].lineno = curr_line;
7254 incl_stack[incl_level].fname = gbl.curr_file;
7255 incl_stack[incl_level].list_now = list_now;
7256 incl_stack[incl_level].card_type = CT_NONE; /* no look ahead */
7257 incl_stack[incl_level].sentinel = SL_NONE; /* no look ahead */
7258 incl_stack[incl_level].eof_flag = gbl.eof_flag;
7259 incl_stack[incl_level].is_freeform = is_freeform;
7260 gbl.eof_flag = FALSE;
7261
7262 tmp_fd = fopen(fullname, "r");
7263 if (tmp_fd != NULL) {
7264 curr_fd = tmp_fd;
7265 ++incl_level;
7266 add_headerfile(fullname, 1, 0);
7267 if (!XBIT(120, 0x4000000)) {
7268 gbl.findex = hdr_stack[hdr_level - 1].findex;
7269 gbl.curr_file = hdr_stack[hdr_level - 1].fname;
7270 } else {
7271 gbl.curr_file = fullname;
7272 }
7273 curr_line = 0;
7274 if (flg.list)
7275 list_line(fullname);
7276 list_now = flg.list;
7277 put_include(FR_B_INCL, gbl.findex);
7278 /* -M option: Print list of include files to stdout */
7279 /* -MD option: Print list of include files to file <program>.d */
7280 if (XBIT(123, 2) || XBIT(123, 8)) {
7281 if (gbl.dependfil == NULL) {
7282 if ((gbl.dependfil = tmpf("a")) == NULL)
7283 errfatal(5);
7284 } else
7285 fprintf(gbl.dependfil, "\\\n ");
7286 if (!XBIT(123, 0x40000))
7287 fprintf(gbl.dependfil, "%s ", fullname);
7288 else
7289 fprintf(gbl.dependfil, "\"%s\" ", fullname);
7290 }
7291 return;
7292 }
7293 }
7294 not_found:
7295 /* file not found, nesting depth exceeded, unable to open: */
7296 error(17, 3, curr_line, begin, CNULL);
7297 }
7298
7299 /* for supporting VAX-style include statement */
7300 void
scan_include(char * str)7301 scan_include(char *str)
7302 {
7303 char *p;
7304 char *fullname, *dirname;
7305 char c;
7306 LOGICAL new_list_now;
7307 FILE *tmp_fd;
7308 char *q;
7309
7310 if (sem.which_pass != 0 || sem.mod_cnt > 1)
7311 return;
7312 /*
7313 * str locates string as stored by symtab (get_string); presumably
7314 * it's ok to use the same space to compress the string.
7315 */
7316 p = q = str;
7317 while ((c = *p++)) {
7318 if (c == ' ' || c == '\t')
7319 continue;
7320 *q++ = c;
7321 }
7322 *q = '\0';
7323 new_list_now = list_now;
7324
7325 /* look for /list or /nolist at the end - sets new_list_now */
7326 q--;
7327 if ((*q == 't' || *q == 'T') && (*--q == 's' || *q == 'S') &&
7328 (*--q == 'i' || *q == 'I') && (*--q == 'l' || *q == 'L')) {
7329 if (*--q == '/') {
7330 new_list_now = flg.list;
7331 *q = '\0';
7332 } else if ((*q == 'o' || *q == 'O') && (*--q == 'n' || *q == 'N') &&
7333 (*--q == '/')) {
7334 new_list_now = FALSE;
7335 *q = '\0';
7336 }
7337 }
7338 fullname = getitem(8, MAX_PATHNAME_LEN + 1);
7339 dirname = getitem(8, MAX_PATHNAME_LEN + 1);
7340 if (incl_level < MAX_IDEPTH) {
7341 if (flg.idir) {
7342 for (c = 0; (p = flg.idir[c]); ++c)
7343 if (fndpath(str, fullname, MAX_PATHNAME_LEN, p) == 0)
7344 goto found;
7345 }
7346 dirnam(gbl.curr_file, dirname);
7347 if (fndpath(str, fullname, MAX_PATHNAME_LEN, dirname) == 0)
7348 goto found;
7349 if (fndpath(str, fullname, MAX_PATHNAME_LEN, DIRWORK) == 0)
7350 goto found;
7351 if (flg.stdinc == 0) {
7352 if (fndpath(str, fullname, MAX_PATHNAME_LEN, DIRSINCS) == 0)
7353 goto found;
7354 } else if (flg.stdinc != (char *)1) {
7355 if (fndpath(str, fullname, MAX_PATHNAME_LEN, flg.stdinc) == 0)
7356 goto found;
7357 }
7358 goto not_found;
7359 found:
7360 in_include = TRUE;
7361 NEED(incl_level + 1, incl_stack, ISTACK, incl_stacksz, incl_level + 3);
7362 incl_stack[incl_level].fd = curr_fd;
7363 incl_stack[incl_level].findex = gbl.findex;
7364 incl_stack[incl_level].lineno = curr_line;
7365 incl_stack[incl_level].fname = gbl.curr_file;
7366 incl_stack[incl_level].list_now = list_now;
7367 incl_stack[incl_level].card_type = card_type;
7368 incl_stack[incl_level].sentinel = sentinel;
7369 incl_stack[incl_level].first_char = first_char;
7370 incl_stack[incl_level].eof_flag = gbl.eof_flag;
7371 incl_stack[incl_level].is_freeform = is_freeform;
7372 gbl.eof_flag = FALSE;
7373 BCOPY(incl_stack[incl_level].cardb, cardb, char, CARDB_SIZE);
7374 tmp_fd = fopen(fullname, "r");
7375 if (tmp_fd != NULL) {
7376 curr_fd = tmp_fd;
7377 ++incl_level;
7378 add_headerfile(fullname, 1, 0);
7379 if (!XBIT(120, 0x4000000)) {
7380 gbl.findex = hdr_stack[hdr_level - 1].findex;
7381 gbl.curr_file = hdr_stack[hdr_level - 1].fname;
7382 } else {
7383 gbl.curr_file = fullname;
7384 }
7385 curr_line = 0;
7386 if (flg.list)
7387 list_line(fullname);
7388 list_now = new_list_now;
7389 put_include(FR_B_INCL, gbl.findex);
7390 card_type = (*p_read_card)(); /* initiate one card look ahead */
7391 /* -M option: Print list of include files to stdout */
7392 /* -MD option: Print list of include files to file <program>.d */
7393 if (XBIT(123, 2) || XBIT(123, 8)) {
7394 if (gbl.dependfil == NULL) {
7395 if ((gbl.dependfil = tmpf("a")) == NULL)
7396 errfatal(5);
7397 } else
7398 fprintf(gbl.dependfil, "\\\n ");
7399 if (!XBIT(123, 0x40000))
7400 fprintf(gbl.dependfil, "%s ", fullname);
7401 else
7402 fprintf(gbl.dependfil, "\"%s\" ", fullname);
7403 }
7404 return;
7405 }
7406 }
7407 not_found:
7408 /* file not found, nesting depth exceeded, unable to open: */
7409 error(17, 3, gbl.lineno, str, CNULL);
7410 }
7411
7412 /* Define structures and macros for OPTIONS processing: */
7413
7414 static int options_seen = FALSE; /* TRUE if OPTIONS seen in prev. subpg. */
7415 struct c {
7416 char *cmd;
7417 INT caselabel;
7418 };
7419 static int getindex(struct c *, int, char *);
7420
7421 #define SW_CHECK 1
7422 #define SW_NOCHECK 2
7423 #define SW_EXTEND 3
7424 #define SW_NOEXTEND 4
7425 #define SW_GFLOAT 5
7426 #define SW_NOGFLOAT 6
7427 #define SW_I4 8
7428 #define SW_NOI4 9
7429 #define SW_RECURS 10
7430 #define SW_NORECURS 11
7431 #define SW_STANDARD 12
7432 #define SW_NOSTANDARD 13
7433 #define SW_REENTR 14
7434 #define SW_NOREENTR 15
7435
7436 /* cmd field (switch names) must be in alphabetical order for search */
7437 static struct c swtchtab[] = {
7438 {"check", SW_CHECK},
7439 {"extend_source", SW_EXTEND},
7440 {"f77", SW_STANDARD},
7441 {"g_floating", SW_GFLOAT},
7442 {"i4", SW_I4},
7443 {"nocheck", SW_NOCHECK},
7444 {"noextend_source", SW_NOEXTEND},
7445 {"nof77", SW_NOSTANDARD},
7446 {"nog_floating", SW_NOGFLOAT},
7447 {"noi4", SW_NOI4},
7448 {"norecursive", SW_NORECURS},
7449 {"noreentrant", SW_NOREENTR},
7450 {"nostandard", SW_NOSTANDARD},
7451 {"recursive", SW_RECURS},
7452 {"reentrant", SW_REENTR},
7453 {"standard", SW_STANDARD},
7454 };
7455 #define NSWDS (sizeof(swtchtab) / sizeof(struct c))
7456
7457 static struct { /* flg values which can appear after OPTIONS */
7458 int extend_source;
7459 LOGICAL i4;
7460 LOGICAL standard;
7461 LOGICAL recursive;
7462 int x7;
7463 int x70;
7464 } save_flg;
7465
7466 void
scan_opt_restore(void)7467 scan_opt_restore(void)
7468 {
7469 if (options_seen) {
7470 flg.extend_source = save_flg.extend_source;
7471 flg.i4 = save_flg.i4;
7472 flg.standard = save_flg.standard;
7473 flg.recursive = save_flg.recursive;
7474 flg.x[7] = save_flg.x7;
7475 flg.x[70] = save_flg.x70;
7476 body_len = flg.extend_source - 5;
7477 options_seen = FALSE;
7478 }
7479 }
7480
7481 /* for supporting VAX-style options statement */
7482 void
scan_options(void)7483 scan_options(void)
7484 {
7485 char *p;
7486 char *argstring;
7487 int indice;
7488 char savec;
7489
7490 if (DBGBIT(1, 1)) {
7491 fprintf(gbl.dbgfil, "%%");
7492 fprintf(gbl.dbgfil, "%s", scn.options);
7493 fprintf(gbl.dbgfil, "%%\n");
7494 }
7495 options_seen = TRUE;
7496 save_flg.extend_source = flg.extend_source;
7497 save_flg.i4 = flg.i4;
7498 save_flg.standard = flg.standard;
7499 save_flg.recursive = flg.recursive;
7500 save_flg.x7 = flg.x[7];
7501 save_flg.x70 = flg.x[70];
7502
7503 /* loop thru OPTIONS flags: */
7504 savec = *scn.options;
7505 for (argstring = scn.options; savec; argstring = p + 1) {
7506 for (p = argstring + 1;; p++)
7507 if (*p == '/' || *p == '\0' || *p == '=') {
7508 savec = *p;
7509 *p = '\0';
7510 break;
7511 }
7512
7513 indice = getindex(swtchtab, NSWDS, argstring);
7514
7515 if (indice < 0)
7516 goto opt_error;
7517
7518 switch (swtchtab[indice].caselabel) {
7519 case SW_CHECK:
7520 if (savec == '=') {
7521 do {
7522 argstring = ++p;
7523 while (TRUE) {
7524 p++;
7525 if (*p == ',' || *p == '/' || *p == '\0') {
7526 savec = *p;
7527 *p = '\0';
7528 break;
7529 }
7530 }
7531 if (strcmp(argstring, "all") == 0)
7532 flg.x[70] |= 0x2;
7533 else if (strcmp(argstring, "bounds") == 0)
7534 flg.x[70] |= 0x2;
7535 else if (strcmp(argstring, "nobounds") == 0)
7536 flg.x[70] &= (~0x2);
7537 else if (strcmp(argstring, "none") == 0)
7538 flg.x[70] &= (~0x2);
7539 else if (strcmp(argstring, "nooverflow") == 0)
7540 ; /* NO-OP */
7541 else if (strcmp(argstring, "nounderflow") == 0)
7542 ; /* NO-OP */
7543 else if (strcmp(argstring, "overflow") == 0)
7544 ; /* NO-OP */
7545 else if (strcmp(argstring, "underflow") == 0)
7546 ; /* NO-OP */
7547 else {
7548 error(197, 3, 0, "check", CNULL);
7549 break;
7550 }
7551 } while (savec == ',');
7552 break;
7553 }
7554 /* /CHECK no value */
7555 flg.x[70] |= 0x2;
7556 break;
7557 case SW_NOCHECK:
7558 flg.x[70] &= (~0x2);
7559 break;
7560 case SW_EXTEND:
7561 /*
7562 * since line is being extended, as a precaution the character
7563 * overwritten to define the absolute end-of-line by read_card()
7564 * is restored.
7565 * Also, the print buffer is filled after the current card/line
7566 * is in the extended state.
7567 */
7568 cardb[save_flg.extend_source] = save_extend_ch;
7569 flg.extend_source = 132;
7570 body_len = flg.extend_source - 5;
7571 cardb[132] = '\n';
7572 if (card_type != CT_DIRECTIVE)
7573 write_card();
7574 break;
7575 case SW_NOEXTEND:
7576 /*
7577 * since the length of the line is reduced, don't care about
7578 * restoring the character overwritten (it's either at the
7579 * same position or later in the line). Do care about
7580 * filling the print buffer.
7581 */
7582 flg.extend_source = 72;
7583 body_len = flg.extend_source - 5;
7584 cardb[72] = '\n';
7585 if (card_type != CT_DIRECTIVE)
7586 write_card();
7587 break;
7588 case SW_GFLOAT: /* NO-OP */
7589 case SW_NOGFLOAT:
7590 break;
7591 case SW_I4:
7592 flg.i4 = TRUE;
7593 implicit_int(DT_INT); /* call routine in symtab.c */
7594 break;
7595 case SW_NOI4:
7596 flg.i4 = FALSE;
7597 implicit_int(DT_SINT); /* call routine in symtab.c */
7598 break;
7599 case SW_RECURS:
7600 flg.recursive = TRUE;
7601 break;
7602 case SW_NORECURS:
7603 flg.recursive = FALSE;
7604 break;
7605 case SW_STANDARD:
7606 flg.standard = TRUE;
7607 symtab_standard();
7608 break;
7609 case SW_NOSTANDARD:
7610 flg.standard = FALSE;
7611 symtab_nostandard();
7612 break;
7613 case SW_REENTR:
7614 flg.x[7] |= 0x2; /* inhibit terminal func optz. */
7615 flg.recursive = TRUE; /* no static locals */
7616 break;
7617 case SW_NOREENTR:
7618 flg.x[7] &= ~(0x2);
7619 flg.recursive = FALSE;
7620 break;
7621 default:
7622 goto opt_error;
7623 } /* end switch */
7624 if (savec == '=')
7625 goto opt_error;
7626 continue;
7627
7628 opt_error:
7629 error(197, 3, 0, argstring, CNULL);
7630 if (savec != '=')
7631 continue;
7632
7633 skip_opt: /* find the beginning of an option */
7634 while (TRUE) {
7635 p++;
7636 if (*p == '/' || *p == '\0') {
7637 savec = *p;
7638 *p = '\0';
7639 break;
7640 }
7641 }
7642 }
7643 }
7644
7645 /*
7646 * getindex()
7647 * Sequentially searches table[].cmd for elements with prefix string.
7648 * Returns index if found, -1 if not found , -2 if matches >1 elements
7649 * NOTE: table must be in lexic. order to find duplicate prefix matches
7650 */
7651 static int
getindex(struct c * table,int num_elem,char * string)7652 getindex(struct c *table, int num_elem, char *string)
7653 {
7654 int i;
7655 int l;
7656 int fnd;
7657 int len;
7658
7659 l = -1;
7660 fnd = -1;
7661 i = 0;
7662 len = strlen(string);
7663 while ((i < num_elem) && ((l = strncmp(string, table[i].cmd, len)) > 0)) {
7664 i++;
7665 }
7666 if (!l) {
7667 if (len == strlen(table[i].cmd))
7668 fnd = i;
7669 /* check next value to see if it matches, too */
7670 else if ((++i < num_elem) &&
7671 ((l = strncmp(string, table[i].cmd, len)) == 0))
7672 fnd = -2;
7673 else /* found unique match */
7674 fnd = --i;
7675 }
7676
7677 return (fnd);
7678 }
7679
7680 static void
put_astfil(int type,char * line,LOGICAL newline)7681 put_astfil(int type, char *line, LOGICAL newline)
7682 {
7683 int nw;
7684
7685 nw = fwrite((char *)&type, sizeof(int), 1, astb.astfil);
7686 if (nw != 1)
7687 error(10, 4, 0, "(AST file)", CNULL);
7688 if (line != NULL)
7689 fputs(line, astb.astfil);
7690 if (newline)
7691 fputc('\n', astb.astfil);
7692 }
7693
7694 static void
put_lineno(int lineno)7695 put_lineno(int lineno)
7696 {
7697 static int type = FR_LINENO;
7698 int nw;
7699
7700 gbl.lineno = lineno;
7701 nw = fwrite((char *)&type, sizeof(int), 1, astb.astfil);
7702 if (nw != 1)
7703 error(10, 4, 0, "(AST file)", CNULL);
7704 fprintf(astb.astfil, "%d\n", lineno);
7705 }
7706
7707 static void
put_include(int type,int findex)7708 put_include(int type, int findex)
7709 {
7710 int nw;
7711
7712 nw = fwrite((char *)&type, sizeof(int), 1, astb.astfil);
7713 if (nw != 1)
7714 error(10, 4, 0, "(AST file)", CNULL);
7715 nw = fwrite((char *)&findex, sizeof(int), 1, astb.astfil);
7716 if (nw != 1)
7717 error(10, 4, 0, "(AST file)", CNULL);
7718 }
7719
7720 /* read one Fortran statement, including continuations
7721 into stmtb. Process directive lines if encountered. Skip past
7722 comment lines. Handle end of files. Extract labels from initial lines.
7723 Write lines to source listing.
7724 */
7725 static void
ff_get_stmt(void)7726 ff_get_stmt(void)
7727 {
7728 char *p;
7729 int c, outp;
7730 int in_linedir = 0;
7731
7732 card_count = 0;
7733 ff_state.cavail = &stmtb[0];
7734 scn.is_hpf = FALSE;
7735 is_smp = FALSE;
7736 is_sgi = FALSE;
7737 is_dec = FALSE;
7738 is_mem = FALSE;
7739 is_ppragma = FALSE;
7740 is_pgi = FALSE;
7741 is_kernel = FALSE;
7742 is_doconcurrent = false;
7743
7744 for (p = printbuff + 8; *p != '\0' && (isblank(*p));) {
7745 ++p;
7746 }
7747 leadCount = p - (printbuff + 8);
7748
7749 do {
7750 again:
7751 switch (card_type) {
7752 case CT_COMMENT:
7753 put_astfil(curr_line, &printbuff[8], TRUE);
7754 break;
7755
7756 case CT_EOF:
7757 /* pop include */
7758 if (incl_level > 0) {
7759 char *save_filenm;
7760
7761 incl_level--;
7762 if (!incl_stack[incl_level].is_freeform) {
7763 set_input_form(FALSE);
7764 incl_level++;
7765 get_stmt();
7766 return;
7767 }
7768 save_filenm = gbl.curr_file;
7769 curr_fd = incl_stack[incl_level].fd;
7770 gbl.findex = incl_stack[incl_level].findex;
7771 curr_line = incl_stack[incl_level].lineno;
7772 gbl.curr_file = incl_stack[incl_level].fname;
7773 list_now = incl_stack[incl_level].list_now;
7774 gbl.eof_flag = incl_stack[incl_level].eof_flag;
7775 if (curr_line == 1)
7776 add_headerfile(gbl.curr_file, curr_line + 1, 0);
7777 else
7778 add_headerfile(gbl.curr_file, curr_line, 0);
7779
7780 put_include(FR_E_INCL, gbl.findex);
7781
7782 card_type = incl_stack[incl_level].card_type;
7783 sentinel = incl_stack[incl_level].sentinel;
7784 if (card_type != CT_NONE) {
7785 first_char = incl_stack[incl_level].first_char;
7786 BCOPY(cardb, incl_stack[incl_level].cardb, char, CARDB_SIZE);
7787 if (card_type != CT_DIRECTIVE)
7788 write_card();
7789 if (card_type == CT_EOF && incl_level == 0) {
7790 if (gbl.currsub || sem.mod_sym) {
7791 gbl.curr_file = save_filenm;
7792 sem.mod_cnt = 0;
7793 sem.mod_sym = 0;
7794 sem.submod_sym = 0;
7795 errsev(22);
7796 }
7797 finish();
7798 }
7799 } else
7800 card_type = ff_read_card();
7801 if (incl_level == 0)
7802 in_include = FALSE;
7803 if (card_type == CT_EOF && incl_level <= 0)
7804 errsev(22);
7805 else
7806 goto again;
7807 }
7808 /* terminate compilation: */
7809 if (sem.mod_sym) {
7810 errsev(22);
7811 sem.mod_cnt = 0;
7812 sem.mod_sym = 0;
7813 sem.submod_sym = 0;
7814 }
7815 finish();
7816
7817 case CT_DIRECTIVE:
7818 put_astfil(curr_line, &printbuff[8], TRUE);
7819 put_lineno(curr_line);
7820 /* convert upper case letters to lower: */
7821 for (p = &cardb[1]; (c = *p) != ' ' && c != '\n'; ++p)
7822 if (c >= 'A' && c <= 'Z')
7823 *p = tolower(c);
7824 if (strncmp(&cardb[1], "list", 4) == 0)
7825 list_now = flg.list;
7826 else if (strncmp(&cardb[1], "nolist", 6) == 0)
7827 list_now = FALSE;
7828 else if (strncmp(&cardb[1], "eject", 5) == 0) {
7829 if (list_now)
7830 list_page();
7831 } else if (strncmp(&cardb[1], "insert", 6) == 0)
7832 push_include(&cardb[8]);
7833 else /* unrecognized directive: */
7834 errsev(20);
7835 break;
7836
7837 case CT_LINE:
7838 line_directive();
7839 card_type = CT_COMMENT;
7840 break;
7841
7842 case CT_PRAGMA:
7843 put_astfil(curr_line, &printbuff[8], TRUE);
7844 no_crunch = TRUE;
7845 if (card_count == 0) {
7846 if (hdr_level == 0)
7847 fihb.currfindex = gbl.findex = 1;
7848 else
7849 fihb.currfindex = gbl.findex = hdr_stack[hdr_level - 1].findex;
7850 gbl.curr_file = FIH_FULLNAME(gbl.findex);
7851 }
7852 card_count = 1;
7853 put_lineno(curr_line);
7854 p = first_char;
7855 *ff_state.cavail++ = CH_PRAGMA;
7856 while ((*ff_state.cavail++ = *p++) != '\n')
7857 ;
7858 card_type = CT_INITIAL; /* trick rest of processing */
7859 break;
7860
7861 case CT_FIXED:
7862 set_input_form(FALSE);
7863 card_type = CT_COMMENT;
7864 get_stmt();
7865 return;
7866
7867 case CT_FREE:
7868 put_astfil(curr_line, &printbuff[8], TRUE);
7869 set_input_form(TRUE);
7870 card_type = CT_COMMENT;
7871 break;
7872
7873 case CT_DEC:
7874 is_dec = TRUE;
7875 goto initial_card;
7876 case CT_MEM:
7877 is_mem = TRUE;
7878 goto initial_card;
7879 case CT_PPRAGMA:
7880 is_ppragma = TRUE;
7881 goto initial_card;
7882 case CT_PGI:
7883 is_pgi = TRUE;
7884 goto initial_card;
7885 case CT_KERNEL:
7886 is_kernel = TRUE;
7887 goto initial_card;
7888 case CT_SMP:
7889 is_smp = TRUE;
7890 is_sgi = sentinel == SL_SGI;
7891 /* fall thru */
7892 case CT_INITIAL:
7893 initial_card:
7894 gbl.in_include = in_include;
7895 put_astfil(curr_line, &printbuff[8], TRUE);
7896 if (card_count == 0) {
7897 if (hdr_level == 0)
7898 fihb.currfindex = gbl.findex = 1;
7899 else
7900 fihb.currfindex = gbl.findex = hdr_stack[hdr_level - 1].findex;
7901 gbl.curr_file = FIH_FULLNAME(gbl.findex);
7902 }
7903 card_count = 1;
7904 put_lineno(curr_line);
7905
7906 ff_prescan();
7907 card_type = CT_INITIAL;
7908 break;
7909
7910 case CT_CONTINUATION:
7911 if (sentinel == SL_SGI) {
7912 /* sgi continuation - we reach this point if the previous
7913 * statement isn't continued in usual f90 manner, i.e., the
7914 * last nonblank character isn't '&'. If the f90 style is
7915 * used, the above call to ff_prescan() processes the
7916 * continuation.
7917 */
7918 put_astfil(curr_line, &printbuff[8], TRUE);
7919 card_count++;
7920 ff_check_stmtb();
7921 ff_prescan();
7922 } else
7923 error(290, 3, curr_line, CNULL, CNULL);
7924 break;
7925
7926 default:
7927 interr("ff_get_stmt: bad ctype", card_type, 4);
7928 }
7929 /* start new listing page if at END, then read new card: */
7930
7931 if (flg.list && card_type <= CT_COMMENT) {
7932 if (list_now)
7933 list_line(printbuff);
7934 }
7935 #if DEBUG
7936 if (DBGBIT(4, 2))
7937 fprintf(gbl.dbgfil, "line(%4d) %s", curr_line, cardb);
7938 #endif
7939 card_type = ff_read_card();
7940 } while (ff_state.cavail == stmtb || card_type == CT_CONTINUATION ||
7941 card_type == CT_COMMENT || card_type == CT_LINE /* tpr 533 */
7942 );
7943 }
7944
7945 /* read one input line into cardb, and determine its type
7946 (card_type) and determine first character following the
7947 label field (first_char).
7948 */
7949 static int
ff_read_card(void)7950 ff_read_card(void)
7951 {
7952 int c;
7953 int i;
7954 char *p; /* pointer into cardb */
7955 char *firstp; /* pointer which locates first nonblank char */
7956 int ct;
7957
7958 assert(!gbl.eof_flag, "ff_read_card:err", gbl.eof_flag, 4);
7959 sentinel = SL_NONE;
7960
7961 p = _readln(MAX_COLS, TRUE);
7962 if (p == NULL)
7963 return CT_EOF;
7964 first_char = cardb;
7965 ff_state.last_char = (p - cardb);
7966
7967 if (*cardb == '#') {
7968 if (first_line && !fpp_) {
7969 get_fn();
7970 }
7971 first_line = FALSE;
7972 return CT_LINE;
7973 }
7974 first_line = FALSE;
7975 c = cardb[0];
7976 if (c == '%')
7977 return CT_DIRECTIVE;
7978 if (c == '$') /* APFTN64 style of directives */
7979 return CT_DIRECTIVE;
7980 write_card();
7981 for (p = cardb; isblank(*p); p++)
7982 ;
7983 first_char = firstp = p; /* first non-blank character in stmt */
7984 c = *p;
7985 if (c == '\n')
7986 return CT_COMMENT;
7987 ct = CT_INITIAL;
7988 if (c == '!') {
7989 /* possible compiler directive. these directives begin with (upper
7990 * or lower case):
7991 * c$pragma
7992 * cpgi$ cvd$ cdir$
7993 * to check for a directive, all that's done is to copy at most N
7994 * characters after the leading 'c', where N is the max length of
7995 * the allowable prefixes, converting to lower case if necessary.
7996 * if the prefix matches one of the above, a special card type
7997 * is returned. NOTE: can't process the directive now since
7998 * this card represents the read-ahead ---- NEED to ensure that
7999 * semantic actions are performed.
8000 */
8001 #define MAX_DIRLEN 4
8002 char b[MAX_DIRLEN + 1], cc;
8003
8004 /* sun's c$pragma is separate from those whose prefixes end with $ */
8005 if (p[1] == '$' && (p[2] == 'P' || p[2] == 'p') &&
8006 (p[3] == 'R' || p[3] == 'r') && (p[4] == 'A' || p[4] == 'a') &&
8007 (p[5] == 'G' || p[5] == 'g') && (p[6] == 'M' || p[6] == 'm') &&
8008 (p[7] == 'A' || p[7] == 'a')) {
8009 /*
8010 * communicate to p_pragma() that this is a sun directive.
8011 * do so by prepending the substring beginning with the
8012 * first character after "pragma" with "sun".
8013 */
8014 first_char = firstp + 5;
8015 strncpy(first_char, "sun", 3);
8016 if (long_pragma_candidate)
8017 error(285, 3, curr_line, CNULL, CNULL);
8018 return CT_PRAGMA;
8019 }
8020
8021 if (OPENMP && /* c$smp, c$omp - smp directive sentinel */
8022 p[1] == '$' &&
8023 (p[2] == 'S' || p[2] == 's' || p[2] == 'O' || p[2] == 'o') &&
8024 (p[3] == 'M' || p[3] == 'm') && (p[4] == 'P' || p[4] == 'p')) {
8025 firstp += 5;
8026 for (; isblank(*firstp); firstp++)
8027 ;
8028 first_char = firstp; /* first non-blank character in stmt */
8029 c = *firstp;
8030 ct = CT_SMP;
8031 sentinel = SL_OMP;
8032 goto bl_firstchar;
8033 }
8034 /* SGI c$doacross, c$& */
8035 if (SGIMP && p[1] == '$' && (p[2] == 'D' || p[2] == 'd') &&
8036 (p[3] == 'O' || p[3] == 'o') && (p[4] == 'A' || p[4] == 'a') &&
8037 (p[5] == 'C' || p[5] == 'c') && (p[6] == 'R' || p[6] == 'r') &&
8038 (p[7] == 'O' || p[7] == 'o') && (p[8] == 'S' || p[8] == 's') &&
8039 (p[9] == 'S' || p[9] == 's')) {
8040 sentinel = SL_SGI;
8041 first_char = &p[2];
8042 if (long_pragma_candidate)
8043 error(285, 3, curr_line, CNULL, CNULL);
8044 return CT_SMP;
8045 }
8046 /* OpenMP conditional compilation sentinels */
8047 if (OPENMP && p[1] == '$' && (iswhite(p[2]) || isdigit(p[2]))) {
8048 firstp += 2;
8049 for (; isblank(*firstp); firstp++)
8050 ;
8051 first_char = firstp; /* first non-blank character in stmt */
8052 c = *firstp;
8053 goto bl_firstchar;
8054 }
8055 /* sgi's continuation convention ('!$&') will be detected here */
8056 if (SGIMP && p[1] == '$' && p[2] == '&') {
8057 if (!is_sgi)
8058 /* current statement is not an SGI smp statement; just
8059 * treat as a comment.
8060 */
8061 return CT_COMMENT;
8062 sentinel = SL_SGI;
8063 first_char = firstp + 3; /* first character after '&' */
8064 if (long_pragma_candidate)
8065 error(285, 3, curr_line, CNULL, CNULL);
8066 return CT_CONTINUATION;
8067 }
8068 /* Miscellaneous directives which are parsed */
8069 if (XBIT(59, 0x4) && /* c$mem - mem directive sentinel */
8070 p[1] == '$' && (p[2] == 'M' || p[2] == 'm') &&
8071 (p[3] == 'E' || p[3] == 'e') && (p[4] == 'M' || p[4] == 'm')) {
8072 firstp += 5;
8073 for (; isblank(*firstp); firstp++)
8074 ;
8075 first_char = firstp; /* first non-blank character in stmt */
8076 c = *firstp;
8077 ct = CT_MEM; /* change initial card type */
8078 sentinel = SL_MEM;
8079 goto bl_firstchar;
8080 }
8081 if (XBIT_PCAST && /* c$pgi - alternate pgi accelerator directive sentinel */
8082 p[1] == '$' && (p[2] == 'P' || p[2] == 'p') &&
8083 (p[3] == 'G' || p[3] == 'g') && (p[4] == 'I' || p[4] == 'i')) {
8084 firstp += 5;
8085 for (; isblank(*firstp); firstp++)
8086 ;
8087 first_char = firstp; /* first non-blank character in stmt */
8088 c = *firstp;
8089 ct = CT_PGI; /* change initial card type */
8090 sentinel = SL_PGI;
8091 goto bl_firstchar;
8092 }
8093 if (XBIT(137, 1) && /* c$cuf - cuda kernel directive sentinel */
8094 p[1] == '$' && (p[2] == 'C' || p[2] == 'c') &&
8095 (p[3] == 'U' || p[3] == 'u') && (p[4] == 'F' || p[4] == 'f')) {
8096 firstp += 5;
8097 for (; isblank(*firstp); firstp++)
8098 ;
8099 first_char = firstp; /* first non-blank character in stmt */
8100 c = *firstp;
8101 ct = CT_KERNEL; /* change initial card type */
8102 sentinel = SL_KERNEL;
8103 goto bl_firstchar;
8104 }
8105 if (XBIT(137, 1) && /* !@cuf - cuda kernel conditional compilation */
8106 p[1] == '@' && (p[2] == 'C' || p[2] == 'c') &&
8107 (p[3] == 'U' || p[3] == 'u') && (p[4] == 'F' || p[4] == 'f') &&
8108 iswhite(p[5])) {
8109 firstp += 5;
8110 for (; isblank(*firstp); firstp++)
8111 ;
8112 first_char = firstp; /* first non-blank character in stmt */
8113 c = *firstp;
8114 goto bl_firstchar;
8115 }
8116
8117 i = 1;
8118 p = b;
8119 while (TRUE) {
8120 cc = firstp[i];
8121 if (cc >= 'A' && cc <= 'Z')
8122 *p = tolower(cc);
8123 else
8124 *p = cc;
8125 p++;
8126 if (i >= MAX_DIRLEN || cc == '$' || cc == '\n')
8127 break;
8128 i++;
8129 }
8130 if (cc == '$') {
8131 *p = '\0';
8132 if (strncmp(b, "pgi$", 4) == 0 || strncmp(b, "vd$", 3) == 0) {
8133 /* for these directives, point to first character after the
8134 * '$'.
8135 */
8136 first_char = &firstp[i + 1];
8137 if (long_pragma_candidate)
8138 error(285, 3, curr_line, CNULL, CNULL);
8139 return check_pgi_pragma(first_char);
8140 }
8141 if (strncmp(b, "dir$", 4) == 0) {
8142 /*
8143 * communicate to p_pragma() that this is a cray directive.
8144 * do so by prepending the substring beginning with the
8145 * first character after the '$' with "cray".
8146 */
8147 first_char = &firstp[1];
8148 strncpy(first_char, "cray", 4);
8149 i = check_pragma(first_char + 4);
8150 if (i == CT_PPRAGMA) {
8151 strncpy(firstp, " ", 5);
8152 }
8153 if (long_pragma_candidate)
8154 error(285, 3, curr_line, CNULL, CNULL);
8155 return i;
8156 }
8157 if (XBIT(124, 0x100) && strncmp(b, "exe$", 4) == 0) {
8158 firstp += 5;
8159 first_char = firstp;
8160 c = *firstp;
8161 goto bl_firstchar;
8162 }
8163 #if defined(TARGET_WIN)
8164 if (strncmp(b, "dec$", 4) == 0) {
8165 firstp += 5;
8166 first_char = firstp;
8167 c = *firstp;
8168 ct = CT_DEC;
8169 goto bl_firstchar;
8170 }
8171 if (strncmp(b, "ms$", 3) == 0) {
8172 firstp += 4;
8173 first_char = firstp;
8174 c = *firstp;
8175 ct = CT_DEC;
8176 goto bl_firstchar;
8177 }
8178 #endif
8179 }
8180 return CT_COMMENT;
8181 }
8182 bl_firstchar:
8183 if (long_pragma_candidate)
8184 error(285, 3, curr_line, CNULL, CNULL);
8185 if (c == '&') {
8186 first_char = firstp + 1;
8187 return CT_CONTINUATION;
8188 }
8189
8190 return ct;
8191 }
8192
8193 /* Prepare one Fortran stmt for crunching. Copy the current card to
8194 * the statement buffer. Need to watch for the current card containing
8195 * the continuation character.
8196 */
8197 static void
ff_prescan(void)8198 ff_prescan(void)
8199 {
8200 int c;
8201 char *inptr; /* next char to be processed */
8202 char *p; /* pointer into statement buffer */
8203 char quote;
8204 char *amp; /* pointer to '&' in cardb */
8205
8206 ff_state.outptr = ff_state.cavail - 1;
8207 ff_state.amper_ptr = NULL;
8208
8209 for (inptr = first_char; (c = *inptr) != '\n'; inptr++) {
8210 *++ff_state.outptr = c;
8211 switch (c) {
8212 default:
8213 break;
8214
8215 case 'a':
8216 case 'b':
8217 case 'c':
8218 case 'd':
8219 case 'e':
8220 case 'f':
8221 case 'g':
8222 case 'h':
8223 case 'i':
8224 case 'j':
8225 case 'k':
8226 case 'l':
8227 case 'm':
8228 case 'n':
8229 case 'o':
8230 case 'p':
8231 case 'q':
8232 case 'r':
8233 case 's':
8234 case 't':
8235 case 'u':
8236 case 'v':
8237 case 'w':
8238 case 'x':
8239 case 'y':
8240 case 'z':
8241 case 'A':
8242 case 'B':
8243 case 'C':
8244 case 'D':
8245 case 'E':
8246 case 'F':
8247 case 'G':
8248 case 'H':
8249 case 'I':
8250 case 'J':
8251 case 'K':
8252 case 'L':
8253 case 'M':
8254 case 'N':
8255 case 'O':
8256 case 'P':
8257 case 'Q':
8258 case 'R':
8259 case 'S':
8260 case 'T':
8261 case 'U':
8262 case 'V':
8263 case 'W':
8264 case 'X':
8265 case 'Y':
8266 case 'Z':
8267 case '_':
8268 case '$':
8269 /* have the start of an identifier; eat all characters allowed
8270 * to make up an identifer - facilitates checking for a Hollerith
8271 * constant.
8272 */
8273 again_id:
8274 do {
8275 c = *++inptr;
8276 *++ff_state.outptr = c;
8277 } while (isident(c));
8278 if (c == '&') {
8279 last_char[card_count - 1] = ff_state.outptr - stmtb - 1;
8280 ff_get_noncomment(inptr + 1);
8281 ff_state.outptr--;
8282 if (card_type != CT_NONE) {
8283 inptr = first_char - 1;
8284 goto again_id;
8285 }
8286 goto exit_ff_prescan;
8287 }
8288 ff_state.outptr--;
8289 inptr--;
8290 break;
8291
8292 case '&':
8293 last_char[card_count - 1] = ff_state.outptr - stmtb - 1;
8294 ff_get_noncomment(inptr + 1);
8295 ff_state.outptr--;
8296 inptr = first_char - 1;
8297 if (card_type == CT_NONE)
8298 goto exit_ff_prescan;
8299 break;
8300
8301 case '0':
8302 case '1':
8303 case '2':
8304 case '3':
8305 case '4':
8306 case '5':
8307 case '6':
8308 case '7':
8309 case '8':
8310 case '9':
8311 p = ff_state.outptr;
8312 again_number:
8313 do {
8314 c = *++inptr;
8315 *++ff_state.outptr = c;
8316 } while (isdig(c));
8317 if (c == '&') {
8318 last_char[card_count - 1] = ff_state.outptr - stmtb - 1;
8319 ff_get_noncomment(inptr + 1);
8320 ff_state.outptr--;
8321 if (card_type != CT_NONE) {
8322 inptr = first_char - 1;
8323 goto again_number;
8324 }
8325 goto exit_ff_prescan;
8326 }
8327 if (isholl(c)) {
8328 int len;
8329
8330 /* Hollerith constant has been found: */
8331
8332 sscanf(p, "%d", &len);
8333 if (XBIT(125, 4)) {
8334 int ilen = (cardb + ff_state.last_char) - inptr;
8335 /* compute #bytes */
8336 len = kanji_prefix((unsigned char *)inptr + 1, len, ilen);
8337 }
8338 again_hollerith:
8339 ff_state.amper_ptr = NULL;
8340 while (len-- > 0) {
8341 *++ff_state.outptr = c = *++inptr;
8342 if (c == '\n') {
8343 len++;
8344 ff_state.outptr--;
8345 inptr--;
8346 break;
8347 }
8348 if (c == '&') {
8349 ff_state.amper_ptr = ff_state.outptr;
8350 amp = inptr;
8351 } else if (c != ' ')
8352 ff_state.amper_ptr = NULL;
8353 }
8354 if (len >= 0) { /* len == -1 ==> found all characters */
8355 if (ff_state.amper_ptr == NULL)
8356 goto exit_ff_prescan;
8357 #if DEBUG
8358 assert(ff_state.amper_ptr == ff_state.outptr, "ff_prescan:Hollerith&",
8359 inptr - ff_state.amper_ptr + 1, 3);
8360 #endif
8361 last_char[card_count - 1] = ff_state.amper_ptr - stmtb - 1;
8362 ff_get_noncomment(amp + 1);
8363 if (card_type != CT_NONE) {
8364 len++;
8365 inptr = first_char - 1;
8366 ff_state.outptr = ff_state.amper_ptr - 1;
8367 goto again_hollerith;
8368 }
8369 goto exit_ff_prescan;
8370 }
8371 }
8372 ff_state.outptr--;
8373 inptr--;
8374 break;
8375
8376 case '"':
8377 case '\'':
8378 quote = c;
8379 ff_state.amper_ptr = NULL;
8380 while (TRUE) {
8381 c = *++inptr;
8382 if (c == '\n') {
8383 char *q;
8384 if (ff_state.amper_ptr == NULL)
8385 goto exit_ff_prescan;
8386 last_char[card_count - 1] = ff_state.amper_ptr - stmtb - 1;
8387 ff_get_noncomment(amp + 1);
8388 if (card_type != CT_NONE) {
8389 inptr = first_char - 1;
8390 if (flg.standard && *inptr != '&') {
8391 error(170, 2, curr_line, "'&' required as the first character of "
8392 "a continued string literal",
8393 CNULL);
8394 }
8395 ff_state.outptr = ff_state.amper_ptr - 1;
8396 ff_state.amper_ptr = NULL;
8397 continue;
8398 }
8399 goto exit_ff_prescan;
8400 }
8401 *++ff_state.outptr = c;
8402 if (c == '&') {
8403 ff_state.amper_ptr = ff_state.outptr;
8404 amp = inptr;
8405 } else if (c == quote) {
8406 if (*(inptr + 1) == quote) {
8407 *++ff_state.outptr = quote;
8408 inptr++;
8409 } else
8410 break;
8411 } else if (c == '\\' && !flg.standard && !XBIT(124, 0x40) &&
8412 inptr[1] != '\n') {
8413 /* backslash escape in character constant */
8414 *++ff_state.outptr = *++inptr;
8415 }
8416 }
8417 break;
8418
8419 case '!':
8420 ff_chk_pragma(inptr + 1);
8421 ff_state.outptr--;
8422 goto exit_for;
8423 }
8424 }
8425
8426 exit_for:;
8427
8428 exit_ff_prescan:
8429 *++ff_state.outptr = '\n'; /* mark end of stmtb contents */
8430 ff_state.cavail = ff_state.outptr;
8431 last_char[card_count - 1] = ff_state.cavail - stmtb - 1;
8432 }
8433
8434 /* pointer to character after '!' */
8435 static void
ff_chk_pragma(char * ppp)8436 ff_chk_pragma(char *ppp)
8437 {
8438 if (ppp[0] == '$' && (ppp[1] == 'P' || ppp[1] == 'p') &&
8439 (ppp[2] == 'R' || ppp[2] == 'r') && (ppp[3] == 'A' || ppp[3] == 'a') &&
8440 (ppp[4] == 'G' || ppp[4] == 'g') && (ppp[5] == 'M' || ppp[5] == 'm') &&
8441 (ppp[6] == 'A' || ppp[6] == 'a')) {
8442 /*
8443 * communicate to p_pragma() that this is a sun directive.
8444 * do so by prepending the substring beginning with the
8445 * first character after "pragma" with "sun".
8446 * NOTE: p_pragma expects a terminated line; inptr locates
8447 * the end of the line containing "!c$pragma". In
8448 * the next position store a newline.
8449 */
8450 strncpy(&ppp[4], "sun", 3);
8451 p_pragma(&ppp[4], gbl.lineno);
8452 }
8453 }
8454
8455 /* locates character after '&' */
8456 /*
8457 * while processing a number or identifier, found a '&' (expect
8458 * continuation):
8459 * 1. if this is the last non-blank character before, if any,
8460 * inline comment, get a noncomment line.
8461 * 2. if not, then an error.
8462 */
8463 static void
ff_get_noncomment(char * inptr)8464 ff_get_noncomment(char *inptr)
8465 {
8466 char *p;
8467 char c;
8468
8469 for (p = inptr; (c = *p) != '\n'; p++) {
8470 if (c == '!') {
8471 ff_chk_pragma(p + 1);
8472 c = '\n';
8473 break;
8474 }
8475 if (!iswhite(c))
8476 break;
8477 }
8478 if (c == '\n') {
8479 while (TRUE) {
8480 if (flg.list && card_type <= CT_COMMENT) {
8481 if (list_now)
8482 list_line(printbuff);
8483 }
8484 #if DEBUG
8485 if (DBGBIT(4, 2))
8486 fprintf(gbl.dbgfil, "line(%4d) %s", curr_line, cardb);
8487 #endif
8488 card_type = ff_read_card();
8489 if (card_type == CT_LINE) {
8490 line_directive();
8491 }
8492
8493 if (card_type != CT_COMMENT && card_type != CT_LINE)
8494 break;
8495 }
8496 } else
8497 card_type = CT_NONE;
8498
8499 switch (card_type) {
8500 case CT_SMP:
8501 case CT_MEM:
8502 case CT_PGI:
8503 case CT_KERNEL:
8504 case CT_DIRECTIVE:
8505 /* In free source form, OpenMP, 'mem', %, and $ don't require the
8506 * '&' appended to their respective sentinels; e.g.
8507 * !$omp ...openmp... &
8508 * !$omp ...continuation...
8509 *
8510 * !$mem ...mem... &
8511 * !$mem ...continuation...
8512 *
8513 * parentstruct &
8514 * %member = ... !!! parentstruct%member =
8515 *
8516 * namecontains &
8517 * $sign = ... !!! namecontains$sign =
8518 *
8519 */
8520 card_type = CT_CONTINUATION;
8521 /* fall thru */
8522 case CT_INITIAL:
8523 case CT_CONTINUATION:
8524 cont_shared:
8525 check_continuation(curr_line);
8526 put_astfil(curr_line, &printbuff[8], TRUE);
8527 if (card_count == 0) {
8528 error(19, 3, curr_line, CNULL, CNULL);
8529 card_type = CT_NONE;
8530 return;
8531 }
8532 card_count++;
8533 ff_check_stmtb();
8534 return;
8535 default:
8536 error(295, 3, gbl.lineno, CNULL, CNULL);
8537 break;
8538 }
8539
8540 /* error */
8541 card_type = CT_NONE;
8542 }
8543
8544 static int
ff_get_label(char * inp)8545 ff_get_label(char *inp)
8546 {
8547 int c;
8548 int cnt; /* number of characters processed */
8549 char lbuff[8]; /* temporarily holds label name */
8550 char *labp;
8551 int outp;
8552
8553 scn.currlab = 0;
8554 cnt = 0;
8555
8556 /* skip any leading white space */
8557
8558 c = *inp;
8559 while (iswhite(c)) {
8560 if (c == '\n')
8561 goto ret;
8562 c = *++inp;
8563 cnt++;
8564 }
8565
8566 labp = inp;
8567 while (isdig(c)) {
8568 cnt++;
8569 c = *++inp;
8570 }
8571 if (labp != inp) {
8572 atoxi(labp, &scn.labno, inp - labp, 10);
8573 if (scn.labno == 0)
8574 error(18, 3, gbl.lineno, "0", CNULL);
8575 else if (scn.labno > 99999)
8576 error(18, 3, gbl.lineno, "- length exceeds 5 digits", CNULL);
8577 else {
8578 int lab_sptr = getsymf(".L%05ld", (long)scn.labno);
8579 if (!iswhite(c))
8580 errlabel(18, 3, curr_line, SYMNAME(lab_sptr),
8581 "- must be followed by one or more blanks");
8582 scn.currlab = declref(lab_sptr, ST_LABEL, 'd');
8583 if (DEFDG(scn.currlab))
8584 errlabel(97, 3, gbl.lineno, SYMNAME(lab_sptr), CNULL);
8585 /* linked list of labels for internal subprograms */
8586 if (sem.which_pass == 0 && gbl.internal > 1 &&
8587 SYMLKG(scn.currlab) == NOSYM) {
8588 SYMLKP(scn.currlab, sem.flabels);
8589 sem.flabels = scn.currlab;
8590 }
8591 put_astfil(FR_LABEL, NULL, FALSE);
8592 put_astfil(scn.labno, NULL, FALSE);
8593 }
8594 }
8595
8596 ret:
8597 return cnt;
8598 }
8599
8600 static struct {
8601 long file_pos;
8602 } fe_state;
8603
8604 void
fe_init(void)8605 fe_init(void)
8606 {
8607 int nw;
8608
8609 fe_state.file_pos = ftell(astb.astfil);
8610 /* fflush(astb.astfil); fflush() doesn't seem to be always sufficient as an
8611 * intervening operation for read followed by write. So, replace with an
8612 * fseek().
8613 */
8614 nw = fseek(astb.astfil, fe_state.file_pos, 0);
8615 #if DEBUG
8616 assert(nw == 0, "fe_init:bad rewind", nw, 4);
8617 #endif
8618 }
8619
8620 void
fe_save_state(void)8621 fe_save_state(void)
8622 {
8623 fe_state.file_pos = ftell(astb.astfil);
8624 }
8625
8626 void
fe_restart(void)8627 fe_restart(void)
8628 {
8629 int nw;
8630
8631 nw = fseek(astb.astfil, fe_state.file_pos, 0);
8632 #if DEBUG
8633 if (nw == -1)
8634 perror("fe_restart - fseek on astb.astfil");
8635 assert(nw == 0, "fe_restart:bad rewind", nw, 4);
8636 if (DBGBIT(4, 1024))
8637 fprintf(gbl.dbgfil, "----- begin file -----\n");
8638 #endif
8639 /* close dinit files */
8640 dinit_end();
8641 gbl.eof_flag = FALSE;
8642 gbl.nowarn = TRUE; /*disable warnings for second parse; semfin enables*/
8643 }
8644
8645 /*
8646 * restore when the second parse sees an end-of-file or FR_END record
8647 * or when an end-statement is seen which was the last statement in
8648 * the file.
8649 */
8650 static void
_restore_state(void)8651 _restore_state(void)
8652 {
8653 }
8654
8655 /*
8656 * restore only when the second parse sees an end-of-file or FR_END record.
8657 */
8658 void
fe_restore_state(void)8659 fe_restore_state(void)
8660 {
8661 int nw;
8662
8663 sem.which_pass = 0;
8664 scmode = SCM_FIRST;
8665 _restore_state();
8666 nw = fseek(astb.astfil, 0L, 0);
8667 #if DEBUG
8668 assert(nw == 0, "_restore_state:bad rewind", nw, 4);
8669 #endif
8670 }
8671
8672 #include "tokdf.h"
8673 static void
_write_token(int tk,INT ctkv)8674 _write_token(int tk, INT ctkv)
8675 {
8676 static int type = FR_TOKEN;
8677 int nw;
8678 int s1, s2;
8679 int len;
8680 char *p;
8681
8682 nw = fwrite((char *)&type, sizeof(int), 1, astb.astfil);
8683 if (nw != 1)
8684 error(10, 4, 0, "(AST file)", CNULL);
8685 fprintf(astb.astfil, "%d", tk);
8686 fprintf(astb.astfil, " %d", ctkv); /* default token value */
8687
8688 currCol = ((int)(currc - stmtb)) + leadCount;
8689
8690 switch (tk) {
8691 case TK_IDENT:
8692 case TK_NAMED_CONSTRUCT:
8693 p = scn.id.name + ctkv;
8694 len = strlen(p);
8695 currCol = (currCol - len) + 1;
8696 fprintf(astb.astfil, " %d %d %s", currCol, len, p);
8697 fprintf(astb.astfil, " %d %s", (int)strlen(p), p);
8698 break;
8699 case TK_DEFINED_OP:
8700 p = SYMNAME(ctkv);
8701 len = strlen(SYMNAME(ctkv));
8702 fprintf(astb.astfil, " %d %d %s", currCol, len, p);
8703 break;
8704 case TK_ICON:
8705 case TK_RCON:
8706 case TK_NONDEC:
8707 case TK_LOGCONST:
8708 fprintf(astb.astfil, " %d %x", currCol, ctkv);
8709 break;
8710 case TK_DCON:
8711 case TK_CCON:
8712 case TK_NONDDEC:
8713 fprintf(astb.astfil, " %d %x %x", currCol, CONVAL1G(ctkv), CONVAL2G(ctkv));
8714 break;
8715 case TK_K_ICON:
8716 case TK_K_LOGCONST:
8717 fprintf(astb.astfil, " %d %x %x %d", currCol, CONVAL1G(ctkv),
8718 CONVAL2G(ctkv), DTYPEG(ctkv));
8719 break;
8720 case TK_QCON:
8721 fprintf(astb.astfil, " %d %x %x %x %x", currCol, CONVAL1G(ctkv),
8722 CONVAL2G(ctkv), CONVAL3G(ctkv), CONVAL4G(ctkv));
8723 break;
8724 case TK_DCCON:
8725 s1 = CONVAL1G(ctkv);
8726 s2 = CONVAL2G(ctkv);
8727 fprintf(astb.astfil, " %d %x %x %x %x", currCol, CONVAL1G(s1), CONVAL2G(s1),
8728 CONVAL1G(s2), CONVAL2G(s2));
8729 break;
8730 case TK_QCCON:
8731 s1 = CONVAL1G(ctkv);
8732 s2 = CONVAL2G(ctkv);
8733 fprintf(astb.astfil, " %d %x %x %x %x %x %x %x %x", currCol, CONVAL1G(s1),
8734 CONVAL2G(s1), CONVAL3G(s1), CONVAL4G(s1), CONVAL1G(s2),
8735 CONVAL2G(s2), CONVAL3G(s2), CONVAL4G(s2));
8736 break;
8737 case TK_HOLLERITH:
8738 fprintf(astb.astfil, " %d %d", currCol,
8739 CONVAL2G(ctkv)); /* kind of hollerith */
8740 ctkv = CONVAL1G(ctkv); /* auxiliary char constant */
8741 goto common_str; /* fall thru */
8742 case TK_FMTSTR:
8743 case TK_STRING:
8744 case TK_KSTRING:
8745 fprintf(astb.astfil, " %d", currCol);
8746 common_str:
8747 len = string_length(DTYPEG(ctkv));
8748 fprintf(astb.astfil, " %d ", len);
8749 p = stb.n_base + CONVAL1G(ctkv);
8750 while (len-- > 0)
8751 fprintf(astb.astfil, "%02x", (*p++) & 0xff);
8752 break;
8753 case TK_DIRECTIVE:
8754 len = (int)strlen(scn.directive);
8755 fprintf(astb.astfil, " %d %d", currCol, len);
8756 fprintf(astb.astfil, " %s", scn.directive);
8757 break;
8758 case TK_OPTIONS:
8759 len = (int)strlen(scn.options);
8760 fprintf(astb.astfil, " %d %d", currCol, (int)strlen(scn.options));
8761 fprintf(astb.astfil, " %s", scn.options);
8762 break;
8763 case TK_ENDSTMT:
8764 case TK_ENDBLOCKDATA:
8765 case TK_ENDFUNCTION:
8766 case TK_ENDPROCEDURE:
8767 case TK_ENDPROGRAM:
8768 case TK_ENDSUBROUTINE:
8769 case TK_ENDMODULE:
8770 case TK_ENDSUBMODULE:
8771 case TK_CONTAINS:
8772 fprintf(astb.astfil, " %d %d", currCol, gbl.eof_flag);
8773 break;
8774 case TK_EOL:
8775 currCol = 0;
8776 /* fall through to default case */
8777 default:
8778 fprintf(astb.astfil, " %d", currCol);
8779 break;
8780 }
8781 fprintf(astb.astfil, " %s", tokname[tk]);
8782 fprintf(astb.astfil, "\n");
8783 }
8784
8785 static char *tkp;
8786 static void _rd_tkline(char **tkbuf, int *tkbuf_sz);
8787 static int _rd_token(INT *);
8788 static INT get_num(int);
8789 static void get_string(char *);
8790
8791 /** \brief trim white space of source line that has continuations and return
8792 * the index of the last character in the source line.
8793 *
8794 * This function is called by contIndex().
8795 *
8796 * \param line is the source line we are processing.
8797 *
8798 * \return the index (an integer) of the last character in the source line.
8799 */
8800 static int
trimContIdx(char * line)8801 trimContIdx(char *line)
8802 {
8803 int len;
8804 char *p;
8805
8806 if (line == NULL)
8807 return 0;
8808
8809 len = strlen(line);
8810 if (len == 0)
8811 return 0;
8812
8813 for (p = (line + len) - 1; p > line && isspace(*p); --p)
8814 ;
8815
8816 return (int)(p - line);
8817 }
8818
8819 static int
numLeadingSpaces(char * line)8820 numLeadingSpaces(char *line)
8821 {
8822 int i;
8823
8824 if (line == NULL)
8825 return 0;
8826
8827 for (i = 0; *line != '\0'; ++line, ++i) {
8828 if (!isspace(*line) && *line != '&')
8829 break;
8830 }
8831
8832 return i;
8833 }
8834
8835 /** \brief Parse a source line with comments/continuations/string literals
8836 * and return the index of the last non-white space character of the
8837 * source line.
8838 *
8839 * \param line is the source line that we are processing.
8840 *
8841 * \return the index (an integer) of the last character in source line.
8842 */
8843 static int
contIndex(char * line)8844 contIndex(char *line)
8845 {
8846 int i;
8847 bool seenText = false;
8848 int seenQuote = 0;
8849 bool seenFin = false;
8850 int len;
8851
8852 if (line == NULL)
8853 return 0;
8854
8855 len = strlen(line);
8856
8857 for (i = 0; i < len; ++i) {
8858 if (!seenText && !isspace(line[i]) && line[i] != '&') {
8859 seenText = TRUE;
8860 }
8861 if (!seenText) {
8862 continue;
8863 }
8864 if (seenFin) {
8865 return i;
8866 }
8867 if (seenQuote == 0 && (line[i] == '\'' || line[i] == '"')) {
8868 seenQuote = line[i];
8869 } else if (seenQuote != 0 && line[i] == seenQuote) {
8870 seenQuote = 0;
8871 } else if (seenQuote == 0 && (line[i] == '!' || line[i] == '&')) {
8872 seenFin = true;
8873 return i + 1;
8874 }
8875 }
8876
8877 return trimContIdx(line);
8878 }
8879
8880 /** \brief get the post-processed source line in the current source file.
8881 *
8882 * \param line is the desired source line number.
8883 *
8884 * \param src_file is used to store a copy of the source filename that the
8885 * line number is associated with. It could be different from gbl.curr_file.
8886 * If src_file is NULL, then this parameter is ignored. Caller is responsible
8887 * to free the memory that src_file points to.
8888 *
8889 * \param col is the column number associated with the token in the source
8890 * line. It is usually needed if line has continuators.
8891 *
8892 * \param srcCol is the adjusted column number for the current source line. It
8893 * may be different than col when the column is associated with a continued
8894 * source line. This parameter is ignored if it is 0.
8895 *
8896 * \param contNo is greater than zero when source line is a continuation of
8897 * the source line specified in line.
8898 *
8899 * \return the source line associated with line. Result is NULL if line not
8900 * found in source file. Caller is responsible to free the memory allocated
8901 * for the result.
8902 */
8903 char *
get_src_line(int line,char ** src_file,int col,int * srcCol,int * contNo)8904 get_src_line(int line, char **src_file, int col, int *srcCol, int *contNo)
8905 {
8906 int fr_type, i, scratch_sz = 0, line_sz = 0, srcfile_sz = 0;
8907 char *scratch_buf = NULL;
8908 char *line_buf = NULL;
8909 char *srcfile_buf = NULL;
8910 long offset;
8911 int curr_line = 0, len;
8912 int line_len = 0;
8913 int adjCol = 0;
8914 int is_cont = 0;
8915 int adjSrcLine = 0;
8916 int saveCol = currCol;
8917
8918 offset = ftell(astb.astfil);
8919 rewind(astb.astfil);
8920 while (TRUE) {
8921 i = fread((char *)&fr_type, sizeof(int), 1, astb.astfil);
8922 if (feof(astb.astfil) || i != 1) {
8923 /* EOF */
8924 break;
8925 }
8926 switch (fr_type) {
8927 case FR_LINENO:
8928 _rd_tkline(&scratch_buf, &scratch_sz);
8929 sscanf(scratch_buf, "%d", &curr_line);
8930 break;
8931 case FR_SRC:
8932 _rd_tkline(&srcfile_buf, &srcfile_sz);
8933 if (src_file) {
8934 *src_file = srcfile_buf;
8935 }
8936 break;
8937 case FR_STMT:
8938 i = fread((char *)&curr_line, sizeof(int), 1, astb.astfil);
8939 if (feof(astb.astfil) || i != 1) {
8940 interr("get_src_line: truncated ast file", 0, 4);
8941 break;
8942 }
8943 next_stmt:
8944 _rd_tkline(&line_buf, &line_sz);
8945 if (curr_line == line) {
8946
8947 adjCol = line_len;
8948
8949 i = contIndex(line_buf);
8950 line_len += (i > 0) ? i : strlen(line_buf);
8951 line_len -= (is_cont) ? numLeadingSpaces(line_buf) : 0;
8952
8953 if (col < line_len) {
8954 if (is_cont) {
8955 col = ((col + numLeadingSpaces(line_buf)) - adjCol) + is_cont;
8956 }
8957 goto fin;
8958 } else {
8959 ++is_cont;
8960 continue;
8961 }
8962 } else if (line_buf) {
8963 i = sizeof(int);
8964 len = (line_sz > i) ? i : line_sz;
8965 for (i = 0; i < len; ++i)
8966 line_buf[i] = '\0';
8967 line_len = 0;
8968 is_cont = 0;
8969 }
8970 if (curr_line > line) {
8971 goto fin;
8972 }
8973 break;
8974 default:
8975 if (fr_type > 0 && is_cont > 0) {
8976 /* got a line continuation */
8977 adjSrcLine++;
8978 goto next_stmt;
8979 }
8980 _rd_tkline(&scratch_buf, &scratch_sz);
8981 }
8982 }
8983 fin:
8984 currCol = saveCol;
8985 fseek(astb.astfil, offset, SEEK_SET);
8986 FREE(scratch_buf);
8987 if (srcCol) {
8988 *srcCol = col;
8989 }
8990 if (contNo) {
8991 *contNo = adjSrcLine;
8992 }
8993 return line_buf;
8994 }
8995
8996 static int
_read_token(INT * tknv)8997 _read_token(INT *tknv)
8998 {
8999 int i;
9000 int fr_type;
9001 char *pp;
9002 static int prev_lineno = 0;
9003 static int incl_level = 0;
9004 static int lineno = 0;
9005 int findex;
9006 int lab_sptr;
9007
9008 while (TRUE) {
9009 i = fread((char *)&fr_type, sizeof(int), 1, astb.astfil);
9010 if (i < 1) {
9011 #if DEBUG
9012 if (DBGBIT(4, 1024))
9013 fprintf(gbl.dbgfil, "----- end of file -----\n");
9014 #endif
9015 fe_restore_state();
9016 return get_token(tknv);
9017 }
9018 switch (fr_type) {
9019 case FR_END:
9020 #if DEBUG
9021 if (DBGBIT(4, 1024))
9022 fprintf(gbl.dbgfil, "----- end of file: FR_END -----\n");
9023 #endif
9024 fe_restore_state();
9025 return get_token(tknv);
9026 case FR_SRC:
9027 goto read_line;
9028 case FR_B_INCL:
9029 incl_level++;
9030 (void)fread((char *)&findex, sizeof(int), 1, astb.astfil);
9031 gbl.findex = findex;
9032 gbl.curr_file = FIH_FULLNAME(gbl.findex);
9033 #if DEBUG
9034 if (DBGBIT(4, 1024))
9035 fprintf(gbl.dbgfil, "Include level %d: %s", incl_level, tkp);
9036 #endif
9037 break;
9038 case FR_B_HDR:
9039 (void)fread((char *)&findex, sizeof(int), 1, astb.astfil);
9040 gbl.findex = findex;
9041 gbl.curr_file = FIH_FULLNAME(gbl.findex);
9042 #if DEBUG
9043 if (DBGBIT(4, 1024))
9044 fprintf(gbl.dbgfil, "All include level %d: %s", hdr_level, tkp);
9045 #endif
9046 break;
9047 case FR_E_INCL:
9048 (void)fread((char *)&findex, sizeof(int), 1, astb.astfil);
9049 gbl.findex = findex;
9050 gbl.curr_file = FIH_FULLNAME(gbl.findex);
9051 #if DEBUG
9052 if (DBGBIT(4, 1024))
9053 fprintf(gbl.dbgfil, "End of include level %d: %s", incl_level, tkp);
9054 #endif
9055 incl_level--;
9056 break;
9057 case FR_E_HDR:
9058 (void)fread((char *)&findex, sizeof(int), 1, astb.astfil);
9059 gbl.findex = findex;
9060 gbl.curr_file = FIH_FULLNAME(gbl.findex);
9061 #if DEBUG
9062 if (DBGBIT(4, 1024))
9063 fprintf(gbl.dbgfil, "End of all include level %d: %s", hdr_level, tkp);
9064 #endif
9065 break;
9066 case 0:
9067 lineno = gbl.lineno = prev_lineno + 1;
9068 goto read_line;
9069 case FR_LABEL:
9070 (void)fread((char *)&fr_type, sizeof(int), 1, astb.astfil);
9071 lab_sptr = getsymf(".L%05ld", (long)fr_type);
9072 #if DEBUG
9073 if (DBGBIT(4, 1024))
9074 fprintf(gbl.dbgfil, "Label %d\n", fr_type);
9075 #endif
9076 scn.currlab = declref(lab_sptr, ST_LABEL, 'd');
9077 /** HACK -- don't check for multiple defs if the label was moved
9078 ** from a host's end statement to its CONTAINS statement. SEE
9079 ** semant.c:/sem.end_host_labno/
9080 **/
9081 if (DEFDG(scn.currlab) && !L3FG(scn.currlab))
9082 errlabel(97, 3, curr_line, SYMNAME(lab_sptr), CNULL);
9083 /* linked list of labels for internal subprograms */
9084 if (sem.which_pass == 0 && gbl.internal > 1 &&
9085 SYMLKG(scn.currlab) == NOSYM) {
9086 SYMLKP(scn.currlab, sem.flabels);
9087 sem.flabels = scn.currlab;
9088 }
9089 break;
9090 case FR_LINENO:
9091 _rd_tkline(&tkbuf, &tkbuf_sz);
9092 #if DEBUG
9093 if (DBGBIT(4, 1024))
9094 fprintf(gbl.dbgfil, " Lineno: %s", tkp);
9095 #endif
9096 gbl.lineno = get_num(10);
9097 break;
9098 case FR_PRAGMA:
9099 _rd_tkline(&tkbuf, &tkbuf_sz);
9100 #if DEBUG
9101 if (DBGBIT(4, 1024))
9102 fprintf(gbl.dbgfil, " Pragma: %s", tkp);
9103 #endif
9104 p_pragma(tkp, gbl.lineno);
9105 break;
9106 default:
9107 lineno = fr_type;
9108 read_line:
9109 _rd_tkline(&tkbuf, &tkbuf_sz);
9110 switch (fr_type) {
9111 case FR_SRC:
9112 #if DEBUG
9113 if (DBGBIT(4, 1024))
9114 fprintf(gbl.dbgfil, "Source File: %s", tkbuf);
9115 #endif
9116 break;
9117 default:
9118 #if DEBUG
9119 if (DBGBIT(4, 1024))
9120 fprintf(gbl.dbgfil, "%5d: %s", lineno, tkbuf);
9121 #endif
9122 break;
9123 }
9124 break;
9125 case FR_STMT:
9126 #if DEBUG
9127 if (DBGBIT(4, 1024))
9128 fprintf(gbl.dbgfil, "----- new stmt: FR_STMT -----\n");
9129 #endif
9130 scmode = SCM_FIRST;
9131 scn.stmtyp = 0;
9132 scn.currlab = 0;
9133 scn.is_hpf = FALSE;
9134 par_depth = 0;
9135 break;
9136 case FR_TOKEN:
9137 return _rd_token(tknv);
9138 }
9139 prev_lineno = lineno;
9140 }
9141 }
9142
9143 static void
_rd_tkline(char ** tkbuf,int * tkbuf_sz)9144 _rd_tkline(char **tkbuf, int *tkbuf_sz)
9145 {
9146 int i;
9147 int ch;
9148 char *p;
9149
9150 i = 0;
9151 while (TRUE) {
9152 ch = getc(astb.astfil);
9153 if (i + 1 >= *tkbuf_sz) {
9154 *tkbuf_sz += CARDB_SIZE << 3;
9155 *tkbuf = sccrelal(*tkbuf, *tkbuf_sz);
9156 }
9157 (*tkbuf)[i++] = ch;
9158 if (ch == '\n')
9159 break;
9160 }
9161 (*tkbuf)[i] = '\0';
9162 p = tkp = *tkbuf;
9163 /* Process #include files */
9164 if (*p == '#') {
9165 ++p;
9166 while (isblank(*p)) /* skip blank characters */
9167 ++p;
9168 if (!isdig(*p)) {
9169 char *tmp_ptr;
9170 tmp_ptr = gbl.curr_file;
9171 if (hdr_level)
9172 gbl.curr_file = hdr_stack[hdr_level - 1].fname;
9173 error(21, 3, curr_line, CNULL, CNULL);
9174 gbl.curr_file = tmp_ptr;
9175 return;
9176 }
9177 while (isdig(*p)) {
9178 ++p;
9179 }
9180 ++p;
9181 while (isblank(*p)) {
9182 ++p;
9183 }
9184 if (*p == '"') {
9185 *(p + CARDB_SIZE) = '"'; /* limit length of file name */
9186 }
9187 }
9188 }
9189
9190 int
getCurrColumn(void)9191 getCurrColumn(void)
9192 {
9193 return currCol;
9194 }
9195
9196 static int
_rd_token(INT * tknv)9197 _rd_token(INT *tknv)
9198 {
9199 int i;
9200 int len;
9201 INT val[2], num[4];
9202 char *p, *q;
9203 int kind;
9204 int dtype;
9205 int col;
9206
9207 _rd_tkline(&tkbuf, &tkbuf_sz);
9208 #if DEBUG
9209 if (DBGBIT(4, 1024))
9210 fprintf(gbl.dbgfil, " TOKEN: %s", tkbuf);
9211 #endif
9212 tkntyp = get_num(10);
9213 tknval = get_num(10); /* default token value */
9214 currCol = get_num(10); /* get column number */
9215
9216 switch (tkntyp) {
9217 case TK_IDENT:
9218 case TK_NAMED_CONSTRUCT:
9219 len = get_num(10);
9220 p = scn.id.name + tknval;
9221 while (len-- > 0)
9222 *p++ = *++tkp;
9223 *p = '\0';
9224 break;
9225 case TK_DEFINED_OP:
9226 len = get_num(10);
9227 tknval = getsym(++tkp, len);
9228 break;
9229 case TK_ICON:
9230 case TK_RCON:
9231 case TK_NONDEC:
9232 case TK_LOGCONST:
9233 tknval = get_num(16);
9234 break;
9235 case TK_DCON:
9236 num[0] = get_num(16);
9237 num[1] = get_num(16);
9238 tknval = getcon(num, DT_REAL8);
9239 break;
9240 case TK_QCON:
9241 num[0] = get_num(16);
9242 num[1] = get_num(16);
9243 num[2] = get_num(16);
9244 num[3] = get_num(16);
9245 tknval = getcon(num, DT_QUAD);
9246 break;
9247 case TK_CCON:
9248 num[0] = get_num(16);
9249 num[1] = get_num(16);
9250 tknval = getcon(num, DT_CMPLX8);
9251 break;
9252 case TK_DCCON:
9253 num[0] = get_num(16);
9254 num[1] = get_num(16);
9255 val[0] = getcon(num, DT_REAL8);
9256 num[0] = get_num(16);
9257 num[1] = get_num(16);
9258 val[1] = getcon(num, DT_REAL8);
9259 tknval = getcon(val, DT_CMPLX16);
9260 break;
9261 case TK_QCCON:
9262 num[0] = get_num(16);
9263 num[1] = get_num(16);
9264 num[2] = get_num(16);
9265 num[3] = get_num(16);
9266 val[0] = getcon(num, DT_QUAD);
9267 num[0] = get_num(16);
9268 num[1] = get_num(16);
9269 num[2] = get_num(16);
9270 num[3] = get_num(16);
9271 val[1] = getcon(num, DT_QUAD);
9272 tknval = getcon(val, DT_QCMPLX);
9273 break;
9274 case TK_NONDDEC:
9275 num[0] = get_num(16);
9276 num[1] = get_num(16);
9277 tknval = getcon(num, DT_DWORD);
9278 break;
9279 case TK_K_ICON:
9280 case TK_K_LOGCONST:
9281 num[0] = get_num(16);
9282 num[1] = get_num(16);
9283 dtype = get_num(10);
9284 tknval = getcon(num, dtype);
9285 break;
9286 case TK_HOLLERITH:
9287 kind = get_num(10);
9288 /* fall thru */
9289 case TK_FMTSTR:
9290 case TK_STRING:
9291 case TK_KSTRING:
9292 i = len = get_num(10);
9293 q = p = ++tkp;
9294 while (i-- > 0) {
9295 num[0] = hex_to_i((int)p[0]) << 4;
9296 num[0] |= hex_to_i((int)p[1]);
9297 *q++ = num[0];
9298 p += 2;
9299 }
9300 tknval = getstring(tkp, len);
9301 if (tkntyp == TK_HOLLERITH)
9302 tknval = gethollerith(tknval, kind);
9303 break;
9304 case TK_DIRECTIVE:
9305 len = get_num(10);
9306 p = scn.directive;
9307 while (len-- > 0)
9308 *p++ = *++tkp;
9309 *p = '\0';
9310 break;
9311 case TK_OPTIONS:
9312 len = get_num(10);
9313 p = scn.options;
9314 while (len-- > 0)
9315 *p++ = *++tkp;
9316 *p = '\0';
9317 break;
9318 case TK_LPAREN:
9319 case TK_IOLP:
9320 case TK_IMPLP:
9321 par_depth++;
9322 break;
9323 case TK_RPAREN:
9324 par_depth--;
9325 if (bind_state == B_FUNC_FOUND) {
9326 bind_state = B_RPAREN_FOUND;
9327 }
9328 if (par_depth == 0 && scmode == SCM_IF)
9329 scmode = SCM_FIRST;
9330 break;
9331 default:
9332 if (scmode == SCM_FIRST) {
9333 scn.stmtyp = tkntyp;
9334 scmode = SCM_IDENT;
9335 switch (scn.stmtyp) {
9336 case TK_ENDSTMT:
9337 case TK_ENDBLOCKDATA:
9338 case TK_ENDFUNCTION:
9339 case TK_ENDPROCEDURE:
9340 case TK_ENDPROGRAM:
9341 case TK_ENDSUBROUTINE:
9342 case TK_CONTAINS: /* CONTAINS statement will be treated as the
9343 * END of of a blockdata */
9344 if (sem.interface == 0)
9345 scn.end_program_unit = TRUE;
9346 gbl.eof_flag = get_num(10);
9347 if (gbl.eof_flag)
9348 _restore_state();
9349 break;
9350 case TK_ENDMODULE:
9351 case TK_ENDSUBMODULE:
9352 scn.end_program_unit = TRUE;
9353 gbl.eof_flag = get_num(10);
9354 if (gbl.eof_flag)
9355 _restore_state();
9356 break;
9357 case TK_IF:
9358 scmode = SCM_IF;
9359 break;
9360 default:
9361 break;
9362 }
9363 }
9364 break;
9365 }
9366 *tknv = tknval;
9367 return tkntyp;
9368 }
9369
9370 int
get_named_stmtyp(void)9371 get_named_stmtyp(void)
9372 {
9373 long file_pos;
9374 int nw;
9375 int fr_type;
9376 int i;
9377 int tkn;
9378 /*
9379 * The token which names a control construct (TK_NAMED_CONSTRUCT) was
9380 * just seen by semant. Now need to determine the actual statement type.
9381 * Recall that the syntax is
9382 * named_construct : <token>
9383 */
9384 file_pos = ftell(astb.astfil);
9385
9386 /* : */
9387 i = fread((char *)&fr_type, sizeof(int), 1, astb.astfil);
9388 _rd_tkline(&tkbuf, &tkbuf_sz);
9389 #if DEBUG
9390 assert(i >= 1, "get_named_stmtyp:bad read 1", i, 4);
9391 assert(fr_type == FR_TOKEN, "get_named_stmtyp:expected FR_TOKEN 1, got",
9392 fr_type, 4);
9393 tkn = get_num(10);
9394 assert(tkn == TK_COLON, "get_named_stmtyp:expected :, got", tkn, 4);
9395 #endif
9396
9397 /* <token> */
9398 i = fread((char *)&fr_type, sizeof(int), 1, astb.astfil);
9399 _rd_tkline(&tkbuf, &tkbuf_sz);
9400 #if DEBUG
9401 assert(i >= 1, "get_named_stmtyp:bad read 2", i, 4);
9402 assert(fr_type == FR_TOKEN, "get_named_stmtyp:expected FR_TOKEN 2, got",
9403 fr_type, 4);
9404 #endif
9405 tkn = get_num(10);
9406
9407 nw = fseek(astb.astfil, file_pos, 0);
9408 #if DEBUG
9409 assert(nw == 0, "get_named_stmtyp:bad week", nw, 4);
9410 #endif
9411
9412 return tkn;
9413 }
9414
9415 static int
get_num(int radix)9416 get_num(int radix)
9417 {
9418 char *p;
9419 INT val;
9420 static char buffer[64];
9421
9422 while (*tkp == ' ')
9423 tkp++;
9424 p = tkp;
9425 while (*tkp != ' ' && *tkp != '\n')
9426 tkp++;
9427 (void)atoxi(p, &val, (int)(tkp - p), radix);
9428 return val;
9429 }
9430
9431 static void
get_string(char * dest)9432 get_string(char *dest)
9433 {
9434 int i;
9435 char ch;
9436
9437 while (*tkp == ' ')
9438 tkp++;
9439 i = 0;
9440 while ((ch = *tkp) != ' ' && ch != '\n') {
9441 dest[i++] = ch;
9442 tkp++;
9443 }
9444 dest[i] = '\0';
9445 }
9446
9447 static void
realloc_stmtb(void)9448 realloc_stmtb(void)
9449 {
9450 int which;
9451 if (stmtb == stmtbefore)
9452 which = 1;
9453 max_card += 20;
9454 stmtbefore = sccrelal(stmtbefore, (BIGUINT64)(max_card * (MAX_COLS - 1) + 1));
9455 if (stmtbefore == NULL)
9456 error(7, 4, 0, CNULL, CNULL);
9457 stmtbafter = sccrelal(stmtbafter, (BIGUINT64)(max_card * (MAX_COLS - 1) + 1));
9458 if (stmtbafter == NULL)
9459 error(7, 4, 0, CNULL, CNULL);
9460 if (which)
9461 stmtb = stmtbefore;
9462 else
9463 stmtb = stmtbafter;
9464 last_char =
9465 (short *)sccrelal((char *)last_char, (BIGUINT64)(max_card * sizeof(short)));
9466 if (last_char == NULL)
9467 error(7, 4, 0, CNULL, CNULL);
9468 }
9469
9470 static void
ff_check_stmtb(void)9471 ff_check_stmtb(void)
9472 {
9473 if (card_count >= max_card) {
9474 char *oldp;
9475
9476 oldp = stmtb;
9477 realloc_stmtb();
9478 if (stmtb == NULL)
9479 error(7, 4, 0, CNULL, CNULL);
9480 ff_state.cavail = stmtb + (ff_state.cavail - oldp);
9481 ff_state.outptr = stmtb + (ff_state.outptr - oldp);
9482 if (ff_state.amper_ptr)
9483 ff_state.amper_ptr = stmtb + (ff_state.amper_ptr - oldp);
9484 }
9485 if (flg.standard && card_count == 257)
9486 error(170, 2, curr_line, "more than 255 continuations", CNULL);
9487 }
9488
9489 static void
check_continuation(int lineno)9490 check_continuation(int lineno)
9491 {
9492 switch (sentinel) {
9493 case SL_OMP:
9494 if (!is_smp)
9495 goto cont_error;
9496 break;
9497 case SL_SGI:
9498 if (!is_sgi)
9499 goto cont_error;
9500 break;
9501 case SL_MEM:
9502 if (!is_mem)
9503 goto cont_error;
9504 break;
9505 case SL_PGI:
9506 if (!is_pgi)
9507 goto cont_error;
9508 break;
9509 case SL_KERNEL:
9510 if (!is_kernel)
9511 goto cont_error;
9512 break;
9513 default:
9514 if (scn.is_hpf || is_smp || is_sgi || is_mem || is_ppragma || is_kernel || is_pgi
9515 )
9516 goto cont_error;
9517 break;
9518 }
9519 return;
9520
9521 cont_error:
9522 error(292, 3, lineno, CNULL, CNULL);
9523 }
9524
9525 static LOGICAL
is_next_char(char * s,int ch)9526 is_next_char(char *s, int ch)
9527 {
9528 while (*s != ch) {
9529 if (*s == ' ') {
9530 s++;
9531 continue;
9532 }
9533 return FALSE;
9534 }
9535 return TRUE;
9536 }
9537
9538 static int
double_type(char * ip,int * p_idlen)9539 double_type(char *ip, int *p_idlen)
9540 {
9541 if (!is_freeform)
9542 return 0;
9543 if (*ip == ' ') {
9544 int k;
9545 k = is_ident(ip + 1);
9546 if (k == 7 && strncmp(ip + 1, "complex", 7) == 0) {
9547 *p_idlen += 7 + 1;
9548 return TK_DBLECMPLX;
9549 }
9550 if (k == 9 && strncmp(ip + 1, "precision", 9) == 0) {
9551 *p_idlen += 9 + 1;
9552 return TK_DBLEPREC;
9553 }
9554 }
9555 return 0;
9556 }
9557