1 /* @(#)lex.c 1.17 96/09/11 */
2 /*
3 * ====================================================
4 * Copyright (C) 1995 by Sun Microsystems, Inc. All rights reserved.
5 *
6 * Developed at SunSoft, a Sun Microsystems, Inc. business.
7 * Permission to use, copy, modify, and distribute this
8 * software is freely granted, provided that this notice
9 * is preserved.
10 * ====================================================
11 */
12
13 #include "fpp.h"
14 #include "service.h"
15 #include "symtab.h"
16 #include "rgram.h"
17 #include "lex.h"
18 #include "sb.h"
19
20 extern uchar *curp;
21 extern Comment *comments;
22
23 /* ltok is a static memory to hold the current token.
24 * As long as we don't expect pushtok() to be called more
25 * than once the size is equal to 2.
26 */
27 static Token ltok[2];
28 static Token *curtok = <ok[0];
29 static int cur_stmt_id = 0; /* current statement id */
30 static int sym_line; /* current character lineno */
31 static char cont_symbol; /* symbol used in 6th column (fixed mode) */
32
33 #define nextch(c) \
34 while (!*curp) refill();\
35 c = *curp++;\
36 if (c == SYM_CTRL && ctrl_mode) {\
37 while (!*curp) refill();\
38 if (*curp != SYM_CTRL) {\
39 c = (c << 8) | *curp++;\
40 ctrl_mode--;\
41 }\
42 else curp++;\
43 }
44
45 #define unnextch(c) \
46 *--curp = (char)c;\
47 if (is_special(c)) {\
48 *--curp = SYM_CTRL;\
49 ctrl_mode++;\
50 }
51
52
53 static int
skip_comment(unsigned mode)54 skip_comment( unsigned mode ) {
55 wchar c;
56 int i,n;
57 int locfl;
58 int lineno;
59 char *p;
60 static char buffer[BUFSIZE];
61
62 loop: locfl = 0;
63 p = buffer;
64 lineno = line;
65 nextch(c);
66
67 switch (c) {
68 case 'c':
69 case 'C':
70 case 'd':
71 case 'D':
72 case '*':
73 if (!f77fl && !fixedformfl) {
74 unnextch(c);
75 return 0;
76 }
77 if (colm != 0) {
78 unnextch(c);
79 return 0;
80 }
81 /* no break! */
82 case '!':
83 *p++ = (char)c;
84 for (;;) {
85 nextch(c);
86 if (c == '\n') {
87 line++; colm=0;
88 *p++ = (char)c;
89 break;
90 }
91 else if (c == SYM_EOF) {
92 colm=0;
93 *p++ = '\n';
94 break;
95 }
96 *p++ = (char)c;
97 }
98 *p = '\0';
99 for (i=0;i<8;i++) { /* we treat it as pragma if it has '$' */
100 if (buffer[i] == '\0') break;
101 if (buffer[i] == '$') {
102 if (mode & MOD_LCASE)
103 tolowcase(buffer);
104 locfl = 1;
105 break;
106 }
107 }
108 break;
109 case '\n':
110 if (colm != 0) {
111 unnextch(c);
112 return 0;
113 }
114 *p++ = (char)c;
115 line++;
116 break;
117 default:
118 if ( !is_blank(c) ) {
119 unnextch(c);
120 return 0;
121 }
122 CHECK(colm==0);
123 for (n = 1;;n++) {
124 colm++;
125 *p++ = (char)c;
126 nextch(c);
127 if (c == '\n') {
128 line++; colm=0;
129 *p++ = (char)c;
130 break;
131 }
132 else if (c == SYM_EOF) {
133 colm = 0;
134 *p++ = '\n';
135 break;
136 }
137 else if (c == '!') {
138 if (!(fixedformfl && n == 5)) {
139
140 /* Skip the leading spaces.
141 */
142 p = buffer;
143 unnextch(c);
144 goto loop;
145 }
146 }
147 if (!is_blank(c)) {
148 unnextch(c);
149 while (n--) ungetsym(*(--p));
150 CHECK(colm==0);
151 return 0;
152 }
153 }
154 break;
155 }
156
157 *p = '\0';
158
159 if ( !(mode & MOD_FPP) && !falselvl &&
160 (!rmcommfl || locfl) && (p != buffer)) {
161 Comment **t;
162
163 /* Place t onto the end of the list */
164 for (t=&comments; *t; t=&((*t)->next));
165
166 (*t) = my_alloc(sizeof(Comment),1);
167 (*t)->str = my_strdup(buffer);
168 (*t)->next = NULL;
169 (*t)->lineno = lineno;
170 (*t)->length = p - buffer;
171 }
172
173 return 1;
174 }
175
176 static int
skipcont()177 skipcont() {
178 char locbuf[6];
179 char *p = locbuf;
180 wchar c;
181 int n;
182
183 CHECK(colm==0);
184 nextch(c);
185 if (c == '&') {
186 colm = 6;
187 line_width = LINE_WIDTH_MAX;
188 return 1;
189 }
190 else if (c == SYM_FPP) {
191 unnextch(c);
192 return 0;
193 }
194 colm++;
195 for (n=5;;n--) {
196 if (c == '\t') {
197 *p++ = (char)c;
198 nextch(c);
199 if (is_num(c) && c != '0') {
200 colm = 6;
201 line_width = LINE_WIDTH_MAX;
202 return 1;
203 }
204 else {
205 unnextch(c);
206 ungetstr(locbuf, p - locbuf);
207 return 0;
208 }
209 }
210 else if (c == '/') {
211 *p++ = (char)c;
212 nextch(c);
213 if (c == '*') {
214 unnextch(c);
215 ungetstr(locbuf, p - locbuf);
216 return 0;
217 }
218 unnextch(c);
219 c = *--p;
220 }
221 else if (c == '\n' || c == SYM_EOF) {
222 unnextch(c);
223 ungetstr(locbuf ,p - locbuf);
224 colm = 0;
225 return 0;
226 }
227 *p++ = (char)c;
228 if (n == 0) break;
229 nextch(c); colm++;
230 }
231 if (is_blank(c) || c == '0') {
232 ungetstr(locbuf, p - locbuf);
233 return 0;
234 }
235 line_width = line_width0;
236 return 1;
237 }
238
239 static int
skipcont90(unsigned mode)240 skipcont90(unsigned mode) {
241 wchar c;
242 int locfl=0;
243 char locbuf[BUFSIZE];
244 char *p;
245
246 p = locbuf;
247
248 if (mode & MOD_RAW) {
249 for (;;) {
250 nextch(c);
251 switch (c) {
252 case ' ' :
253 case '\t': break;
254 case '&' :
255 if (locfl==1) {
256 colm++;
257 return 1;
258 }
259 else {
260 unnextch(c);
261 ungetstr(locbuf, p - locbuf);
262 return 0;
263 }
264 break;
265 case '\n':
266 if (!locfl) {
267 locfl++;
268 line++; colm = 0;
269 p = locbuf;
270 continue;
271 }
272 /* no break */
273 default :
274 unnextch(c);
275 ungetstr(locbuf, p - locbuf);
276 return locfl;
277 }
278 *p++ = (char)c;
279 colm++;
280 }
281 }
282 else {
283 for (;;) {
284 nextch(c);
285 switch (c) {
286 case ' ' :
287 case '\t': break;
288 case '!' :
289 if (!locfl) {
290 unnextch(c);
291 while (skip_comment(mode));
292 locfl++;
293 p = locbuf;
294 continue;
295 }
296 goto exit;
297 case '\n':
298 if (!locfl) {
299 locfl++;
300 p = locbuf;
301 line++; colm = 0;
302 continue;
303 }
304 goto exit;
305 case '&' :
306 if (locfl==1) {
307 colm++;
308 return 1;
309 }
310 goto exit;
311 case SYM_FPP:
312 if (locfl==1 && colm==0) {
313 unnextch(c);
314 ungetsym('\n');
315 return 0;
316 }
317 goto exit;
318 default:
319 goto exit;
320 }
321 *p++ = (char)c;
322 colm++;
323 }
324 exit: unnextch(c);
325 ungetstr(locbuf, p - locbuf);
326 if (locfl)
327 return 1;
328 else return 0;
329 }
330 }
331
332 static wchar
getsym(unsigned mode)333 getsym( unsigned mode ) {
334 wchar c;
335
336 for (;;) {
337 nextch(c);
338 colm++;
339 sym_line = line;
340
341 if (colm > line_width) {
342 if (c != '\n' && c!= SYM_EOF)
343 continue;
344 }
345 switch (c) {
346 case ' ':
347 case '\t':
348 if (mode & MOD_SPACE)
349 continue;
350 break;
351 case '\n':
352 case SYM_EOF:
353 if ((mode & MOD_RAW) && (mode & MOD_CONT) && colm <= line_width) {
354 if (falselvl == 0) {
355 unnextch(c);
356 c = ' ';
357 }
358 else if (c == '\n') {
359 line++; colm = 0;
360 }
361 else {
362 colm = 0;
363 }
364 }
365 else if (c == '\n') {
366 line++; colm = 0;
367 if (fixedformfl && (mode & MOD_CONT)) {
368 while (skip_comment(mode));
369 if (skipcont()) {
370 CHECK(colm==6);
371 continue;
372 }
373 }
374 }
375 else {
376 colm = 0;
377 }
378 break;
379 case '!':
380 if (!(mode & MOD_RAW) && !(fixedformfl && colm==6)
381 && !(mode & MOD_IF)) {
382
383 /* Process a trailing comment */
384 unnextch(c);
385 skip_comment(mode);
386 CHECK(colm == 0);
387 if (fixedformfl && (mode & MOD_CONT)) {
388 while (skip_comment(mode));
389 if (skipcont()) {
390 CHECK(colm==6);
391 continue;
392 }
393 }
394 c = '\n';
395 }
396 break;
397 case '&':
398 if (!fixedformfl) {
399 if (mode & MOD_CONT) {
400 if (skipcont90(mode))
401 continue;
402 }
403 }
404 break;
405 case '/':
406 if (!(mode & MOD_RAW) && !no_ccom_fl) {
407 nextch(c);
408 if (c == '*') {
409 int loclvl=0;
410
411 colm++;
412 for (;;) {
413 nextch(c);
414 if (c == '*') {
415 colm++;
416 nextch(c);
417 if (c == '/') {
418 colm++;
419 if (!loclvl) break;
420 else loclvl--;
421 }
422 else {
423 unnextch(c);
424 }
425 }
426 else if (c == '\n') {
427 colm = 0;
428 line++;
429 }
430 else if(c == SYM_EOF) {
431 fppmess(ERR_LCOMM);
432 break;
433 }
434 else if(c == '/') {
435 colm++;
436 nextch(c);
437 if (c == '*') {
438 colm++;
439 loclvl++;
440 }
441 else {
442 unnextch(c);
443 }
444 }
445 else {
446 colm++;
447 }
448 }
449 c = SYM_DUMMY;
450 }
451 else {
452 unnextch(c);
453 c = '/';
454 }
455 }
456 break;
457 default:
458 if (!is_special(c) && (mode & MOD_LCASE))
459 c = lowcase(c);
460 break;
461 }
462 return c;
463 }
464 }
465
466 static int
get_tkop(SymPtr symp)467 get_tkop(SymPtr symp) {
468 switch (symvali(symp)) {
469 case FTN_FORMAT:
470 return(TK_FORMAT);
471 case FTN_IMPLICIT:
472 return(TK_IMPLICIT);
473 case FTN_DO:
474 return(TK_DO);
475 case FTN_READ:
476 case FTN_WRITE:
477 return(TK_RDWR);
478 case FTN_ASSIGN:
479 return(TK_ASGN);
480 case FTN_TYPE: /* only for F90 */
481 return(TK_TYPE0);
482 case FTN_BYTE:
483 case FTN_CHARACTER:
484 case FTN_COMPLEX:
485 case FTN_DOUBLECOMP:
486 case FTN_DOUBLEPREC:
487 case FTN_INTEGER:
488 case FTN_LOGICAL:
489 case FTN_REAL:
490 return(TK_TYPE);
491 default:
492 return(TK_KEY);
493 }
494 /* return(TK_KEY); */
495 }
496
497 static int
isfspec(char * s)498 isfspec( char *s ) {
499 char c;
500
501 c = lowcase(*s); s++;
502 switch (c) {
503 case 'b':
504 c = lowcase(*s);
505 if (c == 'n' || c== 'z') {
506 s++;
507 if ( *s == '\0') return 1;
508 else break;
509 }
510 while (is_num(*s)) s++;
511 if (*s == '\0') return 1;
512 break;
513 case 't':
514 c = lowcase(*s);
515 if (c == 'l' || c== 'r')
516 s++;
517 while (is_num(*s)) s++;
518 if (*s == '\0') return 1;
519 break;
520 case 'e':
521 c = lowcase(*s);
522 if (c == 'n' || c== 's')
523 s++;
524 while (is_num(*s)) s++;
525 if (*s == '\0') return 1;
526 break;
527 case 'a': case 'd': case 'f': case 'g':
528 case 'i': case 'l': case 'o': case 'z':
529 while (is_num(*s)) s++;
530 if (*s == '\0') return 1;
531 break;
532 case 's':
533 c = lowcase(*s);
534 if (c == 'p' || c == 's' || c == 'u')
535 s++;
536 if (*s == '\0')
537 return 1;
538 break;
539 case 'x': case 'r': case 'q': case 'p':
540 if (*s == '\0')
541 return 1;
542 break;
543 default:
544 return 0;
545 }
546 return 0;
547 }
548
549 #define st_move1(x) if(!(mode & MOD_NOGRAM)) {st_move(x);}
550
551 Token *
get_token(unsigned mode)552 get_token(unsigned mode) {
553 wchar c,c0;
554 char *endp;
555 int flreal; /* used in number processing */
556 SymPtr symp;
557 static int fllogic = 0; /* to process kind in logical constants */
558 static int flimpl = 0; /* to process implicit statement */
559 static int flformat = 0; /* to process format statement */
560 unsigned lmode; /* local mode */
561
562 lmode = mode /* & ~MOD_CONT */;
563
564 loop: endp = curtok->token;
565 curtok->val = TK_DUMMY;
566
567 c = getsym(mode);
568 CHECK(c);
569 curtok->lineno = sym_line;
570 curtok->stid = cur_stmt_id;
571 switch (c) {
572
573 case '\n':
574 case SYM_EOF: curtok->val = TK_NL;
575 st_move1(curtok->val);
576 *endp++ = (char)c;
577 onequalsym = NULL; /* break assignment subst control */
578 flimpl = 0; /* break implicit processing */
579 flformat = 0; /* break format processing */
580 cur_stmt_id++;
581 break;
582
583 case SYM_FPP: curtok->val = TK_FPP;
584 st_move1(curtok->val);
585 *endp++ = (char)c;
586 break;
587
588 case SYM_DUMMY: *endp++ = ' ';
589 break;
590
591 case SYM_BOS: curtok->val = TK_BOS;
592 st_move1(curtok->val);
593 if (fixedformfl) {
594 CHECK(colm == 6);
595 }
596 *endp++ = cont_symbol;
597 break;
598
599 case SYM_EOMS: /* it also delimits lexems */
600 sympop();
601 if (sbfl) sb_mref_end();
602 goto loop;
603
604 case SYM_BF: /* it simply delimits lexems */
605 symhide();
606 goto loop;
607
608 case SYM_EF: /* it simply delimits lexems */
609 symunhide();
610 goto loop;
611
612 case SYM_EOC: curtok->val = TK_EOC;
613 break;
614
615 case '\\': *endp++ = (char)c;
616 c = getsym(MOD_RAW);
617 if (is_special(c)) {
618 ungetsym(c);
619 }
620 else if (c == '\n' || c == SYM_EOF) {
621 goto loop;
622 /* endp[-1] = c = ' '; */
623 }
624 else {
625 *endp++ = (char)c;
626 st_move1(curtok->val); /* TK_DUMMY */
627 }
628 break;
629 /* case ' ':
630 case '\t': *endp++ = c;
631 break;
632 while (is_blank(c)) {
633 *endp++ = c;
634 if (endp - curtok->token >= MAXTOKENSIZE) {
635 curtok->length = MAXTOKENSIZE;
636 outtok(curtok);
637 endp = curtok->token;
638 }
639 c = getsym(lmode);
640 }
641 ungetsym(c);
642 break;
643 */
644 case '(': curtok->val = TK_LPAR;
645 st_move1(curtok->val);
646 *endp++ = (char)c;
647 if (flimpl) {
648 flimpl++;
649 if (flimpl == 2 && !st_is(ST_NOIMPL)) {
650 st_move1(TK_IMPLICIT1);
651 }
652 }
653 if (flformat) {
654 flformat++;
655 }
656 break;
657 case ')': curtok->val = TK_RPAR;
658 st_move1(curtok->val);
659 *endp++ = (char)c;
660 if (flimpl) {
661 flimpl--;
662 }
663 if (flformat) {
664 flformat--;
665 }
666 break;
667 case ',': curtok->val = TK_COMMA;
668 st_move1(curtok->val);
669 *endp++ = (char)c;
670 if (flimpl == 1) {
671 st_move1(TK_IMPLICIT);
672 }
673 break;
674 case '-': curtok->val = TK_MINUS;
675 st_move1(curtok->val);
676 *endp++ = (char)c;
677 break;
678 case ';': curtok->val = TK_SCLN;
679 st_move1(curtok->val);
680 *endp++ = (char)c;
681 if (!f77fl) {
682 onequalsym = NULL; /* they are stoppers */
683 flimpl = 0;
684 flformat = 0;
685 }
686 break;
687 case '*': *endp++ = (char)c;
688 c = getsym(lmode);
689 if (c == '*')
690 *endp++ = (char)c;
691 else {
692 curtok->val = TK_STAR;
693 ungetsym(c);
694 }
695 st_move1(curtok->val);
696 break;
697 case '|':
698 case '&': *endp++ = (char)c;
699 c0 = c;
700 c = getsym(lmode);
701 if (c == c0)
702 *endp++ = (char)c;
703 else
704 ungetsym(c);
705 st_move1(curtok->val);
706 break;
707 case '!':
708 case '=': *endp++ = (char)c;
709 if (c == '=' && onequalsym) {
710 set_pos(onequalline);
711 fppmess(WARN_PINSUB,symname(onequalsym));
712 onequalsym = NULL;
713 }
714 c = getsym(lmode);
715 if (c == '=')
716 *endp++ = (char)c;
717 else
718 ungetsym(c);
719 st_move1(curtok->val);
720 break;
721 case '<':
722 case '>': *endp++ = (char)c;
723 c0 = c;
724 c = getsym(lmode);
725 if (c == c0 || c == '=')
726 *endp++ = (char)c;
727 else
728 ungetsym(c);
729 st_move1(curtok->val);
730 break;
731 case '.': *endp++ = (char)c;
732 if (!f77fl) {
733 if (!fllogic || fllogic == 2) fllogic++;
734 }
735 *endp = 0;
736 st_move1(curtok->val);
737 break;
738 case '"':
739 case '\'': c0 = c;
740 *endp++ = (char)c;
741 if (c0 == '\'' && st_is(ST_RDWR)) /* READ(10'3) syntax exception */
742 break;
743 for (;;) {
744 c = getsym((mode&MOD_CONT)|MOD_RAW);
745 if (c=='\n' || c==SYM_EOF || c==SYM_EOC) {
746 ungetsym(c);
747 if (falselvl == 0 && c != SYM_EOC)
748 fppmess(ERR_STR,c0);
749 if (mode & MOD_FPP)
750 *endp++ = (char)c0;
751 break;
752 }
753 else if (c == c0) {
754 *endp++ = (char)c;
755 break;
756 }
757 else if (is_special(c))
758 c = ' ';
759 *endp++ = (char)c;
760 if (endp - curtok->token >= MAXTOKENSIZE) {
761 curtok->length = MAXTOKENSIZE;
762 outtok(curtok);
763 endp = curtok->token;
764 }
765 }
766 if (fixedformfl && c0 == '\'') {
767 c = getsym(lmode);
768 if (lowcase(c) == 'o' || lowcase(c) == 'x') {
769 curtok->val = TK_BOZ;
770 *endp++ = (char)c;
771 }
772 else
773 ungetsym(c);
774 }
775 st_move1(curtok->val);
776 break;
777 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
778 case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
779 case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U':
780 case 'V': case 'W': case 'X': case 'Y': case 'Z':
781 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
782 case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
783 case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
784 case 'v': case 'w': case 'x': case 'y': case 'z': case '_':
785
786 /* Check if we are dealing with *kind* of a logical constant
787 * which should be taken without the leading underscore
788 */
789 if (!f77fl && c == '_' && fllogic == 3) {
790 *endp++ = (char)c;
791 *endp = 0;
792 fllogic = 0;
793 goto exit;
794 }
795
796 /* Collect a name */
797 while (is_alphanum(c)) {
798 *endp++ = (char)c;
799 if (endp - curtok->token >= MAXTOKENSIZE) {
800 curtok->length = MAXTOKENSIZE;
801 outtok(curtok);
802 endp = curtok->token;
803 }
804 c = getsym(lmode);
805 }
806 *endp = 0;
807 ungetsym(c);
808 if ((lmode & MOD_SPACE) && line > sym_line) {
809 while (sym_line < line) {
810 ungetsym('\n'); /* it decreases the line */
811 ungetsym('\\');
812 }
813 }
814
815 /* Check if we are dealing with a BOZ constant
816 */
817 if (c == '\'' || c== '"') {
818 if ((endp - curtok->token) == 1) {
819 if (lowcase(curtok->token[0]) == 'b' ||
820 lowcase(curtok->token[0]) == 'o' ||
821 lowcase(curtok->token[0]) == 'z') {
822 curtok->val = TK_BOZ;
823 goto exit;
824 }
825 if (fixedformfl && lowcase(curtok->token[0]) == 'x') {
826 curtok->val = TK_BOZ;
827 goto exit;
828 }
829 }
830 else if (!f77fl && endp[-1] == '_') {
831 ungetsym(*--endp);
832 *endp = 0;
833 }
834 }
835
836 curtok->val = TK_NAME;
837 if ((outfl || falselvl || !substfl) && !dosubstfl) {
838
839 /* The following is for syntax like WRITE(10'3), etc.
840 */
841 if (fixedformfl && st_is(ST_BOS)) {
842 symp = symget(curtok->token,CL_KEY);
843 if (symp)
844 curtok->val = get_tkop(symp);
845 }
846 }
847 else {
848 int n;
849
850 if (!(mode & MOD_SPACE)) {
851 if (st_is(ST_BOS))
852 symp = symget(curtok->token,CL_NM|CL_KEY);
853 else if (st_is(ST_IMPL0)) {
854 symp = symget(curtok->token,CL_NM|CL_KEY);
855 if (symp && (symtype(symp) & CL_KEY)) {
856 curtok->val = get_tkop(symp);
857 if (curtok->val != TK_TYPE0 &&
858 curtok->val != TK_TYPE ) {
859 curtok->val = TK_NAME;
860 symp = NULL;
861 }
862 }
863 }
864 else
865 symp = symget(curtok->token,CL_NM);
866 if ((endp - curtok->token) == 1 && st_is(ST_IMPL))
867 curtok->val = TK_NAME0;
868 if (symp) {
869 if (symtype(symp) & CL_NM) {
870 if (curtok->val == TK_NAME0) {
871 fppmess(WARN_IMPL,curtok->token);
872 }
873 else if (flformat > 1 && isfspec(curtok->token)) {
874 fppmess(WARN_FORMAT,curtok->token);
875 }
876 else if (substitute(symp, lmode)) {
877 st_move1(curtok->val);
878 goto exit;
879 }
880 else goto loop;
881 }
882 else {
883 curtok->val = get_tkop(symp);
884 if (curtok->val == TK_IMPLICIT)
885 flimpl = 1;
886 else if (curtok->val == TK_FORMAT)
887 flformat = 1;
888 }
889 }
890 }
891 else {
892 if (st_is(ST_BOS)) {
893 symp = symgetm(curtok->token,CL_NM|CL_KEY);
894 if (symp) {
895 n = strlen(symname(symp));
896 if (n < endp - curtok->token && n < MAXNAMELEN) {
897 if (symtype(symp) & CL_NM && !onequalsym) {
898 onequalsym = symp;
899 onequalline = curtok->lineno;
900 }
901 ungetstr(curtok->token+n,
902 (endp - curtok->token) - n);
903 ungetsym(SYM_DUMMY);
904 endp = curtok->token + n;
905 *endp = 0;
906 }
907 if (symtype(symp) & CL_NM) {
908 if (symflag(symp))
909 fppmess(WARN_PINSUB,curtok->token);
910 if (substitute(symp, lmode)) {
911 st_move1(curtok->val);
912 goto exit;
913 }
914 else goto loop;
915 }
916 else {
917 curtok->val = get_tkop(symp);
918 if (curtok->val == TK_IMPLICIT)
919 flimpl = 1;
920 else if (curtok->val == TK_FORMAT)
921 flformat = 1;
922 }
923 }
924 }
925 else if (st_is(ST_DO) || st_is(ST_ASSIGN)) {
926 symp = symgetm(curtok->token,CL_NM);
927 if (symp) {
928 n = strlen(symname(symp));
929 ungetstr(curtok->token + n,
930 (endp - curtok->token) - n);
931 ungetsym(SYM_DUMMY);
932 endp = curtok->token + n;
933 *endp = 0;
934 if (substitute(symp, lmode)) {
935 st_move1(curtok->val);
936 goto exit;
937 }
938 else goto loop;
939 }
940 if (st_is(ST_DO))
941 fppmess(WARN_PIOP,"do");
942 else
943 fppmess(WARN_PIOP,"assign");
944 curtok->val = TK_DUMMY;
945 }
946 else if (st_is(ST_ASSIGNUM)) {
947 if (!strncmp(curtok->token,"to",2)) {
948 ungetstr(curtok->token+2,
949 (endp - curtok->token) - 2);
950 ungetsym(SYM_DUMMY);
951 endp = curtok->token+2;
952 *endp = 0;
953 curtok->val = TK_DUMMY;
954 }
955 else {
956 symp = symgetm(curtok->token,CL_NM);
957 if (symp) {
958 if (substitute(symp, lmode)) {
959 st_move1(curtok->val);
960 goto exit;
961 }
962 else goto loop;
963 }
964 fppmess(WARN_PIOP,"assign");
965 curtok->val = TK_DUMMY;
966 }
967 }
968 else if (st_is(ST_TYPE1)) {
969 if (!strncmp(curtok->token,"function",8)) {
970 ungetstr(curtok->token+8,
971 (endp - curtok->token) - 8);
972 ungetsym(SYM_DUMMY);
973 endp = curtok->token+8;
974 *endp = 0;
975 curtok->val = TK_KEY;
976 }
977 else if (!strncmp(curtok->token,"recursive",9)) {
978 ungetstr(curtok->token+9,
979 (endp - curtok->token) - 9);
980 ungetsym(SYM_DUMMY);
981 endp = curtok->token+9;
982 *endp = 0;
983 curtok->val = TK_KEY;
984 }
985 else {
986 symp = symgetm(curtok->token,CL_NM);
987 if (symp) {
988 if (substitute(symp, lmode)) {
989 st_move1(curtok->val);
990 goto exit;
991 }
992 else goto loop;
993 }
994 }
995 }
996 else if (st_is(ST_IMPL0)) {
997 symp = symget(curtok->token,CL_KEY|CL_NM);
998 if (symp) {
999 if (symtype(symp) & CL_KEY) {
1000 curtok->val = get_tkop(symp);
1001 if (curtok->val != TK_TYPE &&
1002 curtok->val != TK_TYPE0)
1003 curtok->val = TK_NAME;
1004 }
1005 else if (substitute(symp, lmode)) {
1006 st_move1(curtok->val);
1007 goto exit;
1008 }
1009 else goto loop;
1010 }
1011 }
1012 else {
1013 if (endp - curtok->token == 1 && st_is(ST_IMPL))
1014 curtok->val = TK_NAME0;
1015 if (symp = symget(curtok->token,CL_NM)) {
1016 if (curtok->val == TK_NAME0) {
1017 fppmess(WARN_IMPL,curtok->token);
1018 }
1019 else if (flformat > 1 && isfspec(curtok->token)) {
1020 fppmess(WARN_FORMAT,curtok->token);
1021 }
1022 else if (substitute(symp, lmode)) {
1023 st_move1(curtok->val);
1024 goto exit;
1025 }
1026 else goto loop;
1027 }
1028 }
1029 }
1030 }
1031 if (!f77fl && fllogic == 1) {
1032 *endp = 0;
1033 if (!strcmp(curtok->token,"true") ||
1034 !strcmp(curtok->token,"false"))
1035 fllogic++;
1036 else fllogic = 0;
1037 /* st_move1(curtok->val);
1038 goto exit;
1039 */
1040 }
1041 st_move1(curtok->val);
1042 break;
1043 case '0': case '1': case '2': case '3': case '4':
1044 case '5': case '6': case '7': case '8': case '9':
1045 *endp++ = (char)c;
1046 flreal=0;
1047 for (;;) {
1048 if (endp - curtok->token >= MAXTOKENSIZE) {
1049 curtok->length = MAXTOKENSIZE;
1050 outtok(curtok);
1051 endp = curtok->token;
1052 }
1053 c = getsym(lmode);
1054 if (is_num(c)) ; /* that's it */
1055 else if (c == '.') {
1056 if (flreal) break;
1057 if (mode & MOD_IF) break;
1058 flreal = 1;
1059 }
1060 else if (lowcase(c) == 'e'||
1061 lowcase(c) == 'd'||
1062 lowcase(c) == 'q') {
1063 if (flreal > 1) break;
1064 if (flreal == 0 && st_is(ST_TYPE)) break;
1065 flreal = 2;
1066 *endp++ = (char)c;
1067 c = getsym(lmode);
1068 if (is_alpha0(c)) {
1069 ungetsym(c);
1070 ungetsym(*--endp);
1071 if (endp[-1] == '.') c = *--endp;
1072 else c = SYM_DUMMY;
1073 break;
1074 }
1075 if (c != '-' && c!='+') {
1076 ungetsym(c);
1077 continue;
1078 }
1079 }
1080 else if (fixedformfl && lowcase(c) == 'h') {
1081 int count;
1082
1083 /*
1084 * Hollerith constant
1085 */
1086 if (flreal) break;
1087 if (st_is(ST_TYPE)) break;
1088 *endp = 0;
1089 strtoi(curtok->token,&count,10);
1090 *endp++ = (char)c;
1091 while (count--) {
1092 c = getsym((mode&MOD_CONT)|MOD_RAW);
1093 if (c=='\n' || c==SYM_EOF || c==SYM_EOC) {
1094 ungetsym(c);
1095 if (!falselvl && c!=SYM_EOC)
1096 fppmess(ERR_HRTH);
1097 break;
1098 }
1099 else if (is_special(c))
1100 c = ' ';
1101 *endp++ = (char)c;
1102 if (endp - curtok->token >= MAXTOKENSIZE) {
1103 curtok->length = MAXTOKENSIZE;
1104 outtok(curtok);
1105 endp = curtok->token;
1106 }
1107 }
1108 curtok->val = TK_DUMMY;
1109 st_move1(curtok->val);
1110 goto exit;
1111 }
1112 else if (c == '_' && !f77fl) { /* kind processing */
1113 do {
1114 *endp++ = (char)c;
1115 if (endp - curtok->token >= MAXTOKENSIZE) {
1116 curtok->length = MAXTOKENSIZE;
1117 outtok(curtok);
1118 endp = curtok->token;
1119 }
1120 c = getsym(lmode);
1121 } while (is_num(c));
1122 break;
1123 }
1124 #if USE_C_HEX_CONST
1125 else if ((mode & MOD_IF) &&
1126 (lowcase(c) == 'x') &&
1127 (curtok->token[0] == '0') &&
1128 (endp - curtok->token == 1) ) {
1129
1130 /* C hexadecimal constants are allowed
1131 * in #if expression */
1132 do {
1133 *endp++ = c;
1134 if (endp - curtok->token >= MAXTOKENSIZE) {
1135 curtok->length = MAXTOKENSIZE;
1136 outtok(curtok);
1137 endp = curtok->token;
1138 }
1139 c = getsym(lmode);
1140 } while (is_alphanum(c));
1141 ungetsym(c);
1142 curtok->val = TK_BOZ;
1143 goto exit;
1144 }
1145 #endif /* USE_C_HEX_CONST */
1146 else break;
1147 *endp++ = (char)c;
1148 }
1149 ungetsym(c);
1150 if (flreal) {
1151 curtok->val = TK_DUMMY;
1152 }
1153 else {
1154 curtok->val = TK_NUM;
1155 }
1156 st_move1(curtok->val);
1157 break;
1158 default: if (!is_blank(c))
1159 st_move1(TK_DUMMY);
1160 *endp++ = (char)c;
1161 break;
1162 }
1163 exit: *endp = 0;
1164 curtok->length = endp - curtok->token;
1165 #if DEBUG
1166 if (debug >= 2) {
1167 printf("line %d stid %d token %d: %s\n",
1168 curtok->lineno,
1169 curtok->stid,
1170 curtok->val,
1171 curtok->token );
1172 }
1173 #endif
1174 return curtok;
1175 }
1176
1177 Token *
get_token_nl(unsigned mode)1178 get_token_nl(unsigned mode) {
1179 wchar c;
1180 char *endp;
1181 int i;
1182
1183 /* The current state is ST_NL */
1184
1185 while (skip_comment(mode));
1186
1187 endp = curtok->token;
1188 CHECK(colm == 0);
1189 c = getsym(mode & MOD_LCASE);
1190 curtok->lineno = line;
1191 curtok->stid = cur_stmt_id;
1192 curtok->val = TK_DUMMY;
1193 CHECK(c);
1194 switch (c) {
1195 case SYM_FPP:
1196 curtok->val = TK_FPP;
1197 st_move(curtok->val);
1198 *endp++ = (char)c;
1199 *endp =0;
1200 curtok->length = 1;
1201 return curtok;
1202 case SYM_EOF:
1203 case '\n':
1204 curtok->val = TK_NL;
1205 cur_stmt_id++;
1206 /* st_move(curtok->val); the state remains ST_NL */
1207 *endp++ = (char)c;
1208 *endp = 0;
1209 curtok->length = 1;
1210 return curtok;
1211 case '&':
1212 /* continuation symbol in first column;
1213 * fixed or free form it is we do the same.
1214 */
1215 ungetsym(c);
1216 st_move(TK_SKIP);
1217 return get_token(mode);
1218 }
1219
1220 /* The following moves us in the
1221 * BeginOfStatement state
1222 */
1223 st_move(TK_DUMMY);
1224
1225 if (!fixedformfl) { /* F90 */
1226 ungetsym(c);
1227 return get_token(mode);
1228 }
1229
1230 /* Collect first 6 symbols */
1231 for (i=0;;i++) {
1232 if (c == '\t') {
1233 colm = 6;
1234 line_width = LINE_WIDTH_MAX;
1235 break;
1236 }
1237 else if (c == SYM_DUMMY) { /* a comment */
1238 c = ' ';
1239 colm = 6;
1240 break;
1241 }
1242 else if (c == SYM_EOF || c == '\n')
1243 break;
1244 if (i == 5) break;
1245 *endp++ = (char)c;
1246 c = getsym(mode & MOD_LCASE);
1247 }
1248 *endp = 0;
1249 if (is_blank(c) || c == '0') {
1250 cont_symbol = (char)c;
1251 ungetsym(SYM_BOS);
1252 while (is_blank(endp[-1]) && endp > curtok->token) endp--;
1253 ungetstr(curtok->token, endp - curtok->token);
1254 }
1255 else if (c == SYM_EOF || c == '\n') {
1256 ungetsym(c);
1257 if (c == '\n') {
1258 colm = 6;
1259 cont_symbol = ' ';
1260 ungetsym(SYM_BOS);
1261 while (is_blank(endp[-1]) && endp > curtok->token) endp--;
1262 }
1263 ungetstr(curtok->token, endp - curtok->token);
1264 }
1265 else {
1266 /* We've got a symbol in the 6th column
1267 * so this line is a continuation card
1268 * no matter how could it happen.
1269 * Output collected symbols as is.
1270 */
1271 *endp++ = (char)c;
1272 curtok->length = endp - curtok->token;
1273 outtok(curtok);
1274
1275 /* The state can't be BegOfStatement */
1276 st_move(TK_SKIP);
1277 }
1278 return get_token(mode);
1279 }
1280
1281 void
unget_tok(Token * tokp)1282 unget_tok(Token *tokp) {
1283 if (tokp->val == TK_NL) {
1284 cur_stmt_id--;
1285 if (tokp->token[0] == '\n') {
1286 ungetsym(tokp->token[0]);
1287 }
1288 else {
1289 ungetsym(SYM_EOF);
1290 }
1291 }
1292 else {
1293 ungetstr(tokp->token, tokp->length);
1294 }
1295 }
1296
1297 Token *
get_cur_tok()1298 get_cur_tok() {
1299 return curtok;
1300 }
1301
1302 void
pushtok()1303 pushtok() {
1304 curtok++;
1305 CHECK(curtok == <ok[1]);
1306 }
1307
1308 void
poptok()1309 poptok() {
1310 curtok--;
1311 CHECK(curtok == <ok[0]);
1312 }
1313