Return to lex.c CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / f77 / pass1.vax

Annotation of 43BSDReno/pgrm/f77/pass1.vax/lex.c, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.