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