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