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