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 8 static char sccsid[] = "@(#)lex.c 5.4 (Berkeley) 05/10/89"; 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 $ 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 * 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 * 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" 41 #include "pathnames.h" 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 { 178 sprintf(temp, "%s/%s", _PATH_INCLUDES, name); 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 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 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 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 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; 707 #ifdef ONLY66 708 if(no66flag && pk->notinf66) 709 errstr("Not a Fortran 66 keyword: %s", 710 pk->keyname); 711 #endif 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 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; 754 while(nextch <= lastch && *nextch != MYQUOTE) 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); 959 if(havdot || havexp) return( dblflag ? SDCON : SRCON); 960 return(SICON); 961 badchar: 962 s[0] = *nextch++; 963 return(SUNKNOWN); 964 } 965 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 }; 1068