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