4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/lex.c

   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:     };

Defined functions

Defined variables

Defined struct's

Defined macros