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