compilers/pcc/pcc-1.0.0/f77/fcom/lex.c

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