Commit | Line | Data |
---|---|---|
5b9f3ea3 KM |
1 | /* |
2 | * Copyright (c) 1980 Regents of the University of California. | |
3 | * All rights reserved. The Berkeley software License Agreement | |
4 | * specifies the terms and conditions for redistribution. | |
5 | */ | |
6 | ||
7 | #ifndef lint | |
dc0e9d50 | 8 | static char sccsid[] = "@(#)lex.c 5.4 (Berkeley) %G%"; |
5b9f3ea3 KM |
9 | #endif not lint |
10 | ||
11 | /* | |
12 | * lex.c | |
13 | * | |
14 | * Lexical scanner routines for the f77 compiler, pass 1, 4.2 BSD. | |
15 | * | |
16 | * University of Utah CS Dept modification history: | |
17 | * | |
18 | * $Log: lex.c,v $ | |
3526f196 DS |
19 | * Revision 5.4 86/01/07 14:01:13 donn |
20 | * Fix the scanning for character constants in gettok() so that it handles | |
21 | * the case when an error has occurred and there is no closing quote. | |
22 | * | |
23 | * Revision 5.3 85/11/25 00:24:06 donn | |
24 | * 4.3 beta | |
25 | * | |
7dbb9c71 DS |
26 | * Revision 5.2 85/08/10 04:45:41 donn |
27 | * Jerry Berkman's changes to ifdef 66 code and handle -r8/double flag. | |
28 | * | |
29 | * Revision 5.1 85/08/10 03:48:20 donn | |
30 | * 4.3 alpha | |
31 | * | |
5b9f3ea3 KM |
32 | * Revision 1.2 84/10/27 02:20:09 donn |
33 | * Fixed bug where the input file and the name field of the include file | |
34 | * structure shared -- when the input file name was freed, the include file | |
35 | * name got stomped on, leading to peculiar error messages. | |
36 | * | |
37 | */ | |
38 | ||
39 | #include "defs.h" | |
40 | #include "tokdefs.h" | |
dc0e9d50 | 41 | #include "pathnames.h" |
5b9f3ea3 KM |
42 | |
43 | # define BLANK ' ' | |
44 | # define MYQUOTE (2) | |
45 | # define SEOF 0 | |
46 | ||
47 | /* card types */ | |
48 | ||
49 | # define STEOF 1 | |
50 | # define STINITIAL 2 | |
51 | # define STCONTINUE 3 | |
52 | ||
53 | /* lex states */ | |
54 | ||
55 | #define NEWSTMT 1 | |
56 | #define FIRSTTOKEN 2 | |
57 | #define OTHERTOKEN 3 | |
58 | #define RETEOS 4 | |
59 | ||
60 | ||
61 | LOCAL int stkey; | |
62 | LOCAL int lastend = 1; | |
63 | ftnint yystno; | |
64 | flag intonly; | |
65 | LOCAL long int stno; | |
66 | LOCAL long int nxtstno; | |
67 | LOCAL int parlev; | |
68 | LOCAL int expcom; | |
69 | LOCAL int expeql; | |
70 | LOCAL char *nextch; | |
71 | LOCAL char *lastch; | |
72 | LOCAL char *nextcd = NULL; | |
73 | LOCAL char *endcd; | |
74 | LOCAL int prevlin; | |
75 | LOCAL int thislin; | |
76 | LOCAL int code; | |
77 | LOCAL int lexstate = NEWSTMT; | |
78 | LOCAL char s[1390]; | |
79 | LOCAL char *send = s+20*66; | |
80 | LOCAL int nincl = 0; | |
81 | LOCAL char *newname = NULL; | |
82 | ||
83 | struct Inclfile | |
84 | { | |
85 | struct Inclfile *inclnext; | |
86 | FILEP inclfp; | |
87 | char *inclname; | |
88 | int incllno; | |
89 | char *incllinp; | |
90 | int incllen; | |
91 | int inclcode; | |
92 | ftnint inclstno; | |
93 | } ; | |
94 | ||
95 | LOCAL struct Inclfile *inclp = NULL; | |
96 | LOCAL struct Keylist { char *keyname; int keyval; char notinf66; } ; | |
97 | LOCAL struct Punctlist { char punchar; int punval; }; | |
98 | LOCAL struct Fmtlist { char fmtchar; int fmtval; }; | |
99 | LOCAL struct Dotlist { char *dotname; int dotval; }; | |
100 | LOCAL struct Keylist *keystart[26], *keyend[26]; | |
101 | ||
102 | ||
103 | ||
104 | ||
105 | inilex(name) | |
106 | char *name; | |
107 | { | |
108 | nincl = 0; | |
109 | inclp = NULL; | |
110 | doinclude(name); | |
111 | lexstate = NEWSTMT; | |
112 | return(NO); | |
113 | } | |
114 | ||
115 | ||
116 | ||
117 | /* throw away the rest of the current line */ | |
118 | flline() | |
119 | { | |
120 | lexstate = RETEOS; | |
121 | } | |
122 | ||
123 | ||
124 | ||
125 | char *lexline(n) | |
126 | int *n; | |
127 | { | |
128 | *n = (lastch - nextch) + 1; | |
129 | return(nextch); | |
130 | } | |
131 | ||
132 | ||
133 | ||
134 | ||
135 | ||
136 | doinclude(name) | |
137 | char *name; | |
138 | { | |
139 | FILEP fp; | |
140 | struct Inclfile *t; | |
141 | char temp[100]; | |
142 | register char *lastslash, *s; | |
143 | ||
144 | if(inclp) | |
145 | { | |
146 | inclp->incllno = thislin; | |
147 | inclp->inclcode = code; | |
148 | inclp->inclstno = nxtstno; | |
149 | if(nextcd) | |
150 | inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd); | |
151 | else | |
152 | inclp->incllinp = 0; | |
153 | } | |
154 | nextcd = NULL; | |
155 | ||
156 | if(++nincl >= MAXINCLUDES) | |
157 | fatal("includes nested too deep"); | |
158 | if(name[0] == '\0') | |
159 | fp = stdin; | |
160 | else if(name[0]=='/' || inclp==NULL) | |
161 | fp = fopen(name, "r"); | |
162 | else { | |
163 | lastslash = NULL; | |
164 | for(s = inclp->inclname ; *s ; ++s) | |
165 | if(*s == '/') | |
166 | lastslash = s; | |
167 | if(lastslash) | |
168 | { | |
169 | *lastslash = '\0'; | |
170 | sprintf(temp, "%s/%s", inclp->inclname, name); | |
171 | *lastslash = '/'; | |
172 | } | |
173 | else | |
174 | strcpy(temp, name); | |
175 | ||
176 | if( (fp = fopen(temp, "r")) == NULL ) | |
177 | { | |
dc0e9d50 | 178 | sprintf(temp, "%s/%s", _PATH_INCLUDES, name); |
5b9f3ea3 KM |
179 | fp = fopen(temp, "r"); |
180 | } | |
181 | if(fp) | |
182 | name = copys(temp); | |
183 | } | |
184 | ||
185 | if( fp ) | |
186 | { | |
187 | t = inclp; | |
188 | inclp = ALLOC(Inclfile); | |
189 | inclp->inclnext = t; | |
190 | prevlin = thislin = 0; | |
191 | inclp->inclname = name; | |
192 | infname = copys(name); | |
193 | infile = inclp->inclfp = fp; | |
194 | } | |
195 | else | |
196 | { | |
197 | fprintf(diagfile, "Cannot open file %s", name); | |
198 | done(1); | |
199 | } | |
200 | } | |
201 | ||
202 | ||
203 | ||
204 | ||
205 | LOCAL popinclude() | |
206 | { | |
207 | struct Inclfile *t; | |
208 | register char *p; | |
209 | register int k; | |
210 | ||
211 | if(infile != stdin) | |
212 | clf(&infile); | |
213 | free(infname); | |
214 | ||
215 | --nincl; | |
216 | t = inclp->inclnext; | |
217 | free(inclp->inclname); | |
218 | free( (charptr) inclp); | |
219 | inclp = t; | |
220 | if(inclp == NULL) | |
221 | return(NO); | |
222 | ||
223 | infile = inclp->inclfp; | |
224 | infname = copys(inclp->inclname); | |
225 | prevlin = thislin = inclp->incllno; | |
226 | code = inclp->inclcode; | |
227 | stno = nxtstno = inclp->inclstno; | |
228 | if(inclp->incllinp) | |
229 | { | |
230 | endcd = nextcd = s; | |
231 | k = inclp->incllen; | |
232 | p = inclp->incllinp; | |
233 | while(--k >= 0) | |
234 | *endcd++ = *p++; | |
235 | free( (charptr) (inclp->incllinp) ); | |
236 | } | |
237 | else | |
238 | nextcd = NULL; | |
239 | return(YES); | |
240 | } | |
241 | ||
242 | ||
243 | ||
244 | ||
245 | yylex() | |
246 | { | |
247 | static int tokno; | |
248 | ||
249 | switch(lexstate) | |
250 | { | |
251 | case NEWSTMT : /* need a new statement */ | |
252 | if(getcds() == STEOF) | |
253 | return(SEOF); | |
254 | lastend = stkey == SEND; | |
255 | crunch(); | |
256 | tokno = 0; | |
257 | lexstate = FIRSTTOKEN; | |
258 | yystno = stno; | |
259 | stno = nxtstno; | |
260 | toklen = 0; | |
261 | return(SLABEL); | |
262 | ||
263 | first: | |
264 | case FIRSTTOKEN : /* first step on a statement */ | |
265 | analyz(); | |
266 | lexstate = OTHERTOKEN; | |
267 | tokno = 1; | |
268 | return(stkey); | |
269 | ||
270 | case OTHERTOKEN : /* return next token */ | |
271 | if(nextch > lastch) | |
272 | goto reteos; | |
273 | ++tokno; | |
274 | if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) | |
275 | goto first; | |
276 | ||
277 | if(stkey==SASSIGN && tokno==3 && nextch<lastch && | |
278 | nextch[0]=='t' && nextch[1]=='o') | |
279 | { | |
280 | nextch+=2; | |
281 | return(STO); | |
282 | } | |
283 | return(gettok()); | |
284 | ||
285 | reteos: | |
286 | case RETEOS: | |
287 | lexstate = NEWSTMT; | |
288 | return(SEOS); | |
289 | } | |
290 | fatali("impossible lexstate %d", lexstate); | |
291 | /* NOTREACHED */ | |
292 | } | |
293 | \f | |
294 | LOCAL getcds() | |
295 | { | |
296 | register char *p, *q; | |
297 | ||
298 | if (newname) | |
299 | { | |
300 | free(infname); | |
301 | infname = newname; | |
302 | newname = NULL; | |
303 | } | |
304 | ||
305 | top: | |
306 | if(nextcd == NULL) | |
307 | { | |
308 | code = getcd( nextcd = s ); | |
309 | stno = nxtstno; | |
310 | if (newname) | |
311 | { | |
312 | free(infname); | |
313 | infname = newname; | |
314 | newname = NULL; | |
315 | } | |
316 | prevlin = thislin; | |
317 | } | |
318 | if(code == STEOF) | |
319 | if( popinclude() ) | |
320 | goto top; | |
321 | else | |
322 | return(STEOF); | |
323 | ||
324 | if(code == STCONTINUE) | |
325 | { | |
326 | if (newname) | |
327 | { | |
328 | free(infname); | |
329 | infname = newname; | |
330 | newname = NULL; | |
331 | } | |
332 | lineno = thislin; | |
333 | err("illegal continuation card ignored"); | |
334 | nextcd = NULL; | |
335 | goto top; | |
336 | } | |
337 | ||
338 | if(nextcd > s) | |
339 | { | |
340 | q = nextcd; | |
341 | p = s; | |
342 | while(q < endcd) | |
343 | *p++ = *q++; | |
344 | endcd = p; | |
345 | } | |
346 | for(nextcd = endcd ; | |
347 | nextcd+66<=send && (code = getcd(nextcd))==STCONTINUE ; | |
348 | nextcd = endcd ) | |
349 | ; | |
350 | nextch = s; | |
351 | lastch = nextcd - 1; | |
352 | if(nextcd >= send) | |
353 | nextcd = NULL; | |
354 | lineno = prevlin; | |
355 | prevlin = thislin; | |
356 | return(STINITIAL); | |
357 | } | |
358 | \f | |
359 | LOCAL getcd(b) | |
360 | register char *b; | |
361 | { | |
362 | register int c; | |
363 | register char *p, *bend; | |
364 | int speclin; | |
365 | static char a[6]; | |
366 | static char *aend = a+6; | |
367 | int num; | |
368 | ||
369 | top: | |
370 | endcd = b; | |
371 | bend = b+66; | |
372 | speclin = NO; | |
373 | ||
374 | if( (c = getc(infile)) == '&') | |
375 | { | |
376 | a[0] = BLANK; | |
377 | a[5] = 'x'; | |
378 | speclin = YES; | |
379 | bend = send; | |
380 | } | |
381 | else if(c=='c' || c=='C' || c=='*') | |
382 | { | |
383 | while( (c = getc(infile)) != '\n') | |
384 | if(c == EOF) | |
385 | return(STEOF); | |
386 | ++thislin; | |
387 | goto top; | |
388 | } | |
389 | else if(c == '#') | |
390 | { | |
391 | c = getc(infile); | |
392 | while (c == BLANK || c == '\t') | |
393 | c = getc(infile); | |
394 | ||
395 | num = 0; | |
396 | while (isdigit(c)) | |
397 | { | |
398 | num = 10*num + c - '0'; | |
399 | c = getc(infile); | |
400 | } | |
401 | thislin = num - 1; | |
402 | ||
403 | while (c == BLANK || c == '\t') | |
404 | c = getc(infile); | |
405 | ||
406 | if (c == '"') | |
407 | { | |
408 | char fname[1024]; | |
409 | int len = 0; | |
410 | ||
411 | c = getc(infile); | |
412 | while (c != '"' && c != '\n') | |
413 | { | |
414 | fname[len++] = c; | |
415 | c = getc(infile); | |
416 | } | |
417 | fname[len++] = '\0'; | |
418 | ||
419 | if (newname) | |
420 | free(newname); | |
421 | newname = (char *) ckalloc(len); | |
422 | strcpy(newname, fname); | |
423 | } | |
424 | ||
425 | while (c != '\n') | |
426 | if (c == EOF) | |
427 | return (STEOF); | |
428 | else | |
429 | c = getc(infile); | |
430 | goto top; | |
431 | } | |
432 | ||
433 | else if(c != EOF) | |
434 | { | |
435 | /* a tab in columns 1-6 skips to column 7 */ | |
436 | ungetc(c, infile); | |
437 | for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; ) | |
438 | if(c == '\t') | |
439 | { | |
440 | while(p < aend) | |
441 | *p++ = BLANK; | |
442 | speclin = YES; | |
443 | bend = send; | |
444 | } | |
445 | else | |
446 | *p++ = c; | |
447 | } | |
448 | if(c == EOF) | |
449 | return(STEOF); | |
450 | if(c == '\n') | |
451 | { | |
452 | while(p < aend) | |
453 | *p++ = BLANK; | |
454 | if( ! speclin ) | |
455 | while(endcd < bend) | |
456 | *endcd++ = BLANK; | |
457 | } | |
458 | else { /* read body of line */ | |
459 | while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF ) | |
460 | *endcd++ = c; | |
461 | if(c == EOF) | |
462 | return(STEOF); | |
463 | if(c != '\n') | |
464 | { | |
465 | while( (c=getc(infile)) != '\n') | |
466 | if(c == EOF) | |
467 | return(STEOF); | |
468 | } | |
469 | ||
470 | if( ! speclin ) | |
471 | while(endcd < bend) | |
472 | *endcd++ = BLANK; | |
473 | } | |
474 | ++thislin; | |
475 | if( !isspace(a[5]) && a[5]!='0') | |
476 | return(STCONTINUE); | |
477 | for(p=a; p<aend; ++p) | |
478 | if( !isspace(*p) ) goto initline; | |
479 | for(p = b ; p<endcd ; ++p) | |
480 | if( !isspace(*p) ) goto initline; | |
481 | goto top; | |
482 | ||
483 | initline: | |
484 | nxtstno = 0; | |
485 | for(p = a ; p<a+5 ; ++p) | |
486 | if( !isspace(*p) ) | |
487 | if(isdigit(*p)) | |
488 | nxtstno = 10*nxtstno + (*p - '0'); | |
489 | else { | |
490 | if (newname) | |
491 | { | |
492 | free(infname); | |
493 | infname = newname; | |
494 | newname = NULL; | |
495 | } | |
496 | lineno = thislin; | |
497 | err("nondigit in statement number field"); | |
498 | nxtstno = 0; | |
499 | break; | |
500 | } | |
501 | return(STINITIAL); | |
502 | } | |
503 | \f | |
504 | LOCAL crunch() | |
505 | { | |
506 | register char *i, *j, *j0, *j1, *prvstr; | |
507 | int ten, nh, quote; | |
508 | ||
509 | /* i is the next input character to be looked at | |
510 | j is the next output character */ | |
511 | parlev = 0; | |
512 | expcom = 0; /* exposed ','s */ | |
513 | expeql = 0; /* exposed equal signs */ | |
514 | j = s; | |
515 | prvstr = s; | |
516 | for(i=s ; i<=lastch ; ++i) | |
517 | { | |
518 | if(isspace(*i) ) | |
519 | continue; | |
520 | if(*i=='\'' || *i=='"') | |
521 | { | |
522 | quote = *i; | |
523 | *j = MYQUOTE; /* special marker */ | |
524 | for(;;) | |
525 | { | |
526 | if(++i > lastch) | |
527 | { | |
528 | err("unbalanced quotes; closing quote supplied"); | |
529 | break; | |
530 | } | |
531 | if(*i == quote) | |
532 | if(i<lastch && i[1]==quote) ++i; | |
533 | else break; | |
534 | else if(*i=='\\' && i<lastch) | |
535 | switch(*++i) | |
536 | { | |
537 | case 't': | |
538 | *i = '\t'; break; | |
539 | case 'b': | |
540 | *i = '\b'; break; | |
541 | case 'n': | |
542 | *i = '\n'; break; | |
543 | case 'f': | |
544 | *i = '\f'; break; | |
545 | case 'v': | |
546 | *i = '\v'; break; | |
547 | case '0': | |
548 | *i = '\0'; break; | |
549 | default: | |
550 | break; | |
551 | } | |
552 | *++j = *i; | |
553 | } | |
554 | j[1] = MYQUOTE; | |
555 | j += 2; | |
556 | prvstr = j; | |
557 | } | |
558 | else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */ | |
559 | { | |
560 | if( ! isdigit(j[-1])) goto copychar; | |
561 | nh = j[-1] - '0'; | |
562 | ten = 10; | |
563 | j1 = prvstr - 1; | |
564 | if (j1<j-5) j1=j-5; | |
565 | for(j0=j-2 ; j0>j1; -- j0) | |
566 | { | |
567 | if( ! isdigit(*j0 ) ) break; | |
568 | nh += ten * (*j0-'0'); | |
569 | ten*=10; | |
570 | } | |
571 | if(j0 <= j1) goto copychar; | |
572 | /* a hollerith must be preceded by a punctuation mark. | |
573 | '*' is possible only as repetition factor in a data statement | |
574 | not, in particular, in character*2h | |
575 | */ | |
576 | ||
577 | if( !(*j0=='*'&&s[0]=='d') && *j0!='/' && *j0!='(' && | |
578 | *j0!=',' && *j0!='=' && *j0!='.') | |
579 | goto copychar; | |
580 | if(i+nh > lastch) | |
581 | { | |
582 | erri("%dH too big", nh); | |
583 | nh = lastch - i; | |
584 | } | |
585 | j0[1] = MYQUOTE; /* special marker */ | |
586 | j = j0 + 1; | |
587 | while(nh-- > 0) | |
588 | { | |
589 | if(*++i == '\\') | |
590 | switch(*++i) | |
591 | { | |
592 | case 't': | |
593 | *i = '\t'; break; | |
594 | case 'b': | |
595 | *i = '\b'; break; | |
596 | case 'n': | |
597 | *i = '\n'; break; | |
598 | case 'f': | |
599 | *i = '\f'; break; | |
600 | case '0': | |
601 | *i = '\0'; break; | |
602 | default: | |
603 | break; | |
604 | } | |
605 | *++j = *i; | |
606 | } | |
607 | j[1] = MYQUOTE; | |
608 | j+=2; | |
609 | prvstr = j; | |
610 | } | |
611 | else { | |
612 | if(*i == '(') ++parlev; | |
613 | else if(*i == ')') --parlev; | |
614 | else if(parlev == 0) | |
615 | if(*i == '=') expeql = 1; | |
616 | else if(*i == ',') expcom = 1; | |
617 | copychar: /*not a string or space -- copy, shifting case if necessary */ | |
618 | if(shiftcase && isupper(*i)) | |
619 | *j++ = tolower(*i); | |
620 | else *j++ = *i; | |
621 | } | |
622 | } | |
623 | lastch = j - 1; | |
624 | nextch = s; | |
625 | } | |
626 | \f | |
627 | LOCAL analyz() | |
628 | { | |
629 | register char *i; | |
630 | ||
631 | if(parlev != 0) | |
632 | { | |
633 | err("unbalanced parentheses, statement skipped"); | |
634 | stkey = SUNKNOWN; | |
635 | return; | |
636 | } | |
637 | if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') | |
638 | { | |
639 | /* assignment or if statement -- look at character after balancing paren */ | |
640 | parlev = 1; | |
641 | for(i=nextch+3 ; i<=lastch; ++i) | |
642 | if(*i == (MYQUOTE)) | |
643 | { | |
644 | while(*++i != MYQUOTE) | |
645 | ; | |
646 | } | |
647 | else if(*i == '(') | |
648 | ++parlev; | |
649 | else if(*i == ')') | |
650 | { | |
651 | if(--parlev == 0) | |
652 | break; | |
653 | } | |
654 | if(i >= lastch) | |
655 | stkey = SLOGIF; | |
656 | else if(i[1] == '=') | |
657 | stkey = SLET; | |
658 | else if( isdigit(i[1]) ) | |
659 | stkey = SARITHIF; | |
660 | else stkey = SLOGIF; | |
661 | if(stkey != SLET) | |
662 | nextch += 2; | |
663 | } | |
664 | else if(expeql) /* may be an assignment */ | |
665 | { | |
666 | if(expcom && nextch<lastch && | |
667 | nextch[0]=='d' && nextch[1]=='o') | |
668 | { | |
669 | stkey = SDO; | |
670 | nextch += 2; | |
671 | } | |
672 | else stkey = SLET; | |
673 | } | |
674 | /* otherwise search for keyword */ | |
675 | else { | |
676 | stkey = getkwd(); | |
677 | if(stkey==SGOTO && lastch>=nextch) | |
678 | if(nextch[0]=='(') | |
679 | stkey = SCOMPGOTO; | |
680 | else if(isalpha(nextch[0])) | |
681 | stkey = SASGOTO; | |
682 | } | |
683 | parlev = 0; | |
684 | } | |
685 | ||
686 | ||
687 | ||
688 | LOCAL getkwd() | |
689 | { | |
690 | register char *i, *j; | |
691 | register struct Keylist *pk, *pend; | |
692 | int k; | |
693 | ||
694 | if(! isalpha(nextch[0]) ) | |
695 | return(SUNKNOWN); | |
696 | k = nextch[0] - 'a'; | |
697 | if(pk = keystart[k]) | |
698 | for(pend = keyend[k] ; pk<=pend ; ++pk ) | |
699 | { | |
700 | i = pk->keyname; | |
701 | j = nextch; | |
702 | while(*++i==*++j && *i!='\0') | |
703 | ; | |
704 | if(*i=='\0' && j<=lastch+1) | |
705 | { | |
706 | nextch = j; | |
7dbb9c71 | 707 | #ifdef ONLY66 |
5b9f3ea3 KM |
708 | if(no66flag && pk->notinf66) |
709 | errstr("Not a Fortran 66 keyword: %s", | |
710 | pk->keyname); | |
7dbb9c71 | 711 | #endif |
5b9f3ea3 KM |
712 | return(pk->keyval); |
713 | } | |
714 | } | |
715 | return(SUNKNOWN); | |
716 | } | |
717 | ||
718 | ||
719 | ||
720 | initkey() | |
721 | { | |
722 | extern struct Keylist keys[]; | |
723 | register struct Keylist *p; | |
724 | register int i,j; | |
725 | ||
726 | for(i = 0 ; i<26 ; ++i) | |
727 | keystart[i] = NULL; | |
728 | ||
729 | for(p = keys ; p->keyname ; ++p) | |
730 | { | |
731 | j = p->keyname[0] - 'a'; | |
732 | if(keystart[j] == NULL) | |
733 | keystart[j] = p; | |
734 | keyend[j] = p; | |
735 | } | |
736 | } | |
737 | \f | |
738 | LOCAL gettok() | |
739 | { | |
740 | int havdot, havexp, havdbl; | |
741 | int radix, val; | |
742 | extern struct Punctlist puncts[]; | |
743 | struct Punctlist *pp; | |
744 | extern struct Fmtlist fmts[]; | |
745 | extern struct Dotlist dots[]; | |
746 | struct Dotlist *pd; | |
747 | ||
748 | char *i, *j, *n1, *p; | |
749 | ||
750 | if(*nextch == (MYQUOTE)) | |
751 | { | |
752 | ++nextch; | |
753 | p = token; | |
3526f196 | 754 | while(nextch <= lastch && *nextch != MYQUOTE) |
5b9f3ea3 KM |
755 | *p++ = *nextch++; |
756 | ++nextch; | |
757 | toklen = p - token; | |
758 | *p = '\0'; | |
759 | return (SHOLLERITH); | |
760 | } | |
761 | /* | |
762 | if(stkey == SFORMAT) | |
763 | { | |
764 | for(pf = fmts; pf->fmtchar; ++pf) | |
765 | { | |
766 | if(*nextch == pf->fmtchar) | |
767 | { | |
768 | ++nextch; | |
769 | if(pf->fmtval == SLPAR) | |
770 | ++parlev; | |
771 | else if(pf->fmtval == SRPAR) | |
772 | --parlev; | |
773 | return(pf->fmtval); | |
774 | } | |
775 | } | |
776 | if( isdigit(*nextch) ) | |
777 | { | |
778 | p = token; | |
779 | *p++ = *nextch++; | |
780 | while(nextch<=lastch && isdigit(*nextch) ) | |
781 | *p++ = *nextch++; | |
782 | toklen = p - token; | |
783 | *p = '\0'; | |
784 | if(nextch<=lastch && *nextch=='p') | |
785 | { | |
786 | ++nextch; | |
787 | return(SSCALE); | |
788 | } | |
789 | else return(SICON); | |
790 | } | |
791 | if( isalpha(*nextch) ) | |
792 | { | |
793 | p = token; | |
794 | *p++ = *nextch++; | |
795 | while(nextch<=lastch && | |
796 | (*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) )) | |
797 | *p++ = *nextch++; | |
798 | toklen = p - token; | |
799 | *p = '\0'; | |
800 | return(SFIELD); | |
801 | } | |
802 | goto badchar; | |
803 | } | |
804 | /* Not a format statement */ | |
805 | ||
806 | if(needkwd) | |
807 | { | |
808 | needkwd = 0; | |
809 | return( getkwd() ); | |
810 | } | |
811 | ||
812 | for(pp=puncts; pp->punchar; ++pp) | |
813 | if(*nextch == pp->punchar) | |
814 | { | |
815 | if( (*nextch=='*' || *nextch=='/') && | |
816 | nextch<lastch && nextch[1]==nextch[0]) | |
817 | { | |
818 | if(*nextch == '*') | |
819 | val = SPOWER; | |
820 | else val = SCONCAT; | |
821 | nextch+=2; | |
822 | } | |
823 | else { | |
824 | val = pp->punval; | |
825 | if(val==SLPAR) | |
826 | ++parlev; | |
827 | else if(val==SRPAR) | |
828 | --parlev; | |
829 | ++nextch; | |
830 | } | |
831 | return(val); | |
832 | } | |
833 | if(*nextch == '.') | |
834 | if(nextch >= lastch) goto badchar; | |
835 | else if(isdigit(nextch[1])) goto numconst; | |
836 | else { | |
837 | for(pd=dots ; (j=pd->dotname) ; ++pd) | |
838 | { | |
839 | for(i=nextch+1 ; i<=lastch ; ++i) | |
840 | if(*i != *j) break; | |
841 | else if(*i != '.') ++j; | |
842 | else { | |
843 | nextch = i+1; | |
844 | return(pd->dotval); | |
845 | } | |
846 | } | |
847 | goto badchar; | |
848 | } | |
849 | if( isalpha(*nextch) ) | |
850 | { | |
851 | p = token; | |
852 | *p++ = *nextch++; | |
853 | while(nextch<=lastch) | |
854 | if( isalpha(*nextch) || isdigit(*nextch) ) | |
855 | *p++ = *nextch++; | |
856 | else break; | |
857 | toklen = p - token; | |
858 | *p = '\0'; | |
859 | if(inioctl && nextch<=lastch && *nextch=='=') | |
860 | { | |
861 | ++nextch; | |
862 | return(SNAMEEQ); | |
863 | } | |
864 | if(toklen>8 && eqn(8,token,"function") && isalpha(token[8]) && | |
865 | nextch<lastch && nextch[0]=='(' && | |
866 | (nextch[1]==')' | isalpha(nextch[1])) ) | |
867 | { | |
868 | nextch -= (toklen - 8); | |
869 | return(SFUNCTION); | |
870 | } | |
871 | if(toklen > VL) | |
872 | { | |
873 | char buff[30]; | |
874 | sprintf(buff, "name %s too long, truncated to %d", | |
875 | token, VL); | |
876 | err(buff); | |
877 | toklen = VL; | |
878 | token[VL] = '\0'; | |
879 | } | |
880 | if(toklen==1 && *nextch==MYQUOTE) | |
881 | { | |
882 | switch(token[0]) | |
883 | { | |
884 | case 'z': case 'Z': | |
885 | case 'x': case 'X': | |
886 | radix = 16; break; | |
887 | case 'o': case 'O': | |
888 | radix = 8; break; | |
889 | case 'b': case 'B': | |
890 | radix = 2; break; | |
891 | default: | |
892 | err("bad bit identifier"); | |
893 | return(SNAME); | |
894 | } | |
895 | ++nextch; | |
896 | for(p = token ; *nextch!=MYQUOTE ; ) | |
897 | if ( *nextch == BLANK || *nextch == '\t') | |
898 | nextch++; | |
899 | else | |
900 | { | |
901 | if (isupper(*nextch)) | |
902 | *nextch = tolower(*nextch); | |
903 | if (hextoi(*p++ = *nextch++) >= radix) | |
904 | { | |
905 | err("invalid binary character"); | |
906 | break; | |
907 | } | |
908 | } | |
909 | ++nextch; | |
910 | toklen = p - token; | |
911 | return( radix==16 ? SHEXCON : | |
912 | (radix==8 ? SOCTCON : SBITCON) ); | |
913 | } | |
914 | return(SNAME); | |
915 | } | |
916 | if( ! isdigit(*nextch) ) goto badchar; | |
917 | numconst: | |
918 | havdot = NO; | |
919 | havexp = NO; | |
920 | havdbl = NO; | |
921 | for(n1 = nextch ; nextch<=lastch ; ++nextch) | |
922 | { | |
923 | if(*nextch == '.') | |
924 | if(havdot) break; | |
925 | else if(nextch+2<=lastch && isalpha(nextch[1]) | |
926 | && isalpha(nextch[2])) | |
927 | break; | |
928 | else havdot = YES; | |
929 | else if( !intonly && (*nextch=='d' || *nextch=='e') ) | |
930 | { | |
931 | p = nextch; | |
932 | havexp = YES; | |
933 | if(*nextch == 'd') | |
934 | havdbl = YES; | |
935 | if(nextch<lastch) | |
936 | if(nextch[1]=='+' || nextch[1]=='-') | |
937 | ++nextch; | |
938 | if( (nextch >= lastch) || ! isdigit(*++nextch) ) | |
939 | { | |
940 | nextch = p; | |
941 | havdbl = havexp = NO; | |
942 | break; | |
943 | } | |
944 | for(++nextch ; | |
945 | nextch<=lastch && isdigit(*nextch); | |
946 | ++nextch); | |
947 | break; | |
948 | } | |
949 | else if( ! isdigit(*nextch) ) | |
950 | break; | |
951 | } | |
952 | p = token; | |
953 | i = n1; | |
954 | while(i < nextch) | |
955 | *p++ = *i++; | |
956 | toklen = p - token; | |
957 | *p = '\0'; | |
958 | if(havdbl) return(SDCON); | |
7dbb9c71 | 959 | if(havdot || havexp) return( dblflag ? SDCON : SRCON); |
5b9f3ea3 KM |
960 | return(SICON); |
961 | badchar: | |
962 | s[0] = *nextch++; | |
963 | return(SUNKNOWN); | |
964 | } | |
965 | \f | |
966 | /* KEYWORD AND SPECIAL CHARACTER TABLES | |
967 | */ | |
968 | ||
969 | struct Punctlist puncts[ ] = | |
970 | { | |
971 | '(', SLPAR, | |
972 | ')', SRPAR, | |
973 | '=', SEQUALS, | |
974 | ',', SCOMMA, | |
975 | '+', SPLUS, | |
976 | '-', SMINUS, | |
977 | '*', SSTAR, | |
978 | '/', SSLASH, | |
979 | '$', SCURRENCY, | |
980 | ':', SCOLON, | |
981 | 0, 0 } ; | |
982 | ||
983 | /* | |
984 | LOCAL struct Fmtlist fmts[ ] = | |
985 | { | |
986 | '(', SLPAR, | |
987 | ')', SRPAR, | |
988 | '/', SSLASH, | |
989 | ',', SCOMMA, | |
990 | '-', SMINUS, | |
991 | ':', SCOLON, | |
992 | 0, 0 } ; | |
993 | */ | |
994 | ||
995 | LOCAL struct Dotlist dots[ ] = | |
996 | { | |
997 | "and.", SAND, | |
998 | "or.", SOR, | |
999 | "not.", SNOT, | |
1000 | "true.", STRUE, | |
1001 | "false.", SFALSE, | |
1002 | "eq.", SEQ, | |
1003 | "ne.", SNE, | |
1004 | "lt.", SLT, | |
1005 | "le.", SLE, | |
1006 | "gt.", SGT, | |
1007 | "ge.", SGE, | |
1008 | "neqv.", SNEQV, | |
1009 | "eqv.", SEQV, | |
1010 | 0, 0 } ; | |
1011 | ||
1012 | LOCAL struct Keylist keys[ ] = | |
1013 | { | |
1014 | { "assign", SASSIGN }, | |
1015 | { "automatic", SAUTOMATIC, YES }, | |
1016 | { "backspace", SBACKSPACE }, | |
1017 | { "blockdata", SBLOCK }, | |
1018 | { "call", SCALL }, | |
1019 | { "character", SCHARACTER, YES }, | |
1020 | { "close", SCLOSE, YES }, | |
1021 | { "common", SCOMMON }, | |
1022 | { "complex", SCOMPLEX }, | |
1023 | { "continue", SCONTINUE }, | |
1024 | { "data", SDATA }, | |
1025 | { "dimension", SDIMENSION }, | |
1026 | { "doubleprecision", SDOUBLE }, | |
1027 | { "doublecomplex", SDCOMPLEX, YES }, | |
1028 | { "elseif", SELSEIF, YES }, | |
1029 | { "else", SELSE, YES }, | |
1030 | { "endfile", SENDFILE }, | |
1031 | { "endif", SENDIF, YES }, | |
1032 | { "end", SEND }, | |
1033 | { "entry", SENTRY, YES }, | |
1034 | { "equivalence", SEQUIV }, | |
1035 | { "external", SEXTERNAL }, | |
1036 | { "format", SFORMAT }, | |
1037 | { "function", SFUNCTION }, | |
1038 | { "goto", SGOTO }, | |
1039 | { "implicit", SIMPLICIT, YES }, | |
1040 | { "include", SINCLUDE, YES }, | |
1041 | { "inquire", SINQUIRE, YES }, | |
1042 | { "intrinsic", SINTRINSIC, YES }, | |
1043 | { "integer", SINTEGER }, | |
1044 | { "logical", SLOGICAL }, | |
1045 | #ifdef NAMELIST | |
1046 | { "namelist", SNAMELIST, YES }, | |
1047 | #endif | |
1048 | { "none", SUNDEFINED, YES }, | |
1049 | { "open", SOPEN, YES }, | |
1050 | { "parameter", SPARAM, YES }, | |
1051 | { "pause", SPAUSE }, | |
1052 | { "print", SPRINT }, | |
1053 | { "program", SPROGRAM, YES }, | |
1054 | { "punch", SPUNCH, YES }, | |
1055 | { "read", SREAD }, | |
1056 | { "real", SREAL }, | |
1057 | { "return", SRETURN }, | |
1058 | { "rewind", SREWIND }, | |
1059 | { "save", SSAVE, YES }, | |
1060 | { "static", SSTATIC, YES }, | |
1061 | { "stop", SSTOP }, | |
1062 | { "subroutine", SSUBROUTINE }, | |
1063 | { "then", STHEN, YES }, | |
1064 | { "undefined", SUNDEFINED, YES }, | |
1065 | { "write", SWRITE }, | |
1066 | { 0, 0 } | |
1067 | }; |