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