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