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