2.11BSD#431 - /usr/src/usr.bin/f77/lex.c

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

Defined functions

Defined variables

Defined struct's

Defined macros